packages feed

seihou-cli 0.5.0.0 → 0.6.0.0

raw patch · 105 files changed

+7558/−2964 lines, 105 filesdep +generic-lensdep +lensdep +streamly-coredep ~baikaidep ~baikai-claudedep ~baikai-openai

Dependencies added: generic-lens, lens, streamly-core

Dependency ranges changed: baikai, baikai-claude, baikai-openai, seihou-core

Files

+ help/manifest.md view
@@ -0,0 +1,82 @@+MANIFEST++Every project seihou generates into carries a .seihou/manifest.json recording+which files were written, which module wrote each one, and which version was+applied. It describes the project rather than the machine, so it is committed+to git alongside the code it describes.++WHAT IT MAY NOT CONTAIN++  No absolute path, home directory, XDG root, or username. Every location the+  manifest names is either relative to the project root or expressed as an+  artifact origin:++    remote    a git URL plus the artifact's name — a module installed from+              somewhere, e.g. https://github.com/user/seihou-modules.git+    project   a path relative to the project root, for an artifact that lives+              inside the project at .seihou/modules/<name>+    local     only a name, for an artifact discovered in your personal+              ~/.config/seihou/modules/ with no recorded upstream++  A "local" origin is deliberately weak. Commands can still find the artifact+  by name, but nothing can verify it is the one the project was generated+  from, and seihou says so rather than pretending otherwise.++OLDER MANIFESTS++  Manifests written before schema version 6 recorded the absolute directory+  each module occupied on the machine that ran the command. That path means+  nothing in another clone, so seihou refuses to read such a manifest instead+  of guessing:++    [error] Error reading manifest: this manifest uses schema version 5, which+    records machine-specific absolute paths; run 'seihou manifest upgrade' to+    convert it++  Convert it from the project root:++    seihou manifest upgrade+    seihou manifest upgrade --dry-run    # show the report, write nothing++  Each recorded path is resolved to an artifact on this machine and replaced+  with that artifact's portable origin. Every conversion is printed, because+  recovering an upstream URL from somebody else's absolute path is inference+  and inference belongs on screen, not hidden inside a committed file.++    Reading .seihou/manifest.json (schema version 5)++      haskell-base       /Users/shinzui/.config/seihou/installed/haskell-base+                      →  remote https://github.com/shinzui/seihou-modules.git++    ✓ Upgraded .seihou/manifest.json to schema version 6.+      Review the diff and commit it: git diff .seihou/manifest.json++  Running it on a manifest that is already current reports that there is+  nothing to do and exits zero.++INSTALL FIRST++  The upgrade can only record what this machine can see. If an artifact the+  manifest names is missing here — or the copy here is older than the version+  recorded — the conversion would have to guess, so the command refuses and+  names what to install or upgrade first.++    seihou install <url>       # for one that is not here at all+    seihou upgrade <name>      # for one that is merely out of date++  Pass --force to write anyway, when recording what this machine has is what+  you actually mean.++RECOVERING++  The upgrade rewrites a file that is in git, which is how you undo it:++    git checkout -- .seihou/manifest.json++  The write is atomic: a complete temporary file is renamed over the manifest,+  so an interrupted run cannot leave a truncated one.++SEE ALSO++  seihou help migrations       moving a project between module versions+  seihou manifest upgrade -h   the full flag reference
help/migrations.md view
@@ -193,6 +193,43 @@   applicable migrations and the run will only advance the manifest).   Recommendations are deduplicated by recorded top-level application. +REFUSING TO GO BACKWARDS++  A migration chain is computed from the locally installed module's+  declared migration list, so a local copy older than the version+  .seihou/manifest.json records produces a chain that stops short of+  where the project already is and rewinds the manifest to match.++  Before planning or generating, 'seihou run' and 'seihou migrate'+  compare the manifest's recorded version and origin against the copy+  installed on this machine. A strictly older local copy, or one+  installed from a different git URL than the manifest records, stops+  the command before any file is written:++    ✗ Refusing to run: your local copy of 'haskell-base' is older than the+      version this project expects.++      Recorded in .seihou/manifest.json:  2.0.0+      Installed on this machine:          1.4.0+      Origin: https://github.com/shinzui/seihou-modules.git++      Update your local copy first:+        seihou upgrade haskell-base++    To proceed anyway — pinning this project to what is installed here —+    re-run with --allow-downgrade.++  Nothing is fetched; seihou reports what to run. Pass+  --allow-downgrade to proceed anyway — the blocks are still printed,+  under a "! Proceeding anyway" heading. 'seihou update' accepts the+  same flag for a candidate older than the recorded version.++  A module found in ~/.config/seihou/modules/ has no recorded+  provenance. Its version is still compared, but its identity is+  reported as unverifiable rather than blocked.++  'seihou status' lists every differing artifact and always exits zero.+ MANIFEST GUARANTEE    After a successful (non-dry-run) migration, the manifest's files map
seihou-cli.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-cli-version: 0.5.0.0+version: 0.6.0.0 synopsis: CLI for Seihou project scaffolding description:   Command-line interface for Seihou, a composable project scaffolding@@ -29,6 +29,7 @@   help/contexts.md   help/git-repository.md   help/kit.md+  help/manifest.md   help/migrations.md   help/modules.md   help/prompts.md@@ -43,10 +44,10 @@ library seihou-cli-internal   default-language: GHC2024   default-extensions:+    DeriveAnyClass     DuplicateRecordFields     NoFieldSelectors     OverloadedLabels-    OverloadedRecordDot     OverloadedStrings     TypeFamilies @@ -58,6 +59,7 @@     Seihou.CLI.AgentConfigShow     Seihou.CLI.AgentLaunch     Seihou.CLI.AgentModels+    Seihou.CLI.AgentTrace     Seihou.CLI.AppliedBlueprint     Seihou.CLI.AppliedBlueprintMigration     Seihou.CLI.BlueprintExecution@@ -75,6 +77,9 @@     Seihou.CLI.InstallHistory     Seihou.CLI.InstallShared     Seihou.CLI.List+    Seihou.CLI.Manifest+    Seihou.CLI.ManifestGuard+    Seihou.CLI.ManifestUpgrade     Seihou.CLI.Migrate     Seihou.CLI.PendingMigrations     Seihou.CLI.PromptRender@@ -106,9 +111,9 @@     aeson >=2.1 && <3,     aeson-pretty >=0.8 && <1,     ansi-terminal >=1.1 && <2,-    baikai ^>=0.4.0.0,-    baikai-claude ^>=0.3.0.1,-    baikai-openai ^>=0.3.0.1,+    baikai ^>=0.4.1.0,+    baikai-claude ^>=0.4.0.0,+    baikai-openai ^>=0.4.0.0,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -116,8 +121,11 @@     effectful-core >=2.4 && <3,     file-embed >=0.0.15 && <1,     filepath >=1.4 && <2,+    generic-lens >=2.2 && <3,+    lens >=5.2 && <6,     process >=1.6 && <2,-    seihou-core ^>=0.5.0.0,+    seihou-core ^>=0.6.0.0,+    streamly-core >=0.3 && <0.5,     temporary >=1.3 && <2,     text >=2.0 && <3,     time >=1.12 && <2,@@ -127,10 +135,10 @@   default-language: GHC2024   ghc-options: -threaded   default-extensions:+    DeriveAnyClass     DuplicateRecordFields     NoFieldSelectors     OverloadedLabels-    OverloadedRecordDot     OverloadedStrings     PackageImports     TypeFamilies@@ -184,10 +192,10 @@     aeson >=2.1 && <3,     aeson-pretty >=0.8 && <1,     ansi-terminal >=1.1 && <2,-    baikai ^>=0.4.0.0,-    baikai-claude ^>=0.3.0.1,+    baikai ^>=0.4.1.0,+    baikai-claude ^>=0.4.0.0,     baikai-kit ^>=0.1.0.2,-    baikai-openai ^>=0.3.0.1,+    baikai-openai ^>=0.4.0.0,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,@@ -195,11 +203,13 @@     effectful-core >=2.4 && <3,     file-embed >=0.0.15 && <1,     filepath >=1.4 && <2,+    generic-lens >=2.2 && <3,     githash ^>=0.1,+    lens >=5.2 && <6,     optparse-applicative >=0.18 && <1,     process >=1.6 && <2,     seihou-cli-internal,-    seihou-core ^>=0.5.0.0,+    seihou-core ^>=0.6.0.0,     temporary >=1.3 && <2,     text >=2.0 && <3,     time >=1.12 && <2,@@ -208,17 +218,15 @@   type: exitcode-stdio-1.0   default-language: GHC2024   default-extensions:+    DeriveAnyClass     DuplicateRecordFields     NoFieldSelectors     OverloadedLabels-    OverloadedRecordDot     OverloadedStrings+    TypeFamilies    hs-source-dirs: test   main-is: Main.hs-  default-extensions:-    TypeFamilies-   other-modules:     Seihou.CLI.AgentCompletionSpec     Seihou.CLI.AgentConfigShowSpec@@ -226,6 +234,8 @@     Seihou.CLI.AgentLaunchSpec     Seihou.CLI.AgentMigrateE2ESpec     Seihou.CLI.AgentModelsSpec+    Seihou.CLI.AgentTraceE2ESpec+    Seihou.CLI.AgentTraceSpec     Seihou.CLI.AppliedBlueprintMigrationSpec     Seihou.CLI.AppliedBlueprintSpec     Seihou.CLI.BlueprintMigrationSpec@@ -238,6 +248,8 @@     Seihou.CLI.InitSpec     Seihou.CLI.InstallHistorySpec     Seihou.CLI.ListSpec+    Seihou.CLI.ManifestGuardSpec+    Seihou.CLI.ManifestUpgradeSpec     Seihou.CLI.MigrateSpec     Seihou.CLI.PendingMigrationSpec     Seihou.CLI.PromptRenderSpec@@ -246,7 +258,10 @@     Seihou.CLI.RemoteVersionSpec     Seihou.CLI.RunBlueprintRefusalSpec     Seihou.CLI.SavePromptedSpec+    Seihou.CLI.SeihouBinary+    Seihou.CLI.SharedManifestE2ESpec     Seihou.CLI.StatusSpec+    Seihou.CLI.TwoDeveloperFixture     Seihou.CLI.UpdateE2ESpec     Seihou.CLI.UpdateFixture     Seihou.CLI.UpdateInteractionSpec@@ -260,17 +275,20 @@    build-depends:     aeson >=2.1 && <3,-    baikai ^>=0.4.0.0,+    baikai ^>=0.4.1.0,     base >=4.18 && <5,     bytestring >=0.11 && <1,     containers >=0.6 && <1,     directory >=1.3 && <2,     effectful-core >=2.4 && <3,     filepath >=1.4 && <2,+    generic-lens >=2.2 && <3,     hspec >=2.11 && <3,+    lens >=5.2 && <6,     process >=1.6 && <2,     seihou-cli-internal,-    seihou-core ^>=0.5.0.0,+    seihou-core ^>=0.6.0.0,+    streamly-core >=0.3 && <0.5,     tasty >=1.4 && <2,     tasty-hspec >=1.2 && <2,     temporary >=1.3 && <2,
src-exe/Main.hs view
@@ -1,6 +1,8 @@ module Main (main) where  import Control.Applicative ((<|>))+import Control.Lens ((^.))+import Data.Generics.Labels () import Data.List (isPrefixOf) import Data.Maybe (isJust) import Data.String (fromString)@@ -8,7 +10,7 @@ import Data.Text.IO qualified as TIO import Options.Applicative (customExecParser, prefs, showHelpOnEmpty) import Seihou.CLI.AgentCompletion qualified as AgentCompletion-import Seihou.CLI.AgentConfig (AgentCommandName (..), loadAgentModelConfigFor)+import Seihou.CLI.AgentConfig (AgentCommandName (..), AgentSettingFlags (..), PendingAgentConfig, loadAgentModelConfigFor, loadPendingAgentConfig, noAgentSettingFlags) import Seihou.CLI.AgentConfigShow (handleAgentConfigShow) import Seihou.CLI.AgentMigrate (handleAgentMigrate) import Seihou.CLI.AgentModels qualified as AgentModels@@ -27,6 +29,7 @@ import Seihou.CLI.Install (handleInstall) import Seihou.CLI.Kit (runKit) import Seihou.CLI.List (ListFilter (..), handleList)+import Seihou.CLI.Manifest (handleManifest) import Seihou.CLI.Migrate (handleMigrate) import Seihou.CLI.NewBlueprint (handleNewBlueprint) import Seihou.CLI.NewModule (handleNewModule)@@ -65,8 +68,8 @@   | not ("-" `isPrefixOf` name) =       Just         ExtensionRunOpts-          { extensionName = fromString name,-            extensionArgs =+          { name = fromString name,+            args =               case rest of                 "--" : forwarded -> forwarded                 forwarded -> forwarded@@ -94,11 +97,11 @@       handleDiff     List listOpts ->       let kinds =-            [KindModule | listOpts.listModulesOnly]-              <> [KindRecipe | listOpts.listRecipesOnly]-              <> [KindBlueprint | listOpts.listBlueprintsOnly]-              <> [KindPrompt | listOpts.listPromptsOnly]-       in handleList (ListFilter listOpts.listRepo listOpts.listTag kinds)+            [KindModule | listOpts ^. #modulesOnly]+              <> [KindRecipe | listOpts ^. #recipesOnly]+              <> [KindBlueprint | listOpts ^. #blueprintsOnly]+              <> [KindPrompt | listOpts ^. #promptsOnly]+       in handleList (ListFilter (listOpts ^. #repo) (listOpts ^. #tag) kinds)     NewModule newModOpts ->       handleNewModule newModOpts     NewRecipe newRecOpts ->@@ -129,32 +132,34 @@       handleSchemaUpgrade schemaUpgradeOpts     Registry registryCmd ->       handleRegistry registryCmd+    ManifestCmd manifestCmd ->+      handleManifest manifestCmd     Kit kitCmd ->       runKit kitCmd     Agent agentOpts -> do-      case agentOpts.agentCommand of+      case agentOpts ^. #command of         AgentAssist assistOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdAssist agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort assistOpts.assistProvider assistOpts.assistModel assistOpts.assistEffort-          handleAssist agentOpts.agentDebug modelConfig assistOpts+          modelConfig <- resolveAgentModelConfigFor AgentCmdAssist (parentAgentFlags agentOpts) (AgentSettingFlags (assistOpts ^. #provider) (assistOpts ^. #model) (assistOpts ^. #effort) (assistOpts ^. #trace))+          handleAssist (agentOpts ^. #debug) modelConfig assistOpts         AgentBootstrap bootstrapOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdBootstrap agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort bootstrapOpts.bootstrapProvider bootstrapOpts.bootstrapModel bootstrapOpts.bootstrapEffort-          handleBootstrap agentOpts.agentDebug modelConfig bootstrapOpts+          modelConfig <- resolveAgentModelConfigFor AgentCmdBootstrap (parentAgentFlags agentOpts) (AgentSettingFlags (bootstrapOpts ^. #provider) (bootstrapOpts ^. #model) (bootstrapOpts ^. #effort) (bootstrapOpts ^. #trace))+          handleBootstrap (agentOpts ^. #debug) modelConfig bootstrapOpts         AgentSetup setupOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdSetup agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort setupOpts.setupProvider setupOpts.setupModel setupOpts.setupEffort-          handleSetup agentOpts.agentDebug modelConfig setupOpts+          modelConfig <- resolveAgentModelConfigFor AgentCmdSetup (parentAgentFlags agentOpts) (AgentSettingFlags (setupOpts ^. #provider) (setupOpts ^. #model) (setupOpts ^. #effort) (setupOpts ^. #trace))+          handleSetup (agentOpts ^. #debug) modelConfig setupOpts         AgentRun blueprintRunOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdRun agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort blueprintRunOpts.runBlueprintProvider blueprintRunOpts.runBlueprintModel blueprintRunOpts.runBlueprintEffort-          handleAgentRun agentOpts.agentDebug modelConfig blueprintRunOpts+          pending <- pendingAgentConfigFor AgentCmdRun (parentAgentFlags agentOpts) (AgentSettingFlags (blueprintRunOpts ^. #provider) (blueprintRunOpts ^. #model) (blueprintRunOpts ^. #effort) (blueprintRunOpts ^. #trace))+          handleAgentRun (agentOpts ^. #debug) pending blueprintRunOpts         AgentMigrate migrationOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdMigrate agentOpts.agentProvider agentOpts.agentModel agentOpts.agentEffort migrationOpts.migrateBlueprintProvider migrationOpts.migrateBlueprintModel migrationOpts.migrateBlueprintEffort-          handleAgentMigrate agentOpts.agentDebug modelConfig migrationOpts+          pending <- pendingAgentConfigFor AgentCmdMigrate (parentAgentFlags agentOpts) (AgentSettingFlags (migrationOpts ^. #provider) (migrationOpts ^. #model) (migrationOpts ^. #effort) (migrationOpts ^. #trace))+          handleAgentMigrate (agentOpts ^. #debug) pending migrationOpts         AgentModels modelsOpts ->-          case agentOpts.agentModel of+          case agentOpts ^. #model of             Just _ -> do               TIO.putStrLn "Error: --model does not apply to 'seihou agent models'; omit it to list known choices."               exitFailure             Nothing ->-              case modelsOpts.modelsProvider <|> agentOpts.agentProvider of+              case modelsOpts ^. #modelsProvider <|> agentOpts ^. #provider of                 Nothing ->                   TIO.putStr (AgentModels.formatAgentModels Nothing AgentModels.availableAgentModels)                 Just providerText ->@@ -169,8 +174,8 @@     Prompt promptCmd -> do       case promptCmd of         PromptRun promptRunOpts -> do-          modelConfig <- resolveAgentModelConfigFor AgentCmdPromptRun Nothing Nothing Nothing promptRunOpts.runPromptProvider promptRunOpts.runPromptModel promptRunOpts.runPromptEffort-          handlePromptRun modelConfig promptRunOpts+          pending <- pendingAgentConfigFor AgentCmdPromptRun noAgentSettingFlags (AgentSettingFlags (promptRunOpts ^. #provider) (promptRunOpts ^. #model) (promptRunOpts ^. #effort) (promptRunOpts ^. #trace))+          handlePromptRun pending promptRunOpts     Extension extensionCmd -> do       case extensionCmd of         ExtensionRun extensionRunOpts ->@@ -180,29 +185,53 @@     Completions completionsCmd ->       handleCompletionsCommand completionsCmd --- | Resolve the effective provider/model/effort for one agent command. The--- subcommand flag wins over the parent @seihou agent@ flag; that combined flag--- then feeds the per-command config resolution, which also consults the+-- | The four agent settings as given on the parent @seihou agent@ command.+parentAgentFlags :: AgentOpts -> AgentSettingFlags+parentAgentFlags agentOpts =+  AgentSettingFlags+    { provider = agentOpts ^. #provider,+      model = agentOpts ^. #model,+      effort = agentOpts ^. #effort,+      trace = agentOpts ^. #trace+    }++-- | Resolve the effective provider/model/effort/trace for one agent command.+-- The subcommand flag wins over the parent @seihou agent@ flag; that combined+-- flag then feeds the per-command config resolution, which also consults the -- command's own @agent.<command>.*@ keys before the shared @agent.*@ defaults. resolveAgentModelConfigFor ::   AgentCommandName ->-  -- | parent @seihou agent@ provider, model, effort-  Maybe Text ->-  Maybe Text ->-  Maybe Text ->-  -- | subcommand provider, model, effort-  Maybe Text ->-  Maybe Text ->-  Maybe Text ->+  -- | flags on the parent @seihou agent@ command+  AgentSettingFlags ->+  -- | flags on the subcommand itself+  AgentSettingFlags ->   IO AgentCompletion.AgentModelConfig-resolveAgentModelConfigFor cmd parentProvider parentModel parentEffort commandProvider commandModel commandEffort = do-  let provider = commandProvider <|> parentProvider-      model = commandModel <|> parentModel-      effort = commandEffort <|> parentEffort-  configResult <--    loadAgentModelConfigFor cmd provider model effort (isJust commandProvider) (isJust commandModel) (isJust commandEffort)+resolveAgentModelConfigFor cmd parentFlags commandFlags = do+  configResult <- loadAgentModelConfigFor cmd parentFlags commandFlags   case configResult of     Left err -> do       TIO.putStrLn $ "Error: " <> err       exitFailure     Right config -> pure config++-- | Gather flags, environment, and config for a command whose artifact may+-- declare its own launch settings, stopping one step short of resolution.+--+-- The blueprint or prompt is not loaded until the handler runs, so the handler+-- finishes resolution itself with 'resolveDeclaredAgentConfig' once it knows+-- what the artifact declares. Flag combination and error reporting match+-- 'resolveAgentModelConfigFor' exactly.+pendingAgentConfigFor ::+  AgentCommandName ->+  -- | flags on the parent @seihou agent@ command+  AgentSettingFlags ->+  -- | flags on the subcommand itself+  AgentSettingFlags ->+  IO PendingAgentConfig+pendingAgentConfigFor cmd parentFlags commandFlags = do+  pendingResult <- loadPendingAgentConfig cmd parentFlags commandFlags+  case pendingResult of+    Left err -> do+      TIO.putStrLn $ "Error: " <> err+      exitFailure+    Right pending -> pure pending
src-exe/Seihou/CLI/AgentLaunchExec.hs view
@@ -28,6 +28,7 @@     launchCodexInteractive,   ) import Baikai.ThinkingLevel (ThinkingLevel)+import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion (AgentModelConfig (..), AgentProvider (..))@@ -50,11 +51,11 @@       TIO.putStr systemPrompt       pure ExitSuccess   | otherwise =-      case modelConfig.agentProvider of+      case modelConfig ^. #provider of         AgentProviderClaudeCli ->-          launchClaude addDirs tools modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt+          launchClaude addDirs tools (modelConfig ^. #model) (modelConfig ^. #effort) systemPrompt initialPrompt         AgentProviderCodexCli ->-          launchCodex addDirs modelConfig.agentModel modelConfig.agentEffort systemPrompt initialPrompt+          launchCodex addDirs (modelConfig ^. #model) (modelConfig ^. #effort) systemPrompt initialPrompt         AgentProviderAnthropic ->           unsupportedInteractiveProvider "anthropic"         AgentProviderOpenAI ->@@ -73,6 +74,8 @@       InteractiveLaunchResult {exitCode} <-         launchClaudeInteractive           defaultClaudeInteractiveConfig+          -- InteractiveLaunchRequest comes from baikai and has no Generic instance,+          -- so these fields have no labels. Record update syntax is the only option.           (interactiveLaunchRequest (promptOrEmpty initialPrompt))             { systemPrompt = Just systemPrompt,               modelId = model,@@ -96,6 +99,8 @@       InteractiveLaunchResult {exitCode} <-         launchCodexInteractive           defaultCodexInteractiveConfig+          -- InteractiveLaunchRequest comes from baikai and has no Generic instance,+          -- so these fields have no labels. Record update syntax is the only option.           (interactiveLaunchRequest (promptOrEmpty initialPrompt))             { systemPrompt = Just systemPrompt,               modelId = model,
src-exe/Seihou/CLI/AgentMigrate.hs view
@@ -5,7 +5,9 @@   ) where +import Baikai.Trace.Sink (TraceSink) import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Maybe (maybeToList) import Data.Text qualified as T import Data.Text.Encoding qualified as TE@@ -14,11 +16,17 @@ import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),-    buildAgentCompletionRequest,+    buildAgentCompletionRequestWith,     runAgentCompletion,   )+import Seihou.CLI.AgentConfig+  ( PendingAgentConfig,+    agentLaunchDeclaration,+    resolveDeclaredAgentConfig,+  ) import Seihou.CLI.AgentLaunch (gatherAgentContext) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs)+import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration) import Seihou.CLI.BlueprintExecution   ( BlueprintExecutionRequest (..),@@ -55,21 +63,31 @@ migrationPromptTemplate :: Text migrationPromptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-migration-prompt.md") -handleAgentMigrate :: Bool -> AgentModelConfig -> BlueprintMigrationOpts -> IO ()-handleAgentMigrate debug modelConfig opts = do-  let level = if opts.migrateBlueprintVerbose then LogVerbose else LogNormal+handleAgentMigrate :: Bool -> PendingAgentConfig -> BlueprintMigrationOpts -> IO ()+handleAgentMigrate debug pendingConfig opts = do+  let level = if opts ^. #verbose then LogVerbose else LogNormal       manifestPath = ".seihou" </> "manifest.json" -  (blueprint, blueprintDir) <- discoverMigrationBlueprint level opts.migrateBlueprintName+  (blueprint, blueprintDir) <- discoverMigrationBlueprint level (opts ^. #name)   validationResult <- validateBlueprint blueprintDir blueprint   case validationResult of     Left err -> exitErr level (renderModuleLoadError err)     Right _ -> pure () -  current <- parseRequestedVersion level "--from" opts.migrateBlueprintFrom-  target <- parseRequestedVersion level "--to" opts.migrateBlueprintTo+  -- Finish provider/model/effort resolution now that the blueprint is loaded:+  -- `agent migrate` reads the same Blueprint record as `agent run`, so it+  -- honors the same launch declaration.+  modelConfig <-+    resolveDeclaredAgentConfig+      level+      ("blueprint '" <> blueprint ^. #name . #unModuleName <> "'")+      pendingConfig+      (agentLaunchDeclaration (blueprint ^. #launch))++  current <- parseRequestedVersion level "--from" (opts ^. #from)+  target <- parseRequestedVersion level "--to" (opts ^. #to)   planned <--    case planBlueprintMigrationChain blueprint.name.unModuleName blueprint.migrations current target of+    case planBlueprintMigrationChain (blueprint ^. #name . #unModuleName) (blueprint ^. #migrations) current target of       Left err -> exitErr level (renderPlanError err)       Right Nothing -> do         TIO.putStrLn "No blueprint migration needed: --from and --to resolve to the same version."@@ -82,14 +100,15 @@       receipts <- readMigrationReceipts level manifestPath       let pending =             pendingBlueprintMigrations-              opts.migrateBlueprintRerun-              blueprint.name+              (opts ^. #rerun)+              (blueprint ^. #name)               receipts               migrationPlan       if null pending         then reportNoPending migrationPlan         else do           prepared <- prepare level modelConfig opts blueprint blueprintDir+          traceSink <- traceSinkForConfig level modelConfig           context <- gatherAgentContext           let renderStep position total migration =                 renderBlueprintMigrationSystemPrompt@@ -104,26 +123,26 @@                   <> maybe                     ""                     ("\n\n===== Initial user instruction =====\n" <>)-                    opts.migrateBlueprintPrompt+                    (opts ^. #prompt)            if debug             then               TIO.putStrLn $                 "Blueprint migrations for "-                  <> blueprint.name.unModuleName+                  <> blueprint ^. #name . #unModuleName                   <> ": "-                  <> renderVersion migrationPlan.blueprintPlanFrom+                  <> renderVersion (migrationPlan ^. #from)                   <> " -> "-                  <> renderVersion migrationPlan.blueprintPlanTo+                  <> renderVersion (migrationPlan ^. #to)                   <> "\n"                   <> formatBlueprintMigrationDebugOutput renderDebugStep pending             else do               result <-                 runBlueprintMigrationsWith-                  (launchMigration modelConfig opts prepared renderStep)+                  (launchMigration traceSink modelConfig opts prepared renderStep)                   (recordMigration manifestPath blueprint)                   pending-              handleRunResult level blueprint.name result+              handleRunResult level (blueprint ^. #name) result  discoverMigrationBlueprint :: LogLevel -> ModuleName -> IO (Blueprint, FilePath) discoverMigrationBlueprint level requestedName = do@@ -132,11 +151,11 @@   case runnableResult of     Right (RunnableBlueprint blueprint dir) -> pure (blueprint, dir)     Right (RunnableModule _ _) ->-      exitErr level $ "'" <> requestedName.unModuleName <> "' is a module, not a blueprint."+      exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a module, not a blueprint."     Right (RunnableRecipe _ _) ->-      exitErr level $ "'" <> requestedName.unModuleName <> "' is a recipe, not a blueprint."+      exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a recipe, not a blueprint."     Right (RunnableAgentPrompt _ _) ->-      exitErr level $ "'" <> requestedName.unModuleName <> "' is a prompt, not a blueprint."+      exitErr level $ "'" <> requestedName ^. #unModuleName <> "' is a prompt, not a blueprint."     Left err -> exitErr level (renderModuleLoadError err)  parseRequestedVersion :: LogLevel -> Text -> Text -> IO Version@@ -151,7 +170,7 @@   case result of     Left err -> exitErr level ("Error reading migration receipts: " <> err)     Right Nothing -> pure []-    Right (Just manifest) -> pure manifest.blueprintMigrations+    Right (Just manifest) -> pure (manifest ^. #blueprintMigrations)  prepare ::   LogLevel ->@@ -162,18 +181,18 @@   IO PreparedBlueprintExecution prepare level modelConfig opts blueprint blueprintDir = do   let providerCanMountFiles =-        modelConfig.agentProvider == AgentProviderClaudeCli-          || modelConfig.agentProvider == AgentProviderCodexCli+        modelConfig ^. #provider == AgentProviderClaudeCli+          || modelConfig ^. #provider == AgentProviderCodexCli   result <-     prepareBlueprintExecution       BlueprintExecutionRequest-        { executionBlueprint = blueprint,-          executionBlueprintDir = blueprintDir,-          executionVariableOverrides = opts.migrateBlueprintVars,-          executionNamespaceOverride = opts.migrateBlueprintNamespace,-          executionContextOverride = opts.migrateBlueprintContext,-          executionCanMountFiles = providerCanMountFiles,-          executionLogLevel = level+        { blueprint = blueprint,+          blueprintDir = blueprintDir,+          variableOverrides = opts ^. #vars,+          namespaceOverride = opts ^. #namespace,+          contextOverride = opts ^. #context,+          canMountFiles = providerCanMountFiles,+          logLevel = level         }   case result of     Left errs -> do@@ -183,6 +202,8 @@     Right prepared -> pure prepared  launchMigration ::+  -- | built once per command, so every migration edge appends to one destination+  TraceSink ->   AgentModelConfig ->   BlueprintMigrationOpts ->   PreparedBlueprintExecution ->@@ -191,18 +212,18 @@   Int ->   BlueprintMigration ->   IO (Either BlueprintMigrationLaunchFailure ())-launchMigration modelConfig opts prepared renderStep position total migration = do+launchMigration traceSink modelConfig opts prepared renderStep position total migration = do   TIO.putStrLn $     "Running blueprint migration "       <> T.pack (show position)       <> "/"       <> T.pack (show total)       <> ": "-      <> migration.from+      <> migration ^. #from       <> " -> "-      <> migration.to+      <> (migration ^. #to)   let systemPrompt = renderStep position total migration-  case modelConfig.agentProvider of+  case modelConfig ^. #provider of     AgentProviderClaudeCli -> launchInteractive systemPrompt     AgentProviderCodexCli -> launchInteractive systemPrompt     AgentProviderAnthropic -> launchCompletion systemPrompt@@ -211,12 +232,12 @@     launchInteractive systemPrompt = do       exitCode <-         launchConfiguredAgentAddingDirs-          (maybeToList prepared.preparedMountedFilesDir)+          (maybeToList (prepared ^. #mountedFilesDir))           modelConfig-          prepared.preparedAllowedTools+          (prepared ^. #allowedTools)           False           systemPrompt-          opts.migrateBlueprintPrompt+          (opts ^. #prompt)       pure $ case exitCode of         ExitSuccess -> Right ()         failure -> Left (BlueprintMigrationProcessFailure failure)@@ -224,7 +245,7 @@     launchCompletion systemPrompt = do       result <-         runAgentCompletion-          (buildAgentCompletionRequest modelConfig systemPrompt opts.migrateBlueprintPrompt)+          (buildAgentCompletionRequestWith traceSink modelConfig systemPrompt (opts ^. #prompt))       case result of         Left err -> pure (Left (BlueprintMigrationProviderFailure err))         Right assistantText -> do@@ -241,10 +262,10 @@   recordAppliedBlueprintMigration     manifestPath     AppliedBlueprintMigration-      { name = blueprint.name,-        blueprintVersion = blueprint.version,-        fromVersion = migration.from,-        toVersion = migration.to,+      { name = blueprint ^. #name,+        blueprintVersion = blueprint ^. #version,+        fromVersion = migration ^. #from,+        toVersion = migration ^. #to,         appliedAt = now,         agentSessionId = Nothing       }@@ -258,14 +279,14 @@       "Completed "         <> T.pack (show (length completed))         <> " blueprint migration(s) for '"-        <> blueprintName.unModuleName+        <> blueprintName ^. #unModuleName         <> "'."   BlueprintMigrationLaunchFailed migration failure -> do     let prefix =           "Blueprint migration "-            <> migration.from+            <> migration ^. #from             <> " -> "-            <> migration.to+            <> migration ^. #to             <> " failed; completed earlier edges remain recorded. "         retry = "Fix the provider error, then rerun the same command to resume."     case failure of@@ -279,9 +300,9 @@     logIO level $       logError $         "Agent completed blueprint migration "-          <> migration.from+          <> migration ^. #from           <> " -> "-          <> migration.to+          <> migration ^. #to           <> ", but its receipt could not be recorded: "           <> err           <> ". The next edge was not started; repair manifest access, then rerun the same command."@@ -289,7 +310,7 @@  reportNoPending :: BlueprintMigrationPlan -> IO () reportNoPending migrationPlan-  | null migrationPlan.blueprintPlanSteps =+  | null (migrationPlan ^. #steps) =       TIO.putStrLn "No blueprint migrations are declared inside the requested version window."   | otherwise =       TIO.putStrLn "All blueprint migrations in the requested version window already have receipts."@@ -312,22 +333,22 @@ renderModuleLoadError = \case   ModuleNotFound name searched ->     "Blueprint '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "' not found. Searched in:\n"       <> T.intercalate "\n" (map (("  " <>) . T.pack) searched)   DhallEvalError name msg ->-    "Failed to evaluate '" <> name.unModuleName <> "': " <> msg+    "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg   DhallDecodeError name msg ->-    "Failed to decode '" <> name.unModuleName <> "': " <> msg+    "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg   ValidationError name msgs ->     "Validation failed for '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "':\n"       <> T.intercalate "\n" (map ("  " <>) msgs)   CircularDependency names ->-    "Circular dependency detected: " <> T.intercalate " -> " (map (.unModuleName) names)+    "Circular dependency detected: " <> T.intercalate " -> " (map (^. #unModuleName) names)   MissingSourceFile name path ->-    "Missing source file in '" <> name.unModuleName <> "': " <> T.pack path+    "Missing source file in '" <> name ^. #unModuleName <> "': " <> T.pack path   RegistryEvalError path msg ->     "Failed to evaluate registry at '" <> path <> "': " <> msg
src-exe/Seihou/CLI/AgentRun.hs view
@@ -15,6 +15,7 @@ import Control.Exception (IOException, displayException, try) import Control.Monad (when) import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, maybeToList) import Data.Set qualified as Set@@ -26,9 +27,14 @@ import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),-    buildAgentCompletionRequest,-    runAgentCompletion,+    buildAgentCompletionRequestWith,+    runAgentCompletionWithCliAccess,   )+import Seihou.CLI.AgentConfig+  ( PendingAgentConfig,+    agentLaunchDeclaration,+    resolveDeclaredAgentConfig,+  ) import Seihou.CLI.AgentLaunch   ( AgentContext (..),     BaselineStatus (..),@@ -42,6 +48,7 @@     substitute,   ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgentAddingDirs)+import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.AppliedBlueprint (recordAppliedBlueprint) import Seihou.CLI.BlueprintExecution   ( BlueprintExecutionRequest (..),@@ -60,6 +67,7 @@ import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts)+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin) import Seihou.Core.Context (resolveContext) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types@@ -84,54 +92,69 @@ import Seihou.Engine.Execute (executePlan) import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import Seihou.Prelude+import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (takeDirectory, (</>))+import System.IO (hIsTerminalDevice, stdin)  -- | The prompt template, embedded at compile time from data/blueprint-prompt.md. promptTemplate :: Text promptTemplate = TE.decodeUtf8 $(embedFile "data/blueprint-prompt.md") -handleAgentRun :: Bool -> AgentModelConfig -> BlueprintRunOpts -> IO ()-handleAgentRun debug modelConfig opts = do-  let level = if opts.runBlueprintVerbose then LogVerbose else LogNormal+handleAgentRun :: Bool -> PendingAgentConfig -> BlueprintRunOpts -> IO ()+handleAgentRun debug pending opts = do+  let level = if opts ^. #verbose then LogVerbose else LogNormal+  stdinIsTerminal <- hIsTerminalDevice stdin+  let batch = opts ^. #batch || not stdinIsTerminal    -- (a) Discover and validate. discoverRunnable resolves by directory   -- name (priority: module > recipe > blueprint).   searchPaths <- defaultSearchPaths-  runnableResult <- discoverRunnable searchPaths opts.runBlueprintName+  runnableResult <- discoverRunnable searchPaths (opts ^. #name)   (bp, blueprintDir) <- case runnableResult of     Right (RunnableBlueprint b dir) -> pure (b, dir)     Right (RunnableModule _ _) ->       exitErr level $         "'"-          <> opts.runBlueprintName.unModuleName+          <> opts ^. #name . #unModuleName           <> "' is a module, not a blueprint. Did you mean 'seihou run "-          <> opts.runBlueprintName.unModuleName+          <> opts ^. #name . #unModuleName           <> "'?"     Right (RunnableRecipe _ _) ->       exitErr level $         "'"-          <> opts.runBlueprintName.unModuleName+          <> opts ^. #name . #unModuleName           <> "' is a recipe, not a blueprint. Did you mean 'seihou run "-          <> opts.runBlueprintName.unModuleName+          <> opts ^. #name . #unModuleName           <> "'?"     Left err -> exitErr level (renderModuleLoadError err) +  -- Finish provider/model/effort resolution now that the blueprint is loaded+  -- and its launch declaration is known. This must precede the+  -- providerCanMountFiles computation below, which depends on the final+  -- provider.+  modelConfig <-+    resolveDeclaredAgentConfig+      level+      ("blueprint '" <> bp ^. #name . #unModuleName <> "'")+      pending+      (agentLaunchDeclaration (bp ^. #launch))+   let providerCanMountFiles =-        modelConfig.agentProvider == AgentProviderClaudeCli-          || modelConfig.agentProvider == AgentProviderCodexCli+        modelConfig ^. #provider == AgentProviderClaudeCli+          || modelConfig ^. #provider == AgentProviderCodexCli   -- (b) Resolve variables and prepare the shared prompt/reference/tool state.   preparedResult <-     prepareBlueprintExecution       BlueprintExecutionRequest-        { executionBlueprint = bp,-          executionBlueprintDir = blueprintDir,-          executionVariableOverrides = opts.runBlueprintVars,-          executionNamespaceOverride = opts.runBlueprintNamespace,-          executionContextOverride = opts.runBlueprintContext,-          executionCanMountFiles = providerCanMountFiles,-          executionLogLevel = level+        { blueprint = bp,+          blueprintDir = blueprintDir,+          variableOverrides = opts ^. #vars,+          namespaceOverride = opts ^. #namespace,+          contextOverride = opts ^. #context,+          canMountFiles = providerCanMountFiles,+          logLevel = level         }   prepared <- case preparedResult of     Left errs -> do@@ -139,17 +162,17 @@       mapM_ (logIO level . logError . ("  " <>) . formatVarError) errs       exitFailure     Right result -> pure result-  let resolved = prepared.preparedResolvedVariables-      cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runBlueprintVars]+  let resolved = (prepared ^. #resolvedVariables)+      cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts ^. #vars]    -- (c) Baseline.   baseline <--    if opts.runBlueprintNoBaseline+    if opts ^. #noBaseline       then pure BaselineSkipped       else-        if null bp.baseModules+        if null (bp ^. #baseModules)           then pure BaselineEmpty-          else applyBaseline level opts bp.baseModules cliOverrides resolved+          else applyBaseline level opts (bp ^. #baseModules) cliOverrides resolved    -- (d) Render the system prompt around the prepared shared body.   ctx <- gatherAgentContext@@ -157,13 +180,14 @@    -- (f) Launch.   launchSucceeded <--    runRenderedAgentPrompt+    runRenderedAgentPromptMode       debug+      batch       modelConfig-      prepared.preparedAllowedTools-      prepared.preparedMountedFilesDir+      (prepared ^. #allowedTools)+      (prepared ^. #mountedFilesDir)       systemPrompt-      opts.runBlueprintPrompt+      (opts ^. #prompt)    -- (g) Record the applied-blueprint provenance into   -- .seihou/manifest.json only after a successful provider response. In@@ -183,11 +207,14 @@               <> err  runRenderedAgentPrompt :: Bool -> AgentModelConfig -> [String] -> Maybe FilePath -> Text -> Maybe Text -> IO Bool-runRenderedAgentPrompt debug modelConfig tools mFilesDir systemPrompt initialPrompt+runRenderedAgentPrompt debug = runRenderedAgentPromptMode debug False++runRenderedAgentPromptMode :: Bool -> Bool -> AgentModelConfig -> [String] -> Maybe FilePath -> Text -> Maybe Text -> IO Bool+runRenderedAgentPromptMode debug batch modelConfig tools mFilesDir systemPrompt initialPrompt   | debug = do       TIO.putStr systemPrompt       pure True-  | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do+  | not batch && (modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli) = do       exitCode <-         launchConfiguredAgentAddingDirs           (maybeToList mFilesDir)@@ -200,7 +227,12 @@         ExitSuccess -> pure True         ExitFailure _ -> exitWith exitCode   | otherwise = do-      result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt)+      sink <- traceSinkForConfig LogNormal modelConfig+      result <-+        runAgentCompletionWithCliAccess+          (maybeToList mFilesDir)+          tools+          (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt)       case result of         Right assistantText -> do           TIO.putStrLn assistantText@@ -217,8 +249,8 @@   Blueprint -> BaselineStatus -> BlueprintRunOpts -> UTCTime -> AppliedBlueprint appliedBlueprintFromOutcome bp baseline opts now =   AppliedBlueprint-    { name = bp.name,-      blueprintVersion = bp.version,+    { name = bp ^. #name,+      blueprintVersion = bp ^. #version,       appliedAt = now,       baselineModules = case baseline of         BaselineApplied entries -> map fst entries@@ -227,7 +259,7 @@       noBaseline = case baseline of         BaselineSkipped -> True         _ -> False,-      userPrompt = opts.runBlueprintPrompt,+      userPrompt = opts ^. #prompt,       agentSessionId = Nothing     } @@ -250,7 +282,7 @@ applyBaseline level opts baseModules cliOverridesIn resolvedBlueprintVars = do   searchPaths <- defaultSearchPaths   (primary, additionals) <- case baseModules of-    d : rs -> pure (d.depModule, map (.depModule) rs)+    d : rs -> pure (d ^. #module_, map (^. #module_) rs)     [] -> exitErr level "internal error: applyBaseline called with empty baseModules"   compositionResult <- loadComposition searchPaths primary additionals   modulesInOrder <- case compositionResult of@@ -259,18 +291,27 @@       exitFailure     Right ms -> pure ms +  -- Classify every baseline module's discovery directory into a portable+  -- origin before anything is recorded, so the manifest stays meaningful on+  -- another developer's machine.+  projectRoot <- getCurrentDirectory+  originedModules <-+    traverse+      (\(inst, m, dir) -> (inst,m,) <$> detectArtifactOrigin projectRoot dir)+      modulesInOrder+   -- Fold the blueprint's resolved vars into the CLI override map for   -- the base modules. CLI overrides (already present in cliOverridesIn)   -- win over blueprint values, mirroring 'seihou run' semantics.   let blueprintAsOverrides =         Map.fromList-          [(vn, varValueToText rv.value) | (vn, rv) <- Map.toList resolvedBlueprintVars]+          [(vn, varValueToText (rv ^. #value)) | (vn, rv) <- Map.toList resolvedBlueprintVars]       cliOverrides = Map.union cliOverridesIn blueprintAsOverrides    envPairs <- getEnvironment   let envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]-      namespace = fromMaybe (deriveNamespace primary) opts.runBlueprintNamespace-  context <- resolveContext opts.runBlueprintContext envVars+      namespace = fromMaybe (deriveNamespace primary) (opts ^. #namespace)+  context <- resolveContext (opts ^. #context) envVars   let contextName = fromMaybe "" context    baseResolveResult <- runEff $ runConfigReader $ runConsole $ do@@ -298,7 +339,7 @@    -- Compile the plan.   let quads =-        [ (inst, m, dir, Map.map (.value) (baseResolved Map.! inst))+        [ (inst, m, dir, Map.map (^. #value) (baseResolved Map.! inst))         | (inst, m, dir) <- modulesInOrder         ]   planResult <- compileComposedPlan quads@@ -330,26 +371,33 @@   diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do     let composedNames =           Set.fromList $-            concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder+            concatMap (\(inst, _, _) -> [inst ^. #module_, qualifiedName inst]) modulesInOrder     computeDiff manifest composedNames planned    resolutions <--    runEff $ runConsole $ resolveConflicts opts.runBlueprintForce diff.conflicts+    runEff $ runConsole $ resolveConflicts (opts ^. #force) (diff ^. #conflicts)   case resolutions of     Nothing -> do       logIO level $ logError "Baseline conflicts detected (use --force to overwrite):"-      mapM_ (\c -> logIO level (logError ("  ! " <> T.pack c.path))) diff.conflicts+      mapM_ (\c -> logIO level (logError ("  ! " <> T.pack (c ^. #path)))) (diff ^. #conflicts)       exitFailure     Just conflictResolved -> do       let keepRecords =             Map.fromList-              [ ( c.path,-                  case Map.lookup c.path manifest.files of-                    Just existing -> existing {hash = c.diskHash, generatedAt = now}+              [ ( c ^. #path,+                  case Map.lookup (c ^. #path) (manifest ^. #files) of+                    Just existing ->+                      ( existing+                          & #hash+                          .~ c+                          ^. #diskHash+                          & #generatedAt+                          .~ now+                      )                     Nothing ->                       FileRecord-                        { hash = c.diskHash,-                          moduleName = c.moduleName,+                        { hash = c ^. #diskHash,+                          moduleName = c ^. #moduleName,                           strategy = Template,                           generatedAt = now,                           baseline = Nothing,@@ -358,7 +406,7 @@                 )               | (c, KeepCurrent) <- conflictResolved               ]-          skipPaths = [c.path | (c, Skip) <- conflictResolved]+          skipPaths = [c ^. #path | (c, Skip) <- conflictResolved]           excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths)           opsForExec = filter (not . opTargetsPath excludePaths) ops @@ -373,22 +421,22 @@                   case baselineResult of                     Left err -> pure (Left err)                     Right baselineRecords -> do-                      let orphanedPaths = map (.path) diff.orphaned-                          cleanedFiles = foldr Map.delete manifest.files orphanedPaths-                          allModuleEntries = updateAllModules manifest.modules modulesInOrder now+                      let orphanedPaths = map (^. #path) (diff ^. #orphaned)+                          cleanedFiles = foldr Map.delete (manifest ^. #files) orphanedPaths+                          allModuleEntries = updateAllModules (manifest ^. #modules) originedModules now                           allResolvedVals =-                            Map.unions [Map.map (.value) vs | vs <- Map.elems baseResolved]+                            Map.unions [Map.map (^. #value) vs | vs <- Map.elems baseResolved]                           newManifest =                             Manifest                               { version = currentManifestVersion,                                 genAt = now,                                 modules = allModuleEntries,-                                vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars,+                                vars = Map.union (Map.map varValueToText allResolvedVals) (manifest ^. #vars),                                 files = Map.unions [baselineRecords, keepRecords, cleanedFiles],-                                applications = manifest.applications,-                                recipe = manifest.recipe,-                                blueprint = manifest.blueprint,-                                blueprintMigrations = manifest.blueprintMigrations+                                applications = manifest ^. #applications,+                                recipe = manifest ^. #recipe,+                                blueprint = manifest ^. #blueprint,+                                blueprintMigrations = manifest ^. #blueprintMigrations                               }                       writeManifest newManifest                       pure (Right newManifest)@@ -413,9 +461,9 @@           logIO level $ logWarn $ "Warning: could not prune generated baselines: " <> T.pack (displayException err)         Right _ -> pure () -      let nNew = length diff.new-          nMod = length diff.modified-          nUnch = length diff.unchanged+      let nNew = length (diff ^. #new)+          nMod = length (diff ^. #modified)+          nUnch = length (diff ^. #unchanged)       logIO level $         logInfo $           "Baseline applied: "@@ -427,27 +475,27 @@             <> " unchanged."       pure $         BaselineApplied-          [(m.name, m.version) | (_, m, _) <- modulesInOrder]+          [(m ^. #name, m ^. #version) | (_, m, _) <- modulesInOrder]  -- | Stitch the system-prompt template together. Each block in -- @blueprint-prompt.md@ has a @{{key}}@ placeholder filled here. renderSystemPrompt :: AgentContext -> PreparedBlueprintExecution -> BaselineStatus -> Text renderSystemPrompt ctx prepared baseline =-  let bp = prepared.preparedBlueprint+  let bp = (prepared ^. #blueprint)    in substitute-        [ ("cwd", ctx.cwd),+        [ ("cwd", ctx ^. #cwd),           ("seihou_project_state", formatSeihouProjectState ctx),           ("manifest_state", formatManifestState ctx),           ("module_dhall_state", formatModuleDhallState ctx),           ("local_modules", formatLocalModules ctx),           ("available_modules", formatAvailableModules ctx),-          ("blueprint_name", bp.name.unModuleName),-          ("blueprint_version", fromMaybe "(unspecified)" bp.version),-          ("blueprint_description", fromMaybe "(no description)" bp.description),+          ("blueprint_name", bp ^. #name . #unModuleName),+          ("blueprint_version", fromMaybe "(unspecified)" (bp ^. #version)),+          ("blueprint_description", fromMaybe "(no description)" (bp ^. #description)),           ("baseline_status", formatBaselineStatus baseline),-          ("reference_files", prepared.preparedReferenceFiles),-          ("reference_files_dir", prepared.preparedReferenceFilesAccess),-          ("user_prompt", prepared.preparedSharedPrompt)+          ("reference_files", prepared ^. #referenceFiles),+          ("reference_files_dir", prepared ^. #referenceFilesAccess),+          ("user_prompt", prepared ^. #sharedPrompt)         ]         promptTemplate @@ -462,27 +510,27 @@ -- applied-modules list. Local copy of @Seihou.CLI.Run.updateAllModules@. updateAllModules ::   [AppliedModule] ->-  [(ModuleInstance, Module, FilePath)] ->+  [(ModuleInstance, Module, ArtifactOrigin)] ->   UTCTime ->   [AppliedModule] updateAllModules existing modulesInOrder now =   let composedKeys =         Set.fromList-          [ (inst.instanceModule, inst.instanceParentVars)+          [ (inst ^. #module_, inst ^. #parentVars)           | (inst, _, _) <- modulesInOrder           ]       filtered =-        filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing+        filter (\am -> not (Set.member (am ^. #name, am ^. #parentVars) composedKeys)) existing       new =         [ AppliedModule-            { name = inst.instanceModule,-              parentVars = inst.instanceParentVars,-              source = dir,-              moduleVersion = m.version,+            { name = inst ^. #module_,+              parentVars = inst ^. #parentVars,+              origin = origin,+              moduleVersion = m ^. #version,               appliedAt = now,-              removal = m.removal+              removal = m ^. #removal             }-        | (inst, m, dir) <- modulesInOrder+        | (inst, m, origin) <- modulesInOrder         ]    in filtered ++ new @@ -497,24 +545,24 @@ renderModuleLoadError = \case   ModuleNotFound name searched ->     "Module '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "' not found. Searched in:\n"       <> T.intercalate "\n" (map (("  " <>) . T.pack) searched)   DhallEvalError name msg ->-    "Failed to evaluate '" <> name.unModuleName <> "': " <> msg+    "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg   DhallDecodeError name msg ->-    "Failed to decode '" <> name.unModuleName <> "': " <> msg+    "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg   ValidationError name msgs ->     "Validation failed for '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "':\n"       <> T.intercalate "\n" (map ("  " <>) msgs)   CircularDependency names ->     "Circular dependency detected: "-      <> T.intercalate " -> " (map (.unModuleName) names)+      <> T.intercalate " -> " (map (^. #unModuleName) names)   MissingSourceFile name path ->     "Missing source file in '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "': "       <> T.pack path   RegistryEvalError path msg ->
src-exe/Seihou/CLI/Assist.hs view
@@ -6,12 +6,13 @@ where  import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),-    buildAgentCompletionRequest,+    buildAgentCompletionRequestWith,     runAgentCompletion,   ) import Seihou.CLI.AgentLaunch@@ -26,7 +27,9 @@     substitute,   ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent)+import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (AssistOpts (..))+import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -38,12 +41,12 @@ handleAssist debug modelConfig assistOpts = do   ctx <- gatherAgentContext   let systemPrompt = renderPrompt ctx-  runRenderedAgentPrompt debug modelConfig systemPrompt assistOpts.assistPrompt+  runRenderedAgentPrompt debug modelConfig systemPrompt (assistOpts ^. #prompt)  renderPrompt :: AgentContext -> Text renderPrompt ctx =   substitute-    [ ("cwd", ctx.cwd),+    [ ("cwd", ctx ^. #cwd),       ("seihou_project_state", formatSeihouProjectState ctx),       ("manifest_state", formatManifestState ctx),       ("module_dhall_state", formatModuleDhallState ctx),@@ -55,11 +58,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt   | debug = TIO.putStr systemPrompt-  | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do+  | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do       exitCode <- launchConfiguredAgent modelConfig defaultAllowedTools debug systemPrompt initialPrompt       exitWith exitCode   | otherwise = do-      result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt)+      sink <- traceSinkForConfig LogNormal modelConfig+      result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt)       case result of         Right assistantText -> TIO.putStrLn assistantText         Left err -> do
src-exe/Seihou/CLI/Bootstrap.hs view
@@ -6,13 +6,14 @@ where  import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),-    buildAgentCompletionRequest,+    buildAgentCompletionRequestWith,     runAgentCompletion,   ) import Seihou.CLI.AgentLaunch@@ -27,7 +28,9 @@     substitute,   ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent)+import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (BootstrapOpts (..))+import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -39,12 +42,12 @@ handleBootstrap debug modelConfig bootstrapOpts = do   ctx <- gatherAgentContext   let systemPrompt = renderPrompt ctx bootstrapOpts-  runRenderedAgentPrompt debug modelConfig systemPrompt bootstrapOpts.bootstrapPrompt+  runRenderedAgentPrompt debug modelConfig systemPrompt (bootstrapOpts ^. #prompt)  renderPrompt :: AgentContext -> BootstrapOpts -> Text renderPrompt ctx bootstrapOpts =   substitute-    [ ("cwd", ctx.cwd),+    [ ("cwd", ctx ^. #cwd),       ("seihou_project_state", formatSeihouProjectState ctx),       ("manifest_state", formatManifestState ctx),       ("module_dhall_state", formatModuleDhallState ctx),@@ -57,11 +60,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt   | debug = TIO.putStr systemPrompt-  | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do+  | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do       exitCode <- launchConfiguredAgent modelConfig bootstrapAllowedTools debug systemPrompt initialPrompt       exitWith exitCode   | otherwise = do-      result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt)+      sink <- traceSinkForConfig LogNormal modelConfig+      result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt)       case result of         Right assistantText -> TIO.putStrLn assistantText         Left err -> do@@ -70,7 +74,7 @@  bootstrapMode :: BootstrapOpts -> Text bootstrapMode opts-  | opts.bootstrapRepo =+  | (opts ^. #repo) =       T.unlines         [ "**Mode: Multi-module repository**",           "",
src-exe/Seihou/CLI/Browse.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.BrowseFormat (formatBrowseRegistry, formatBrowseSingleBlueprint, formatBrowseSingleModule, formatBrowseSinglePrompt)@@ -21,7 +22,7 @@  handleBrowse :: BrowseOpts -> IO () handleBrowse bopts = do-  let source = bopts.browseSource+  let source = (bopts ^. #source)    withSystemTempDirectory "seihou-browse" $ \tmpDir -> do     let repoName = parseModuleName source@@ -50,7 +51,7 @@             logIO LogNormal (logError $ "failed to load module: " <> T.pack (show err))             exitFailure           Right m ->-            TIO.putStr $ formatBrowseSingleModule source m.name.unModuleName m.description+            TIO.putStr $ formatBrowseSingleModule source (m ^. #name . #unModuleName) (m ^. #description)       SingleRecipe rootDir -> do         let dhallFile = rootDir </> "recipe.dhall"         decoded <- evalRecipeFromFile dhallFile@@ -59,7 +60,7 @@             logIO LogNormal (logError $ "failed to load recipe: " <> T.pack (show err))             exitFailure           Right r ->-            TIO.putStr $ formatBrowseSingleModule source r.name.unRecipeName r.description+            TIO.putStr $ formatBrowseSingleModule source (r ^. #name . #unRecipeName) (r ^. #description)       SingleBlueprint rootDir -> do         let dhallFile = rootDir </> "blueprint.dhall"         decoded <- evalBlueprintFromFile dhallFile@@ -68,9 +69,7 @@             logIO LogNormal (logError $ "failed to load blueprint: " <> T.pack (show err))             exitFailure           Right b -> do-            let bpName = case b of Blueprint nm _ _ _ _ _ _ _ _ _ _ -> nm-                bpDesc = case b of Blueprint _ _ d _ _ _ _ _ _ _ _ -> d-            TIO.putStr $ formatBrowseSingleBlueprint source bpName.unModuleName bpDesc+            TIO.putStr $ formatBrowseSingleBlueprint source (b ^. #name . #unModuleName) (b ^. #description)       SinglePrompt rootDir -> do         let dhallFile = rootDir </> "prompt.dhall"         decoded <- evalAgentPromptFromFile dhallFile@@ -79,16 +78,16 @@             logIO LogNormal (logError $ "failed to load prompt: " <> T.pack (show err))             exitFailure           Right p ->-            TIO.putStr $ formatBrowseSinglePrompt source p.name.unModuleName p.description+            TIO.putStr $ formatBrowseSinglePrompt source (p ^. #name . #unModuleName) (p ^. #description)       MultiModule registry -> do         driftWarnings <- checkRegistryVersionDrift cloneDir registry         logIO LogNormal (mapM_ logWarn driftWarnings)-        let matchTag e = case bopts.browseTag of+        let matchTag e = case bopts ^. #tag of               Nothing -> True-              Just tag -> tag `elem` e.tags+              Just tag -> tag `elem` (e ^. #tags)             tagged =-              [(ModuleEntry, e) | e <- registry.modules, matchTag e]-                ++ [(RecipeEntry, e) | e <- registry.recipes, matchTag e]-                ++ [(BlueprintEntry, e) | e <- registry.blueprints, matchTag e]-                ++ [(PromptEntry, e) | e <- registry.prompts, matchTag e]-        TIO.putStr $ formatBrowseRegistry source registry tagged bopts.browseTag+              [(ModuleEntry, e) | e <- registry ^. #modules, matchTag e]+                ++ [(RecipeEntry, e) | e <- registry ^. #recipes, matchTag e]+                ++ [(BlueprintEntry, e) | e <- registry ^. #blueprints, matchTag e]+                ++ [(PromptEntry, e) | e <- registry ^. #prompts, matchTag e]+        TIO.putStr $ formatBrowseRegistry source registry tagged (bopts ^. #tag)
src-exe/Seihou/CLI/Commands.hs view
@@ -39,18 +39,21 @@     RegistryCommand (..),     SyncVersionsOpts (..),     ValidateRegistryOpts (..),+    ManifestCommand (..),+    ManifestUpgradeOpts (..),     commandParser,     opts,   ) where  import Data.Text qualified as T-import GHC.Generics (Generic) import Options.Applicative import Options.Applicative.Help.Pretty (Doc, indent, line, pretty, vsep) import Seihou.CLI.Extension (ExtensionRunOpts (..)) import Seihou.CLI.Help (HelpCommand, helpCommandParser) import Seihou.CLI.Kit (KitCommand, kitCommandParser)+import Seihou.CLI.Manifest (ManifestCommand (..))+import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts (..)) import Seihou.CLI.Migrate (MigrateOpts (..)) import Seihou.CLI.Registry (RegistryCommand (..)) import Seihou.CLI.Registry.Sync (SyncVersionsOpts (..))@@ -84,6 +87,7 @@   | Migrate MigrateOpts   | SchemaUpgrade SchemaUpgradeOpts   | Registry RegistryCommand+  | ManifestCmd ManifestCommand   | Kit KitCommand   | Agent AgentOpts   | Prompt PromptCommand@@ -103,16 +107,17 @@   deriving stock (Eq, Show, Generic)  data AgentOpts = AgentOpts-  { agentDebug :: Bool,-    agentProvider :: Maybe Text,-    agentModel :: Maybe Text,-    agentEffort :: Maybe Text,-    agentCommand :: AgentCommand+  { debug :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text),+    command :: !AgentCommand   }   deriving stock (Eq, Show, Generic)  data AgentModelsOpts = AgentModelsOpts-  { modelsProvider :: Maybe Text+  { modelsProvider :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic) @@ -127,20 +132,20 @@   deriving stock (Eq, Show, Generic)  data RunOpts = RunOpts-  { runModule :: Maybe ModuleName,-    runAdditional :: [ModuleName],-    runVars :: [(Text, Text)],-    runDryRun :: Bool,-    runDiff :: Bool,-    runForce :: Bool,-    runNoCommands :: Bool,-    runNamespace :: Maybe Text,-    runContext :: Maybe Text,-    runVerbose :: Bool,-    runSavePrompted :: Maybe Bool,-    runConfirmDefaults :: Bool,-    runCommit :: Bool,-    runCommitMessage :: Maybe Text,+  { module_ :: !(Maybe ModuleName),+    additional :: ![ModuleName],+    vars :: ![(Text, Text)],+    dryRun :: !Bool,+    diff :: !Bool,+    force :: !Bool,+    noCommands :: !Bool,+    namespace :: !(Maybe Text),+    context :: !(Maybe Text),+    verbose :: !Bool,+    savePrompted :: !(Maybe Bool),+    confirmDefaults :: !Bool,+    commit :: !Bool,+    commitMessage :: !(Maybe Text),     -- | When 'True', a pre-flight pending-migration check that finds     -- any chain for one of the composed modules will apply that chain     -- to the project (and the manifest) before the run plan is@@ -148,89 +153,106 @@     -- 'seihou run' to refuse with an actionable message and a     -- non-zero exit, so a user never silently writes new templates     -- into paths a migration would have moved.-    runWithMigrations :: Bool+    withMigrations :: !Bool,+    -- | When 'True', generate even though a 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), either condition makes @seihou run@ refuse+    -- before writing anything, so a developer whose install cache lags+    -- behind a teammate's commit cannot silently regenerate the project+    -- from the older module. The blocking artifacts are printed either+    -- way; the flag only decides whether the run continues.+    allowDowngrade :: !Bool   }   deriving stock (Eq, Show, Generic)  data UpdateOpts = UpdateOpts-  { updateTargets :: [Text],-    updateVars :: [(Text, Text)],-    updateDryRun :: Bool,-    updateJson :: Bool,-    updateReconfigure :: Bool,-    updateForce :: Bool,-    updateRunAllCommands :: Bool,-    updateNoCommands :: Bool,-    updateCommit :: Bool,-    updateCommitMessage :: Maybe Text+  { targets :: ![Text],+    vars :: ![(Text, Text)],+    dryRun :: !Bool,+    json :: !Bool,+    reconfigure :: !Bool,+    force :: !Bool,+    runAllCommands :: !Bool,+    noCommands :: !Bool,+    commit :: !Bool,+    commitMessage :: !(Maybe Text),+    -- | When 'True', accept a candidate artifact whose version is lower+    -- than the version @.seihou\/manifest.json@ records. Unlike+    -- @seihou run@, @seihou update@ does not generate from whatever is+    -- installed locally — it clones from the origin URL the manifest+    -- itself records — so the only downgrade it can produce is an+    -- upstream that moved backwards. This flag is the escape hatch for+    -- pinning to such a version deliberately.+    allowDowngrade :: !Bool   }   deriving stock (Eq, Show, Generic)  data RemoveOpts = RemoveOpts-  { removeModule :: ModuleName,-    removeDryRun :: Bool,-    removeForce :: Bool,-    removeVerbose :: Bool+  { module_ :: !ModuleName,+    dryRun :: !Bool,+    force :: !Bool,+    verbose :: !Bool   }   deriving stock (Eq, Show, Generic)  data VarsOpts = VarsOpts-  { varsModule :: Maybe ModuleName,-    varsExplain :: Bool,-    varsVars :: [(Text, Text)],-    varsNamespace :: Maybe Text,-    varsContext :: Maybe Text+  { module_ :: !(Maybe ModuleName),+    explain :: !Bool,+    vars :: ![(Text, Text)],+    namespace :: !(Maybe Text),+    context :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data InstallOpts = InstallOpts-  { installSource :: Maybe Text,-    installName :: Maybe Text,-    installModules :: [Text],-    installAll :: Bool+  { source :: !(Maybe Text),+    name :: !(Maybe Text),+    modules :: ![Text],+    all :: !Bool   }   deriving stock (Eq, Show, Generic)  data NewModuleOpts = NewModuleOpts-  { newModuleName :: Text,-    newModulePath :: Maybe FilePath+  { name :: !Text,+    path :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic)  data NewRecipeOpts = NewRecipeOpts-  { newRecipeName :: Text,-    newRecipeModules :: [Text],-    newRecipePath :: Maybe FilePath+  { name :: !Text,+    modules :: ![Text],+    path :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic)  data NewBlueprintOpts = NewBlueprintOpts-  { newBlueprintName :: Text,-    newBlueprintPath :: Maybe FilePath+  { name :: !Text,+    path :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic)  data NewPromptOpts = NewPromptOpts-  { newPromptName :: Text,-    newPromptPath :: Maybe FilePath+  { name :: !Text,+    path :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic)  data ValidateOpts = ValidateOpts-  { validatePath :: Maybe FilePath,-    validateLint :: Bool+  { path :: !(Maybe FilePath),+    lint :: !Bool   }   deriving stock (Eq, Show, Generic)  data ValidateBlueprintOpts = ValidateBlueprintOpts-  { validateBlueprintPath :: Maybe FilePath,-    validateBlueprintLint :: Bool+  { path :: !(Maybe FilePath),+    lint :: !Bool   }   deriving stock (Eq, Show, Generic)  data ValidatePromptOpts = ValidatePromptOpts-  { validatePromptPath :: Maybe FilePath,-    validatePromptLint :: Bool+  { path :: !(Maybe FilePath),+    lint :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -242,11 +264,11 @@   deriving stock (Eq, Show, Generic)  data ConfigOpts = ConfigOpts-  { configAction :: ConfigAction,-    configGlobal :: Bool,-    configNamespace :: Maybe Text,-    configContext :: Maybe Text,-    configEffective :: Bool+  { action :: !ConfigAction,+    global :: !Bool,+    namespace :: !(Maybe Text),+    context :: !(Maybe Text),+    effective :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -259,105 +281,111 @@   deriving stock (Eq, Show, Generic)  data ListOpts = ListOpts-  { listRepo :: Maybe Text,-    listTag :: Maybe Text,-    listModulesOnly :: Bool,-    listRecipesOnly :: Bool,-    listBlueprintsOnly :: Bool,-    listPromptsOnly :: Bool+  { repo :: !(Maybe Text),+    tag :: !(Maybe Text),+    modulesOnly :: !Bool,+    recipesOnly :: !Bool,+    blueprintsOnly :: !Bool,+    promptsOnly :: !Bool   }   deriving stock (Eq, Show, Generic)  data BrowseOpts = BrowseOpts-  { browseSource :: Text,-    browseTag :: Maybe Text+  { source :: !Text,+    tag :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data StatusOpts = StatusOpts-  { statusCheckUpdates :: Bool+  { statusCheckUpdates :: !Bool   }   deriving stock (Eq, Show, Generic)  data OutdatedOpts = OutdatedOpts-  { outdatedJson :: Bool+  { outdatedJson :: !Bool   }   deriving stock (Eq, Show, Generic)  data UpgradeOpts = UpgradeOpts-  { upgradeModules :: [Text],-    upgradeDryRun :: Bool,-    upgradeJson :: Bool,-    upgradeSkipUnversioned :: Bool,+  { modules :: ![Text],+    dryRun :: !Bool,+    json :: !Bool,+    skipUnversioned :: !Bool,     -- | If 'True', after each successful per-module upgrade, also run     -- 'Seihou.CLI.Migrate.runMigrate' against the *current project*     -- (cwd), if and only if that module is applied locally. Default     -- 'False'; the unset path emits a one-line advisory pointing the     -- user at @seihou update@ when migrations would be pending.-    upgradeWithMigrations :: Bool+    withMigrations :: !Bool   }   deriving stock (Eq, Show, Generic)  data SchemaUpgradeOpts = SchemaUpgradeOpts-  { schemaUpgradePath :: Maybe FilePath,-    schemaUpgradeDryRun :: Bool,-    schemaUpgradeAll :: Bool+  { path :: !(Maybe FilePath),+    dryRun :: !Bool,+    all :: !Bool   }   deriving stock (Eq, Show, Generic)  data AssistOpts = AssistOpts-  { assistPrompt :: Maybe Text,-    assistProvider :: Maybe Text,-    assistModel :: Maybe Text,-    assistEffort :: Maybe Text+  { prompt :: !(Maybe Text),+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data BootstrapOpts = BootstrapOpts-  { bootstrapPrompt :: Maybe Text,-    bootstrapRepo :: Bool,-    bootstrapProvider :: Maybe Text,-    bootstrapModel :: Maybe Text,-    bootstrapEffort :: Maybe Text+  { prompt :: !(Maybe Text),+    repo :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data SetupOpts = SetupOpts-  { setupPrompt :: Maybe Text,-    setupProvider :: Maybe Text,-    setupModel :: Maybe Text,-    setupEffort :: Maybe Text+  { prompt :: !(Maybe Text),+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data BlueprintRunOpts = BlueprintRunOpts-  { runBlueprintName :: ModuleName,-    runBlueprintPrompt :: Maybe Text,-    runBlueprintVars :: [(Text, Text)],-    runBlueprintNoBaseline :: Bool,-    runBlueprintNamespace :: Maybe Text,-    runBlueprintContext :: Maybe Text,-    runBlueprintVerbose :: Bool,-    runBlueprintForce :: Bool,-    runBlueprintProvider :: Maybe Text,-    runBlueprintModel :: Maybe Text,-    runBlueprintEffort :: Maybe Text+  { name :: !ModuleName,+    prompt :: !(Maybe Text),+    vars :: ![(Text, Text)],+    noBaseline :: !Bool,+    namespace :: !(Maybe Text),+    context :: !(Maybe Text),+    verbose :: !Bool,+    force :: !Bool,+    batch :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  data BlueprintMigrationOpts = BlueprintMigrationOpts-  { migrateBlueprintName :: ModuleName,-    migrateBlueprintFrom :: Text,-    migrateBlueprintTo :: Text,-    migrateBlueprintPrompt :: Maybe Text,-    migrateBlueprintVars :: [(Text, Text)],-    migrateBlueprintNamespace :: Maybe Text,-    migrateBlueprintContext :: Maybe Text,-    migrateBlueprintVerbose :: Bool,-    migrateBlueprintRerun :: Bool,-    migrateBlueprintProvider :: Maybe Text,-    migrateBlueprintModel :: Maybe Text,-    migrateBlueprintEffort :: Maybe Text+  { name :: !ModuleName,+    from :: !Text,+    to :: !Text,+    prompt :: !(Maybe Text),+    vars :: ![(Text, Text)],+    namespace :: !(Maybe Text),+    context :: !(Maybe Text),+    verbose :: !Bool,+    rerun :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic) @@ -366,16 +394,17 @@   deriving stock (Eq, Show, Generic)  data PromptRunOpts = PromptRunOpts-  { runPromptName :: ModuleName,-    runPromptPrompt :: Maybe Text,-    runPromptVars :: [(Text, Text)],-    runPromptNamespace :: Maybe Text,-    runPromptContext :: Maybe Text,-    runPromptVerbose :: Bool,-    runPromptDebug :: Bool,-    runPromptProvider :: Maybe Text,-    runPromptModel :: Maybe Text,-    runPromptEffort :: Maybe Text+  { name :: !ModuleName,+    prompt :: !(Maybe Text),+    vars :: ![(Text, Text)],+    namespace :: !(Maybe Text),+    context :: !(Maybe Text),+    verbose :: !Bool,+    debug :: !Bool,+    provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic) @@ -420,6 +449,7 @@         <> command "remove" removeInfo         <> command "status" statusInfo         <> command "diff" diffInfo+        <> command "manifest" manifestInfo     )     <|> hsubparser       ( command "list" listInfo@@ -833,6 +863,10 @@         ( long "with-migrations"             <> help "Apply any pending module migrations before the run plan; without this, 'seihou run' refuses when migrations are pending"         )+      <*> switch+        ( long "allow-downgrade"+            <> help "Proceed even when a module installed locally is older than the version recorded in .seihou/manifest.json"+        )  updateParser :: Parser Command updateParser =@@ -851,19 +885,24 @@       <*> updateCommandFlags       <*> switch (long "commit" <> help "Commit successfully updated managed paths")       <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)"))+      <*> switch+        ( long "allow-downgrade"+            <> help "Accept a candidate artifact older than the version recorded in .seihou/manifest.json"+        )   where-    makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage =+    makeUpdateOpts targets vars dryRun json reconfigure force (runAll, noCommands) commit commitMessage allowDowngrade =       UpdateOpts-        { updateTargets = targets,-          updateVars = vars,-          updateDryRun = dryRun,-          updateJson = json,-          updateReconfigure = reconfigure,-          updateForce = force,-          updateRunAllCommands = runAll,-          updateNoCommands = noCommands,-          updateCommit = commit,-          updateCommitMessage = commitMessage+        { targets = targets,+          vars = vars,+          dryRun = dryRun,+          json = json,+          reconfigure = reconfigure,+          force = force,+          runAllCommands = runAll,+          noCommands = noCommands,+          commit = commit,+          commitMessage = commitMessage,+          allowDowngrade = allowDowngrade         }     updateCommandFlags =       flag' (True, False) (long "run-all-commands" <> help "Run every generated command, including unchanged ones")@@ -1278,6 +1317,10 @@       <*> switch (long "no-fetch" <> help "Skip the remote fetch; use only the locally installed copy")       <*> switch (long "commit" <> help "Commit migrated files to git after execution (uses AI-generated message)")       <*> optional (option (T.pack <$> str) (long "commit-message" <> metavar "MSG" <> help "Custom commit message (implies --commit)"))+      <*> switch+        ( long "allow-downgrade"+            <> help "Proceed even when a module installed locally is older than the version recorded in .seihou/manifest.json"+        )  migrateFooter :: Doc migrateFooter =@@ -1366,6 +1409,70 @@         <> progDesc "Manage Claude Code and Codex skills and subagents"     ) +manifestInfo :: ParserInfo Command+manifestInfo =+  info+    (ManifestCmd <$> manifestCommandParser <**> helper)+    ( fullDesc+        <> progDesc "Operate on this project's .seihou/manifest.json"+        <> footerDoc+          ( Just $+              vsep+                [ pretty ("The manifest is checked into version control and describes the" :: String),+                  pretty ("project, not the machine. These commands maintain it." :: String),+                  line,+                  pretty ("Current subcommands:" :: String),+                  indent 2 $+                    vsep+                      [ pretty ("upgrade   Convert a manifest written by an older seihou" :: String)+                      ],+                  line,+                  pretty ("Examples:" :: String),+                  indent 2 $+                    vsep+                      [ pretty ("seihou manifest upgrade --dry-run" :: String),+                        pretty ("seihou manifest upgrade" :: String)+                      ]+                ]+          )+    )++manifestCommandParser :: Parser ManifestCommand+manifestCommandParser =+  hsubparser+    (command "upgrade" manifestUpgradeInfo)++manifestUpgradeInfo :: ParserInfo ManifestCommand+manifestUpgradeInfo =+  info+    (manifestUpgradeParser <**> helper)+    ( fullDesc+        <> progDesc "Convert a manifest written by an older seihou to the portable format"+        <> footerDoc+          ( Just $+              vsep+                [ pretty ("Manifests written before schema version 6 record, for every applied" :: String),+                  pretty ("module, the absolute directory that module occupied on the machine" :: String),+                  pretty ("that ran seihou. Those paths mean nothing in another clone, so this" :: String),+                  pretty ("command replaces each one with a portable origin: the git URL the" :: String),+                  pretty ("module was installed from, or a path relative to the project root." :: String),+                  line,+                  pretty ("Recovering an upstream URL from somebody else's absolute path takes" :: String),+                  pretty ("inference, so every conversion is printed. Review the result with" :: String),+                  pretty ("git diff .seihou/manifest.json before committing it." :: String),+                  line,+                  pretty ("Run from the project root. Running it twice is safe." :: String)+                ]+          )+    )++manifestUpgradeParser :: Parser ManifestCommand+manifestUpgradeParser =+  fmap ManifestUpgrade $+    ManifestUpgradeOpts+      <$> switch (long "dry-run" <> help "Show every conversion without writing the manifest")+      <*> switch (long "force" <> help "Write even when a converted artifact is missing or stale here")+ registryInfo :: ParserInfo Command registryInfo =   info@@ -1529,6 +1636,7 @@             )         )       <*> effortOption+      <*> traceOption       <*> agentCommandParser  agentCommandParser :: Parser AgentCommand@@ -1581,6 +1689,7 @@       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  agentBootstrapInfo :: ParserInfo AgentCommand agentBootstrapInfo =@@ -1619,6 +1728,7 @@       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  agentSetupInfo :: ParserInfo AgentCommand agentSetupInfo =@@ -1656,6 +1766,7 @@       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  agentRunInfo :: ParserInfo AgentCommand agentRunInfo =@@ -1678,6 +1789,8 @@                   pretty ("Pass --no-baseline to skip baseline application; --debug (on the parent" :: String),                   pretty ("'seihou agent --debug') prints the resolved system prompt without" :: String),                   pretty ("contacting the configured provider." :: String),+                  pretty ("Pass --batch to use a non-interactive CLI provider; Seihou selects" :: String),+                  pretty ("batch mode automatically when stdin is not a terminal." :: String),                   line,                   pretty ("Examples:" :: String),                   indent 2 $@@ -1686,6 +1799,7 @@                         pretty ("seihou agent run my-blueprint \"set this up for billing\"" :: String),                         pretty ("seihou agent run my-blueprint --var service.name=billing" :: String),                         pretty ("seihou agent run my-blueprint --no-baseline" :: String),+                        pretty ("seihou agent run my-blueprint --batch" :: String),                         pretty ("seihou agent --debug run my-blueprint" :: String)                       ]                 ]@@ -1708,9 +1822,11 @@       <*> optional (option (T.pack <$> str) (long "context" <> short 'c' <> metavar "CTX" <> help "Override context for config lookup"))       <*> switch (long "verbose" <> short 'v' <> help "Show detailed progress messages")       <*> switch (long "force" <> help "Auto-resolve baseline conflicts (accept new files)")+      <*> switch (long "batch" <> help "Run a non-interactive CLI provider (automatic when stdin is not a terminal)")       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  agentMigrateInfo :: ParserInfo AgentCommand agentMigrateInfo =@@ -1760,6 +1876,7 @@       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  agentModelsInfo :: ParserInfo AgentCommand agentModelsInfo =@@ -1896,6 +2013,7 @@       <*> providerOption       <*> modelOption       <*> effortOption+      <*> traceOption  helpCmdInfo :: ParserInfo Command helpCmdInfo =@@ -2021,4 +2139,14 @@       ( long "effort"           <> metavar "LEVEL"           <> help "Reasoning effort: minimal, low, medium, high, xhigh, or max"+      )++traceOption :: Parser (Maybe Text)+traceOption =+  optional $+    option+      (T.pack <$> str)+      ( long "trace"+          <> metavar "SETTING"+          <> help "Record model calls: off, file, stdout, or stderr (file path: agent.tracePath)"       )
src-exe/Seihou/CLI/Config.hs view
@@ -18,15 +18,15 @@ import System.Exit (exitFailure)  handleConfig :: ConfigOpts -> IO ()-handleConfig ConfigOpts {configAction, configGlobal, configNamespace, configContext, configEffective} = do-  let scope = resolveScope configGlobal configNamespace configContext-  case configAction of+handleConfig ConfigOpts {action, global, namespace, context, effective} = do+  let scope = resolveScope global namespace context+  case action of     ConfigSet key value -> handleSet scope key value     ConfigGet key -> handleGet scope key     ConfigUnset key -> handleUnset scope key     ConfigList-      | configEffective -> handleListEffective configNamespace configContext-      | otherwise -> handleList configGlobal configNamespace configContext+      | effective -> handleListEffective namespace context+      | otherwise -> handleList global namespace context  resolveScope :: Bool -> Maybe Text -> Maybe Text -> ConfigScope resolveScope True _ _ = ScopeGlobal
src-exe/Seihou/CLI/Context.hs view
@@ -64,7 +64,7 @@     else do       entries <- listDirectory contextsDir       dirs <- filterM (doesDirectoryExist . (contextsDir </>)) entries-      let candidates = [Candidate {candidateDisplay = T.pack d, candidateValue = T.pack d} | d <- dirs]+      let candidates = [Candidate {display = T.pack d, value = T.pack d} | d <- dirs]           opts = withPrompt "context> " <> withHeight "40%" <> withAnsi <> withNoSort       runEff $ runFzfIO fzfCfg $ selectOne opts candidates   where
src-exe/Seihou/CLI/Help.hs view
@@ -9,6 +9,7 @@  import Data.FileEmbed (embedStringFile) import Data.Foldable (forM_)+import Data.Generics.Labels () import Data.List (find) import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -16,10 +17,11 @@ import Seihou.Prelude  data HelpTopic = HelpTopic-  { topicName :: !Text,-    topicDescription :: !Text,-    topicContent :: !Text+  { name :: !Text,+    description :: !Text,+    content :: !Text   }+  deriving stock (Generic)  data HelpCommand   = ListTopics@@ -36,6 +38,7 @@     HelpTopic "config" "Config scopes, reading, and writing values" configContent,     HelpTopic "git-repository" "Sharing and installing items from git" gitRepositoryContent,     HelpTopic "kit" "Manage Claude Code and Codex skills and subagents" kitContent,+    HelpTopic "manifest" "What .seihou/manifest.json records and how to upgrade it" manifestContent,     HelpTopic "migrations" "Migrating a project between module versions" migrationsContent,     HelpTopic "prompts" "Reusable agent-session prompt artifacts" promptsContent,     HelpTopic "templating" "Placeholder substitution, {{#if}} blocks, and patterns" templatingContent,@@ -66,6 +69,9 @@ kitContent :: Text kitContent = $(embedStringFile "help/kit.md") +manifestContent :: Text+manifestContent = $(embedStringFile "help/manifest.md")+ migrationsContent :: Text migrationsContent = $(embedStringFile "help/migrations.md") @@ -90,7 +96,7 @@           <> help ("Help topic: " <> T.unpack topicList)       )   where-    topicList = T.intercalate ", " (map (.topicName) helpTopics)+    topicList = T.intercalate ", " (map (^. #name) helpTopics)  handleHelpCommand :: HelpCommand -> IO () handleHelpCommand = \case@@ -101,7 +107,7 @@ listTopics = do   TIO.putStrLn "HELP TOPICS\n"   forM_ helpTopics $ \t ->-    TIO.putStrLn $ "  " <> padRight 17 t.topicName <> t.topicDescription+    TIO.putStrLn $ "  " <> padRight 17 (t ^. #name) <> (t ^. #description)   TIO.putStrLn "\nUse 'seihou help <topic>' for details."  padRight :: Int -> Text -> Text@@ -109,8 +115,8 @@  showTopic :: Text -> IO () showTopic name =-  case find (\t -> t.topicName == T.toLower name) helpTopics of-    Just t -> TIO.putStrLn t.topicContent+  case find (\t -> t ^. #name == T.toLower name) helpTopics of+    Just t -> TIO.putStrLn (t ^. #content)     Nothing -> do       TIO.putStrLn $ "Unknown topic: " <> name-      TIO.putStrLn $ "Available: " <> T.intercalate ", " (map (.topicName) helpTopics)+      TIO.putStrLn $ "Available: " <> T.intercalate ", " (map (^. #name) helpTopics)
src-exe/Seihou/CLI/Install.hs view
@@ -8,6 +8,7 @@  import Control.Applicative ((<|>)) import Control.Monad (when)+import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.BrowseFormat (kindLabel)@@ -36,7 +37,7 @@  handleInstall :: InstallOpts -> IO () handleInstall iopts = do-  source <- resolveSource iopts.installSource+  source <- resolveSource (iopts ^. #source)    TIO.putStrLn $ "Installing from " <> source <> "..." @@ -59,19 +60,19 @@         logIO LogNormal (logError "repository contains neither seihou-registry.dhall nor a supported runnable Dhall file.")         exitFailure       SingleModule rootDir -> do-        when (not (null iopts.installModules) || iopts.installAll) $+        when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-module repositories.")         installSingleModule iopts rootDir source Nothing       SingleRecipe rootDir -> do-        when (not (null iopts.installModules) || iopts.installAll) $+        when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-recipe repositories.")         installSingleRecipe iopts rootDir source       SingleBlueprint rootDir -> do-        when (not (null iopts.installModules) || iopts.installAll) $+        when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-blueprint repositories.")         installSingleBlueprint iopts rootDir source       SinglePrompt rootDir -> do-        when (not (null iopts.installModules) || iopts.installAll) $+        when (not (null (iopts ^. #modules)) || iopts ^. #all) $           logIO LogNormal (logWarn "--module and --all flags are ignored for single-prompt repositories.")         installSinglePrompt iopts rootDir source       MultiModule registry -> do@@ -95,7 +96,7 @@ resolveSource (Just url) = pure url resolveSource Nothing = do   history <- readHistory-  case history.entries of+  case history ^. #entries of     [] -> do       TIO.putStrLn "No URL specified and no install history found."       TIO.putStrLn "Usage: seihou install <git-url>"@@ -111,8 +112,8 @@ fzfUrlSelection fzfCfg entries = do   let candidates =         [ Candidate-            { candidateDisplay = entry.url,-              candidateValue = entry.url+            { display = entry ^. #url,+              value = entry ^. #url             }         | entry <- entries         ]@@ -137,7 +138,7 @@   TIO.putStrLn "Previously used sources:"   let numbered = zip [1 :: Int ..] entries   mapM_-    (\(i, entry) -> TIO.putStrLn $ "  " <> T.pack (show i) <> ") " <> entry.url)+    (\(i, entry) -> TIO.putStrLn $ "  " <> T.pack (show i) <> ") " <> entry ^. #url)     numbered   TIO.putStrLn ""   TIO.putStr "Select a source (number): "@@ -146,7 +147,7 @@   case readMaybe (T.unpack (T.strip input)) of     Just n       | n >= 1 && n <= length entries ->-          pure (entries !! (n - 1)).url+          pure ((entries !! (n - 1)) ^. #url)     _ -> do       TIO.putStrLn "Invalid selection."       exitFailure@@ -154,7 +155,7 @@ -- | Install a single-module repo (legacy behavior). installSingleModule :: InstallOpts -> FilePath -> Text -> Maybe Text -> IO () installSingleModule iopts rootDir source registryName = do-  let name = case iopts.installName of+  let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source @@ -181,14 +182,14 @@     Right _ -> pure ()   TIO.putStrLn "  Validated module definition" -  installModuleDir rootDir name source registryName modul.version []+  installModuleDir rootDir name source registryName (modul ^. #version) []   TIO.putStrLn ""   TIO.putStrLn $ "Module available as: " <> T.pack name  -- | Install a single-recipe repo. installSingleRecipe :: InstallOpts -> FilePath -> Text -> IO () installSingleRecipe iopts rootDir source = do-  let name = case iopts.installName of+  let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source @@ -202,7 +203,7 @@ -- | Install a single-blueprint repo. installSingleBlueprint :: InstallOpts -> FilePath -> Text -> IO () installSingleBlueprint iopts rootDir source = do-  let name = case iopts.installName of+  let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source @@ -229,7 +230,7 @@     Right _ -> pure ()   TIO.putStrLn "  Validated blueprint definition" -  let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v+  let bpVersion = (bp ^. #version)   installModuleDir rootDir name source Nothing bpVersion []   TIO.putStrLn ""   TIO.putStrLn $ "Blueprint available as: " <> T.pack name@@ -237,7 +238,7 @@ -- | Install a single-prompt repo. installSinglePrompt :: InstallOpts -> FilePath -> Text -> IO () installSinglePrompt iopts rootDir source = do-  let name = case iopts.installName of+  let name = case iopts ^. #name of         Just n -> T.unpack n         Nothing -> parseModuleName source @@ -264,7 +265,7 @@     Right _ -> pure ()   TIO.putStrLn "  Validated prompt definition" -  installModuleDir rootDir name source Nothing prompt.version []+  installModuleDir rootDir name source Nothing (prompt ^. #version) []   TIO.putStrLn ""   TIO.putStrLn $ "Prompt available as: " <> T.pack name @@ -275,7 +276,7 @@   if null selected     then TIO.putStrLn "No entries selected."     else do-      results <- mapM (installRegistryEntry cloneDir source registry.repoName) selected+      results <- mapM (installRegistryEntry cloneDir source (registry ^. #repoName)) selected       let succeeded = length (filter id results)           failed = length results - succeeded       TIO.putStrLn ""@@ -290,7 +291,7 @@ -- | All registry entries (modules, recipes, blueprints, prompts) in display order. -- Used wherever installation must treat all four kinds uniformly. allEntries :: Registry -> [RegistryEntry]-allEntries registry = registry.modules ++ registry.recipes ++ registry.blueprints ++ registry.prompts+allEntries registry = registry ^. #modules ++ registry ^. #recipes ++ registry ^. #blueprints ++ (registry ^. #prompts)  -- | Pair each registry entry with its 'EntryKind' tag, preserving the -- module → recipe → blueprint → prompt display order. Used by the install picker@@ -298,18 +299,18 @@ -- after selection. labelledEntries :: Registry -> [(EntryKind, RegistryEntry)] labelledEntries registry =-  map ((,) ModuleEntry) registry.modules-    ++ map ((,) RecipeEntry) registry.recipes-    ++ map ((,) BlueprintEntry) registry.blueprints-    ++ map ((,) PromptEntry) registry.prompts+  map ((,) ModuleEntry) (registry ^. #modules)+    ++ map ((,) RecipeEntry) (registry ^. #recipes)+    ++ map ((,) BlueprintEntry) (registry ^. #blueprints)+    ++ map ((,) PromptEntry) (registry ^. #prompts)  -- | Select which modules to install from a registry. selectModules :: InstallOpts -> Registry -> IO [RegistryEntry] selectModules iopts registry-  | iopts.installAll = pure (allEntries registry)-  | not (null iopts.installModules) = do+  | (iopts ^. #all) = pure (allEntries registry)+  | not (null (iopts ^. #modules)) = do       let entries = allEntries registry-          findEntry name = filter (\e -> e.name.unModuleName == name) entries+          findEntry name = filter (\e -> e ^. #name . #unModuleName == name) entries           (found, missing) =             foldr               ( \name (f, m) -> case findEntry name of@@ -317,7 +318,7 @@                   [] -> (f, name : m)               )               ([], [])-              iopts.installModules+              (iopts ^. #modules)       if not (null missing)         then do           logIO LogNormal $ do@@ -337,13 +338,13 @@   let entries = labelledEntries registry       candidates =         [ Candidate-            { candidateDisplay =+            { display =                 kindLabel kind                   <> "  "-                  <> entry.name.unModuleName-                  <> maybe "" (\d -> "  " <> d) entry.description-                  <> if null entry.tags then "" else "  [" <> T.intercalate ", " entry.tags <> "]",-              candidateValue = entry+                  <> entry ^. #name . #unModuleName+                  <> maybe "" (\d -> "  " <> d) (entry ^. #description)+                  <> if null (entry ^. #tags) then "" else "  [" <> T.intercalate ", " (entry ^. #tags) <> "]",+              value = entry             }         | (kind, entry) <- entries         ]@@ -361,8 +362,8 @@ promptModuleSelection :: Registry -> IO [RegistryEntry] promptModuleSelection registry = do   TIO.putStrLn ""-  TIO.putStrLn $ registry.repoName-  case registry.repoDescription of+  TIO.putStrLn $ (registry ^. #repoName)+  case registry ^. #repoDescription of     Just desc -> TIO.putStrLn $ "  " <> desc     Nothing -> pure ()   TIO.putStrLn ""@@ -376,8 +377,8 @@             <> ") "             <> kindLabel kind             <> "  "-            <> entry.name.unModuleName-            <> maybe "" (\d -> " - " <> d) entry.description+            <> entry ^. #name . #unModuleName+            <> maybe "" (\d -> " - " <> d) (entry ^. #description)     )     entries   TIO.putStrLn ""@@ -407,13 +408,13 @@ -- | Install a single registry entry (module, recipe, blueprint, or prompt). installRegistryEntry :: FilePath -> Text -> Text -> RegistryEntry -> IO Bool installRegistryEntry cloneDir source repoName entry = do-  let entryDir = cloneDir </> entry.path-      name = T.unpack entry.name.unModuleName+  let entryDir = cloneDir </> (entry ^. #path)+      name = T.unpack (entry ^. #name . #unModuleName)       moduleDhall = entryDir </> "module.dhall"       recipeDhall = entryDir </> "recipe.dhall"       blueprintDhall = entryDir </> "blueprint.dhall"       promptDhall = entryDir </> "prompt.dhall"-  TIO.putStrLn $ "  Installing " <> entry.name.unModuleName <> "..."+  TIO.putStrLn $ "  Installing " <> entry ^. #name . #unModuleName <> "..."    hasModule <- doesFileExist moduleDhall   if hasModule@@ -422,29 +423,29 @@       case decoded of         Left err -> do           logIO LogNormal $ do-            logError $ "  failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err)+            logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)           pure False         Right modul -> do           result <- validateModule entryDir modul           case result of             Left (ValidationError _ errors) -> do               logIO LogNormal $ do-                logError $ "  " <> entry.name.unModuleName <> " has validation errors:"+                logError $ "  " <> entry ^. #name . #unModuleName <> " has validation errors:"                 mapM_ (\e -> logError $ "    - " <> e) errors               pure False             Left err -> do               logIO LogNormal (logError $ "  " <> T.pack (show err))               pure False             Right _ -> do-              let ver = entry.version <|> modul.version-              installModuleDir entryDir name source (Just repoName) ver entry.tags+              let ver = entry ^. #version <|> (modul ^. #version)+              installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)               TIO.putStrLn $ "    Installed as: " <> T.pack name               pure True     else do       hasRecipe <- doesFileExist recipeDhall       if hasRecipe         then do-          installModuleDir entryDir name source (Just repoName) entry.version entry.tags+          installModuleDir entryDir name source (Just repoName) (entry ^. #version) (entry ^. #tags)           TIO.putStrLn $ "    Installed recipe as: " <> T.pack name           pure True         else do@@ -455,12 +456,12 @@               case decoded of                 Left err -> do                   logIO LogNormal $ do-                    logError $ "  failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err)+                    logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)                   pure False                 Right bp -> do-                  let bpVersion = case bp of Blueprint _ v _ _ _ _ _ _ _ _ _ -> v-                      ver = entry.version <|> bpVersion-                  installModuleDir entryDir name source (Just repoName) ver entry.tags+                  let bpVersion = (bp ^. #version)+                      ver = entry ^. #version <|> bpVersion+                  installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)                   TIO.putStrLn $ "    Installed blueprint as: " <> T.pack name                   pure True             else do@@ -471,27 +472,27 @@                   case decoded of                     Left err -> do                       logIO LogNormal $ do-                        logError $ "  failed to load " <> entry.name.unModuleName <> ": " <> T.pack (show err)+                        logError $ "  failed to load " <> entry ^. #name . #unModuleName <> ": " <> T.pack (show err)                       pure False                     Right prompt -> do                       result <- validateAgentPrompt entryDir prompt                       case result of                         Left (ValidationError _ errors) -> do                           logIO LogNormal $ do-                            logError $ "  " <> entry.name.unModuleName <> " has validation errors:"+                            logError $ "  " <> entry ^. #name . #unModuleName <> " has validation errors:"                             mapM_ (\e -> logError $ "    - " <> e) errors                           pure False                         Left err -> do                           logIO LogNormal (logError $ "  " <> T.pack (show err))                           pure False                         Right _ -> do-                          let ver = entry.version <|> prompt.version-                          installModuleDir entryDir name source (Just repoName) ver entry.tags+                          let ver = entry ^. #version <|> (prompt ^. #version)+                          installModuleDir entryDir name source (Just repoName) ver (entry ^. #tags)                           TIO.putStrLn $ "    Installed prompt as: " <> T.pack name                           pure True                 else do                   logIO LogNormal $ do-                    logError $ "  entry '" <> entry.name.unModuleName <> "' has no supported runnable Dhall file at " <> T.pack entry.path+                    logError $ "  entry '" <> entry ^. #name . #unModuleName <> "' has no supported runnable Dhall file at " <> T.pack (entry ^. #path)                   pure False  readMaybe :: String -> Maybe Int
src-exe/Seihou/CLI/NewBlueprint.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewBlueprintOpts (..))@@ -17,7 +18,7 @@  handleNewBlueprint :: NewBlueprintOpts -> IO () handleNewBlueprint nopts = do-  let name = nopts.newBlueprintName+  let name = (nopts ^. #name)    -- Validate blueprint name format   if not (isValidBlueprintName name)@@ -29,7 +30,7 @@     else pure ()    -- Determine output directory-  let outputDir = case nopts.newBlueprintPath of+  let outputDir = case nopts ^. #path of         Just p -> p         Nothing -> T.unpack name
src-exe/Seihou/CLI/NewModule.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewModuleOpts (..))@@ -17,7 +18,7 @@  handleNewModule :: NewModuleOpts -> IO () handleNewModule nopts = do-  let name = nopts.newModuleName+  let name = (nopts ^. #name)    -- Validate module name format   if not (isValidModuleName name)@@ -29,7 +30,7 @@     else pure ()    -- Determine output directory-  let outputDir = case nopts.newModulePath of+  let outputDir = case nopts ^. #path of         Just p -> p         Nothing -> T.unpack name
src-exe/Seihou/CLI/NewPrompt.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewPromptOpts (..))@@ -18,7 +19,7 @@  handleNewPrompt :: NewPromptOpts -> IO () handleNewPrompt nopts = do-  let name = nopts.newPromptName+  let name = (nopts ^. #name)    if not (isValidModuleName name)     then do@@ -28,7 +29,7 @@       exitFailure     else pure () -  let outputDir = case nopts.newPromptPath of+  let outputDir = case nopts ^. #path of         Just p -> p         Nothing -> T.unpack name
src-exe/Seihou/CLI/NewRecipe.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (NewRecipeOpts (..))@@ -15,7 +16,7 @@  handleNewRecipe :: NewRecipeOpts -> IO () handleNewRecipe ropts = do-  let name = ropts.newRecipeName+  let name = (ropts ^. #name)    -- Validate recipe name format   if not (isValidRecipeName name)@@ -27,7 +28,7 @@     else pure ()    -- Determine output directory-  let outputDir = case ropts.newRecipePath of+  let outputDir = case ropts ^. #path of         Just p -> p         Nothing -> T.unpack name @@ -43,7 +44,7 @@   createDirectoryIfMissing True outputDir    -- Write recipe.dhall-  let dhallContent = recipeDhall name ropts.newRecipeModules+  let dhallContent = recipeDhall name (ropts ^. #modules)   writeFile (outputDir </> "recipe.dhall") (T.unpack dhallContent)   TIO.putStrLn $ "Created " <> T.pack (outputDir </> "recipe.dhall")
src-exe/Seihou/CLI/Outdated.hs view
@@ -11,6 +11,7 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -37,7 +38,7 @@ handleOutdated oopts = do   searchPaths <- defaultSearchPaths   modules <- discoverAllModules searchPaths-  let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules+  let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules    if null installed     then TIO.putStrLn "No installed modules found."@@ -46,7 +47,7 @@       if null entries         then TIO.putStrLn "No installed modules with origin metadata found."         else-          if oopts.outdatedJson+          if oopts ^. #outdatedJson             then LBS.putStr (encodePretty entries)             else renderTable entries @@ -63,7 +64,7 @@   [DiscoveredModule] ->   IO ([OutdatedEntry], CheckStats) checkInstalledModulesForUpdates modules = do-  let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules+  let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules   originsWithModules <- mapM readOriginWithModule installed   let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules]       skipped = length installed - length withOrigins@@ -78,7 +79,7 @@             Map.toList $               Map.fromListWith                 (++)-                [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- withOrigins]+                [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- withOrigins]       TIO.putStrLn "Checking installed modules for updates..."       entries <- concat <$> mapM checkSource grouped       pure@@ -89,7 +90,7 @@ -- | Read origin info from a discovered module's directory. readOriginWithModule :: DiscoveredModule -> IO (DiscoveredModule, Maybe OriginInfo) readOriginWithModule dm = do-  let originFile = dm.discoveredDir </> ".seihou-origin.json"+  let originFile = dm ^. #dir </> ".seihou-origin.json"   exists <- doesFileExist originFile   if exists     then do@@ -130,7 +131,7 @@ compareModule :: FilePath -> (DiscoveredModule, OriginInfo) -> IO OutdatedEntry compareModule cloneDir (dm, origin) = do   let name = moduleNameFromDm dm-      installedVer = origin.version+      installedVer = (origin ^. #version)   availableVer <- fetchAvailable cloneDir (ModuleName name)   let status = compareVersions installedVer availableVer   pure@@ -155,9 +156,9 @@ -- | Compare installed and available version strings. -- | Extract the module name text from a DiscoveredModule. moduleNameFromDm :: DiscoveredModule -> Text-moduleNameFromDm dm = case dm.discoveredResult of-  Right m -> m.name.unModuleName-  Left _ -> dirName dm.discoveredDir+moduleNameFromDm dm = case dm ^. #result of+  Right m -> (m ^. #name . #unModuleName)+  Left _ -> dirName (dm ^. #dir)  -- | Extract the last path component as a name. dirName :: FilePath -> Text@@ -170,7 +171,7 @@ mkUnreachable dm origin =   OutdatedEntry     { moduleName = moduleNameFromDm dm,-      installedVersion = origin.version,+      installedVersion = origin ^. #version,       availableVersion = Nothing,       status = Unreachable     }@@ -179,9 +180,9 @@ renderTable :: [OutdatedEntry] -> IO () renderTable entries = do   colorEnabled <- useColor-  let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries))-      maxInstLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.installedVersion)) entries))-      maxAvailLen = max 9 (maximum (map (T.length . maybe "(none)" id . (.availableVersion)) entries))+  let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries))+      maxInstLen = max 9 (maximum (map (T.length . maybe "(none)" id . (^. #installedVersion)) entries))+      maxAvailLen = max 9 (maximum (map (T.length . maybe "(none)" id . (^. #availableVersion)) entries))        padR n t = t <> T.replicate (n - T.length t + 2) " " @@ -192,14 +193,14 @@           <> "Status"        formatRow e =-        let instText = maybe "(none)" id e.installedVersion-            availText = maybe "(none)" id e.availableVersion-            statusTxt = case e.status of+        let instText = maybe "(none)" id (e ^. #installedVersion)+            availText = maybe "(none)" id (e ^. #availableVersion)+            statusTxt = case e ^. #status of               UpToDate -> if colorEnabled then green "up to date" else "up to date"               OutdatedSt -> if colorEnabled then red "outdated" else "outdated"               Unversioned -> if colorEnabled then dim "unversioned" else "unversioned"               Unreachable -> if colorEnabled then yellow "unreachable" else "unreachable"-         in padR maxNameLen e.moduleName+         in padR maxNameLen (e ^. #moduleName)               <> padR maxInstLen instText               <> padR maxAvailLen availText               <> statusTxt@@ -209,7 +210,7 @@   mapM_ (TIO.putStrLn . formatRow) entries    let total = length entries-      outdated = length (filter (\e -> e.status == OutdatedSt) entries)+      outdated = length (filter (\e -> e ^. #status == OutdatedSt) entries)   TIO.putStrLn ""   TIO.putStrLn $     T.pack (show total)
src-exe/Seihou/CLI/PromptRun.hs view
@@ -3,11 +3,16 @@   ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Set qualified as Set import Data.Text qualified as T-import Seihou.CLI.AgentCompletion (AgentModelConfig)+import Seihou.CLI.AgentConfig+  ( PendingAgentConfig,+    agentLaunchDeclaration,+    resolveDeclaredAgentConfig,+  ) import Seihou.CLI.AgentLaunch (gatherAgentContext, setupAllowedTools) import Seihou.CLI.AgentRun (runRenderedAgentPrompt) import Seihou.CLI.Commands (PromptRunOpts (..))@@ -40,34 +45,34 @@ import System.Environment (getEnvironment) import System.Exit (exitFailure) -handlePromptRun :: AgentModelConfig -> PromptRunOpts -> IO ()-handlePromptRun modelConfig opts = do-  let level = if opts.runPromptVerbose then LogVerbose else LogNormal+handlePromptRun :: PendingAgentConfig -> PromptRunOpts -> IO ()+handlePromptRun pending opts = do+  let level = if opts ^. #verbose then LogVerbose else LogNormal    searchPaths <- defaultSearchPaths-  runnableResult <- discoverRunnable searchPaths opts.runPromptName+  runnableResult <- discoverRunnable searchPaths (opts ^. #name)   (prompt, promptDir) <- case runnableResult of     Right (RunnableAgentPrompt p dir) -> pure (p, dir)     Right (RunnableModule _ _) ->       exitErr level $         "'"-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "' is a module, not a prompt. Did you mean 'seihou run "-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "'?"     Right (RunnableRecipe _ _) ->       exitErr level $         "'"-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "' is a recipe, not a prompt. Did you mean 'seihou run "-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "'?"     Right (RunnableBlueprint _ _) ->       exitErr level $         "'"-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "' is a blueprint, not a prompt. Did you mean 'seihou agent run "-          <> opts.runPromptName.unModuleName+          <> opts ^. #name . #unModuleName           <> "'?"     Left err -> exitErr level (renderModuleLoadError err) @@ -76,28 +81,37 @@     Left err -> exitErr level (renderModuleLoadError err)     Right _ -> pure () +  -- Finish provider/model/effort resolution now that the prompt is loaded, so+  -- an unusable declaration is reported alongside the prompt's other errors.+  modelConfig <-+    resolveDeclaredAgentConfig+      level+      ("prompt '" <> prompt ^. #name . #unModuleName <> "'")+      pending+      (agentLaunchDeclaration (prompt ^. #launch))+   let placeholderModule =         Module-          { name = prompt.name,-            version = prompt.version,-            description = prompt.description,-            vars = relaxCommandVarDecls prompt.commandVars prompt.vars,+          { name = prompt ^. #name,+            version = prompt ^. #version,+            description = prompt ^. #description,+            vars = relaxCommandVarDecls (prompt ^. #commandVars) (prompt ^. #vars),             exports = [],-            prompts = prompt.prompts,+            prompts = prompt ^. #prompts,             steps = [],             commands = [],             dependencies = [],             removal = Nothing,             migrations = []           }-      placeholderInst = primaryInstance prompt.name+      placeholderInst = primaryInstance (prompt ^. #name)       placeholderTriple = (placeholderInst, placeholderModule, promptDir)    envPairs <- getEnvironment-  let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts.runPromptVars]+  let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- opts ^. #vars]       envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]-      namespace = fromMaybe (deriveNamespace prompt.name) opts.runPromptNamespace-  context <- resolveContext opts.runPromptContext envVars+      namespace = fromMaybe (deriveNamespace (prompt ^. #name)) (opts ^. #namespace)+  context <- resolveContext (opts ^. #context) envVars   let contextName = fromMaybe "" context    resolveResult <- runEff $ runConfigReader $ runConsole $ do@@ -124,7 +138,7 @@       exitFailure     Right r -> pure (Map.findWithDefault Map.empty placeholderInst r) -  commandResult <- runEff $ runProcessIO $ resolveCommandVars prompt.vars prompt.commandVars resolvedNormal+  commandResult <- runEff $ runProcessIO $ resolveCommandVars (prompt ^. #vars) (prompt ^. #commandVars) resolvedNormal   resolved <- case commandResult of     Left errs -> do       logIO level $ do@@ -133,27 +147,27 @@       exitFailure     Right r -> pure r -  let renderedPrompt = renderPromptBody resolved prompt.prompt+  let renderedPrompt = renderPromptBody resolved (prompt ^. #prompt)   ctx <- gatherAgentContext-  let systemPrompt = renderPromptSystemPrompt ctx prompt resolved renderedPrompt opts.runPromptPrompt+  let systemPrompt = renderPromptSystemPrompt ctx prompt resolved renderedPrompt (opts ^. #prompt)    _ <-     runRenderedAgentPrompt-      opts.runPromptDebug+      (opts ^. #debug)       modelConfig       setupAllowedTools       Nothing       systemPrompt-      opts.runPromptPrompt+      (opts ^. #prompt)   pure ()  relaxCommandVarDecls :: [CommandVar] -> [VarDecl] -> [VarDecl] relaxCommandVarDecls commandVars =   map relaxOne   where-    commandNames = Set.fromList (map (.name) commandVars)+    commandNames = Set.fromList (map (^. #name) commandVars)     relaxOne decl-      | Set.member decl.name commandNames = decl {required = False}+      | Set.member (decl ^. #name) commandNames = decl & #required .~ False       | otherwise = decl  exitErr :: LogLevel -> Text -> IO a@@ -165,24 +179,24 @@ renderModuleLoadError = \case   ModuleNotFound name searched ->     "Prompt '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "' not found. Searched in:\n"       <> T.intercalate "\n" (map (("  " <>) . T.pack) searched)   DhallEvalError name msg ->-    "Failed to evaluate '" <> name.unModuleName <> "': " <> msg+    "Failed to evaluate '" <> name ^. #unModuleName <> "': " <> msg   DhallDecodeError name msg ->-    "Failed to decode '" <> name.unModuleName <> "': " <> msg+    "Failed to decode '" <> name ^. #unModuleName <> "': " <> msg   ValidationError name msgs ->     "Validation failed for '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "':\n"       <> T.intercalate "\n" (map ("  " <>) msgs)   CircularDependency names ->     "Circular dependency detected: "-      <> T.intercalate " -> " (map (.unModuleName) names)+      <> T.intercalate " -> " (map (^. #unModuleName) names)   MissingSourceFile name path ->     "Missing source file in '"-      <> name.unModuleName+      <> name ^. #unModuleName       <> "': "       <> T.pack path   RegistryEvalError path msg ->
src-exe/Seihou/CLI/Remove.hs view
@@ -4,6 +4,7 @@ where  import Control.Monad (foldM, when)+import Data.Generics.Labels () import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -22,7 +23,7 @@ handleRemove :: RemoveOpts -> IO () handleRemove opts = do   let manifestPath = ".seihou" </> "manifest.json"-      modName = opts.removeModule+      modName = (opts ^. #module_)    -- Read the manifest   manifestResult <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest@@ -39,13 +40,13 @@   let mApplied = findAppliedModule manifest modName   case mApplied of     Nothing -> do-      TIO.putStrLn $ "Module '" <> modName.unModuleName <> "' is not applied in this project."+      TIO.putStrLn $ "Module '" <> modName ^. #unModuleName <> "' is not applied in this project."       exitFailure-    Just am -> case am.removal of+    Just am -> case am ^. #removal of       Nothing -> do         TIO.putStrLn $           "Module '"-            <> modName.unModuleName+            <> modName ^. #unModuleName             <> "' has no removal spec. Add a 'removal' section to its module.dhall to make it removable."         exitFailure       Just removal -> do@@ -53,12 +54,12 @@         planResult <- runEff $ runFilesystem $ buildRemovalOps manifest modName removal         plan <- case planResult of           Left (ModuleNotApplied name) -> do-            TIO.putStrLn $ "Module '" <> name.unModuleName <> "' is not applied in this project."+            TIO.putStrLn $ "Module '" <> name ^. #unModuleName <> "' is not applied in this project."             exitFailure           Left (ModuleNotRemovable name) -> do             TIO.putStrLn $               "Module '"-                <> name.unModuleName+                <> name ^. #unModuleName                 <> "' has no removal spec."             exitFailure           Left (RemovalUnsafePath label path reason) -> do@@ -75,24 +76,24 @@         colorEnabled <- useColor          -- Display plan-        TIO.putStrLn $ "Removal plan for " <> modName.unModuleName <> ":"+        TIO.putStrLn $ "Removal plan for " <> modName ^. #unModuleName <> ":" -        if null plan.ops+        if null (plan ^. #ops)           then TIO.putStrLn "  (no removal operations)"-          else mapM_ (displayOp colorEnabled) plan.ops+          else mapM_ (displayOp colorEnabled) (plan ^. #ops)          -- Dry run exits here-        when opts.removeDryRun $ do+        when (opts ^. #dryRun) $ do           TIO.putStrLn ""           TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)"           exitWith ExitSuccess          -- Collect conflict files for interactive resolution-        let conflictFiles = [p | DeleteFileOp p RFConflict <- plan.ops]+        let conflictFiles = [p | DeleteFileOp p RFConflict <- plan ^. #ops]          -- Resolve conflicts         keepSet <--          if null conflictFiles || opts.removeForce+          if null conflictFiles || opts ^. #force             then pure Set.empty             else do               isInteractive <- hIsTerminalDevice stdin@@ -103,7 +104,7 @@                 else resolveConflictsInteractively conflictFiles          -- Prompt for confirmation (if there are any actionable ops)-        let actionableOps = [() | op <- plan.ops, isActionable op]+        let actionableOps = [() | op <- plan ^. #ops, isActionable op]         when (not (null actionableOps)) $ do           TIO.putStr "\n  Proceed? [y/N] "           hFlush stdout@@ -119,13 +120,13 @@         runEff $ runFilesystem $ runManifestStore manifestPath $ writeManifest updatedManifest          -- Report-        let deleted = length [() | DeleteFileOp _ s <- plan.ops, s /= RFGone, not (Set.member "" keepSet)]-            stripped = length [() | StripSectionOp _ <- plan.ops]-            commands = length [() | RemovalCommandOp _ _ <- plan.ops]+        let deleted = length [() | DeleteFileOp _ s <- plan ^. #ops, s /= RFGone, not (Set.member "" keepSet)]+            stripped = length [() | StripSectionOp _ <- plan ^. #ops]+            commands = length [() | RemovalCommandOp _ _ <- plan ^. #ops]         TIO.putStrLn $           applyColor colorEnabled green "✓"             <> " Removed module "-            <> applyColor colorEnabled bold modName.unModuleName+            <> applyColor colorEnabled bold (modName ^. #unModuleName)             <> "."             <> formatCounts deleted stripped commands @@ -170,7 +171,7 @@ -- | Find an applied module by name in the manifest. findAppliedModule :: Manifest -> ModuleName -> Maybe AppliedModule findAppliedModule manifest modName =-  case filter (\am -> am.name == modName) manifest.modules of+  case filter (\am -> am ^. #name == modName) (manifest ^. #modules) of     (am : _) -> Just am     [] -> Nothing
src-exe/Seihou/CLI/Run.hs view
@@ -5,6 +5,7 @@  import Control.Exception (IOException, displayException, try) import Control.Monad (foldM, forM_, unless, when)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust) import Data.Set qualified as Set@@ -25,6 +26,13 @@ import Seihou.CLI.Commands (RunOpts (..)) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo)+import Seihou.CLI.ManifestGuard+  ( ArtifactCheck,+    blockingChecks,+    checkAppliedArtifactsFor,+    formatGuardOverride,+    formatGuardRefusal,+  ) import Seihou.CLI.Migrate   ( MigrateError (..),     MigrateOpts (..),@@ -36,13 +44,15 @@     formatRefusalMessage,   ) import Seihou.CLI.SavePrompted (collectPromptedValues, offerSavePrompted)-import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, toVarNameMap, unwrapConfig)+import Seihou.CLI.Shared (deriveNamespace, formatBlueprintRefusal, formatVarError, logIO, resolveAppliedArtifactDir, toVarNameMap, unwrapConfig) import Seihou.CLI.Style (bold, dim, formatPlanViewColor, green, magenta, red, useColor, yellow) import Seihou.Composition.Instance (ModuleInstance (..), qualifiedName) import Seihou.Composition.Plan (compileComposedPlan) import Seihou.Composition.Recipe (expandRecipe) import Seihou.Composition.Resolve (loadComposition, resolveWithPrompts) import Seihou.Core.Application (attachApplication, buildAppliedComposition, mkApplicationId, replaceAppliedComposition)+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactRef (renderArtifactRefError) import Seihou.Core.Context (resolveContext) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable)@@ -72,6 +82,7 @@ import Seihou.Interaction.Confirm (confirmDefaults) import Seihou.Manifest.Types (currentManifestVersion, emptyManifest) import Seihou.Prelude+import System.Directory (getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit (ExitCode (..), exitFailure, exitWith) import System.FilePath (takeDirectory)@@ -79,11 +90,11 @@  handleRun :: RunOpts -> IO () handleRun runOpts = do-  let additional = runOpts.runAdditional-      level = if runOpts.runVerbose then LogVerbose else LogNormal+  let additional = (runOpts ^. #additional)+      level = if runOpts ^. #verbose then LogVerbose else LogNormal    -- 0. Resolve module name (from argument or fzf picker)-  modName <- case runOpts.runModule of+  modName <- case runOpts ^. #module_ of     Just name -> pure name     Nothing -> do       fzfCfg <- detectFzfConfig@@ -114,20 +125,20 @@             logIO level $               logError $                 "Invalid recipe '"-                  <> recipe.name.unRecipeName+                  <> recipe ^. #name . #unRecipeName                   <> "': "                   <> T.intercalate "; " errs             exitFailure           Right (primary, recipeAdditional, overrides, _recipeVars, _recipePrompts) -> do             logIO level $               logInfo $-                "Recipe '" <> recipe.name.unRecipeName <> "' expanding to " <> T.pack (show (length recipe.modules)) <> " modules"+                "Recipe '" <> recipe ^. #name . #unRecipeName <> "' expanding to " <> T.pack (show (length (recipe ^. #modules))) <> " modules"             pure               ( primary,                 recipeAdditional ++ additional,                 overrides,-                Just (recipe.name, recipe.version),-                (AppliedRecipeTarget recipe.name, recipeDir, recipe.version)+                Just (recipe ^. #name, recipe ^. #version),+                (AppliedRecipeTarget (recipe ^. #name), recipeDir, recipe ^. #version)               )       Right (RunnableModule modul moduleDir) ->         pure@@ -135,7 +146,7 @@             additional,             Map.empty,             Nothing,-            (AppliedModuleTarget modName, moduleDir, modul.version)+            (AppliedModuleTarget modName, moduleDir, modul ^. #version)           )       Right (RunnableBlueprint _b _blueprintDir) -> do         -- Use the user-typed name (modName) rather than the blueprint's@@ -159,14 +170,14 @@   modulesInOrder <- case compositionResult of     Left (ModuleNotFound name searched) -> do       logIO level $ do-        logError $ "Module '" <> name.unModuleName <> "' not found."+        logError $ "Module '" <> name ^. #unModuleName <> "' not found."         logError "Searched in:"         mapM_ (\p -> logError $ "  " <> T.pack p) searched       exitFailure     Left (CircularDependency names) -> do       logIO level $ do         logError "Circular dependency detected:"-        logError $ "  " <> T.intercalate " -> " (map (.unModuleName) names)+        logError $ "  " <> T.intercalate " -> " (map (^. #unModuleName) names)       exitFailure     Left err -> exitError level (T.pack (show err))     Right ms -> pure ms@@ -175,15 +186,15 @@   when (length modulesInOrder > 1) $     logIO level $ do       logInfo $ "Composing " <> T.pack (show (length modulesInOrder)) <> " modules:"-      mapM_ (\(_, m, _) -> logInfo $ "  " <> m.name.unModuleName) modulesInOrder+      mapM_ (\(_, m, _) -> logInfo $ "  " <> m ^. #name . #unModuleName) modulesInOrder    -- 2. Resolve variables with export visibility and interactive prompts   envPairs <- getEnvironment   -- Merge recipe overrides with CLI overrides (CLI wins on conflict)-  let cliOverrides = Map.union (Map.fromList [(VarName k, v) | (k, v) <- runOpts.runVars]) recipeOverrides+  let cliOverrides = Map.union (Map.fromList [(VarName k, v) | (k, v) <- runOpts ^. #vars]) recipeOverrides       envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]-      namespace = fromMaybe (deriveNamespace primaryName) runOpts.runNamespace-  context <- resolveContext runOpts.runContext envVars+      namespace = fromMaybe (deriveNamespace primaryName) (runOpts ^. #namespace)+  context <- resolveContext (runOpts ^. #context) envVars   let contextName = fromMaybe "" context   (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do     localCfg <- readLocalConfig >>= unwrapConfig level@@ -206,23 +217,23 @@    -- 2a. Optionally confirm default-sourced values.   resolved <--    if runOpts.runConfirmDefaults+    if runOpts ^. #confirmDefaults       then runEff $ runConsole $ confirmDefaults modulesInOrder resolvedInitial       else pure resolvedInitial    -- 2b. Emit diagnostics for unused config keys-  let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder+  let allDecls = concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder       allResolved = Map.unions [vs | vs <- Map.elems resolved]       (unusedKeys, _) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap   when (not (null unusedKeys)) $     logIO level $       logWarn $         "Config keys not matching any declared variable: "-          <> T.intercalate ", " (map (.unVarName) unusedKeys)+          <> T.intercalate ", " (map (^. #unVarName) unusedKeys)    -- 3. Compile composed plan (all modules merged)   let quads =-        [ (inst, m, dir, Map.map (.value) (resolved Map.! inst))+        [ (inst, m, dir, Map.map (^. #value) (resolved Map.! inst))         | (inst, m, dir) <- modulesInOrder         ]   planResult <- compileComposedPlan quads@@ -236,7 +247,7 @@    -- 4. Filter out command ops if --no-commands   let opsFiltered =-        if runOpts.runNoCommands+        if runOpts ^. #noCommands           then filter (not . isCommandOp) ops           else ops @@ -263,11 +274,26 @@       exitFailure     Right m -> pure (fromMaybe (emptyManifest now) m) -  -- 6b. Pre-flight pending-migration check. We only consider modules in+  let composedModuleNames =+        Set.fromList [m ^. #name | (_, m, _) <- modulesInOrder]++  -- 6b. Pre-flight downgrade and origin guard: refuse to generate from a+  -- module that is older than, or came from somewhere other than, what the+  -- manifest records. This runs *before* the pending-migration check below+  -- because a stale local copy is the more fundamental problem — the+  -- migration chain is computed from that same older copy, so its advice+  -- would point the wrong way. Like the migration check, it considers only+  -- modules in the current composition; a stale module this run does not+  -- touch must not block it.+  projectRoot <- getCurrentDirectory+  searchPaths <- defaultSearchPaths+  guardChecks <-+    checkAppliedArtifactsFor projectRoot searchPaths (Just composedModuleNames) initialManifest+  enforceArtifactGuard runOpts (blockingChecks guardChecks)++  -- 6c. Pre-flight pending-migration check. We only consider modules in   -- the current composition: a pending chain on an unrelated module   -- must not block this run.-  let composedModuleNames =-        Set.fromList [m.name | (_, m, _) <- modulesInOrder]   pendings <-     detectPendingMigrations initialManifest (Just composedModuleNames)   manifest <-@@ -276,47 +302,56 @@   -- Commands are planned against the previously accepted receipts for this   -- exact top-level application. Ordinary run deliberately remains run-all;   -- --no-commands disables execution while retaining matching old receipts.+  -- What lands in the manifest must mean the same thing on every machine, so+  -- each artifact's discovery directory is classified into a portable origin+  -- before it is recorded. See docs/adr/0001-manifest-is-a-checked-in-machine-independent-artifact.md.   let (appliedTarget, targetSource, targetVersion) = targetInfo-      currentApplicationId = mkApplicationId appliedTarget additional+  targetOrigin <- detectArtifactOrigin projectRoot targetSource+  originedModules <-+    traverse+      (\(inst, m, dir) -> (inst,m,) <$> detectArtifactOrigin projectRoot dir)+      modulesInOrder++  let currentApplicationId = mkApplicationId appliedTarget additional       priorCommandReceipts =-        case [ application.commandReceipts-             | application <- manifest.applications,-               application.applicationId == currentApplicationId+        case [ application ^. #commandReceipts+             | application <- manifest ^. #applications,+               application ^. #applicationId == currentApplicationId              ] of           receipts : _ -> receipts           [] -> Map.empty       commandPolicy =-        if runOpts.runNoCommands+        if runOpts ^. #noCommands           then DisableCommands           else RunAllCommands       commandPlan = planCommands commandPolicy priorCommandReceipts ops       candidateCommandReceipts =         finalizeCommandReceipts commandPlan [] priorCommandReceipts -  -- 6c. Compute the diff against the (possibly post-migration) manifest.+  -- 6d. Compute the diff against the (possibly post-migration) manifest.   diff <- runEff $ runFilesystem $ runManifestStore manifestPath $ do     -- Diff needs every name that could own a manifest file. Each     -- instance owns its qualified name; the bare module name is still     -- matched to cover manifest entries written before the schema bump.     let composedNames =           Set.fromList $-            concatMap (\(inst, _, _) -> [inst.instanceModule, qualifiedName inst]) modulesInOrder+            concatMap (\(inst, _, _) -> [inst ^. #module_, qualifiedName inst]) modulesInOrder     computeDiff manifest composedNames planned    colorEnabled <- useColor -  let modNames = map (\(_, m, _) -> m.name) modulesInOrder+  let modNames = map (\(_, m, _) -> m ^. #name) modulesInOrder       allVarValues =         Map.unions-          [Map.map (.value) vs | vs <- Map.elems resolved]+          [Map.map (^. #value) vs | vs <- Map.elems resolved]       preview = buildPreview opsFiltered (Just diff) ownerMap    -- 6. Handle --dry-run: show plan view and exit-  if runOpts.runDryRun+  if runOpts ^. #dryRun     then       TIO.putStr (formatPlanViewColor colorEnabled modNames allVarValues preview diff)     else-      if runOpts.runDiff+      if runOpts ^. #diff         then TIO.putStr (formatDiff colorEnabled diff ownerMap)         else do           -- Show plan view@@ -324,7 +359,7 @@            -- Prompt for confirmation (skip if --force or non-interactive)           interactive <- hIsTerminalDevice stdin-          when (interactive && not runOpts.runForce) $ do+          when (interactive && not (runOpts ^. #force)) $ do             TIO.putStr "\n  Proceed? [Y/n] "             hFlush stdout             response <- T.strip . T.pack <$> getLine@@ -335,24 +370,30 @@           resolutions <-             runEff $               runConsole $-                resolveConflicts runOpts.runForce diff.conflicts+                resolveConflicts (runOpts ^. #force) (diff ^. #conflicts)           case resolutions of             Nothing -> do               TIO.putStrLn "Conflicts detected (use --force to overwrite):"-              mapM_ (\c -> TIO.putStrLn $ "  ! " <> T.pack c.path) diff.conflicts+              mapM_ (\c -> TIO.putStrLn $ "  ! " <> T.pack (c ^. #path)) (diff ^. #conflicts)               exitFailure             Just conflictResolved -> do               -- Partition resolutions: accept (overwrite), keep (update manifest only), skip (ignore)               let keepRecords =                     Map.fromList-                      [ ( c.path,-                          case Map.lookup c.path manifest.files of+                      [ ( c ^. #path,+                          case Map.lookup (c ^. #path) (manifest ^. #files) of                             Just existing ->-                              existing {hash = c.diskHash, generatedAt = now}+                              ( existing+                                  & #hash+                                  .~ c+                                  ^. #diskHash+                                  & #generatedAt+                                  .~ now+                              )                             Nothing ->                               FileRecord-                                { hash = c.diskHash,-                                  moduleName = c.moduleName,+                                { hash = c ^. #diskHash,+                                  moduleName = c ^. #moduleName,                                   strategy = Template,                                   generatedAt = now,                                   baseline = Nothing,@@ -361,7 +402,7 @@                         )                       | (c, KeepCurrent) <- conflictResolved                       ]-                  skipPaths = [c.path | (c, Skip) <- conflictResolved]+                  skipPaths = [c ^. #path | (c, Skip) <- conflictResolved]                   excludePaths = Set.fromList (Map.keys keepRecords ++ skipPaths)                   opsForExec = filter (not . opTargetsPath excludePaths) opsFiltered @@ -380,31 +421,32 @@                             Left err -> pure (Left err)                             Right baselineRecords -> do                               -- Build updated manifest with all composed modules.-                              let orphanedPaths = map (.path) diff.orphaned-                                  cleanedFiles = foldr Map.delete manifest.files orphanedPaths-                                  allModuleEntries = updateAllModules manifest.modules modulesInOrder now+                              let orphanedPaths = map (^. #path) (diff ^. #orphaned)+                                  cleanedFiles = foldr Map.delete (manifest ^. #files) orphanedPaths+                                  allModuleEntries = updateAllModules (manifest ^. #modules) originedModules now                                   allResolvedVals =                                     Map.unions-                                      [Map.map (.value) vs | vs <- Map.elems resolved]+                                      [Map.map (^. #value) vs | vs <- Map.elems resolved]                                   appliedRecipe = case recipeInfo of                                     Just (rName, rVersion) ->                                       Just AppliedRecipe {name = rName, recipeVersion = rVersion, appliedAt = now}-                                    Nothing -> manifest.recipe+                                    Nothing -> (manifest ^. #recipe)                                   appliedCompositionWithoutReceipts =                                     buildAppliedComposition                                       appliedTarget-                                      targetSource+                                      targetOrigin                                       targetVersion                                       additional                                       (Just namespace)                                       context-                                      modulesInOrder+                                      originedModules                                       resolved                                       now                                   appliedComposition =-                                    appliedCompositionWithoutReceipts-                                      { commandReceipts = candidateCommandReceipts-                                      }+                                    ( appliedCompositionWithoutReceipts+                                        & #commandReceipts+                                        .~ candidateCommandReceipts+                                    )                                   applicationDestinations =                                     Set.fromList [path | Just path <- map operationDestination opsFiltered]                                   combinedFiles = Map.unions [baselineRecords, keepRecords, cleanedFiles]@@ -412,7 +454,7 @@                                     Map.mapWithKey                                       ( \path record ->                                           if Set.member path applicationDestinations-                                            then attachApplication appliedComposition.applicationId (Map.lookup path manifest.files) record+                                            then attachApplication (appliedComposition ^. #applicationId) (Map.lookup path (manifest ^. #files)) record                                             else record                                       )                                       combinedFiles@@ -421,12 +463,12 @@                                       { version = currentManifestVersion,                                         genAt = now,                                         modules = allModuleEntries,-                                        vars = Map.union (Map.map varValueToText allResolvedVals) manifest.vars,+                                        vars = Map.union (Map.map varValueToText allResolvedVals) (manifest ^. #vars),                                         files = ownedFiles,-                                        applications = replaceAppliedComposition appliedComposition manifest.applications,+                                        applications = replaceAppliedComposition appliedComposition (manifest ^. #applications),                                         recipe = appliedRecipe,-                                        blueprint = manifest.blueprint,-                                        blueprintMigrations = manifest.blueprintMigrations+                                        blueprint = manifest ^. #blueprint,+                                        blueprintMigrations = manifest ^. #blueprintMigrations                                       }                               writeManifest newManifest                               pure (Right newManifest)@@ -454,9 +496,9 @@                 Right _ -> pure ()                -- Report results-              let nNew = length diff.new-                  nMod = length diff.modified-                  nUnch = length diff.unchanged+              let nNew = length (diff ^. #new)+                  nMod = length (diff ^. #modified)+                  nUnch = length (diff ^. #unchanged)               TIO.putStrLn $                 T.pack (show nNew)                   <> " new, "@@ -469,8 +511,8 @@               -- returns candidate receipts only when the entire phase               -- succeeds, so a failed run leaves the candidate manifest with               -- no newly-minted success evidence.-              forM_ commandPlan.commands $ \planned ->-                when (planned.disposition == CommandWillRun) $+              forM_ (commandPlan ^. #commands) $ \planned ->+                when (planned ^. #disposition == CommandWillRun) $                   logIO level (logDebug $ "  run  " <> plannedCommandText planned)               commandResult <-                 runEff $@@ -484,14 +526,14 @@               completedReceipts <- case commandResult of                 Right receipts -> pure receipts                 Left commandError -> do-                  when (not (T.null commandError.stdout)) $ TIO.putStr commandError.stdout-                  when (not (T.null commandError.stderr)) $ TIO.putStr commandError.stderr+                  when (not (T.null (commandError ^. #stdout))) $ TIO.putStr (commandError ^. #stdout)+                  when (not (T.null (commandError ^. #stderr))) $ TIO.putStr (commandError ^. #stderr)                   logIO level $                     logError $                       "Command failed (exit "-                        <> T.pack (show commandError.exitCode)+                        <> T.pack (show (commandError ^. #exitCode))                         <> "): "-                        <> plannedCommandText commandError.command+                        <> plannedCommandText (commandError ^. #command)                   exitFailure                let finalCommandReceipts =@@ -514,10 +556,10 @@                 Right () -> pure ()                -- Commit generated files if --commit or --commit-message-              when (runOpts.runCommit || isJust runOpts.runCommitMessage) $ do+              when (runOpts ^. #commit || isJust (runOpts ^. #commitMessage)) $ do                 let filesToStage =-                      map (.path) diff.new-                        ++ map (.path) diff.modified+                      map (^. #path) (diff ^. #new)+                        ++ map (^. #path) (diff ^. #modified)                         ++ [manifestPath, baselineDir]                 inGit <- runEff $ runProcessIO $ isGitRepo                 if inGit@@ -531,7 +573,7 @@                         case addExit of                           ExitFailure _ -> logIO level (logWarn $ "git add failed: " <> addErr)                           ExitSuccess -> do-                            commitMsg <- case runOpts.runCommitMessage of+                            commitMsg <- case runOpts ^. #commitMessage of                               Just msg -> pure msg                               Nothing -> do                                 diffText <- runEff $ runProcessIO $ gitDiffCached@@ -549,7 +591,7 @@                 runEff $                   runConfigWriter $                     runConsole $-                      offerSavePrompted runOpts.runSavePrompted interactive prompted+                      offerSavePrompted (runOpts ^. #savePrompted) interactive prompted  -- Helpers @@ -564,43 +606,43 @@     "Warning: "       <> T.pack path       <> " (from "-      <> overwritten.unModuleName+      <> overwritten ^. #unModuleName       <> ") overwritten by "-      <> overwriter.unModuleName+      <> (overwriter ^. #unModuleName) printWarning level (ContentMerged path base contributor) =   logIO level . logWarn $     "Merged: "       <> T.pack path       <> " (base from "-      <> base.unModuleName+      <> base ^. #unModuleName       <> ", patched by "-      <> contributor.unModuleName+      <> contributor ^. #unModuleName       <> ")"  formatDiff :: Bool -> DiffResult -> Map.Map FilePath ModuleName -> Text formatDiff color diff ownerMap' =   T.unlines $     concat-      [ if null diff.new+      [ if null (diff ^. #new)           then []-          else "New files:" : map (\f -> "  " <> colorWrap green "[new]" <> "  " <> colorWrap green (T.pack f.path) <> modSuffix f.path) diff.new,-        if null diff.modified+          else "New files:" : map (\f -> "  " <> colorWrap green "[new]" <> "  " <> colorWrap green (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #new),+        if null (diff ^. #modified)           then []-          else "Modified files:" : map (\f -> "  " <> colorWrap yellow "[modified]" <> "  " <> colorWrap yellow (T.pack f.path) <> modSuffix f.path) diff.modified,-        if null diff.unchanged+          else "Modified files:" : map (\f -> "  " <> colorWrap yellow "[modified]" <> "  " <> colorWrap yellow (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #modified),+        if null (diff ^. #unchanged)           then []-          else "Unchanged files:" : map (\f -> "  " <> colorWrap dim "[unchanged]" <> "  " <> colorWrap dim (T.pack f)) diff.unchanged,-        if null diff.conflicts+          else "Unchanged files:" : map (\f -> "  " <> colorWrap dim "[unchanged]" <> "  " <> colorWrap dim (T.pack f)) (diff ^. #unchanged),+        if null (diff ^. #conflicts)           then []-          else "Conflicts:" : map (\f -> "  " <> colorWrap (bold . red) "[conflict]" <> "  " <> colorWrap (bold . red) (T.pack f.path) <> modSuffix f.path) diff.conflicts,-        if null diff.orphaned+          else "Conflicts:" : map (\f -> "  " <> colorWrap (bold . red) "[conflict]" <> "  " <> colorWrap (bold . red) (T.pack (f ^. #path)) <> modSuffix (f ^. #path)) (diff ^. #conflicts),+        if null (diff ^. #orphaned)           then []-          else "Orphaned files:" : map (\f -> "  " <> colorWrap magenta "[orphaned]" <> "  " <> colorWrap magenta (T.pack f.path)) diff.orphaned+          else "Orphaned files:" : map (\f -> "  " <> colorWrap magenta "[orphaned]" <> "  " <> colorWrap magenta (T.pack (f ^. #path))) (diff ^. #orphaned)       ]   where     colorWrap fn t = if color then fn t else t     modSuffix path = case Map.lookup path ownerMap' of-      Just mn -> "  " <> colorWrap dim ("(" <> mn.unModuleName <> ")")+      Just mn -> "  " <> colorWrap dim ("(" <> mn ^. #unModuleName <> ")")       Nothing -> ""  varValueToText :: VarValue -> Text@@ -629,7 +671,7 @@ operationDestination _ = Nothing  plannedCommandText :: PlannedCommand -> Text-plannedCommandText planned = case planned.operation of+plannedCommandText planned = case planned ^. #operation of   RunCommandOp {command} -> command   _ -> "<non-command operation>" @@ -640,14 +682,32 @@   Manifest setApplicationCommandReceipts applicationId receipts manifest =   manifest-    { applications = map updateApplication manifest.applications-    }+    & #applications+    %~ map updateApplication   where     updateApplication application-      | application.applicationId == applicationId =-          application {commandReceipts = receipts}+      | application ^. #applicationId == applicationId =+          application & #commandReceipts .~ receipts       | otherwise = application +-- | Apply the downgrade / origin-mismatch policy.+--+-- Without @--allow-downgrade@: the run refuses before a single file is+-- written, so the project and its manifest are left byte-identical.+--+-- With @--allow-downgrade@: the same blocks are printed under a+-- "proceeding anyway" lead-in and the run continues. They are printed+-- rather than suppressed on purpose — a deliberate downgrade is still a+-- downgrade, and the diff it produces should not be the first time anyone+-- hears about it.+enforceArtifactGuard :: RunOpts -> [ArtifactCheck] -> IO ()+enforceArtifactGuard _ [] = pure ()+enforceArtifactGuard runOpts blocking+  | runOpts ^. #allowDowngrade = TIO.putStr (formatGuardOverride blocking)+  | otherwise = do+      TIO.putStr (formatGuardRefusal blocking)+      exitFailure+ -- | Apply the pending-migration policy. -- -- Without @--with-migrations@: the run refuses and prints a one-line@@ -669,10 +729,10 @@   IO Manifest handlePendingMigrations _ _ _ manifest [] = pure manifest handlePendingMigrations level runOpts manifestPath manifest pendings-  | not runOpts.runWithMigrations = do+  | not (runOpts ^. #withMigrations) = do       TIO.putStr (formatRefusalMessage pendings)       exitFailure-  | runOpts.runDryRun = do+  | (runOpts ^. #dryRun) = do       TIO.putStrLn "Pending migrations detected (--with-migrations + --dry-run):"       mapM_ (TIO.putStrLn . renderPendingSummary) pendings       TIO.putStrLn ""@@ -691,17 +751,17 @@ renderPendingSummary :: (ModuleName, MigrationPlan) -> Text renderPendingSummary (name, plan) =   "  "-    <> name.unModuleName+    <> name ^. #unModuleName     <> ": "-    <> renderVersion plan.planFrom+    <> renderVersion (plan ^. #from)     <> " -> "-    <> renderVersion plan.planTo+    <> renderVersion (plan ^. #to)     <> " ("-    <> T.pack (show (length plan.planSteps))+    <> T.pack (show (length (plan ^. #steps)))     <> " step(s))"  -- | Apply one pending plan in-band. Reuses 'runMigrate' with--- @migrateNoFetch=True@ since 'detectPendingMigrations' already+-- @noFetch=True@ since 'detectPendingMigrations' already -- compared against the locally installed copy: there is no need to -- clone the source repo a second time. Migration conflicts (a tracked -- file the user has edited since generation) propagate as a hard@@ -719,26 +779,43 @@       logIO level $         logError $           "internal error: applied module '"-            <> modName.unModuleName+            <> modName ^. #unModuleName             <> "' missing while applying its migration"       exitFailure     Just am -> do       let opts =             MigrateOpts-              { migrateModule = modName,-                migrateTo = Nothing,-                migrateDryRun = False,-                migrateForce = False,-                migrateJson = False,-                migrateVerbose = False,-                migrateNoFetch = True,-                migrateCommit = False,-                migrateCommitMessage = Nothing+              { module_ = modName,+                to = Nothing,+                dryRun = False,+                force = False,+                json = False,+                verbose = False,+                noFetch = True,+                commit = False,+                commitMessage = Nothing,+                -- Only 'handleMigrate' consults this; 'runMigrate' is the+                -- guard-free core, and 'handleRun' has already applied the+                -- guard to this run's composition above.+                allowDowngrade = False               }-      result <- runMigrate opts manifest am.source+      -- The manifest records a portable origin, so the module has to be+      -- located on this machine before it can be re-read.+      resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin)+      moduleDir <- case resolved of+        Left refErr -> do+          logIO level $+            logError $+              "Migration failed for "+                <> modName ^. #unModuleName+                <> ":\n\n"+                <> renderArtifactRefError refErr+          exitFailure+        Right directory -> pure directory+      result <- runMigrate opts manifest moduleDir       case result of         Right (MigrateApplied _ manifest' _ _) -> do-          TIO.putStrLn $ "  Migrated " <> modName.unModuleName+          TIO.putStrLn $ "  Migrated " <> (modName ^. #unModuleName)           pure manifest'         Right (MigrateNoOp _) -> pure manifest         Right (MigrateDryRunOK {}) -> pure manifest@@ -746,27 +823,28 @@           logIO level $             logError $               "Migration failed for "-                <> modName.unModuleName+                <> modName ^. #unModuleName                 <> ": "                 <> renderMigrateError err           exitFailure  renderMigrateError :: MigrateError -> Text renderMigrateError err = case err of-  MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied"-  MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName+  MigrateModuleNotApplied n -> "module " <> n ^. #unModuleName <> " not applied"+  MigrateNoRecordedVersion n -> "no version recorded for " <> (n ^. #unModuleName)   MigrateInstalledModuleEvalFailed _ msg -> msg-  MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName+  MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> (n ^. #unModuleName)   MigrateUnparseableInstalledVersion v -> "bad version " <> v   MigrateUnparseableTargetVersion v -> "bad target version " <> v   MigrateUnparseableManifestVersion v -> "bad manifest version " <> v   MigratePlanFailed _ -> "plan failed"   MigrateExecFailed _ -> "execution failed; revert your edits or run 'seihou migrate <module> --force' first"   MigrateNoManifest _ -> "no manifest in current dir"+  MigrateArtifactUnresolved refErr -> renderArtifactRefError refErr  findAppliedByName :: Manifest -> ModuleName -> Maybe AppliedModule findAppliedByName manifest name =-  case filter (\am -> am.name == name) manifest.modules of+  case filter (\am -> am ^. #name == name) (manifest ^. #modules) of     (am : _) -> Just am     [] -> Nothing @@ -781,25 +859,25 @@ -- refreshes the matching instance and leaves siblings unchanged. updateAllModules ::   [AppliedModule] ->-  [(ModuleInstance, Module, FilePath)] ->+  [(ModuleInstance, Module, ArtifactOrigin)] ->   UTCTime ->   [AppliedModule] updateAllModules existing modulesInOrder now =   let composedKeys =         Set.fromList-          [ (inst.instanceModule, inst.instanceParentVars)+          [ (inst ^. #module_, inst ^. #parentVars)           | (inst, _, _) <- modulesInOrder           ]-      filtered = filter (\am -> not (Set.member (am.name, am.parentVars) composedKeys)) existing+      filtered = filter (\am -> not (Set.member (am ^. #name, am ^. #parentVars) composedKeys)) existing       new =         [ AppliedModule-            { name = inst.instanceModule,-              parentVars = inst.instanceParentVars,-              source = dir,-              moduleVersion = m.version,+            { name = inst ^. #module_,+              parentVars = inst ^. #parentVars,+              origin = origin,+              moduleVersion = m ^. #version,               appliedAt = now,-              removal = m.removal+              removal = m ^. #removal             }-        | (inst, m, dir) <- modulesInOrder+        | (inst, m, origin) <- modulesInOrder         ]    in filtered ++ new
src-exe/Seihou/CLI/SchemaUpgrade.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (SchemaUpgradeOpts (..))@@ -16,14 +17,14 @@  handleSchemaUpgrade :: SchemaUpgradeOpts -> IO () handleSchemaUpgrade opts-  | opts.schemaUpgradeAll = do+  | (opts ^. #all) = do       searchPaths <- defaultSearchPaths       modules <- discoverAllModules searchPaths-      let paths = [dir </> "module.dhall" | DiscoveredModule {discoveredDir = dir} <- modules]-      results <- mapM (processModule opts.schemaUpgradeDryRun) paths+      let paths = [dir </> "module.dhall" | DiscoveredModule {dir = dir} <- modules]+      results <- mapM (processModule (opts ^. #dryRun)) paths       printSummary results   | otherwise = do-      moduleDir <- case opts.schemaUpgradePath of+      moduleDir <- case opts ^. #path of         Just p -> pure p         Nothing -> getCurrentDirectory       let dhallFile = moduleDir </> "module.dhall"@@ -33,7 +34,7 @@           TIO.putStrLn $ "Error: " <> T.pack dhallFile <> " not found."           exitFailure         else do-          results <- sequence [processModule opts.schemaUpgradeDryRun dhallFile]+          results <- sequence [processModule (opts ^. #dryRun) dhallFile]           printSummary results  data ProcessResult
src-exe/Seihou/CLI/Setup.hs view
@@ -6,12 +6,13 @@ where  import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),-    buildAgentCompletionRequest,+    buildAgentCompletionRequestWith,     runAgentCompletion,   ) import Seihou.CLI.AgentLaunch@@ -26,7 +27,9 @@     substitute,   ) import Seihou.CLI.AgentLaunchExec (launchConfiguredAgent)+import Seihou.CLI.AgentTrace (traceSinkForConfig) import Seihou.CLI.Commands (SetupOpts (..))+import Seihou.Core.Types (LogLevel (..)) import Seihou.Prelude import System.Exit (exitFailure, exitWith) @@ -38,12 +41,12 @@ handleSetup debug modelConfig setupOpts = do   ctx <- gatherAgentContext   let systemPrompt = renderPrompt ctx-  runRenderedAgentPrompt debug modelConfig systemPrompt setupOpts.setupPrompt+  runRenderedAgentPrompt debug modelConfig systemPrompt (setupOpts ^. #prompt)  renderPrompt :: AgentContext -> Text renderPrompt ctx =   substitute-    [ ("cwd", ctx.cwd),+    [ ("cwd", ctx ^. #cwd),       ("seihou_project_state", formatSeihouProjectState ctx),       ("manifest_state", formatManifestState ctx),       ("module_dhall_state", formatModuleDhallState ctx),@@ -55,11 +58,12 @@ runRenderedAgentPrompt :: Bool -> AgentModelConfig -> Text -> Maybe Text -> IO () runRenderedAgentPrompt debug modelConfig systemPrompt initialPrompt   | debug = TIO.putStr systemPrompt-  | modelConfig.agentProvider == AgentProviderClaudeCli || modelConfig.agentProvider == AgentProviderCodexCli = do+  | modelConfig ^. #provider == AgentProviderClaudeCli || modelConfig ^. #provider == AgentProviderCodexCli = do       exitCode <- launchConfiguredAgent modelConfig setupAllowedTools debug systemPrompt initialPrompt       exitWith exitCode   | otherwise = do-      result <- runAgentCompletion (buildAgentCompletionRequest modelConfig systemPrompt initialPrompt)+      sink <- traceSinkForConfig LogNormal modelConfig+      result <- runAgentCompletion (buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt)       case result of         Right assistantText -> TIO.putStrLn assistantText         Left err -> do
src-exe/Seihou/CLI/Status.hs view
@@ -4,12 +4,14 @@ where  import Control.Exception (SomeException, try)+import Data.Generics.Labels () import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (StatusOpts (..))+import Seihou.CLI.ManifestGuard (ArtifactCheck, checkAppliedArtifacts) import Seihou.CLI.Outdated (checkInstalledModulesForUpdates) import Seihou.CLI.PendingMigrations (detectPendingMigrations) import Seihou.CLI.Shared (logIO)-import Seihou.CLI.StatusRender (formatStatus)+import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus) import Seihou.CLI.Style (useColor) import Seihou.CLI.VersionCompare (OutdatedEntry (..)) import Seihou.Core.Module (defaultSearchPaths, discoverAllModules)@@ -20,6 +22,7 @@ import Seihou.Effect.ManifestStore (readManifest) import Seihou.Effect.ManifestStoreInterp (runManifestStore) import Seihou.Prelude+import System.Directory (getCurrentDirectory) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -47,11 +50,32 @@       TIO.putStrLn "No Seihou manifest found. Run 'seihou run <module>' to generate a project."     Right (Just (manifest, tracked)) -> do       mEntries <--        if opts.statusCheckUpdates && not (null manifest.modules)+        if opts ^. #statusCheckUpdates && not (null (manifest ^. #modules))           then fetchUpdateEntries           else pure Nothing       pendings <- detectPendingMigrations manifest Nothing       TIO.putStr (formatStatus colorEnabled manifest tracked mEntries pendings)+      -- Report, never fail: a stale or mismatched module makes 'seihou run'+      -- refuse, and this is where a developer finds out before that happens.+      -- Any IO failure while checking is swallowed for the same reason.+      guardChecks <- fetchArtifactChecks manifest+      TIO.putStr (formatArtifactChecks colorEnabled guardChecks)++-- | Compare every recorded artifact against this machine, catching any IO+-- failure so status still renders. An empty list means "nothing to report",+-- which is also what a failed check yields — @seihou status@ must not turn a+-- reporting problem into an exit code.+fetchArtifactChecks :: Manifest -> IO [ArtifactCheck]+fetchArtifactChecks manifest = do+  outcome <- try $ do+    projectRoot <- getCurrentDirectory+    searchPaths <- defaultSearchPaths+    checkAppliedArtifacts projectRoot searchPaths manifest+  case outcome of+    Left (e :: SomeException) -> do+      hPutStrLn stderr ("warning: artifact check failed: " <> show e)+      pure []+    Right checks -> pure checks  -- | Run the update check, catching any IO failure so status still renders. fetchUpdateEntries :: IO (Maybe [OutdatedEntry])
src-exe/Seihou/CLI/Update.hs view
@@ -6,6 +6,7 @@ import Control.Monad (unless, when) import Data.Aeson (encode, object, (.=)) 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@@ -45,9 +46,9 @@  validateOptions :: UpdateOpts -> IO () validateOptions opts-  | opts.updateDryRun && (opts.updateCommit || isJust opts.updateCommitMessage) =+  | opts ^. #dryRun && (opts ^. #commit || isJust (opts ^. #commitMessage)) =       failCli opts "invalid_options" "--commit and --commit-message cannot be used with --dry-run"-  | opts.updateRunAllCommands && opts.updateNoCommands =+  | opts ^. #runAllCommands && (opts ^. #noCommands) =       failCli opts "invalid_options" "--run-all-commands and --no-commands are mutually exclusive"   | otherwise = pure () @@ -55,50 +56,51 @@ requestFromOptions terminal opts =   Service.UpdateRequest     { selection =-        if null opts.updateTargets+        if null (opts ^. #targets)           then Service.AllRecordedApplications-          else Service.NamedUpdateTargets opts.updateTargets,-      varOverrides = opts.updateVars,-      reconfigure = opts.updateReconfigure,+          else Service.NamedUpdateTargets (opts ^. #targets),+      varOverrides = opts ^. #vars,+      reconfigure = opts ^. #reconfigure,       promptPolicy =-        if terminal && not opts.updateJson+        if terminal && not (opts ^. #json)           then Service.AllowPrompts           else Service.ForbidPrompts,       commandPolicy =-        if opts.updateRunAllCommands+        if opts ^. #runAllCommands           then RunAllCommands-          else if opts.updateNoCommands then DisableCommands else RunChangedCommands,-      dryRun = opts.updateDryRun+          else if opts ^. #noCommands then DisableCommands else RunChangedCommands,+      dryRun = opts ^. #dryRun,+      allowDowngrade = opts ^. #allowDowngrade     }  handlePlanned :: Bool -> UpdateOpts -> Either Service.UpdateError Service.UpdatePlan -> IO () handlePlanned _ opts (Left err) = do-  if opts.updateJson+  if opts ^. #json     then LBS.putStrLn (encodeUpdateOutput (errorOutput err))     else TIO.hPutStr stderr (renderUpdateHuman False (errorOutput err))   exitFailure handlePlanned terminal opts (Right originalPlan) = do   forced <--    if opts.updateForce+    if opts ^. #force       then either (failInteraction opts) pure (forceResolveUpdatePlan originalPlan)       else pure originalPlan   resolved <-     resolveInteractively-      (if terminal && not opts.updateJson then Interactive else NonInteractive)+      (if terminal && not (opts ^. #json) then Interactive else NonInteractive)       forced       >>= either (failInteraction opts) pure   color <- useColor   if Service.isUpdateNoOp resolved     then-      if opts.updateJson+      if opts ^. #json         then LBS.putStrLn (encodeUpdateOutput (planOutput resolved))         else TIO.putStrLn "Already up to date."     else-      if opts.updateDryRun+      if opts ^. #dryRun         then emitPlan color opts resolved         else do-          unless opts.updateJson $ TIO.putStr (renderUpdateHuman color (planOutput resolved))-          accepted <- if opts.updateJson then pure True else confirmApply terminal+          unless (opts ^. #json) $ TIO.putStr (renderUpdateHuman color (planOutput resolved))+          accepted <- if opts ^. #json then pure True else confirmApply terminal           if not accepted             then TIO.hPutStrLn stderr "Update cancelled; no managed state was changed."             else do@@ -106,10 +108,10 @@               case applied of                 Left err -> handlePlanned terminal opts (Left err)                 Right result -> do-                  if opts.updateJson+                  if opts ^. #json                     then LBS.putStrLn (encodeUpdateOutput (resultOutput result))                     else TIO.putStr (renderUpdateHuman color (resultOutput result))-                  when (opts.updateCommit || isJust opts.updateCommitMessage) $ do+                  when (opts ^. #commit || isJust (opts ^. #commitMessage)) $ do                     committed <- commitUpdate opts result                     case committed of                       Left err -> do@@ -119,7 +121,7 @@  emitPlan :: Bool -> UpdateOpts -> Service.UpdatePlan -> IO () emitPlan color opts plan =-  if opts.updateJson+  if opts ^. #json     then LBS.putStrLn (encodeUpdateOutput (planOutput plan))     else TIO.putStr (renderUpdateHuman color (planOutput plan)) @@ -147,7 +149,7 @@  commitUpdate :: UpdateOpts -> Service.UpdateResult -> IO (Either Text ()) commitUpdate opts result = do-  let candidates = filter (not . isAbsolute) (Set.toAscList result.touchedPaths)+  let candidates = filter (not . isAbsolute) (Set.toAscList (result ^. #touchedPaths))   inRepo <- runEff $ runProcessIO isGitRepo   if not inRepo     then pure (Right ())@@ -161,11 +163,11 @@           case addExit of             ExitFailure _ -> pure (Left (T.strip addErr))             ExitSuccess -> do-              message <- case opts.updateCommitMessage of+              message <- case opts ^. #commitMessage of                 Just custom -> pure custom                 Nothing -> do                   diff <- runEff $ runProcessIO gitDiffCached-                  let modules = map (ModuleName . (.name)) result.versions+                  let modules = map (ModuleName . (^. #name)) (result ^. #versions)                   generateCommitMessage modules diff               (commitExit, _, commitErr) <- runEff $ runProcessIO $ gitCommit message               pure $ case commitExit of@@ -190,7 +192,7 @@  failCli :: UpdateOpts -> Text -> Text -> IO a failCli opts code message = do-  if opts.updateJson+  if opts ^. #json     then       LBS.putStrLn $         encode $
src-exe/Seihou/CLI/Upgrade.hs view
@@ -9,6 +9,7 @@ import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -24,6 +25,7 @@   ) import Seihou.CLI.Outdated (moduleNameFromDm, readOriginWithModule) import Seihou.CLI.RemoteVersion (fetchTrueModuleVersion)+import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.CLI.Style (dim, green, red, useColor, yellow) import Seihou.CLI.VersionCompare (OutdatedStatus (..), compareVersions) import Seihou.Core.Install (parseModuleName)@@ -50,20 +52,20 @@   deriving stock (Eq, Show)  data UpgradeEntry = UpgradeEntry-  { moduleName :: Text,-    oldVersion :: Maybe Text,-    newVersion :: Maybe Text,-    upgradeStatus :: UpgradeStatus+  { moduleName :: !Text,+    oldVersion :: !(Maybe Text),+    newVersion :: !(Maybe Text),+    upgradeStatus :: !UpgradeStatus   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance ToJSON UpgradeEntry where   toJSON e =     object-      [ "module" .= e.moduleName,-        "oldVersion" .= e.oldVersion,-        "newVersion" .= e.newVersion,-        "status" .= statusText e.upgradeStatus+      [ "module" .= (e ^. #moduleName),+        "oldVersion" .= (e ^. #oldVersion),+        "newVersion" .= (e ^. #newVersion),+        "status" .= statusText (e ^. #upgradeStatus)       ]     where       statusText :: UpgradeStatus -> Text@@ -77,7 +79,7 @@ handleUpgrade uopts = do   searchPaths <- defaultSearchPaths   modules <- discoverAllModules searchPaths-  let installed = filter (\dm -> dm.discoveredSource == SourceInstalled) modules+  let installed = filter (\dm -> dm ^. #source == SourceInstalled) modules    if null installed     then TIO.putStrLn "No installed modules found."@@ -85,7 +87,7 @@       originsWithModules <- mapM readOriginWithModule installed       let withOrigins = [(dm, origin) | (dm, Just origin) <- originsWithModules] -      filtered <- case uopts.upgradeModules of+      filtered <- case uopts ^. #modules of         [] -> pure withOrigins         names -> do           let result = [(dm, origin) | (dm, origin) <- withOrigins, moduleNameFromDm dm `elem` names]@@ -99,15 +101,15 @@       if null filtered         then TIO.putStrLn "No installed modules with origin metadata found."         else do-          let grouped = Map.toList $ Map.fromListWith (++) [(origin.sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered]+          let grouped = Map.toList $ Map.fromListWith (++) [(origin ^. #sourceUrl, [(dm, origin)]) | (dm, origin) <- filtered] -          if uopts.upgradeDryRun+          if uopts ^. #dryRun             then TIO.putStrLn "Checking installed modules for updates (dry run)..."             else TIO.putStrLn "Upgrading installed modules..."            entries <- concat <$> mapM (upgradeSource uopts) grouped -          if uopts.upgradeJson+          if uopts ^. #json             then LBS.putStr (encodePretty entries)             else renderUpgradeTable entries @@ -115,7 +117,7 @@           -- migrations pending for any module that was upgraded just           -- now. Either run them (--with-migrations) or print a           -- one-line advisory per module.-          unless uopts.upgradeDryRun $+          unless (uopts ^. #dryRun) $             handlePostUpgradeMigrations uopts entries  upgradeSource :: UpgradeOpts -> (Text, [(DiscoveredModule, OriginInfo)]) -> IO [UpgradeEntry]@@ -144,7 +146,7 @@ mkUnreachableEntry dm origin =   UpgradeEntry     { moduleName = moduleNameFromDm dm,-      oldVersion = origin.version,+      oldVersion = origin ^. #version,       newVersion = Nothing,       upgradeStatus = SourceUnreachable     }@@ -152,22 +154,22 @@ upgradeModule :: UpgradeOpts -> FilePath -> RepoContents -> Text -> (DiscoveredModule, OriginInfo) -> IO UpgradeEntry upgradeModule uopts cloneDir contents sourceUrl (dm, origin) = do   let name = moduleNameFromDm dm-      installedVer = origin.version+      installedVer = (origin ^. #version)   availableVer <- fetchAvailable cloneDir (ModuleName name)   let status = compareVersions installedVer availableVer    case status of     OutdatedSt-      | uopts.upgradeDryRun ->+      | uopts ^. #dryRun ->           pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}       | otherwise ->           doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer     UpToDate ->       pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = AlreadyUpToDate}     Unversioned-      | uopts.upgradeSkipUnversioned ->+      | uopts ^. #skipUnversioned ->           pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Skipped}-      | uopts.upgradeDryRun ->+      | uopts ^. #dryRun ->           pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}       | otherwise ->           doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer@@ -177,10 +179,10 @@ doUpgrade :: FilePath -> RepoContents -> Text -> OriginInfo -> Text -> Maybe Text -> Maybe Text -> IO UpgradeEntry doUpgrade cloneDir contents sourceUrl origin name installedVer availableVer = do   let result = case contents of-        SingleModule rootDir -> Just (rootDir, origin.repoName)+        SingleModule rootDir -> Just (rootDir, origin ^. #repoName)         MultiModule registry ->-          case filter (\e -> e.name.unModuleName == name) registry.modules of-            (entry : _) -> Just (cloneDir </> entry.path, Just registry.repoName)+          case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of+            (entry : _) -> Just (cloneDir </> entry ^. #path, Just (registry ^. #repoName))             [] -> Nothing         SingleRecipe _ -> Nothing         SingleBlueprint _ -> Nothing@@ -207,21 +209,21 @@               -- docs/plans/14-fix-outdated-version-detection.md). Tags are               -- still sourced from the registry entry since module.dhall               -- has no equivalent field.-              let (ver, entryTags) = case contents of-                    MultiModule registry -> case filter (\e -> e.name.unModuleName == name) registry.modules of-                      (entry : _) -> (modul.version <|> entry.version, entry.tags)-                      [] -> (modul.version, [])-                    _ -> (modul.version, [])-              installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver entryTags+              let (ver, tags) = case contents of+                    MultiModule registry -> case filter (\e -> e ^. #name . #unModuleName == name) (registry ^. #modules) of+                      (entry : _) -> (modul ^. #version <|> entry ^. #version, entry ^. #tags)+                      [] -> (modul ^. #version, [])+                    _ -> (modul ^. #version, [])+              installModuleDir moduleDir (T.unpack name) sourceUrl registryName ver tags               TIO.putStrLn $ "    Upgraded " <> name               pure UpgradeEntry {moduleName = name, oldVersion = installedVer, newVersion = availableVer, upgradeStatus = Upgraded}  renderUpgradeTable :: [UpgradeEntry] -> IO () renderUpgradeTable entries = do   colorEnabled <- useColor-  let maxNameLen = max 6 (maximum (map (T.length . (.moduleName)) entries))-      maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.oldVersion)) entries))-      maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (.newVersion)) entries))+  let maxNameLen = max 6 (maximum (map (T.length . (^. #moduleName)) entries))+      maxOldLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #oldVersion)) entries))+      maxNewLen = max 3 (maximum (map (T.length . maybe "(none)" id . (^. #newVersion)) entries))        padR n t = t <> T.replicate (n - T.length t + 2) " " @@ -232,15 +234,15 @@           <> "Status"        formatRow e =-        let oldText = maybe "(none)" id e.oldVersion-            newText = maybe "(none)" id e.newVersion-            statusTxt = case e.upgradeStatus of+        let oldText = maybe "(none)" id (e ^. #oldVersion)+            newText = maybe "(none)" id (e ^. #newVersion)+            statusTxt = case e ^. #upgradeStatus of               Upgraded -> if colorEnabled then green "upgraded" else "upgraded"               AlreadyUpToDate -> if colorEnabled then dim "up to date" else "up to date"               Skipped -> if colorEnabled then yellow "skipped (unversioned)" else "skipped (unversioned)"               UpgradeFailed reason -> if colorEnabled then red ("failed: " <> reason) else "failed: " <> reason               SourceUnreachable -> if colorEnabled then yellow "unreachable" else "unreachable"-         in padR maxNameLen e.moduleName+         in padR maxNameLen (e ^. #moduleName)               <> padR maxOldLen oldText               <> padR maxNewLen newText               <> statusTxt@@ -249,9 +251,9 @@   TIO.putStrLn header   mapM_ (TIO.putStrLn . formatRow) entries -  let upgraded = length (filter (\e -> e.upgradeStatus == Upgraded) entries)+  let upgraded = length (filter (\e -> e ^. #upgradeStatus == Upgraded) entries)       failed = length (filter isFailedEntry entries)-      skipped = length (filter (\e -> e.upgradeStatus == Skipped) entries)+      skipped = length (filter (\e -> e ^. #upgradeStatus == Skipped) entries)   TIO.putStrLn ""   TIO.putStrLn $     T.pack (show (length entries))@@ -263,7 +265,7 @@       <> "."  isFailedEntry :: UpgradeEntry -> Bool-isFailedEntry e = case e.upgradeStatus of+isFailedEntry e = case e ^. #upgradeStatus of   UpgradeFailed _ -> True   SourceUnreachable -> True   _ -> False@@ -280,7 +282,7 @@ handlePostUpgradeMigrations uopts entries = do   let manifestPath = ".seihou" </> "manifest.json"       upgraded =-        [ entry.moduleName | entry <- entries, entry.upgradeStatus == Upgraded+        [ entry ^. #moduleName | entry <- entries, entry ^. #upgradeStatus == Upgraded         ]   if null upgraded     then pure ()@@ -297,20 +299,27 @@   case findAppliedByName manifest name of     Nothing -> pure ()     Just am -> do-      let dhallFile = am.source </> "module.dhall"-      r <- evalModuleFromFile dhallFile-      case r of+      -- The manifest records a portable origin, so the just-upgraded module+      -- has to be located on this machine before its migrations can be read.+      -- This is advisory reporting after a successful upgrade, so a module+      -- that does not resolve here is skipped rather than reported.+      resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin)+      case resolved of         Left _ -> pure ()-        Right installed ->-          case pendingChainFor am installed of-            Nothing -> pure ()-            Just plan-              | uopts.upgradeWithMigrations -> runOnePostUpgradeMigration am.source name-              | otherwise -> printAdvisory name plan+        Right moduleDir -> do+          r <- evalModuleFromFile (moduleDir </> "module.dhall")+          case r of+            Left _ -> pure ()+            Right installed ->+              case pendingChainFor am installed of+                Nothing -> pure ()+                Just plan+                  | uopts ^. #withMigrations -> runOnePostUpgradeMigration moduleDir name+                  | otherwise -> printAdvisory name plan  findAppliedByName :: Manifest -> Text -> Maybe AppliedModule findAppliedByName manifest name =-  case filter (\am -> am.name.unModuleName == name) manifest.modules of+  case filter (\am -> am ^. #name . #unModuleName == name) (manifest ^. #modules) of     (am : _) -> Just am     [] -> Nothing @@ -321,11 +330,11 @@         "note: "           <> name           <> " has "-          <> T.pack (show (length plan.planSteps))+          <> T.pack (show (length (plan ^. #steps)))           <> " migration(s) pending ("-          <> renderVersion plan.planFrom+          <> renderVersion (plan ^. #from)           <> " → "-          <> renderVersion plan.planTo+          <> renderVersion (plan ^. #to)           <> "); run 'seihou update' to reconcile the recorded project application"   TIO.putStrLn $ if colorEnabled then yellow msg else msg @@ -340,18 +349,22 @@     Right (Just manifest) -> do       let opts =             MigrateOpts-              { migrateModule = ModuleName name,-                migrateTo = Nothing,-                migrateDryRun = False,-                migrateForce = False,-                migrateJson = False,-                migrateVerbose = False,+              { module_ = ModuleName name,+                to = Nothing,+                dryRun = False,+                force = False,+                json = False,+                verbose = False,                 -- The post-upgrade hook has already refreshed the                 -- installed copy via 'seihou upgrade'; skip the                 -- redundant fetch in 'runMigrate'.-                migrateNoFetch = True,-                migrateCommit = False,-                migrateCommitMessage = Nothing+                noFetch = True,+                commit = False,+                commitMessage = Nothing,+                -- Only 'handleMigrate' consults this; 'runMigrate' is the+                -- guard-free core, and the upgrade that got us here has+                -- just refreshed the installed copy anyway.+                allowDowngrade = False               }       result <- runMigrate opts manifest installedDir       case result of@@ -369,10 +382,10 @@  renderMigrateError :: MigrateError -> Text renderMigrateError err = case err of-  MigrateModuleNotApplied n -> "module " <> n.unModuleName <> " not applied"-  MigrateNoRecordedVersion n -> "no version recorded for " <> n.unModuleName+  MigrateModuleNotApplied n -> "module " <> n ^. #unModuleName <> " not applied"+  MigrateNoRecordedVersion n -> "no version recorded for " <> (n ^. #unModuleName)   MigrateInstalledModuleEvalFailed _ msg -> msg-  MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> n.unModuleName+  MigrateInstalledModuleHasNoVersion n _ -> "no version on installed " <> (n ^. #unModuleName)   MigrateUnparseableInstalledVersion v -> "bad version " <> v   MigrateUnparseableTargetVersion v -> "bad target version " <> v   MigrateUnparseableManifestVersion v -> "bad manifest version " <> v
src-exe/Seihou/CLI/Validate.hs view
@@ -3,6 +3,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Commands (ValidateOpts (..))@@ -19,7 +20,7 @@ handleValidateModule :: ValidateOpts -> IO () handleValidateModule vopts = do   -- Determine module path-  moduleDir <- case vopts.validatePath of+  moduleDir <- case vopts ^. #path of     Just p -> pure p     Nothing -> getCurrentDirectory @@ -39,7 +40,7 @@    case decoded of     Left err -> do-      -- Dhall failed: build a report with reportDhallOk = False+      -- Dhall failed: build a report with dhallOk = False       let dummyModule =             Module               { name = ModuleName "<unknown>",@@ -56,17 +57,17 @@               }           report =             ValidateReport-              { reportModule = dummyModule,-                reportPath = moduleDir,-                reportDhallOk = False,-                reportDhallError = Just (T.pack (show err)),-                reportChecks = []+              { module_ = dummyModule,+                path = moduleDir,+                dhallOk = False,+                dhallError = Just (T.pack (show err)),+                checks = []               }       TIO.putStr (renderReportColor colorEnabled report)       exitFailure     Right modul -> do       -- Build the structured report-      report <- buildReport vopts.validateLint moduleDir modul+      report <- buildReport (vopts ^. #lint) moduleDir modul       TIO.putStr (renderReportColor colorEnabled report)       if reportHasErrors report         then exitFailure
src-exe/Seihou/CLI/ValidateBlueprint.hs view
@@ -3,8 +3,10 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Seihou.CLI.AgentConfig (agentLaunchDeclaration, validateAgentLaunchDeclaration) import Seihou.CLI.Commands (ValidateBlueprintOpts (..)) import Seihou.CLI.Shared (logIO) import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow)@@ -12,6 +14,7 @@   ( checkBlueprintAllowedTools,     checkBlueprintBaseModules,     checkBlueprintFiles,+    checkBlueprintLaunch,     checkBlueprintNameFormat,     checkBlueprintPromptNonEmpty,     checkBlueprintPromptRefs,@@ -34,18 +37,19 @@ -- and a 'files/' integrity check). data BlueprintReport = BlueprintReport   { -- | 'Nothing' when Dhall evaluation failed; otherwise the decoded record-    brBlueprint :: Maybe Blueprint,+    blueprint :: !(Maybe Blueprint),     -- | Display name; equals the decoded blueprint's name when available-    brName :: Text,-    brPath :: FilePath,-    brDhallOk :: Bool,-    brDhallError :: Maybe Text,-    brChecks :: [DiagCheck]+    name :: !Text,+    path :: !FilePath,+    dhallOk :: !Bool,+    dhallError :: !(Maybe Text),+    checks :: ![DiagCheck]   }+  deriving stock (Generic)  handleValidateBlueprint :: ValidateBlueprintOpts -> IO () handleValidateBlueprint vopts = do-  blueprintDir <- case vopts.validateBlueprintPath of+  blueprintDir <- case vopts ^. #path of     Just p -> pure p     Nothing -> getCurrentDirectory @@ -65,12 +69,12 @@     Left err -> do       let report =             BlueprintReport-              { brBlueprint = Nothing,-                brName = "<unknown>",-                brPath = blueprintDir,-                brDhallOk = False,-                brDhallError = Just (T.pack (show err)),-                brChecks = []+              { blueprint = Nothing,+                name = "<unknown>",+                path = blueprintDir,+                dhallOk = False,+                dhallError = Just (T.pack (show err)),+                checks = []               }       TIO.putStr (renderBlueprintReport colorEnabled report)       exitFailure@@ -99,27 +103,35 @@           DiagCheck "Base modules" DiagError baseErrors,           DiagCheck "Reference file existence" DiagError fileErrors,           DiagCheck "Tags" DiagError (checkBlueprintTags b),-          DiagCheck "Allowed tools" DiagError (checkBlueprintAllowedTools b)+          DiagCheck "Allowed tools" DiagError (checkBlueprintAllowedTools b),+          -- Two layers: the core rule rejects blanks, and the CLI parses the+          -- declared provider and effort against the vocabularies it owns.+          DiagCheck+            "Launch settings"+            DiagError+            ( checkBlueprintLaunch b+                <> validateAgentLaunchDeclaration (agentLaunchDeclaration (b ^. #launch))+            )         ]   pure     BlueprintReport-      { brBlueprint = Just b,-        brName = b.name.unModuleName,-        brPath = baseDir,-        brDhallOk = True,-        brDhallError = Nothing,-        brChecks = checks+      { blueprint = Just b,+        name = b ^. #name . #unModuleName,+        path = baseDir,+        dhallOk = True,+        dhallError = Nothing,+        checks = checks       }  blueprintReportHasErrors :: BlueprintReport -> Bool blueprintReportHasErrors r =-  not r.brDhallOk-    || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.brChecks+  not (r ^. #dhallOk)+    || any (\c -> c ^. #severity == DiagError && not (null (c ^. #details))) (r ^. #checks)  renderBlueprintReport :: Bool -> BlueprintReport -> Text renderBlueprintReport color report =   T.unlines $-    [ "Validating blueprint at " <> T.pack report.brPath <> "...",+    [ "Validating blueprint at " <> T.pack (report ^. #path) <> "...",       ""     ]       ++ dhallLine@@ -137,45 +149,45 @@     labelWarn t = if color then yellow t else t      dhallLine =-      if report.brDhallOk+      if report ^. #dhallOk         then ["  " <> okMark <> " blueprint.dhall evaluates successfully"]         else           ["  " <> errMark <> " blueprint.dhall failed to evaluate"]-            ++ case report.brDhallError of+            ++ case report ^. #dhallError of               Just errText -> ["      " <> detailStyle errText]               Nothing -> [] -    summaryLines = case report.brBlueprint of+    summaryLines = case report ^. #blueprint of       Nothing -> []       Just b ->-        [ "  " <> okMark <> " Blueprint name: " <> nameStyle b.name.unModuleName,-          "  " <> okMark <> " " <> T.pack (show (length b.vars)) <> " variables declared",-          "  " <> okMark <> " " <> T.pack (show (length b.prompts)) <> " prompts defined",-          "  " <> okMark <> " " <> T.pack (show (length b.baseModules)) <> " base modules declared",-          "  " <> okMark <> " " <> T.pack (show (length b.files)) <> " reference files declared"+        [ "  " <> okMark <> " Blueprint name: " <> nameStyle (b ^. #name . #unModuleName),+          "  " <> okMark <> " " <> T.pack (show (length (b ^. #vars))) <> " variables declared",+          "  " <> okMark <> " " <> T.pack (show (length (b ^. #prompts))) <> " prompts defined",+          "  " <> okMark <> " " <> T.pack (show (length (b ^. #baseModules))) <> " base modules declared",+          "  " <> okMark <> " " <> T.pack (show (length (b ^. #files))) <> " reference files declared"         ] -    checkLines = concatMap renderCheck report.brChecks+    checkLines = concatMap renderCheck (report ^. #checks)      renderCheck c-      | null c.diagDetails =-          ["  " <> okMark <> " " <> c.diagLabel]-      | c.diagSeverity == DiagWarning =-          ("  " <> warnMark <> " " <> labelWarn c.diagLabel)-            : map (\d -> "      " <> detailStyle d) c.diagDetails+      | null (c ^. #details) =+          ["  " <> okMark <> " " <> c ^. #label]+      | c ^. #severity == DiagWarning =+          ("  " <> warnMark <> " " <> labelWarn (c ^. #label))+            : map (\d -> "      " <> detailStyle d) (c ^. #details)       | otherwise =-          ("  " <> errMark <> " " <> labelErr c.diagLabel)-            : map (\d -> "      " <> detailStyle d) c.diagDetails+          ("  " <> errMark <> " " <> labelErr (c ^. #label))+            : map (\d -> "      " <> detailStyle d) (c ^. #details)      errorCount =       length         [ ()-        | c <- report.brChecks,-          c.diagSeverity == DiagError,-          not (null c.diagDetails)+        | c <- report ^. #checks,+          c ^. #severity == DiagError,+          not (null (c ^. #details))         ] -    dhallFailed = not report.brDhallOk+    dhallFailed = not (report ^. #dhallOk)     totalErrors = errorCount + (if dhallFailed then 1 else 0)      resultLine@@ -183,5 +195,5 @@           let msg = T.pack (show totalErrors) <> " error(s) found."            in (if color then bold (red msg) else msg) <> " Blueprint is invalid."       | otherwise =-          let msg = "Blueprint '" <> report.brName <> "' is valid."+          let msg = "Blueprint '" <> report ^. #name <> "' is valid."            in if color then green msg else msg
src-exe/Seihou/CLI/ValidatePrompt.hs view
@@ -3,8 +3,10 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Seihou.CLI.AgentConfig (agentLaunchDeclaration, validateAgentLaunchDeclaration) import Seihou.CLI.Commands (ValidatePromptOpts (..)) import Seihou.CLI.Shared (logIO) import Seihou.CLI.Style (bold, cyan, dim, green, red, useColor, yellow)@@ -14,6 +16,7 @@     checkAgentPromptCommandVars,     checkAgentPromptFiles,     checkAgentPromptGuidance,+    checkAgentPromptLaunch,     checkAgentPromptNameFormat,     checkAgentPromptPromptRefs,     checkAgentPromptTags,@@ -29,17 +32,18 @@ import System.Exit (ExitCode (..), exitFailure, exitWith)  data PromptReport = PromptReport-  { prPrompt :: Maybe AgentPrompt,-    prName :: Text,-    prPath :: FilePath,-    prDhallOk :: Bool,-    prDhallError :: Maybe Text,-    prChecks :: [DiagCheck]+  { prompt :: !(Maybe AgentPrompt),+    name :: !Text,+    path :: !FilePath,+    dhallOk :: !Bool,+    dhallError :: !(Maybe Text),+    checks :: ![DiagCheck]   }+  deriving stock (Generic)  handleValidatePrompt :: ValidatePromptOpts -> IO () handleValidatePrompt vopts = do-  promptDir <- case vopts.validatePromptPath of+  promptDir <- case vopts ^. #path of     Just p -> pure p     Nothing -> getCurrentDirectory @@ -59,12 +63,12 @@     Left err -> do       let report =             PromptReport-              { prPrompt = Nothing,-                prName = "<unknown>",-                prPath = promptDir,-                prDhallOk = False,-                prDhallError = Just (T.pack (show err)),-                prChecks = []+              { prompt = Nothing,+                name = "<unknown>",+                path = promptDir,+                dhallOk = False,+                dhallError = Just (T.pack (show err)),+                checks = []               }       TIO.putStr (renderPromptReport colorEnabled report)       exitFailure@@ -88,27 +92,35 @@           DiagCheck "Prompt guidance" DiagError (checkAgentPromptGuidance p),           DiagCheck "Reference file existence" DiagError fileErrors,           DiagCheck "Tags" DiagError (checkAgentPromptTags p),-          DiagCheck "Allowed tools" DiagError (checkAgentPromptAllowedTools p)+          DiagCheck "Allowed tools" DiagError (checkAgentPromptAllowedTools p),+          -- Two layers: the core rule rejects blanks, and the CLI parses the+          -- declared provider and effort against the vocabularies it owns.+          DiagCheck+            "Launch settings"+            DiagError+            ( checkAgentPromptLaunch p+                <> validateAgentLaunchDeclaration (agentLaunchDeclaration (p ^. #launch))+            )         ]   pure     PromptReport-      { prPrompt = Just p,-        prName = p.name.unModuleName,-        prPath = baseDir,-        prDhallOk = True,-        prDhallError = Nothing,-        prChecks = checks+      { prompt = Just p,+        name = p ^. #name . #unModuleName,+        path = baseDir,+        dhallOk = True,+        dhallError = Nothing,+        checks = checks       }  promptReportHasErrors :: PromptReport -> Bool promptReportHasErrors r =-  not r.prDhallOk-    || any (\c -> c.diagSeverity == DiagError && not (null c.diagDetails)) r.prChecks+  not (r ^. #dhallOk)+    || any (\c -> c ^. #severity == DiagError && not (null (c ^. #details))) (r ^. #checks)  renderPromptReport :: Bool -> PromptReport -> Text renderPromptReport color report =   T.unlines $-    [ "Validating prompt at " <> T.pack report.prPath <> "...",+    [ "Validating prompt at " <> T.pack (report ^. #path) <> "...",       ""     ]       ++ dhallLine@@ -126,46 +138,46 @@     labelWarn t = if color then yellow t else t      dhallLine =-      if report.prDhallOk+      if report ^. #dhallOk         then ["  " <> okMark <> " prompt.dhall evaluates successfully"]         else           ["  " <> errMark <> " prompt.dhall failed to evaluate"]-            ++ case report.prDhallError of+            ++ case report ^. #dhallError of               Just errText -> ["      " <> detailStyle errText]               Nothing -> [] -    summaryLines = case report.prPrompt of+    summaryLines = case report ^. #prompt of       Nothing -> []       Just p ->-        [ "  " <> okMark <> " Prompt name: " <> nameStyle p.name.unModuleName,-          "  " <> okMark <> " " <> T.pack (show (length p.vars)) <> " variables declared",-          "  " <> okMark <> " " <> T.pack (show (length p.prompts)) <> " prompts defined",-          "  " <> okMark <> " " <> T.pack (show (length p.commandVars)) <> " command variables declared",-          "  " <> okMark <> " " <> T.pack (show (length p.guidance)) <> " guidance blocks declared",-          "  " <> okMark <> " " <> T.pack (show (length p.files)) <> " reference files declared"+        [ "  " <> okMark <> " Prompt name: " <> nameStyle (p ^. #name . #unModuleName),+          "  " <> okMark <> " " <> T.pack (show (length (p ^. #vars))) <> " variables declared",+          "  " <> okMark <> " " <> T.pack (show (length (p ^. #prompts))) <> " prompts defined",+          "  " <> okMark <> " " <> T.pack (show (length (p ^. #commandVars))) <> " command variables declared",+          "  " <> okMark <> " " <> T.pack (show (length (p ^. #guidance))) <> " guidance blocks declared",+          "  " <> okMark <> " " <> T.pack (show (length (p ^. #files))) <> " reference files declared"         ] -    checkLines = concatMap renderCheck report.prChecks+    checkLines = concatMap renderCheck (report ^. #checks)      renderCheck c-      | null c.diagDetails =-          ["  " <> okMark <> " " <> c.diagLabel]-      | c.diagSeverity == DiagWarning =-          ("  " <> warnMark <> " " <> labelWarn c.diagLabel)-            : map (\d -> "      " <> detailStyle d) c.diagDetails+      | null (c ^. #details) =+          ["  " <> okMark <> " " <> c ^. #label]+      | c ^. #severity == DiagWarning =+          ("  " <> warnMark <> " " <> labelWarn (c ^. #label))+            : map (\d -> "      " <> detailStyle d) (c ^. #details)       | otherwise =-          ("  " <> errMark <> " " <> labelErr c.diagLabel)-            : map (\d -> "      " <> detailStyle d) c.diagDetails+          ("  " <> errMark <> " " <> labelErr (c ^. #label))+            : map (\d -> "      " <> detailStyle d) (c ^. #details)      errorCount =       length         [ ()-        | c <- report.prChecks,-          c.diagSeverity == DiagError,-          not (null c.diagDetails)+        | c <- report ^. #checks,+          c ^. #severity == DiagError,+          not (null (c ^. #details))         ] -    dhallFailed = not report.prDhallOk+    dhallFailed = not (report ^. #dhallOk)     totalErrors = errorCount + (if dhallFailed then 1 else 0)      resultLine@@ -173,5 +185,5 @@           let msg = T.pack (show totalErrors) <> " error(s) found."            in (if color then bold (red msg) else msg) <> " Prompt is invalid."       | otherwise =-          let msg = "Prompt '" <> report.prName <> "' is valid."+          let msg = "Prompt '" <> report ^. #name <> "' is valid."            in if color then green msg else msg
src-exe/Seihou/CLI/Vars.hs view
@@ -4,6 +4,7 @@ where  import Control.Monad (when)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T@@ -30,7 +31,7 @@ handleVars :: VarsOpts -> IO () handleVars vopts = do   -- Resolve module name (from argument or fzf picker)-  modName <- case vopts.varsModule of+  modName <- case vopts ^. #module_ of     Just name -> pure name     Nothing -> do       fzfCfg <- detectFzfConfig@@ -61,7 +62,7 @@   case discResult of     Left (ModuleNotFound _ searched) -> do       logIO LogNormal $ do-        logError $ "Module '" <> modName.unModuleName <> "' not found."+        logError $ "Module '" <> modName ^. #unModuleName <> "' not found."         logError "Searched in:"         mapM_ (\p -> logError $ "  " <> T.pack p) searched       exitFailure@@ -69,18 +70,18 @@       logIO LogNormal (logError $ T.pack (show err))       exitFailure     Right (RunnableModule m _) ->-      if vopts.varsExplain+      if vopts ^. #explain         then explainMode modName vopts         else declarationModeModule m     Right (RunnableRecipe r _) ->-      if vopts.varsExplain+      if vopts ^. #explain         then explainMode modName vopts         else declarationModeRecipe r     Right (RunnableBlueprint b _) ->-      if vopts.varsExplain+      if vopts ^. #explain         then do           logIO LogNormal $ do-            logError $ "'" <> modName.unModuleName <> "' is a blueprint; --explain is not supported in this release."+            logError $ "'" <> modName ^. #unModuleName <> "' is a blueprint; --explain is not supported in this release."             logError "Resolving a blueprint's variables requires the agent runner."             logError "Run `seihou agent run <blueprint>` instead (when EP-31 ships)."             logError "For a read-only listing of declared variables, omit --explain."@@ -90,11 +91,11 @@ -- | Declaration mode for a module: list declared variables. declarationModeModule :: Module -> IO () declarationModeModule modul = do-  let vs = modul.vars+  let vs = (modul ^. #vars)   if null vs     then TIO.putStrLn "No variables declared."     else do-      TIO.putStrLn $ "Variables for " <> modul.name.unModuleName <> ":"+      TIO.putStrLn $ "Variables for " <> modul ^. #name . #unModuleName <> ":"       TIO.putStrLn ""       TIO.putStr (formatDeclarations vs) @@ -103,11 +104,11 @@ -- compose); this prints those without expanding the recipe. declarationModeRecipe :: Recipe -> IO () declarationModeRecipe r = do-  let vs = r.vars+  let vs = (r ^. #vars)   if null vs     then TIO.putStrLn "No variables declared."     else do-      TIO.putStrLn $ "Variables for " <> r.name.unRecipeName <> " (recipe):"+      TIO.putStrLn $ "Variables for " <> r ^. #name . #unRecipeName <> " (recipe):"       TIO.putStrLn ""       TIO.putStr (formatDeclarations vs) @@ -116,11 +117,11 @@ -- glance that this is the agent-driven runnable, not a module/recipe. declarationModeBlueprint :: Blueprint -> IO () declarationModeBlueprint b = do-  let vs = b.vars+  let vs = (b ^. #vars)   if null vs     then TIO.putStrLn "No variables declared."     else do-      TIO.putStrLn $ "Variables for " <> b.name.unModuleName <> " (blueprint):"+      TIO.putStrLn $ "Variables for " <> b ^. #name . #unModuleName <> " (blueprint):"       TIO.putStrLn ""       TIO.putStr (formatDeclarations vs) @@ -133,14 +134,14 @@   modulesInOrder <- case compositionResult of     Left (ModuleNotFound name searched) -> do       logIO LogNormal $ do-        logError $ "Module '" <> name.unModuleName <> "' not found."+        logError $ "Module '" <> name ^. #unModuleName <> "' not found."         logError "Searched in:"         mapM_ (\p -> logError $ "  " <> T.pack p) searched       exitFailure     Left (CircularDependency names) -> do       logIO LogNormal $ do         logError "Circular dependency detected:"-        logError $ "  " <> T.intercalate " -> " (map (.unModuleName) names)+        logError $ "  " <> T.intercalate " -> " (map (^. #unModuleName) names)       exitFailure     Left err -> do       logIO LogNormal (logError $ T.pack (show err))@@ -157,10 +158,10 @@    -- Resolve variables with the full composition pipeline   envPairs <- getEnvironment-  let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts.varsVars]+  let cliOverrides = Map.fromList [(VarName k, v) | (k, v) <- vopts ^. #vars]       envVars = Map.fromList [(T.pack k, T.pack v) | (k, v) <- envPairs]-      namespace = fromMaybe (deriveNamespace modName) vopts.varsNamespace-  context <- resolveContext vopts.varsContext envVars+      namespace = fromMaybe (deriveNamespace modName) (vopts ^. #namespace)+  context <- resolveContext (vopts ^. #context) envVars   let contextName = fromMaybe "" context   (resolveResult, localMap, nsMap, ctxMap, globalMap) <- runEff $ runConfigReader $ runConsole $ do     localCfg <- readLocalConfig >>= unwrapConfig LogNormal@@ -188,16 +189,16 @@             Map.unions               [ vs               | (inst, vs) <- Map.toList resolved,-                inst.instanceModule == modName+                inst ^. #module_ == modName               ]-      TIO.putStrLn $ "Variables for " <> modName.unModuleName <> ":"+      TIO.putStrLn $ "Variables for " <> modName ^. #unModuleName <> ":"       TIO.putStrLn ""       if Map.null targetResolved         then TIO.putStrLn "  (no variables resolved)"         else TIO.putStr (formatExplain targetResolved)        -- Show diagnostics-      let allDecls = concatMap (\(_, m, _) -> m.vars) modulesInOrder+      let allDecls = concatMap (\(_, m, _) -> m ^. #vars) modulesInOrder           allResolved = Map.unions [vs | vs <- Map.elems resolved]           (unusedKeys, unresolvedOpt) = diagnoseResolution allResolved allDecls localMap nsMap ctxMap globalMap       when (not (null unusedKeys)) $ do
src/Seihou/CLI/AgentCompletion.hs view
@@ -4,15 +4,21 @@   ( AgentProvider (..),     AgentModelConfig (..),     AgentCompletionRequest (..),+    TraceSetting (..),     defaultAgentModelConfig,     defaultModelForProvider,     providerFromText,     providerToText,     effortFromText,     effortToText,+    traceFromText,+    traceToText,     buildAgentCompletionRequest,+    buildAgentCompletionRequestWith,     buildBaikaiModel,     runAgentCompletion,+    runAgentCompletionWithCliAccess,+    runAgentCompletionWith,     responseText,   ) where@@ -23,11 +29,18 @@ import Baikai.Provider.Claude.Cli qualified as ClaudeCli import Baikai.Provider.OpenAI.Api qualified as OpenAIApi import Baikai.Provider.OpenAI.Cli qualified as CodexCli+import Baikai.Response qualified as BaikaiResponse import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel)+import Baikai.Trace qualified as BaikaiTrace+import Baikai.Trace.Sink (TraceSink, silent) import Control.Exception (try)+import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as Text import Data.Vector qualified as V+import GHC.Generics (Generic)+import System.Directory (getCurrentDirectory)  data AgentProvider   = AgentProviderClaudeCli@@ -36,35 +49,81 @@   | AgentProviderOpenAI   deriving stock (Eq, Show) +-- | Where trace events for a model call should go.+--+-- Baikai emits a small stream of 'Baikai.Trace.Event.TraceEvent' values per+-- call — one when the call starts, one when it finishes or fails — carrying+-- the provider, model, elapsed milliseconds, token counts, and dollar cost.+-- This closed vocabulary names the four destinations Seihou exposes, rather+-- than exposing Baikai's composable @TraceSink@ surface (a streamly fold),+-- which no config string could express.+data TraceSetting+  = -- | Emit nothing. The default, and byte-for-byte the historical behavior.+    TraceOff+  | -- | Append one JSON object per line to the resolved trace file.+    TraceFile+  | -- | Print one human-readable line per event to stdout.+    TraceStdout+  | -- | Print one human-readable line per event to stderr.+    TraceStderr+  deriving stock (Eq, Show)+ data AgentModelConfig = AgentModelConfig-  { agentProvider :: AgentProvider,-    agentModel :: Maybe Text,+  { provider :: !AgentProvider,+    model :: !(Maybe Text),     -- | Reasoning effort. 'Nothing' leaves the provider/CLI default alone.-    agentEffort :: Maybe ThinkingLevel+    effort :: !(Maybe ThinkingLevel),+    -- | Where call traces go. 'TraceOff' emits nothing.+    trace :: !TraceSetting,+    -- | The configured @agent.tracePath@, when set. 'Nothing' means the+    -- built-in default path is used by the file sink.+    tracePath :: !(Maybe FilePath)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show) +-- | Note the absence of 'Eq' and 'Show': 'TraceSink' wraps a streamly fold,+-- which is a function and so has neither. Tests compare the inspectable fields+-- individually. data AgentCompletionRequest = AgentCompletionRequest-  { completionSystemPrompt :: Text,-    completionInitialPrompt :: Maybe Text,-    completionModelConfig :: AgentModelConfig+  { systemPrompt :: !Text,+    initialPrompt :: !(Maybe Text),+    modelConfig :: !AgentModelConfig,+    -- | Where this call's trace events go. Baikai's 'silent' sink when tracing+    -- is off, which is the default and costs nothing.+    traceSink :: !TraceSink   }-  deriving stock (Eq, Show)+  deriving stock (Generic) +-- | Build a request that emits no trace events. buildAgentCompletionRequest :: AgentModelConfig -> Text -> Maybe Text -> AgentCompletionRequest-buildAgentCompletionRequest modelConfig systemPrompt initialPrompt =+buildAgentCompletionRequest = buildAgentCompletionRequestWith silent++-- | Build a request whose model call reports to the given sink. Construct the+-- sink with 'Seihou.CLI.AgentTrace.traceSinkFor'; build it once per command+-- rather than per call, so a command that makes several calls appends them all+-- to the same destination.+buildAgentCompletionRequestWith ::+  TraceSink ->+  AgentModelConfig ->+  Text ->+  Maybe Text ->   AgentCompletionRequest-    { completionSystemPrompt = systemPrompt,-      completionInitialPrompt = initialPrompt,-      completionModelConfig = modelConfig+buildAgentCompletionRequestWith sink modelConfig systemPrompt initialPrompt =+  AgentCompletionRequest+    { systemPrompt = systemPrompt,+      initialPrompt = initialPrompt,+      modelConfig = modelConfig,+      traceSink = sink     }  defaultAgentModelConfig :: AgentModelConfig defaultAgentModelConfig =   AgentModelConfig-    { agentProvider = AgentProviderClaudeCli,-      agentModel = Nothing,-      agentEffort = Nothing+    { provider = AgentProviderClaudeCli,+      model = Nothing,+      effort = Nothing,+      trace = TraceOff,+      tracePath = Nothing     }  -- | Parse a reasoning-effort level name (case-insensitive) into a Baikai@@ -88,6 +147,27 @@ effortToText :: ThinkingLevel -> Text effortToText = renderThinkingLevel +-- | Parse a trace-destination name (case-insensitive) into a 'TraceSetting'.+traceFromText :: Text -> Either Text TraceSetting+traceFromText raw =+  case Text.toLower (Text.strip raw) of+    "off" -> Right TraceOff+    "file" -> Right TraceFile+    "stdout" -> Right TraceStdout+    "stderr" -> Right TraceStderr+    other ->+      Left $+        "Unknown trace setting '"+          <> other+          <> "'. Expected one of: off, file, stdout, stderr."++-- | Render a 'TraceSetting' to its canonical name.+traceToText :: TraceSetting -> Text+traceToText TraceOff = "off"+traceToText TraceFile = "file"+traceToText TraceStdout = "stdout"+traceToText TraceStderr = "stderr"+ -- | The deterministic default model for a provider when the user has configured -- none. The two local CLI providers pin a specific model so a @seihou agent@ -- session never inherits whatever model the ambient @claude@ or @codex@ session@@ -122,33 +202,33 @@  buildBaikaiModel :: AgentModelConfig -> Baikai.Model buildBaikaiModel config =-  case config.agentProvider of+  case config ^. #provider of     AgentProviderClaudeCli ->       baseCliModel-        { Baikai.modelId = maybe "" id config.agentModel,-          Baikai.name = maybe "Claude CLI default" id config.agentModel,+        { Baikai.modelId = maybe "" id (config ^. #model),+          Baikai.name = maybe "Claude CLI default" id (config ^. #model),           Baikai.api = Baikai.AnthropicMessagesCli,           Baikai.provider = "anthropic"         }     AgentProviderCodexCli ->       baseCliModel-        { Baikai.modelId = maybe "" id config.agentModel,-          Baikai.name = maybe "Codex CLI default" id config.agentModel,+        { Baikai.modelId = maybe "" id (config ^. #model),+          Baikai.name = maybe "Codex CLI default" id (config ^. #model),           Baikai.api = Baikai.OpenAICompletionsCli,           Baikai.provider = "openai"         }     AgentProviderAnthropic ->       Baikai.emptyModel-        { Baikai.modelId = maybe "claude-sonnet-4-6" id config.agentModel,-          Baikai.name = maybe "Claude Sonnet 4.6" id config.agentModel,+        { Baikai.modelId = maybe "claude-sonnet-4-6" id (config ^. #model),+          Baikai.name = maybe "Claude Sonnet 4.6" id (config ^. #model),           Baikai.api = Baikai.AnthropicMessages,           Baikai.provider = "anthropic",           Baikai.baseUrl = "https://api.anthropic.com"         }     AgentProviderOpenAI ->       Baikai.emptyModel-        { Baikai.modelId = maybe "gpt-4o-mini" id config.agentModel,-          Baikai.name = maybe "GPT-4o Mini" id config.agentModel,+        { Baikai.modelId = maybe "gpt-4o-mini" id (config ^. #model),+          Baikai.name = maybe "GPT-4o Mini" id (config ^. #model),           Baikai.api = Baikai.OpenAIChatCompletions,           Baikai.provider = "openai",           Baikai.baseUrl = "https://api.openai.com"@@ -161,28 +241,57 @@         }  runAgentCompletion :: AgentCompletionRequest -> IO (Either Text Text)-runAgentCompletion req = do-  registerAgentProviders+runAgentCompletion = runAgentCompletionWith registerAgentProviders++-- | Run a completion while granting local CLI providers access to the current+-- workspace and mounted blueprint references. API providers ignore this local+-- access configuration. This is the non-interactive counterpart to the+-- interactive launcher used by normal @seihou agent run@ sessions.+runAgentCompletionWithCliAccess :: [FilePath] -> [String] -> AgentCompletionRequest -> IO (Either Text Text)+runAgentCompletionWithCliAccess extraDirs tools =+  runAgentCompletionWith (registerAgentProvidersWithCliAccess extraDirs tools)++-- | The shared implementation behind 'runAgentCompletion' and+-- 'runAgentCompletionWithCliAccess', parameterised by which providers to+-- register. Exported so tests can install a stub provider in place of a real+-- one; production callers should use one of the two wrappers.+runAgentCompletionWith :: IO () -> AgentCompletionRequest -> IO (Either Text Text)+runAgentCompletionWith registerProviders req = do+  registerProviders   initialMessages <-     maybe       (pure V.empty)       (fmap V.singleton . Baikai.userNow)-      req.completionInitialPrompt-  let model = buildBaikaiModel req.completionModelConfig+      (req ^. #initialPrompt)+  let model = buildBaikaiModel (req ^. #modelConfig)       ctx =         Baikai.emptyContext-          { Baikai.systemPrompt = Just req.completionSystemPrompt,+          { Baikai.systemPrompt = Just (req ^. #systemPrompt),             Baikai.messages = initialMessages           }-      options = Baikai.emptyOptions {BaikaiOptions.thinking = req.completionModelConfig.agentEffort}-  result <- try (Baikai.completeRequest model ctx options) :: IO (Either Baikai.BaikaiError Baikai.Response)+      options = Baikai.emptyOptions {BaikaiOptions.thinking = req ^. #modelConfig . #effort}+  result <-+    try (BaikaiTrace.withTrace (req ^. #traceSink) model ctx options) ::+      IO (Either Baikai.BaikaiError Baikai.Response)   pure $ case result of+    -- Retained deliberately. 'withTrace' does not throw for provider failures,+    -- but its doc comment states that downstream-of-the-fold exceptions still+    -- propagate — an unwritable trace path, for instance.     Left err -> Left (Text.pack (show err))-    Right resp ->-      let body = responseText resp-       in if Text.null (Text.strip body)-            then Left "Provider returned no assistant text."-            else Right body+    Right resp -> case BaikaiResponse.responseError resp of+      -- 'withTrace' surfaces a provider failure as an error-shaped Response+      -- rather than an exception, and such a response has no assistant text.+      -- Without this branch every provider error — a bad API key, a rate+      -- limit, an unknown model — would fall through to the empty-text guard+      -- below and be reported as "Provider returned no assistant text.",+      -- losing the message the user needs. Formatting matches the exception+      -- branch exactly, so the text a user sees is what it always was.+      Just err -> Left (Text.pack (show err))+      Nothing ->+        let body = responseText resp+         in if Text.null (Text.strip body)+              then Left "Provider returned no assistant text."+              else Right body  responseText :: Baikai.Response -> Text responseText =@@ -200,3 +309,34 @@   CodexCli.register   ClaudeApi.register   OpenAIApi.register++registerAgentProvidersWithCliAccess :: [FilePath] -> [String] -> IO ()+registerAgentProvidersWithCliAccess extraDirs tools = do+  cwd <- getCurrentDirectory+  Baikai.registerApiProvider $+    ClaudeCli.claudeCliProvider+      ClaudeCli.defaultClaudeCliConfig+        { ClaudeCli.workingDir = Just cwd,+          ClaudeCli.extraArgs = claudeAccessArgs extraDirs tools+        }+  Baikai.registerApiProvider $+    CodexCli.codexCliProvider+      CodexCli.defaultCodexCliConfig+        { CodexCli.workingDir = Just cwd,+          CodexCli.extraArgs = codexAccessArgs extraDirs+        }+  ClaudeApi.register+  OpenAIApi.register++claudeAccessArgs :: [FilePath] -> [String] -> [Text]+claudeAccessArgs extraDirs tools =+  ( if null tools+      then []+      else ["--allowedTools", Text.intercalate "," (map Text.pack tools)]+  )+    <> concatMap (\dir -> ["--add-dir", Text.pack dir]) extraDirs++codexAccessArgs :: [FilePath] -> [Text]+codexAccessArgs extraDirs =+  ["--sandbox", "workspace-write"]+    <> concatMap (\dir -> ["--add-dir", Text.pack dir]) extraDirs
src/Seihou/CLI/AgentConfig.hs view
@@ -2,6 +2,8 @@   ( -- * Inputs     AgentConfigInputs (..),     baseAgentConfigInputs,+    AgentSettingFlags (..),+    noAgentSettingFlags,      -- * Command identity     AgentCommandName (..),@@ -13,12 +15,16 @@     agentProviderConfigKey,     agentModelConfigKey,     agentEffortConfigKey,+    agentTraceConfigKey,+    agentTracePathConfigKey,     agentCommandProviderConfigKey,     agentCommandModelConfigKey,     agentCommandEffortConfigKey,+    agentCommandTraceConfigKey,     agentProviderEnvVar,     agentModelEnvVar,     agentEffortEnvVar,+    agentTraceEnvVar,      -- * Provenance     AgentConfigSource (..),@@ -29,9 +35,22 @@     -- * Resolution     resolveAgentModelConfig,     resolveAgentModelConfigFor,+    resolveTracePath,     loadAgentModelConfig,     loadAgentModelConfigFor, +    -- * Artifact-declared launch settings+    AgentLaunchDeclaration (..),+    noAgentLaunchDeclaration,+    agentLaunchDeclaration,+    validateAgentLaunchDeclaration,+    PendingAgentConfig (..),+    loadPendingAgentConfig,+    resolvePendingAgentConfig,+    resolvedAgentModelConfig,+    formatResolvedAgentProvenance,+    resolveDeclaredAgentConfig,+     -- * Whole-configuration inspection     ResolvedCommandConfig (..),     loadResolvedAgentConfig,@@ -39,21 +58,32 @@ where  import Baikai.ThinkingLevel (ThinkingLevel)+import Control.Applicative ((<|>))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust) import Data.Text qualified as T import Seihou.CLI.AgentCompletion   ( AgentModelConfig (..),     AgentProvider (..),+    TraceSetting (..),     defaultAgentModelConfig,     defaultModelForProvider,     effortFromText,+    effortToText,     providerFromText,+    providerToText,+    traceFromText,+    traceToText,   )-import Seihou.CLI.Shared (formatConfigError)+import Seihou.CLI.Shared (formatConfigError, logIO)+import Seihou.Core.Types (AgentLaunch (..), LogLevel) import Seihou.Effect.ConfigReader (readGlobalConfig, readLocalConfig) import Seihou.Effect.ConfigReaderInterp (runConfigReader)+import Seihou.Effect.Logger (logError, logInfo) import Seihou.Prelude import System.Environment (lookupEnv)+import System.Exit (exitFailure)  -- | All the raw material provider/model resolution draws on, in one record so -- the pure resolver can be unit-tested without touching the filesystem or the@@ -65,19 +95,32 @@ -- provenance label reported for a CLI-sourced value; they never change which -- value wins. data AgentConfigInputs = AgentConfigInputs-  { cliProvider :: Maybe Text,-    cliModel :: Maybe Text,-    cliEffort :: Maybe Text,-    cliProviderFromSubcommand :: Bool,-    cliModelFromSubcommand :: Bool,-    cliEffortFromSubcommand :: Bool,-    envProvider :: Maybe Text,-    envModel :: Maybe Text,-    envEffort :: Maybe Text,-    localConfig :: Map Text Text,-    globalConfig :: Map Text Text+  { cliProvider :: !(Maybe Text),+    cliModel :: !(Maybe Text),+    cliEffort :: !(Maybe Text),+    cliTrace :: !(Maybe Text),+    cliProviderFromSubcommand :: !Bool,+    cliModelFromSubcommand :: !Bool,+    cliEffortFromSubcommand :: !Bool,+    cliTraceFromSubcommand :: !Bool,+    envProvider :: !(Maybe Text),+    envModel :: !(Maybe Text),+    envEffort :: !(Maybe Text),+    envTrace :: !(Maybe Text),+    -- | Declared by the blueprint or prompt being run, when the command has+    -- one. Only populated once the artifact has been loaded; see+    -- 'resolvePendingAgentConfig'.+    declaredProvider :: !(Maybe Text),+    declaredModel :: !(Maybe Text),+    declaredEffort :: !(Maybe Text),+    -- | Reserved: no schema field feeds this yet. It exists so all four+    -- settings are structurally identical, making a future @launch.trace@ an+    -- insertion rather than a redesign.+    declaredTrace :: !(Maybe Text),+    localConfig :: !(Map Text Text),+    globalConfig :: !(Map Text Text)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | An 'AgentConfigInputs' with nothing set: no flags, no environment, empty -- config maps. Handy as a base for tests and for callers that only populate a@@ -88,16 +131,70 @@     { cliProvider = Nothing,       cliModel = Nothing,       cliEffort = Nothing,+      cliTrace = Nothing,       cliProviderFromSubcommand = False,       cliModelFromSubcommand = False,       cliEffortFromSubcommand = False,+      cliTraceFromSubcommand = False,       envProvider = Nothing,       envModel = Nothing,       envEffort = Nothing,+      envTrace = Nothing,+      declaredProvider = Nothing,+      declaredModel = Nothing,+      declaredEffort = Nothing,+      declaredTrace = Nothing,       localConfig = Map.empty,       globalConfig = Map.empty     } +-- | The four agent settings as supplied on one command-line tier — either the+-- parent @seihou agent@ command or the subcommand itself.+--+-- Grouping them keeps the loader signatures honest: four same-typed+-- @Maybe Text@ values in a row, twice over, are trivial to transpose by+-- accident, and the compiler would not notice.+data AgentSettingFlags = AgentSettingFlags+  { provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text),+    trace :: !(Maybe Text)+  }+  deriving stock (Eq, Generic, Show)++-- | No flags supplied on this tier.+noAgentSettingFlags :: AgentSettingFlags+noAgentSettingFlags =+  AgentSettingFlags+    { provider = Nothing,+      model = Nothing,+      effort = Nothing,+      trace = Nothing+    }++-- | Fold the parent and subcommand flag tiers into gathered inputs. The+-- subcommand's own flag wins over the parent @seihou agent@ flag; which tier+-- supplied the winner only affects the provenance label, never the value.+applyAgentSettingFlags :: AgentSettingFlags -> AgentSettingFlags -> AgentConfigInputs -> AgentConfigInputs+applyAgentSettingFlags parent command inputs =+  inputs+    & #cliProvider+    .~ (command ^. #provider <|> parent ^. #provider)+    & #cliModel+    .~ (command ^. #model <|> parent ^. #model)+    & #cliEffort+    .~ (command ^. #effort <|> parent ^. #effort)+    & #cliTrace+    .~ (command ^. #trace <|> parent ^. #trace)+    & #cliProviderFromSubcommand+    .~ isJust (command ^. #provider)+    & #cliModelFromSubcommand+    .~ isJust (command ^. #model)+    & #cliEffortFromSubcommand+    .~ isJust (command ^. #effort)+    & #cliTraceFromSubcommand+    .~ isJust (command ^. #trace)+ -- | The agent-driven commands whose provider/model can be configured -- independently. Each maps to a config-key segment (see 'agentCommandSegment'). data AgentCommandName@@ -141,6 +238,15 @@ agentEffortConfigKey :: Text agentEffortConfigKey = "agent.effort" +-- | The cross-command default trace-destination key, @agent.trace@.+agentTraceConfigKey :: Text+agentTraceConfigKey = "agent.trace"++-- | The trace file path key, @agent.tracePath@. Free-form (any path) and+-- deliberately not per-command: one project writes one trace file.+agentTracePathConfigKey :: Text+agentTracePathConfigKey = "agent.tracePath"+ -- | The per-command provider key, e.g. @agent.assist.provider@. agentCommandProviderConfigKey :: AgentCommandName -> Text agentCommandProviderConfigKey c = "agent." <> agentCommandSegment c <> ".provider"@@ -153,6 +259,10 @@ agentCommandEffortConfigKey :: AgentCommandName -> Text agentCommandEffortConfigKey c = "agent." <> agentCommandSegment c <> ".effort" +-- | The per-command trace-destination key, e.g. @agent.run.trace@.+agentCommandTraceConfigKey :: AgentCommandName -> Text+agentCommandTraceConfigKey c = "agent." <> agentCommandSegment c <> ".trace"+ agentProviderEnvVar :: String agentProviderEnvVar = "SEIHOU_AGENT_PROVIDER" @@ -162,9 +272,12 @@ agentEffortEnvVar :: String agentEffortEnvVar = "SEIHOU_AGENT_EFFORT" +agentTraceEnvVar :: String+agentTraceEnvVar = "SEIHOU_AGENT_TRACE"+ -- | Which of the resolvable fields a value belongs to. Used only to build -- provenance labels.-data AgentField = ProviderField | ModelField | EffortField+data AgentField = ProviderField | ModelField | EffortField | TraceField   deriving stock (Eq, Show)  -- | Where a resolved value came from, highest precedence first.@@ -175,6 +288,8 @@     SourceCliParent   | -- | @SEIHOU_AGENT_PROVIDER@/@SEIHOU_AGENT_MODEL@.     SourceEnv+  | -- | The blueprint's or prompt's own @launch.<field>@ declaration.+    SourceArtifactDeclaration   | -- | Local @agent.<command>.<field>@.     SourceLocalCommand   | -- | Local @agent.<field>@.@@ -189,10 +304,10 @@  -- | A resolved value paired with the source that supplied it. data ResolvedAgentField a = ResolvedAgentField-  { resolvedValue :: a,-    resolvedSource :: AgentConfigSource+  { value :: !a,+    source :: !AgentConfigSource   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | A short human label describing where a value came from, suitable for -- bracketed display. For config-file sources it names the concrete key that@@ -203,36 +318,57 @@     SourceCliSubcommand -> "flag on subcommand"     SourceCliParent -> "flag on `seihou agent`"     SourceEnv -> "env: " <> T.pack (envVarName field)+    SourceArtifactDeclaration -> artifactKind c <> ": launch." <> fieldName field     SourceLocalCommand -> "local: " <> commandKey field c     SourceLocalDefault -> "local: " <> defaultKey field     SourceGlobalCommand -> "global: " <> commandKey field c     SourceGlobalDefault -> "global: " <> defaultKey field     SourceBuiltinDefault -> "built-in default" +-- | Which kind of artifact declares launch settings for a command, so the+-- provenance label names the thing the user actually ran.+artifactKind :: AgentCommandName -> Text+artifactKind AgentCmdPromptRun = "prompt"+artifactKind _ = "blueprint"++fieldName :: AgentField -> Text+fieldName ProviderField = "provider"+fieldName ModelField = "model"+fieldName EffortField = "effort"+fieldName TraceField = "trace"+ envVarName :: AgentField -> String envVarName ProviderField = agentProviderEnvVar envVarName ModelField = agentModelEnvVar envVarName EffortField = agentEffortEnvVar+envVarName TraceField = agentTraceEnvVar  defaultKey :: AgentField -> Text defaultKey ProviderField = agentProviderConfigKey defaultKey ModelField = agentModelConfigKey defaultKey EffortField = agentEffortConfigKey+defaultKey TraceField = agentTraceConfigKey  commandKey :: AgentField -> AgentCommandName -> Text commandKey ProviderField = agentCommandProviderConfigKey commandKey ModelField = agentCommandModelConfigKey commandKey EffortField = agentCommandEffortConfigKey+commandKey TraceField = agentCommandTraceConfigKey  -- | The full result of resolving one command's provider and model, with -- provenance, used by the @seihou agent config@ inspection command. data ResolvedCommandConfig = ResolvedCommandConfig-  { rccCommand :: AgentCommandName,-    rccProvider :: ResolvedAgentField AgentProvider,-    rccModel :: ResolvedAgentField (Maybe Text),-    rccEffort :: ResolvedAgentField (Maybe ThinkingLevel)+  { command :: !AgentCommandName,+    provider :: !(ResolvedAgentField AgentProvider),+    model :: !(ResolvedAgentField (Maybe Text)),+    effort :: !(ResolvedAgentField (Maybe ThinkingLevel)),+    trace :: !(ResolvedAgentField TraceSetting),+    -- | The configured @agent.tracePath@, if any. Carried without provenance:+    -- it is free-form, has no CLI flag and no per-command variant, so there is+    -- no precedence story worth displaying.+    tracePath :: !(Maybe FilePath)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Flat resolver, preserved for backward compatibility. It never consults the -- per-command config keys, so a caller with only @agent.provider@/@agent.model@@@ -241,24 +377,26 @@ resolveAgentModelConfig inputs = do   provider <-     resolveProvider-      [ candidate inputs.cliProvider SourceCliSubcommand,-        candidate inputs.envProvider SourceEnv,-        candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault,-        candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault+      [ candidate (inputs ^. #cliProvider) SourceCliSubcommand,+        candidate (inputs ^. #envProvider) SourceEnv,+        candidate (Map.lookup agentProviderConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+        candidate (Map.lookup agentProviderConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault       ]   let modelField =-        applyProviderDefaultModel provider.resolvedValue $+        applyProviderDefaultModel (provider ^. #value) $           resolveModel-            [ candidate inputs.cliModel SourceCliSubcommand,-              candidate inputs.envModel SourceEnv,-              candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault,-              candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault+            [ candidate (inputs ^. #cliModel) SourceCliSubcommand,+              candidate (inputs ^. #envModel) SourceEnv,+              candidate (Map.lookup agentModelConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+              candidate (Map.lookup agentModelConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault             ]   pure     AgentModelConfig-      { agentProvider = provider.resolvedValue,-        agentModel = modelField.resolvedValue,-        agentEffort = Nothing+      { provider = provider ^. #value,+        model = modelField ^. #value,+        effort = Nothing,+        trace = TraceOff,+        tracePath = Nothing       }  -- | Resolve the provider, model, and reasoning effort for a specific command,@@ -266,8 +404,14 @@ -- reporting the source of each value. -- -- Precedence, highest first: subcommand flag, parent @agent@ flag, environment--- variable, local @agent.<command>.<field>@, local @agent.<field>@, global+-- variable, the artifact's own @launch.<field>@ declaration, local+-- @agent.<command>.<field>@, local @agent.<field>@, global -- @agent.<command>.<field>@, global @agent.<field>@, built-in default.+--+-- The declaration tier is only populated for commands that load an artifact+-- first; see 'resolvePendingAgentConfig'. For every other caller the+-- @declared*@ inputs are 'Nothing' and this behaves exactly as it did before+-- the tier existed. resolveAgentModelConfigFor ::   AgentCommandName ->   AgentConfigInputs ->@@ -275,58 +419,86 @@     Text     ( ResolvedAgentField AgentProvider,       ResolvedAgentField (Maybe Text),-      ResolvedAgentField (Maybe ThinkingLevel)+      ResolvedAgentField (Maybe ThinkingLevel),+      ResolvedAgentField TraceSetting     ) resolveAgentModelConfigFor c inputs = do   provider <--    (\p -> ResolvedAgentField p.resolvedValue p.resolvedSource)+    (\p -> ResolvedAgentField (p ^. #value) (p ^. #source))       <$> resolveProvider (providerCandidates c inputs)-  let model = applyProviderDefaultModel provider.resolvedValue (resolveModel (modelCandidates c inputs))+  let model = applyProviderDefaultModel (provider ^. #value) (resolveModel (modelCandidates c inputs))   effort <- resolveEffort (effortCandidates c inputs)-  pure (provider, model, effort)+  trace <- resolveTrace (traceCandidates c inputs)+  pure (provider, model, effort, trace) +-- | Resolve the trace file path: local @agent.tracePath@ beats global, and a+-- blank value counts as absent. There is no CLI flag and no per-command+-- variant — 'agentTracePathConfigKey' is free-form, so it stays outside the+-- validated four-value 'TraceSetting' vocabulary.+resolveTracePath :: AgentConfigInputs -> Maybe FilePath+resolveTracePath inputs =+  T.unpack . fst+    <$> firstNonBlankWithSource+      [ candidate (Map.lookup agentTracePathConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+        candidate (Map.lookup agentTracePathConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault+      ]+ -- | When no model was configured (source is the built-in default), substitute -- the provider's deterministic default so the two local CLI providers always -- resolve to a concrete model instead of 'Nothing'. The source stays -- 'SourceBuiltinDefault' — the value is a built-in, just a non-empty one. applyProviderDefaultModel :: AgentProvider -> ResolvedAgentField (Maybe Text) -> ResolvedAgentField (Maybe Text) applyProviderDefaultModel prov field =-  case field.resolvedValue of+  case field ^. #value of     Just _ -> field     Nothing -> case defaultModelForProvider prov of-      Just m -> field {resolvedValue = Just m}+      Just m -> (field & #value ?~ m)       Nothing -> field  providerCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] providerCandidates c inputs =-  [ candidate inputs.cliProvider (cliSource inputs.cliProviderFromSubcommand),-    candidate inputs.envProvider SourceEnv,-    candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.localConfig) SourceLocalCommand,-    candidate (Map.lookup agentProviderConfigKey inputs.localConfig) SourceLocalDefault,-    candidate (Map.lookup (agentCommandProviderConfigKey c) inputs.globalConfig) SourceGlobalCommand,-    candidate (Map.lookup agentProviderConfigKey inputs.globalConfig) SourceGlobalDefault+  [ candidate (inputs ^. #cliProvider) (cliSource (inputs ^. #cliProviderFromSubcommand)),+    candidate (inputs ^. #envProvider) SourceEnv,+    candidate (inputs ^. #declaredProvider) SourceArtifactDeclaration,+    candidate (Map.lookup (agentCommandProviderConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand,+    candidate (Map.lookup agentProviderConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+    candidate (Map.lookup (agentCommandProviderConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand,+    candidate (Map.lookup agentProviderConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault   ]  modelCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] modelCandidates c inputs =-  [ candidate inputs.cliModel (cliSource inputs.cliModelFromSubcommand),-    candidate inputs.envModel SourceEnv,-    candidate (Map.lookup (agentCommandModelConfigKey c) inputs.localConfig) SourceLocalCommand,-    candidate (Map.lookup agentModelConfigKey inputs.localConfig) SourceLocalDefault,-    candidate (Map.lookup (agentCommandModelConfigKey c) inputs.globalConfig) SourceGlobalCommand,-    candidate (Map.lookup agentModelConfigKey inputs.globalConfig) SourceGlobalDefault+  [ candidate (inputs ^. #cliModel) (cliSource (inputs ^. #cliModelFromSubcommand)),+    candidate (inputs ^. #envModel) SourceEnv,+    candidate (inputs ^. #declaredModel) SourceArtifactDeclaration,+    candidate (Map.lookup (agentCommandModelConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand,+    candidate (Map.lookup agentModelConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+    candidate (Map.lookup (agentCommandModelConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand,+    candidate (Map.lookup agentModelConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault   ]  effortCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)] effortCandidates c inputs =-  [ candidate inputs.cliEffort (cliSource inputs.cliEffortFromSubcommand),-    candidate inputs.envEffort SourceEnv,-    candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.localConfig) SourceLocalCommand,-    candidate (Map.lookup agentEffortConfigKey inputs.localConfig) SourceLocalDefault,-    candidate (Map.lookup (agentCommandEffortConfigKey c) inputs.globalConfig) SourceGlobalCommand,-    candidate (Map.lookup agentEffortConfigKey inputs.globalConfig) SourceGlobalDefault+  [ candidate (inputs ^. #cliEffort) (cliSource (inputs ^. #cliEffortFromSubcommand)),+    candidate (inputs ^. #envEffort) SourceEnv,+    candidate (inputs ^. #declaredEffort) SourceArtifactDeclaration,+    candidate (Map.lookup (agentCommandEffortConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand,+    candidate (Map.lookup agentEffortConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+    candidate (Map.lookup (agentCommandEffortConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand,+    candidate (Map.lookup agentEffortConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault   ] +traceCandidates :: AgentCommandName -> AgentConfigInputs -> [(Maybe Text, AgentConfigSource)]+traceCandidates c inputs =+  [ candidate (inputs ^. #cliTrace) (cliSource (inputs ^. #cliTraceFromSubcommand)),+    candidate (inputs ^. #envTrace) SourceEnv,+    candidate (inputs ^. #declaredTrace) SourceArtifactDeclaration,+    candidate (Map.lookup (agentCommandTraceConfigKey c) (inputs ^. #localConfig)) SourceLocalCommand,+    candidate (Map.lookup agentTraceConfigKey (inputs ^. #localConfig)) SourceLocalDefault,+    candidate (Map.lookup (agentCommandTraceConfigKey c) (inputs ^. #globalConfig)) SourceGlobalCommand,+    candidate (Map.lookup agentTraceConfigKey (inputs ^. #globalConfig)) SourceGlobalDefault+  ]+ cliSource :: Bool -> AgentConfigSource cliSource True = SourceCliSubcommand cliSource False = SourceCliParent@@ -337,7 +509,7 @@ resolveProvider candidates =   case firstNonBlankWithSource candidates of     Just (txt, src) -> (\p -> ResolvedAgentField p src) <$> providerFromText txt-    Nothing -> Right (ResolvedAgentField defaultAgentModelConfig.agentProvider SourceBuiltinDefault)+    Nothing -> Right (ResolvedAgentField (defaultAgentModelConfig ^. #provider) SourceBuiltinDefault)  -- | Resolve a model from an ordered candidate list. An unset model resolves to -- 'Nothing' with source 'SourceBuiltinDefault', letting the provider pick.@@ -357,6 +529,16 @@     Just (txt, src) -> (\lvl -> ResolvedAgentField (Just lvl) src) <$> effortFromText txt     Nothing -> Right (ResolvedAgentField Nothing SourceBuiltinDefault) +-- | Resolve a trace destination from an ordered candidate list. Unlike the+-- model and effort resolvers there is no \"unset\" state: an unconfigured trace+-- resolves to 'TraceOff' with source 'SourceBuiltinDefault', which emits+-- nothing.+resolveTrace :: [(Maybe Text, AgentConfigSource)] -> Either Text (ResolvedAgentField TraceSetting)+resolveTrace candidates =+  case firstNonBlankWithSource candidates of+    Just (txt, src) -> (\t -> ResolvedAgentField t src) <$> traceFromText txt+    Nothing -> Right (ResolvedAgentField TraceOff SourceBuiltinDefault)+ candidate :: Maybe Text -> AgentConfigSource -> (Maybe Text, AgentConfigSource) candidate value src = (value, src) @@ -376,7 +558,15 @@ -- the flat resolver. Preserved for backward compatibility. loadAgentModelConfig :: Maybe Text -> Maybe Text -> IO (Either Text AgentModelConfig) loadAgentModelConfig cliProvider cliModel = do-  inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel Nothing False False False+  inputsOrErr <-+    gatherAgentConfigInputs+      noAgentSettingFlags+      ( noAgentSettingFlags+          & #provider+          .~ cliProvider+          & #model+          .~ cliModel+      )   pure (inputsOrErr >>= resolveAgentModelConfig)  -- | Read the environment and config, then resolve provider/model/effort for a@@ -384,64 +574,59 @@ -- need. loadAgentModelConfigFor ::   AgentCommandName ->-  -- | winning provider flag (subcommand @<|>@ parent)-  Maybe Text ->-  -- | winning model flag-  Maybe Text ->-  -- | winning effort flag-  Maybe Text ->-  -- | provider flag came from the subcommand?-  Bool ->-  -- | model flag came from the subcommand?-  Bool ->-  -- | effort flag came from the subcommand?-  Bool ->+  -- | flags on the parent @seihou agent@ command+  AgentSettingFlags ->+  -- | flags on the subcommand itself+  AgentSettingFlags ->   IO (Either Text AgentModelConfig)-loadAgentModelConfigFor c cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do-  inputsOrErr <- gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub+loadAgentModelConfigFor c parentFlags commandFlags = do+  inputsOrErr <- gatherAgentConfigInputs parentFlags commandFlags   pure $ do     inputs <- inputsOrErr-    (provider, model, effort) <- resolveAgentModelConfigFor c inputs+    (provider, model, effort, trace) <- resolveAgentModelConfigFor c inputs     pure       AgentModelConfig-        { agentProvider = provider.resolvedValue,-          agentModel = model.resolvedValue,-          agentEffort = effort.resolvedValue+        { provider = provider ^. #value,+          model = model ^. #value,+          effort = effort ^. #value,+          trace = trace ^. #value,+          tracePath = resolveTracePath inputs         }  -- | Resolve every configurable command from the real environment and config, -- with no CLI flags, for the @seihou agent config@ inspection view. loadResolvedAgentConfig :: IO (Either Text [ResolvedCommandConfig]) loadResolvedAgentConfig = do-  inputsOrErr <- gatherAgentConfigInputs Nothing Nothing Nothing False False False+  inputsOrErr <- gatherAgentConfigInputs noAgentSettingFlags noAgentSettingFlags   pure $ do     inputs <- inputsOrErr     traverse (resolveOne inputs) allAgentCommands   where     resolveOne inputs c = do-      (provider, model, effort) <- resolveAgentModelConfigFor c inputs+      (provider, model, effort, trace) <- resolveAgentModelConfigFor c inputs       pure         ResolvedCommandConfig-          { rccCommand = c,-            rccProvider = provider,-            rccModel = model,-            rccEffort = effort+          { command = c,+            provider = provider,+            model = model,+            effort = effort,+            trace = trace,+            tracePath = resolveTracePath inputs           }  -- | Shared IO: read @SEIHOU_AGENT_*@ and the local + global config maps into an -- 'AgentConfigInputs'. Any config read error surfaces as 'Left'. gatherAgentConfigInputs ::-  Maybe Text ->-  Maybe Text ->-  Maybe Text ->-  Bool ->-  Bool ->-  Bool ->+  -- | flags on the parent @seihou agent@ command+  AgentSettingFlags ->+  -- | flags on the subcommand itself+  AgentSettingFlags ->   IO (Either Text AgentConfigInputs)-gatherAgentConfigInputs cliProvider cliModel cliEffort providerFromSub modelFromSub effortFromSub = do+gatherAgentConfigInputs parentFlags commandFlags = do   envProvider <- fmap T.pack <$> lookupEnv agentProviderEnvVar   envModel <- fmap T.pack <$> lookupEnv agentModelEnvVar   envEffort <- fmap T.pack <$> lookupEnv agentEffortEnvVar+  envTrace <- fmap T.pack <$> lookupEnv agentTraceEnvVar   (localResult, globalResult) <- runEff $ runConfigReader $ do     local <- readLocalConfig     global <- readGlobalConfig@@ -449,17 +634,176 @@   pure $ do     local <- first formatConfigError localResult     global <- first formatConfigError globalResult-    pure-      AgentConfigInputs-        { cliProvider = cliProvider,-          cliModel = cliModel,-          cliEffort = cliEffort,-          cliProviderFromSubcommand = providerFromSub,-          cliModelFromSubcommand = modelFromSub,-          cliEffortFromSubcommand = effortFromSub,-          envProvider = envProvider,-          envModel = envModel,-          envEffort = envEffort,-          localConfig = local,-          globalConfig = global-        }+    pure $+      applyAgentSettingFlags+        parentFlags+        commandFlags+        ( baseAgentConfigInputs+            & #envProvider+            .~ envProvider+            & #envModel+            .~ envModel+            & #envEffort+            .~ envEffort+            & #envTrace+            .~ envTrace+            & #localConfig+            .~ local+            & #globalConfig+            .~ global+        )++-- | The three launch fields the resolver understands, projected out of an+-- artifact's @launch@ record. @mode@ is deliberately absent: it is reserved+-- and no part of the resolution path.+data AgentLaunchDeclaration = AgentLaunchDeclaration+  { provider :: !(Maybe Text),+    model :: !(Maybe Text),+    effort :: !(Maybe Text)+  }+  deriving stock (Eq, Generic, Show)++-- | A declaration that states nothing, leaving every field to the user's+-- flags, environment, and config.+noAgentLaunchDeclaration :: AgentLaunchDeclaration+noAgentLaunchDeclaration =+  AgentLaunchDeclaration+    { provider = Nothing,+      model = Nothing,+      effort = Nothing+    }++-- | Project a decoded artifact's launch record into the resolver's declaration+-- tier. An artifact with no @launch@ record declares nothing.+agentLaunchDeclaration :: Maybe AgentLaunch -> AgentLaunchDeclaration+agentLaunchDeclaration Nothing = noAgentLaunchDeclaration+agentLaunchDeclaration (Just l) =+  AgentLaunchDeclaration+    { provider = l ^. #provider,+      model = l ^. #model,+      effort = l ^. #effort+    }++-- | Parse-check a declared launch record, returning one message per invalid+-- value. An empty list means the declaration is usable.+--+-- The model is not checked: it is free-form by design, since providers accept+-- aliases and custom model IDs.+validateAgentLaunchDeclaration :: AgentLaunchDeclaration -> [Text]+validateAgentLaunchDeclaration decl =+  check "launch.provider" providerFromText (decl ^. #provider)+    <> check "launch.effort" effortFromText (decl ^. #effort)+  where+    check :: Text -> (Text -> Either Text a) -> Maybe Text -> [Text]+    check key parse value =+      [ key <> ": " <> err+      | Just raw <- [value],+        not (T.null (T.strip raw)),+        Left err <- [parse (T.strip raw)]+      ]++-- | Everything needed to finish resolution later: the command identity plus+-- the flags, environment, and config already gathered. A handler holds one of+-- these while it discovers and decodes its artifact, then finishes with+-- 'resolvePendingAgentConfig'.+--+-- This two-phase shape exists because the artifact's declaration is only known+-- after the handler loads it, but resolution must still be a single pass over+-- one ordered precedence list.+data PendingAgentConfig = PendingAgentConfig+  { command :: !AgentCommandName,+    inputs :: !AgentConfigInputs+  }+  deriving stock (Eq, Generic, Show)++-- | Read the environment and config for a command whose artifact may declare+-- its own launch settings, stopping short of resolution.+loadPendingAgentConfig ::+  AgentCommandName ->+  -- | flags on the parent @seihou agent@ command+  AgentSettingFlags ->+  -- | flags on the subcommand itself+  AgentSettingFlags ->+  IO (Either Text PendingAgentConfig)+loadPendingAgentConfig c parentFlags commandFlags = do+  inputsOrErr <- gatherAgentConfigInputs parentFlags commandFlags+  pure (PendingAgentConfig c <$> inputsOrErr)++-- | Finish resolution by folding the artifact's declaration into the gathered+-- inputs and running the ordinary precedence chain.+resolvePendingAgentConfig ::+  PendingAgentConfig ->+  AgentLaunchDeclaration ->+  Either Text ResolvedCommandConfig+resolvePendingAgentConfig pending decl = do+  let inputs =+        ( (pending ^. #inputs)+            & #declaredProvider+            .~ decl+            ^. #provider+            & #declaredModel+            .~ decl+            ^. #model+            & #declaredEffort+            .~ decl+            ^. #effort+        )+  (provider, model, effort, trace) <- resolveAgentModelConfigFor (pending ^. #command) inputs+  pure+    ResolvedCommandConfig+      { command = pending ^. #command,+        provider = provider,+        model = model,+        effort = effort,+        trace = trace,+        tracePath = resolveTracePath inputs+      }++-- | Project a resolved command config down to what the launch layer needs,+-- discarding provenance.+resolvedAgentModelConfig :: ResolvedCommandConfig -> AgentModelConfig+resolvedAgentModelConfig rcc =+  AgentModelConfig+    { provider = rcc ^. #provider . #value,+      model = rcc ^. #model . #value,+      effort = rcc ^. #effort . #value,+      trace = rcc ^. #trace . #value,+      tracePath = rcc ^. #tracePath+    }++-- | A one-line provenance summary for a verbose log line, e.g.+--+-- > provider claude-cli [built-in default], model claude-sonnet-5 [blueprint: launch.model], effort max [blueprint: launch.effort]+formatResolvedAgentProvenance :: ResolvedCommandConfig -> Text+formatResolvedAgentProvenance rcc =+  T.intercalate+    ", "+    [ part "provider" (providerToText (rcc ^. #provider . #value)) ProviderField (rcc ^. #provider . #source),+      part "model" (fromMaybe "<provider default>" (rcc ^. #model . #value)) ModelField (rcc ^. #model . #source),+      part "effort" (maybe "<unset>" effortToText (rcc ^. #effort . #value)) EffortField (rcc ^. #effort . #source),+      part "trace" (traceToText (rcc ^. #trace . #value)) TraceField (rcc ^. #trace . #source)+    ]+  where+    part label value field src =+      label <> " " <> value <> " [" <> agentConfigSourceLabel (rcc ^. #command) field src <> "]"++-- | Finish resolution with the artifact's declaration, logging the resolved+-- provenance at verbose level and exiting with an actionable message when the+-- artifact declares an unusable value.+--+-- The label names the artifact in the error message, e.g.+-- @"blueprint 'payments-service'"@.+resolveDeclaredAgentConfig ::+  LogLevel ->+  Text ->+  PendingAgentConfig ->+  AgentLaunchDeclaration ->+  IO AgentModelConfig+resolveDeclaredAgentConfig level label pending decl =+  case resolvePendingAgentConfig pending decl of+    Left err -> do+      logIO level (logError $ "Invalid agent settings for " <> label <> ": " <> err)+      exitFailure+    Right resolved -> do+      logIO level (logInfo $ "Agent: " <> formatResolvedAgentProvenance resolved)+      pure (resolvedAgentModelConfig resolved)
src/Seihou/CLI/AgentConfigShow.hs view
@@ -4,9 +4,10 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO-import Seihou.CLI.AgentCompletion (effortToText, providerToText)+import Seihou.CLI.AgentCompletion (effortToText, providerToText, traceToText) import Seihou.CLI.AgentConfig   ( AgentField (..),     ResolvedAgentField (..),@@ -19,9 +20,9 @@ import System.Exit (exitFailure)  -- | @seihou agent config@: read the real environment and config, resolve the--- provider, model, and reasoning effort for every agent command, and print a--- table labelling the source that supplied each value, followed by the--- precedence legend.+-- provider, model, reasoning effort, and trace destination for every agent+-- command, and print a table labelling the source that supplied each value,+-- followed by the precedence legend. handleAgentConfigShow :: IO () handleAgentConfigShow = do   result <- loadResolvedAgentConfig@@ -36,44 +37,51 @@ formatResolvedAgentConfig :: [ResolvedCommandConfig] -> Text formatResolvedAgentConfig resolved =   T.unlines $-    [ "Resolved agent provider, model, and effort per command",+    [ "Resolved agent provider, model, effort, and trace per command",       "(highest-precedence source wins; see precedence list below)",       ""     ]       <> concatMap renderCommand resolved       <> ["", precedenceLegend]   where-    labelWidth = maximum (0 : map (\rcc -> T.length (agentCommandLabel rcc.rccCommand)) resolved)+    labelWidth = maximum (0 : map (\rcc -> T.length (agentCommandLabel (rcc ^. #command))) resolved)     valueWidth = maximum (0 : concatMap commandValueWidths resolved)      commandValueWidths rcc =       [ T.length (providerValue rcc),         T.length (modelValue rcc),-        T.length (effortValue rcc)+        T.length (effortValue rcc),+        T.length (traceValue rcc)       ] -    providerValue rcc = providerToText rcc.rccProvider.resolvedValue-    modelValue rcc = maybe "(default)" id rcc.rccModel.resolvedValue-    effortValue rcc = maybe "(default)" effortToText rcc.rccEffort.resolvedValue+    providerValue rcc = providerToText (rcc ^. #provider . #value)+    modelValue rcc = maybe "(default)" id (rcc ^. #model . #value)+    effortValue rcc = maybe "(default)" effortToText (rcc ^. #effort . #value)+    traceValue rcc = traceToText (rcc ^. #trace . #value)      renderCommand rcc =-      let cmd = rcc.rccCommand+      let cmd = (rcc ^. #command)           label = agentCommandLabel cmd        in [ row               (padRight labelWidth label)               "provider"               (providerValue rcc)-              (agentConfigSourceLabel cmd ProviderField rcc.rccProvider.resolvedSource),+              (agentConfigSourceLabel cmd ProviderField (rcc ^. #provider . #source)),             row               (padRight labelWidth "")               "model   "               (modelValue rcc)-              (agentConfigSourceLabel cmd ModelField rcc.rccModel.resolvedSource),+              (agentConfigSourceLabel cmd ModelField (rcc ^. #model . #source)),             row               (padRight labelWidth "")               "effort  "               (effortValue rcc)-              (agentConfigSourceLabel cmd EffortField rcc.rccEffort.resolvedSource)+              (agentConfigSourceLabel cmd EffortField (rcc ^. #effort . #source)),+            row+              (padRight labelWidth "")+              "trace   "+              (traceValue rcc)+              (agentConfigSourceLabel cmd TraceField (rcc ^. #trace . #source))           ]      row label field value sourceLabel =@@ -95,14 +103,25 @@   T.intercalate     "\n"     [ "Precedence, highest first:",-      "  1. --provider / --model / --effort flag on the subcommand",-      "  2. --provider / --model / --effort flag on `seihou agent`",-      "  3. SEIHOU_AGENT_PROVIDER / SEIHOU_AGENT_MODEL / SEIHOU_AGENT_EFFORT environment variables",-      "  4. local  .seihou/config.dhall          agent.<command>.{provider,model,effort}",-      "  5. local  .seihou/config.dhall          agent.{provider,model,effort}",-      "  6. global ~/.config/seihou/config.dhall  agent.<command>.{provider,model,effort}",-      "  7. global ~/.config/seihou/config.dhall  agent.{provider,model,effort}",-      "  8. built-in default: provider claude-cli; model pinned per provider",+      "  1. --provider / --model / --effort / --trace flag on the subcommand",+      "  2. --provider / --model / --effort / --trace flag on `seihou agent`",+      "  3. SEIHOU_AGENT_PROVIDER / SEIHOU_AGENT_MODEL / SEIHOU_AGENT_EFFORT /",+      "     SEIHOU_AGENT_TRACE environment variables",+      "  4. blueprint.dhall / prompt.dhall       launch.{provider,model,effort}",+      "  5. local  .seihou/config.dhall          agent.<command>.{provider,model,effort,trace}",+      "  6. local  .seihou/config.dhall          agent.{provider,model,effort,trace}",+      "  7. global ~/.config/seihou/config.dhall  agent.<command>.{provider,model,effort,trace}",+      "  8. global ~/.config/seihou/config.dhall  agent.{provider,model,effort,trace}",+      "  9. built-in default: provider claude-cli; model pinned per provider",       "     (claude-cli -> claude-opus-4-8, codex-cli -> gpt-5.6-terra); effort unset",-      "     (the CLI/provider chooses its own reasoning effort)"+      "     (the CLI/provider chooses its own reasoning effort); trace off",+      "",+      "Tier 4 is per-artifact: it depends on which blueprint or prompt you run, so",+      "the table above cannot show it. Run with --verbose to see the resolved",+      "settings and their sources for a specific run. `trace` has no tier-4",+      "declaration: no blueprint or prompt schema field feeds it.",+      "",+      "The trace file path is set with agent.tracePath (local, then global). It is",+      "free-form and has no flag, environment variable, or per-command variant;",+      "unset means .seihou/trace.jsonl."     ]
src/Seihou/CLI/AgentLaunch.hs view
@@ -19,6 +19,7 @@   ) where +import Data.Generics.Labels () import Data.List (nub) import Data.Maybe (fromMaybe) import Data.Text qualified as T@@ -29,14 +30,15 @@  -- | Dynamic context gathered from the current directory, shared across agent commands. data AgentContext = AgentContext-  { cwd :: Text,-    seihouInitialized :: Bool,-    hasManifest :: Bool,-    localModuleDhall :: Bool,-    localModules :: [Text],+  { cwd :: !Text,+    seihouInitialized :: !Bool,+    hasManifest :: !Bool,+    localModuleDhall :: !Bool,+    localModules :: ![Text],     -- | (name, description, source)-    availableModules :: [(Text, Text, Text)]+    availableModules :: ![(Text, Text, Text)]   }+  deriving stock (Generic)  gatherAgentContext :: IO AgentContext gatherAgentContext = do@@ -140,31 +142,31 @@  formatSeihouProjectState :: AgentContext -> Text formatSeihouProjectState ctx-  | ctx.seihouInitialized = "Seihou project: .seihou/ directory exists (this is a seihou-managed project)"+  | (ctx ^. #seihouInitialized) = "Seihou project: .seihou/ directory exists (this is a seihou-managed project)"   | otherwise = "Seihou project: No .seihou/ directory (not yet a seihou project in this directory)"  formatManifestState :: AgentContext -> Text formatManifestState ctx-  | ctx.hasManifest = "Manifest: .seihou/manifest.json exists (modules have been applied here)"+  | (ctx ^. #hasManifest) = "Manifest: .seihou/manifest.json exists (modules have been applied here)"   | otherwise = "Manifest: No manifest (no modules applied yet)"  formatModuleDhallState :: AgentContext -> Text formatModuleDhallState ctx-  | ctx.localModuleDhall = "Module in cwd: module.dhall found in current directory (user is authoring a module here)"+  | (ctx ^. #localModuleDhall) = "Module in cwd: module.dhall found in current directory (user is authoring a module here)"   | otherwise = ""  formatLocalModules :: AgentContext -> Text formatLocalModules ctx-  | null ctx.localModules = ""-  | otherwise = T.intercalate "\n" $ "Local modules:" : map ("  - " <>) ctx.localModules+  | null (ctx ^. #localModules) = ""+  | otherwise = T.intercalate "\n" $ "Local modules:" : map ("  - " <>) (ctx ^. #localModules)  formatAvailableModules :: AgentContext -> Text formatAvailableModules ctx-  | null ctx.availableModules = "Available modules: None discovered"+  | null (ctx ^. #availableModules) = "Available modules: None discovered"   | otherwise =       T.intercalate "\n" $         "Available modules across search paths:"-          : map formatMod ctx.availableModules+          : map formatMod (ctx ^. #availableModules)   where     formatMod (name, desc, src) = "  - " <> name <> " — " <> desc <> " (" <> src <> ")" @@ -179,11 +181,11 @@     else pure []  toModuleInfo :: DiscoveredModule -> [(Text, Text, Text)]-toModuleInfo dm = case dm.discoveredResult of+toModuleInfo dm = case dm ^. #result of   Right m ->-    [ ( m.name.unModuleName,-        maybe "(no description)" id m.description,-        sourceLabel dm.discoveredSource+    [ ( m ^. #name . #unModuleName,+        maybe "(no description)" id (m ^. #description),+        sourceLabel (dm ^. #source)       )     ]   Left _ -> []@@ -211,9 +213,9 @@ formatBlueprintIdentity bp =   T.intercalate     "\n"-    [ "Name: " <> bp.name.unModuleName,-      "Version: " <> fromMaybe "(unspecified)" bp.version,-      "Description: " <> fromMaybe "(no description)" bp.description+    [ "Name: " <> bp ^. #name . #unModuleName,+      "Version: " <> fromMaybe "(unspecified)" (bp ^. #version),+      "Description: " <> fromMaybe "(no description)" (bp ^. #description)     ]  -- | Render the "## Baseline" body for the agent prompt.@@ -225,8 +227,8 @@ formatBaselineStatus (BaselineApplied entries) =   T.intercalate "\n" (map render entries)   where-    render (n, Just v) = "  - " <> n.unModuleName <> " (v" <> v <> ")"-    render (n, Nothing) = "  - " <> n.unModuleName <> " (unversioned)"+    render (n, Just v) = "  - " <> n ^. #unModuleName <> " (v" <> v <> ")"+    render (n, Nothing) = "  - " <> n ^. #unModuleName <> " (unversioned)"  -- | Render a blueprint's @files@ list as the body of the -- "## Reference Files" block. When the directory exists, the interactive@@ -236,9 +238,9 @@ formatReferenceFiles [] = "(no reference files)" formatReferenceFiles bfs = T.intercalate "\n" (map render bfs)   where-    render bf = case bf.description of-      Just d -> "  - " <> T.pack bf.src <> " — " <> d-      Nothing -> "  - " <> T.pack bf.src+    render bf = case bf ^. #description of+      Just d -> "  - " <> T.pack (bf ^. #src) <> " — " <> d+      Nothing -> "  - " <> T.pack (bf ^. #src)  -- | Render guidance for the blueprint's reference-files directory. A -- present path means the directory is mounted and readable by the interactive
+ src/Seihou/CLI/AgentTrace.hs view
@@ -0,0 +1,87 @@+-- | Turning a resolved 'TraceSetting' into a live Baikai 'TraceSink'.+--+-- This is the only module in Seihou that touches the filesystem on behalf of+-- tracing (it creates the trace file's parent directory) and the only one that+-- imports "Baikai.Trace.Sink". Keeping it separate from+-- "Seihou.CLI.AgentCompletion" keeps sink construction — which is effectful —+-- out of the pure resolution path.+module Seihou.CLI.AgentTrace+  ( traceSinkForConfig,+    traceSinkFor,+    resolveTraceFilePath,+    defaultTraceFileName,+    stderrSink,+  )+where++import Baikai.Trace.Sink (TraceSink (..), fileSink, renderHuman, silent, stdoutSink)+import Data.Generics.Labels ()+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.CLI.AgentCompletion (AgentModelConfig (..), TraceSetting (..), traceToText)+import Seihou.CLI.Shared (logIO)+import Seihou.Core.Types (LogLevel)+import Seihou.Effect.Logger (logInfo)+import Seihou.Prelude+import Streamly.Data.Fold qualified as Fold+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory)+import System.IO (stderr)++-- | Where the file sink writes when @agent.tracePath@ is unset:+-- @.seihou/trace.jsonl@, beside the manifest and project config that Seihou+-- already keeps there.+defaultTraceFileName :: FilePath+defaultTraceFileName = ".seihou" </> "trace.jsonl"++-- | The configured @agent.tracePath@ when set and non-blank, otherwise+-- 'defaultTraceFileName'. A whitespace-only path counts as absent, matching+-- the resolver's treatment of every other setting.+resolveTraceFilePath :: Maybe FilePath -> FilePath+resolveTraceFilePath configured =+  case configured of+    Just raw | not (T.null (T.strip (T.pack raw))) -> raw+    _ -> defaultTraceFileName++-- | Print each event to stderr using Baikai's 'renderHuman'.+--+-- Baikai ships 'stdoutSink' but no stderr equivalent, and stderr is where+-- Seihou already sends out-of-band information (see+-- "Seihou.Effect.LoggerInterp"), so trace lines never corrupt assistant output+-- a user is piping.+stderrSink :: TraceSink+stderrSink = TraceSink (Fold.drainMapM (TIO.hPutStrLn stderr . renderHuman))++-- | Build the sink a resolved trace setting names.+--+-- 'TraceOff' yields Baikai's 'silent' sink, which discards every event — that+-- is the default, and it is what keeps tracing free when nobody asked for it.+-- 'TraceFile' creates the trace file's parent directory first, so the first+-- traced run in a project without a @.seihou/@ directory succeeds.+traceSinkFor :: TraceSetting -> Maybe FilePath -> IO TraceSink+traceSinkFor setting configuredPath =+  case setting of+    TraceOff -> pure silent+    TraceStdout -> pure stdoutSink+    TraceStderr -> pure stderrSink+    TraceFile -> do+      let path = resolveTraceFilePath configuredPath+      createDirectoryIfMissing True (takeDirectory path)+      fileSink path++-- | Build the sink a resolved agent configuration asks for, naming the+-- destination at verbose level.+--+-- Call this once per command rather than once per model call, so a command+-- that makes several calls — @seihou agent migrate@ walks one call per+-- migration edge — reports one destination and appends every call to it.+traceSinkForConfig :: LogLevel -> AgentModelConfig -> IO TraceSink+traceSinkForConfig level config = do+  case config ^. #trace of+    TraceOff -> pure ()+    TraceFile ->+      logIO level $+        logInfo ("Trace: writing call traces to " <> T.pack (resolveTraceFilePath (config ^. #tracePath)))+    other ->+      logIO level (logInfo ("Trace: writing call traces to " <> traceToText other))+  traceSinkFor (config ^. #trace) (config ^. #tracePath)
src/Seihou/CLI/AppliedBlueprint.hs view
@@ -11,6 +11,7 @@   ) where +import Data.Generics.Labels () import Seihou.Core.Types (AppliedBlueprint (..)) import Seihou.Effect.Filesystem (createDirectoryIfMissing) import Seihou.Effect.FilesystemInterp (runFilesystem)@@ -40,6 +41,6 @@         writeManifest (writeAppliedBlueprint ab m)         pure (Right ())       Right Nothing -> do-        writeManifest (writeAppliedBlueprint ab (emptyManifest ab.appliedAt))+        writeManifest (writeAppliedBlueprint ab (emptyManifest (ab ^. #appliedAt)))         pure (Right ())       Left err -> pure (Left err)
src/Seihou/CLI/AppliedBlueprintMigration.hs view
@@ -4,6 +4,7 @@   ) where +import Data.Generics.Labels () import Seihou.Core.Types (AppliedBlueprintMigration (..)) import Seihou.Effect.Filesystem (createDirectoryIfMissing) import Seihou.Effect.FilesystemInterp (runFilesystem)@@ -26,6 +27,6 @@         writeManifest (writeAppliedBlueprintMigration receipt manifest)         pure (Right ())       Right Nothing -> do-        writeManifest (writeAppliedBlueprintMigration receipt (emptyManifest receipt.appliedAt))+        writeManifest (writeAppliedBlueprintMigration receipt (emptyManifest (receipt ^. #appliedAt)))         pure (Right ())       Left err -> pure (Left err)
src/Seihou/CLI/BlueprintExecution.hs view
@@ -13,6 +13,7 @@   ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T@@ -46,30 +47,30 @@ -- Provider capability is represented as a boolean so this library module does -- not need to know about Baikai or the executable command model. data BlueprintExecutionRequest = BlueprintExecutionRequest-  { executionBlueprint :: Blueprint,-    executionBlueprintDir :: FilePath,-    executionVariableOverrides :: [(Text, Text)],-    executionNamespaceOverride :: Maybe Text,-    executionContextOverride :: Maybe Text,-    executionCanMountFiles :: Bool,-    executionLogLevel :: LogLevel+  { blueprint :: !Blueprint,+    blueprintDir :: !FilePath,+    variableOverrides :: ![(Text, Text)],+    namespaceOverride :: !(Maybe Text),+    contextOverride :: !(Maybe Text),+    canMountFiles :: !Bool,+    logLevel :: !LogLevel   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Prepared state that both execution modes consume. The mounted path is -- absolute when present; the access text preserves the existing API-provider -- explanation when local files cannot be mounted. data PreparedBlueprintExecution = PreparedBlueprintExecution-  { preparedBlueprint :: Blueprint,-    preparedBlueprintDir :: FilePath,-    preparedResolvedVariables :: Map VarName ResolvedVar,-    preparedMountedFilesDir :: Maybe FilePath,-    preparedReferenceFiles :: Text,-    preparedReferenceFilesAccess :: Text,-    preparedSharedPrompt :: Text,-    preparedAllowedTools :: [String]+  { blueprint :: !Blueprint,+    blueprintDir :: !FilePath,+    resolvedVariables :: !(Map VarName ResolvedVar),+    mountedFilesDir :: !(Maybe FilePath),+    referenceFiles :: !Text,+    referenceFilesAccess :: !Text,+    sharedPrompt :: !Text,+    allowedTools :: ![String]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Resolve one blueprint through the same CLI/environment/config/prompt -- precedence used by @seihou run@ and the existing agent runner.@@ -77,47 +78,47 @@   BlueprintExecutionRequest ->   IO (Either [VarError] PreparedBlueprintExecution) prepareBlueprintExecution request = do-  let bp = request.executionBlueprint-      blueprintDir = request.executionBlueprintDir+  let bp = (request ^. #blueprint)+      blueprintDir = (request ^. #blueprintDir)       filesDir = blueprintDir </> "files"   filesExist <- doesDirectoryExist filesDir   mountedFilesDir <--    if filesExist && request.executionCanMountFiles+    if filesExist && request ^. #canMountFiles       then Just <$> makeAbsolute filesDir       else pure Nothing    let placeholderModule =         Module-          { name = bp.name,-            version = bp.version,-            description = bp.description,-            vars = bp.vars,+          { name = bp ^. #name,+            version = bp ^. #version,+            description = bp ^. #description,+            vars = bp ^. #vars,             exports = [],-            prompts = bp.prompts,+            prompts = bp ^. #prompts,             steps = [],             commands = [],             dependencies = [],             removal = Nothing,             migrations = []           }-      placeholderInst = primaryInstance bp.name+      placeholderInst = primaryInstance (bp ^. #name)       placeholderTriple = (placeholderInst, placeholderModule, blueprintDir)    envPairs <- getEnvironment   let cliOverrides =         Map.fromList-          [(VarName key, value) | (key, value) <- request.executionVariableOverrides]+          [(VarName key, value) | (key, value) <- request ^. #variableOverrides]       envVars = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs]       namespace =-        fromMaybe (deriveNamespace bp.name) request.executionNamespaceOverride-  context <- resolveContext request.executionContextOverride envVars+        fromMaybe (deriveNamespace (bp ^. #name)) (request ^. #namespaceOverride)+  context <- resolveContext (request ^. #contextOverride) envVars   let contextName = fromMaybe "" context    resolveResult <- runEff $ runConfigReader $ runConsole $ do-    localCfg <- readLocalConfig >>= unwrapConfig request.executionLogLevel-    nsCfg <- readNamespaceConfig namespace >>= unwrapConfig request.executionLogLevel-    ctxCfg <- readContextConfig contextName >>= unwrapConfig request.executionLogLevel-    globalCfg <- readGlobalConfig >>= unwrapConfig request.executionLogLevel+    localCfg <- readLocalConfig >>= unwrapConfig (request ^. #logLevel)+    nsCfg <- readNamespaceConfig namespace >>= unwrapConfig (request ^. #logLevel)+    ctxCfg <- readContextConfig contextName >>= unwrapConfig (request ^. #logLevel)+    globalCfg <- readGlobalConfig >>= unwrapConfig (request ^. #logLevel)     resolveWithPrompts       [placeholderTriple]       cliOverrides@@ -134,14 +135,14 @@     let resolved = Map.findWithDefault Map.empty placeholderInst allResolved     Right       PreparedBlueprintExecution-        { preparedBlueprint = bp,-          preparedBlueprintDir = blueprintDir,-          preparedResolvedVariables = resolved,-          preparedMountedFilesDir = mountedFilesDir,-          preparedReferenceFiles = formatReferenceFiles bp.files,-          preparedReferenceFilesAccess = formatReferenceFilesDir mountedFilesDir,-          preparedSharedPrompt = renderBlueprintText resolved bp.prompt,-          preparedAllowedTools = resolveBlueprintTools bp.allowedTools+        { blueprint = bp,+          blueprintDir = blueprintDir,+          resolvedVariables = resolved,+          mountedFilesDir = mountedFilesDir,+          referenceFiles = formatReferenceFiles (bp ^. #files),+          referenceFilesAccess = formatReferenceFilesDir mountedFilesDir,+          sharedPrompt = renderBlueprintText resolved (bp ^. #prompt),+          allowedTools = resolveBlueprintTools (bp ^. #allowedTools)         }  -- | Substitute resolved blueprint variables into any blueprint-owned text.@@ -150,8 +151,8 @@   foldl'     ( \rendered (name, value) ->         T.replace-          ("{{" <> name.unVarName <> "}}")-          (varValueToText value.value)+          ("{{" <> name ^. #unVarName <> "}}")+          (varValueToText (value ^. #value))           rendered     )     template
src/Seihou/CLI/BlueprintMigration.hs view
@@ -11,6 +11,7 @@   ) where +import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text qualified as T import Seihou.CLI.AgentLaunch@@ -62,7 +63,7 @@   BlueprintMigration ->   Text renderBlueprintMigrationInstruction resolved migration =-  renderBlueprintText resolved migration.prompt+  renderBlueprintText resolved (migration ^. #prompt)  -- | Fill the migration-specific embedded template. The template itself stays -- in the executable target because @Data.FileEmbed@ traps it there; accepting@@ -76,26 +77,26 @@   BlueprintMigration ->   Text renderBlueprintMigrationSystemPrompt template ctx prepared position total migration =-  let blueprint = prepared.preparedBlueprint+  let blueprint = (prepared ^. #blueprint)       renderedInstruction =-        renderBlueprintMigrationInstruction prepared.preparedResolvedVariables migration+        renderBlueprintMigrationInstruction (prepared ^. #resolvedVariables) migration    in substitute-        [ ("cwd", ctx.cwd),+        [ ("cwd", ctx ^. #cwd),           ("seihou_project_state", formatSeihouProjectState ctx),           ("manifest_state", formatManifestState ctx),           ("module_dhall_state", formatModuleDhallState ctx),           ("local_modules", formatLocalModules ctx),           ("available_modules", formatAvailableModules ctx),-          ("blueprint_name", blueprint.name.unModuleName),-          ("blueprint_version", fromMaybe "(unspecified)" blueprint.version),-          ("blueprint_description", fromMaybe "(no description)" blueprint.description),-          ("migration_from", migration.from),-          ("migration_to", migration.to),+          ("blueprint_name", blueprint ^. #name . #unModuleName),+          ("blueprint_version", fromMaybe "(unspecified)" (blueprint ^. #version)),+          ("blueprint_description", fromMaybe "(no description)" (blueprint ^. #description)),+          ("migration_from", migration ^. #from),+          ("migration_to", migration ^. #to),           ("migration_position", T.pack (show position)),           ("migration_total", T.pack (show total)),-          ("reference_files", prepared.preparedReferenceFiles),-          ("reference_files_dir", prepared.preparedReferenceFilesAccess),-          ("shared_prompt", prepared.preparedSharedPrompt),+          ("reference_files", prepared ^. #referenceFiles),+          ("reference_files_dir", prepared ^. #referenceFilesAccess),+          ("shared_prompt", prepared ^. #sharedPrompt),           ("migration_prompt", renderedInstruction)         ]         template@@ -116,9 +117,9 @@             <> "/"             <> T.pack (show total)             <> "] "-            <> migration.from+            <> migration ^. #from             <> " -> "-            <> migration.to+            <> migration ^. #to             <> " =====",           render position total migration         ]@@ -136,15 +137,15 @@   BlueprintMigrationPlan ->   [BlueprintMigration] pendingBlueprintMigrations rerun blueprintName receipts plan-  | rerun = plan.blueprintPlanSteps-  | otherwise = filter (not . alreadyApplied) plan.blueprintPlanSteps+  | rerun = plan ^. #steps+  | otherwise = filter (not . alreadyApplied) (plan ^. #steps)   where     alreadyApplied migration =       any         ( \receipt ->-            receipt.name == blueprintName-              && receipt.fromVersion == migration.from-              && receipt.toVersion == migration.to+            receipt ^. #name == blueprintName+              && receipt ^. #fromVersion == migration ^. #from+              && receipt ^. #toVersion == migration ^. #to         )         receipts
src/Seihou/CLI/BrowseFormat.hs view
@@ -7,6 +7,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Registry (EntryKind (..), Registry (..), RegistryEntry (..)) import Seihou.Core.Types (ModuleName (..))@@ -27,9 +28,9 @@ formatBrowseRegistry :: Text -> Registry -> [(EntryKind, RegistryEntry)] -> Maybe Text -> Text formatBrowseRegistry source registry filtered tagFilter =   let header =-        registry.repoName+        registry ^. #repoName           <> "\n"-          <> maybe "" (<> "\n") registry.repoDescription+          <> maybe "" (<> "\n") (registry ^. #repoDescription)           <> "\n"    in if null filtered         then@@ -39,7 +40,7 @@                    Nothing -> "No entries in registry.\n"                )         else-          let nameOf e = let (ModuleName n) = e.name in n+          let nameOf e = let (ModuleName n) = (e ^. #name) in n               maxNameLen = maximum (map (T.length . nameOf . snd) filtered)               entryLines = T.unlines (map (formatEntry maxNameLen) filtered)               n = length filtered@@ -95,11 +96,11 @@  formatEntry :: Int -> (EntryKind, RegistryEntry) -> Text formatEntry maxNameLen (kind, entry) =-  let (ModuleName name) = entry.name+  let (ModuleName name) = (entry ^. #name)       padding = T.replicate (maxNameLen - T.length name + 3) " "-      desc = maybe "" id entry.description+      desc = maybe "" id (entry ^. #description)       tagsText =-        if null entry.tags+        if null (entry ^. #tags)           then ""-          else "  [" <> T.intercalate ", " entry.tags <> "]"+          else "  [" <> T.intercalate ", " (entry ^. #tags) <> "]"    in "  " <> kindLabel kind <> "  " <> name <> padding <> desc <> tagsText
src/Seihou/CLI/CommandExecution.hs view
@@ -13,6 +13,7 @@   ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) import Data.Time (UTCTime)@@ -39,35 +40,35 @@  -- | A rendered command paired with its stable identity and selected action. data PlannedCommand = PlannedCommand-  { operation :: Operation,-    fingerprint :: CommandFingerprint,-    disposition :: CommandDisposition+  { operation :: !Operation,+    fingerprint :: !CommandFingerprint,+    disposition :: !CommandDisposition   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | An ordered command phase. Declaration/composition order is also execution -- order. newtype CommandPlan = CommandPlan   { commands :: [PlannedCommand]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Counts suitable for human or machine-readable previews. data CommandPlanSummary = CommandPlanSummary-  { willRun :: Int,-    skippedUnchanged :: Int,-    skippedDisabled :: Int+  { willRun :: !Int,+    skippedUnchanged :: !Int,+    skippedDisabled :: !Int   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | A failed shell command and its captured process result. data CommandExecutionError = CommandExecutionError-  { command :: PlannedCommand,-    exitCode :: Int,-    stdout :: Text,-    stderr :: Text+  { command :: !PlannedCommand,+    exitCode :: !Int,+    stdout :: !Text,+    stderr :: !Text   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Select command dispositions according to policy and prior successful -- receipts. Non-command operations are ignored.@@ -92,13 +93,13 @@ -- | Count each command disposition without changing command order. summarizeCommandPlan :: CommandPlan -> CommandPlanSummary summarizeCommandPlan commandPlan =-  foldl' count emptySummary commandPlan.commands+  foldl' count emptySummary (commandPlan ^. #commands)   where     emptySummary = CommandPlanSummary {willRun = 0, skippedUnchanged = 0, skippedDisabled = 0}-    count summary planned = case planned.disposition of-      CommandWillRun -> summary {willRun = summary.willRun + 1}-      CommandSkippedUnchanged -> summary {skippedUnchanged = summary.skippedUnchanged + 1}-      CommandSkippedDisabled -> summary {skippedDisabled = summary.skippedDisabled + 1}+    count summary planned = case planned ^. #disposition of+      CommandWillRun -> (summary & #willRun %~ (+ 1))+      CommandSkippedUnchanged -> (summary & #skippedUnchanged %~ (+ 1))+      CommandSkippedDisabled -> summary & #skippedDisabled %~ (+ 1)  -- | Execute runnable commands sequentially with @sh -c@. Stop at the first -- failure. The caller receives receipts only if the entire phase succeeds.@@ -107,7 +108,7 @@   UTCTime ->   CommandPlan ->   Eff es (Either CommandExecutionError [CommandReceipt])-executeCommandPlan completedAt commandPlan = go [] commandPlan.commands+executeCommandPlan completedAt commandPlan = go [] (commandPlan ^. #commands)   where     go = executeCommands completedAt (\_ _ _ -> pure ()) @@ -122,7 +123,7 @@   CommandPlan ->   Eff es (Either CommandExecutionError [CommandReceipt]) executeCommandPlanWithOutput completedAt onSuccess commandPlan =-  executeCommands completedAt onSuccess [] commandPlan.commands+  executeCommands completedAt onSuccess [] (commandPlan ^. #commands)  executeCommands ::   (Process :> es) =>@@ -134,10 +135,10 @@ executeCommands completedAt onSuccess = go   where     go completed [] = pure (Right (reverse completed))-    go completed (planned : remaining) = case planned.disposition of+    go completed (planned : remaining) = case planned ^. #disposition of       CommandSkippedUnchanged -> go completed remaining       CommandSkippedDisabled -> go completed remaining-      CommandWillRun -> case planned.operation of+      CommandWillRun -> case planned ^. #operation of         RunCommandOp {command, workDir, moduleName} -> do           (processExit, stdout, stderr) <- runProcess "sh" ["-c", command] workDir           case processExit of@@ -145,7 +146,7 @@               onSuccess planned stdout stderr               let receipt =                     CommandReceipt-                      { fingerprint = planned.fingerprint,+                      { fingerprint = planned ^. #fingerprint,                         moduleName,                         command,                         workDir,@@ -173,17 +174,17 @@   Map CommandFingerprint CommandReceipt ->   Map CommandFingerprint CommandReceipt finalizeCommandReceipts commandPlan completed priorReceipts =-  Map.fromList (mapMaybe receiptFor commandPlan.commands)+  Map.fromList (mapMaybe receiptFor (commandPlan ^. #commands))   where-    completedByFingerprint = Map.fromList [(receipt.fingerprint, receipt) | receipt <- completed]+    completedByFingerprint = Map.fromList [(receipt ^. #fingerprint, receipt) | receipt <- completed]      receiptFor planned =-      case Map.lookup planned.fingerprint completedByFingerprint of-        Just receipt -> Just (planned.fingerprint, receipt)-        Nothing -> case planned.disposition of+      case Map.lookup (planned ^. #fingerprint) completedByFingerprint of+        Just receipt -> Just (planned ^. #fingerprint, receipt)+        Nothing -> case planned ^. #disposition of           CommandWillRun -> Nothing           CommandSkippedUnchanged -> retainPrior planned           CommandSkippedDisabled -> retainPrior planned      retainPrior planned =-      (planned.fingerprint,) <$> Map.lookup planned.fingerprint priorReceipts+      (planned ^. #fingerprint,) <$> Map.lookup (planned ^. #fingerprint) priorReceipts
src/Seihou/CLI/CommitMessage.hs view
@@ -5,6 +5,8 @@ where  import Control.Exception (SomeException, try)+import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.Core.Types (ModuleName (..))@@ -31,6 +33,8 @@  callClaude :: [ModuleName] -> T.Text -> IO (Maybe T.Text) callClaude modNames diffText = do+  -- CreateProcess is a third-party type with no Generic instance, so it has+  -- no #std_out label to set. Record update syntax is the only option here.   let prompt = buildPrompt modNames diffText       cp =         (proc "claude" ["-p", T.unpack prompt])@@ -69,7 +73,7 @@       "- Do not wrap the output in backticks or code fences"     ]   where-    moduleList = T.intercalate ", " (map (.unModuleName) modNames)+    moduleList = T.intercalate ", " (map (^. #unModuleName) modNames)  -- | Strip markdown code-fence wrapping (``` ... ```) from text. -- Handles optional language tags (e.g., ```text).@@ -89,5 +93,5 @@  fallbackMessage :: [ModuleName] -> T.Text fallbackMessage [] = "chore(seihou): apply modules"-fallbackMessage [m] = "chore(seihou): apply " <> m.unModuleName-fallbackMessage ms = "chore(seihou): apply " <> T.intercalate ", " (map (.unModuleName) ms)+fallbackMessage [m] = "chore(seihou): apply " <> (m ^. #unModuleName)+fallbackMessage ms = "chore(seihou): apply " <> T.intercalate ", " (map (^. #unModuleName) ms)
src/Seihou/CLI/Diff.hs view
@@ -4,6 +4,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.CLI.Shared (logIO)@@ -43,9 +44,9 @@  formatDiffOutput :: Bool -> [TrackedFile] -> Text formatDiffOutput color tracked =-  let modified = filter (\t -> t.status == TfsModified) tracked-      deleted = filter (\t -> t.status == TfsDeleted) tracked-      unchanged = filter (\t -> t.status == TfsUnchanged) tracked+  let modified = filter (\t -> t ^. #status == TfsModified) tracked+      deleted = filter (\t -> t ^. #status == TfsDeleted) tracked+      unchanged = filter (\t -> t ^. #status == TfsUnchanged) tracked       nMod = length modified       nDel = length deleted       nUnch = length unchanged@@ -53,7 +54,7 @@    in if null changed         then "No changes since last generation.\n"         else-          let maxPathLen = maximum (map (length . (.path)) changed)+          let maxPathLen = maximum (map (length . (^. #path)) changed)               header = "Seihou Diff:\n"               fileLines = map (formatLine color maxPathLen) changed               summary =@@ -68,12 +69,12 @@  formatLine :: Bool -> Int -> TrackedFile -> Text formatLine color maxPathLen tf =-  let (label, colorFn) = case tf.status of+  let (label, colorFn) = case tf ^. #status of         TfsModified -> ("modified", yellow)         TfsDeleted -> ("deleted ", red)         TfsUnchanged -> ("unchanged", dim)-      path = T.pack tf.path-      modName = tf.moduleName.unModuleName+      path = T.pack (tf ^. #path)+      modName = (tf ^. #moduleName . #unModuleName)       paddedLabel = if color then colorFn label else label       paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " "       modAttr = if color then dim ("(" <> modName <> ")") else "(" <> modName <> ")"
src/Seihou/CLI/Extension.hs view
@@ -7,6 +7,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO import Seihou.Prelude@@ -16,10 +17,10 @@ import System.Process (rawSystem)  data ExtensionRunOpts = ExtensionRunOpts-  { extensionName :: Text,-    extensionArgs :: [String]+  { name :: !Text,+    args :: ![String]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data ExtensionRunError   = ExtensionNotFound Text String@@ -32,16 +33,16 @@  runExtension :: ExtensionRunOpts -> IO (Either ExtensionRunError ()) runExtension opts = do-  let exeName = extensionExecutableName opts.extensionName+  let exeName = extensionExecutableName (opts ^. #name)   found <- findExecutable exeName   case found of     Nothing ->-      pure (Left (ExtensionNotFound opts.extensionName exeName))+      pure (Left (ExtensionNotFound (opts ^. #name) exeName))     Just exePath -> do-      code <- rawSystem exePath opts.extensionArgs+      code <- rawSystem exePath (opts ^. #args)       pure $ case code of         ExitSuccess -> Right ()-        failure -> Left (ExtensionExited opts.extensionName failure)+        failure -> Left (ExtensionExited (opts ^. #name) failure)  handleExtensionRun :: ExtensionRunOpts -> IO () handleExtensionRun opts = do
src/Seihou/CLI/InstallHistory.hs view
@@ -15,6 +15,7 @@ import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show)@@ -29,13 +30,13 @@  -- | A single entry in the install URL history. data HistoryEntry = HistoryEntry-  { url :: Text,-    lastUsed :: Text+  { url :: !Text,+    lastUsed :: !Text   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance ToJSON HistoryEntry where-  toJSON e = object ["url" .= e.url, "lastUsed" .= e.lastUsed]+  toJSON e = object ["url" .= (e ^. #url), "lastUsed" .= (e ^. #lastUsed)]  instance FromJSON HistoryEntry where   parseJSON = withObject "HistoryEntry" $ \o ->@@ -45,10 +46,10 @@ newtype InstallHistory = InstallHistory   { entries :: [HistoryEntry]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance ToJSON InstallHistory where-  toJSON h = object ["entries" .= h.entries]+  toJSON h = object ["entries" .= (h ^. #entries)]  instance FromJSON InstallHistory where   parseJSON = withObject "InstallHistory" $ \o ->@@ -101,6 +102,6 @@   history <- readHistoryFrom path   let timestamp = T.pack (iso8601Show now)       newEntry = HistoryEntry {url = url, lastUsed = timestamp}-      filtered = filter (\e -> e.url /= url) history.entries+      filtered = filter (\e -> e ^. #url /= url) (history ^. #entries)       updated = take maxHistoryEntries (newEntry : filtered)   writeHistoryTo path (InstallHistory updated)
src/Seihou/CLI/InstallShared.hs view
@@ -12,14 +12,15 @@ where  import Control.Monad (when)-import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))-import Data.Aeson qualified as Aeson+import Data.Aeson (ToJSON (..), object, (.=)) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Seihou.CLI.Shared (logIO)+import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo) import Seihou.Core.Types (LogLevel (..)) import Seihou.Effect.Logger (logWarn) import Seihou.Prelude@@ -28,7 +29,6 @@     copyFile,     createDirectoryIfMissing,     doesDirectoryExist,-    doesFileExist,     getXdgDirectory,     listDirectory,     removeDirectoryRecursive,@@ -40,50 +40,33 @@ -- Origin metadata -- ---------------------------------------------------------------------------- --- | Read side of @.seihou-origin.json@. Tolerates files written by older--- 'seihou install' runs that may have been missing optional fields.-data OriginInfo = OriginInfo-  { sourceUrl :: Text,-    repoName :: Maybe Text,-    version :: Maybe Text-  }-  deriving stock (Eq, Show)--instance FromJSON OriginInfo where-  parseJSON = withObject "OriginInfo" $ \v ->-    OriginInfo <$> v .: "sourceUrl" <*> v .:? "repoName" <*> v .:? "version"---- | Read and parse @.seihou-origin.json@ at the given installed-module--- directory. Returns 'Nothing' if the file is absent or unparseable.-readOriginInfo :: FilePath -> IO (Maybe OriginInfo)-readOriginInfo installedDir = do-  let path = installedDir </> ".seihou-origin.json"-  exists <- doesFileExist path-  if not exists-    then pure Nothing-    else do-      bs <- LBS.readFile path-      pure (Aeson.decode bs)+-- The read side ('OriginInfo', 'readOriginInfo') lives in+-- "Seihou.Core.ArtifactOriginDetect" because @seihou-core@ needs it to+-- classify an artifact directory into a portable manifest origin and cannot+-- depend on @seihou-cli-internal@. It is re-exported here so existing+-- importers are unaffected. The write side below stays in the CLI, which is+-- the only place that installs anything.  -- | Write side of @.seihou-origin.json@. Captures everything 'seihou -- install' / 'seihou upgrade' want to record at install time, including -- the timestamp. data OriginMeta = OriginMeta-  { sourceUrl :: Text,-    repoName :: Maybe Text,-    installedAt :: Text,-    version :: Maybe Text,-    tags :: [Text]+  { sourceUrl :: !Text,+    repoName :: !(Maybe Text),+    installedAt :: !Text,+    version :: !(Maybe Text),+    tags :: ![Text]   }+  deriving stock (Generic)  instance ToJSON OriginMeta where   toJSON m =     object-      [ "sourceUrl" .= m.sourceUrl,-        "repoName" .= m.repoName,-        "installedAt" .= m.installedAt,-        "version" .= m.version,-        "tags" .= m.tags+      [ "sourceUrl" .= (m ^. #sourceUrl),+        "repoName" .= (m ^. #repoName),+        "installedAt" .= (m ^. #installedAt),+        "version" .= (m ^. #version),+        "tags" .= (m ^. #tags)       ]  -- ----------------------------------------------------------------------------
src/Seihou/CLI/List.hs view
@@ -12,6 +12,7 @@ import Data.Aeson (FromJSON (..), withObject, (.:?)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text qualified as T@@ -25,10 +26,11 @@  -- | Origin metadata read from @.seihou-origin.json@. data OriginInfo = OriginInfo-  { originRepoName :: Maybe Text,-    originVersion :: Maybe Text,-    originTags :: [Text]+  { repoName :: !(Maybe Text),+    version :: !(Maybe Text),+    tags :: ![Text]   }+  deriving stock (Generic)  instance FromJSON OriginInfo where   parseJSON = withObject "OriginInfo" $ \v ->@@ -38,11 +40,11 @@ -- imported from Commands) so the internal library does not depend on -- optparse-applicative. data ListFilter = ListFilter-  { filterRepo :: Maybe Text,-    filterTag :: Maybe Text,-    filterKinds :: [RunnableKind]+  { repo :: !(Maybe Text),+    tag :: !(Maybe Text),+    kinds :: ![RunnableKind]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  noFilter :: ListFilter noFilter = ListFilter Nothing Nothing []@@ -61,59 +63,59 @@  readOrigin :: DiscoveredModule -> IO (FilePath, Maybe OriginInfo) readOrigin dm = do-  let originFile = dm.discoveredDir </> ".seihou-origin.json"+  let originFile = dm ^. #dir </> ".seihou-origin.json"   exists <- doesFileExist originFile   if exists     then do       bs <- LBS.readFile originFile       case Aeson.decode bs of-        Just info -> pure (dm.discoveredDir, Just info)-        Nothing -> pure (dm.discoveredDir, Nothing)-    else pure (dm.discoveredDir, Nothing)+        Just info -> pure (dm ^. #dir, Just info)+        Nothing -> pure (dm ^. #dir, Nothing)+    else pure (dm ^. #dir, Nothing)  readRunnableOrigin :: DiscoveredRunnable -> IO (FilePath, Maybe OriginInfo) readRunnableOrigin dr = do-  let originFile = dr.drDir </> ".seihou-origin.json"+  let originFile = dr ^. #dir </> ".seihou-origin.json"   exists <- doesFileExist originFile   if exists     then do       bs <- LBS.readFile originFile       case Aeson.decode bs of-        Just info -> pure (dr.drDir, Just info)-        Nothing -> pure (dr.drDir, Nothing)-    else pure (dr.drDir, Nothing)+        Just info -> pure (dr ^. #dir, Just info)+        Nothing -> pure (dr ^. #dir, Nothing)+    else pure (dr ^. #dir, Nothing)  runnableToEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredRunnable -> Entry runnableToEntryWithOrigin origins dr =-  let (originName, originVer, originTags) = case Map.lookup dr.drDir origins of-        Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags)+  let (originName, originVer, tags) = case Map.lookup (dr ^. #dir) origins of+        Just (Just info) -> (info ^. #repoName, info ^. #version, info ^. #tags)         _ -> (Nothing, Nothing, [])-      srcLabel = sourceLabelWithOrigin dr.drSource originName originVer-      kindSuffix = case dr.drKind of+      srcLabel = sourceLabelWithOrigin (dr ^. #source) originName originVer+      kindSuffix = case dr ^. #kind of         KindModule -> ""         KindRecipe -> " [recipe]"         KindBlueprint -> " [blueprint]"         KindPrompt -> " [prompt]"-   in if dr.drIsError+   in if dr ^. #isError         then           Entry-            { entryName = dr.drName,-              entryDesc = "[error: " <> fromMaybe "unknown" dr.drError <> "]",-              entrySource = srcLabel <> kindSuffix,-              entryIsError = True,-              entryRepoName = originName,-              entryTags = originTags,-              entryKind = dr.drKind+            { name = dr ^. #name,+              desc = "[error: " <> fromMaybe "unknown" (dr ^. #error) <> "]",+              source = srcLabel <> kindSuffix,+              isError = True,+              repoName = originName,+              tags = tags,+              kind = dr ^. #kind             }         else           Entry-            { entryName = dr.drName,-              entryDesc = fromMaybe "(no description)" dr.drDescription,-              entrySource = srcLabel <> kindSuffix,-              entryIsError = False,-              entryRepoName = originName,-              entryTags = originTags,-              entryKind = dr.drKind+            { name = dr ^. #name,+              desc = fromMaybe "(no description)" (dr ^. #description),+              source = srcLabel <> kindSuffix,+              isError = False,+              repoName = originName,+              tags = tags,+              kind = dr ^. #kind             }  -- | Format list output — backward-compatible version without origin info.@@ -128,21 +130,21 @@   | null entries =       -- With nothing to show, the kind comes from the active filter (if any).       "No "-        <> pluralize 0 (summaryNoun listOpts.filterKinds)+        <> pluralize 0 (summaryNoun (listOpts ^. #kinds))         <> " found."         <> filterSuffix         <> "\n\nSearched:\n"         <> T.unlines (map ("  " <>) searchPaths)   | otherwise =-      let maxNameLen = maximum (map (T.length . (.entryName)) entries)-          maxDescLen = maximum (map (T.length . (.entryDesc)) entries)+      let maxNameLen = maximum (map (T.length . (^. #name)) entries)+          maxDescLen = maximum (map (T.length . (^. #desc)) entries)           header = "Available modules, recipes, blueprints, and prompts:\n"           fileLines = map (formatEntry color maxNameLen maxDescLen) entries           n = length entries           nSources = length searchPaths           -- The count noun reflects the kinds actually shown: a single shared           -- kind names that kind; a mix falls back to the neutral "item".-          noun = pluralize n (summaryNoun (map (.entryKind) entries))+          noun = pluralize n (summaryNoun (map (^. #kind) entries))           summary =             T.pack (show n)               <> " "@@ -181,10 +183,10 @@ formatFilterSuffix :: ListFilter -> Text formatFilterSuffix opts =   let parts =-        maybe [] (\r -> ["repo=" <> r]) opts.filterRepo-          <> maybe [] (\t -> ["tag=" <> t]) opts.filterTag+        maybe [] (\r -> ["repo=" <> r]) (opts ^. #repo)+          <> maybe [] (\t -> ["tag=" <> t]) (opts ^. #tag)           <> kindPart-      kindPart = case opts.filterKinds of+      kindPart = case opts ^. #kinds of         [] -> []         ks -> ["kind=" <> T.intercalate "+" (map kindNoun ks)]    in if null parts@@ -202,56 +204,56 @@ applyFilters opts = filter match   where     match entry = repoMatch entry && tagMatch entry && kindMatch entry-    repoMatch entry = case opts.filterRepo of+    repoMatch entry = case opts ^. #repo of       Nothing -> True-      Just r -> entry.entryRepoName == Just r-    tagMatch entry = case opts.filterTag of+      Just r -> entry ^. #repoName == Just r+    tagMatch entry = case opts ^. #tag of       Nothing -> True-      Just t -> t `elem` entry.entryTags-    kindMatch entry = case opts.filterKinds of+      Just t -> t `elem` (entry ^. #tags)+    kindMatch entry = case opts ^. #kinds of       [] -> True-      ks -> entry.entryKind `elem` ks+      ks -> (entry ^. #kind) `elem` ks  data Entry = Entry-  { entryName :: Text,-    entryDesc :: Text,-    entrySource :: Text,-    entryIsError :: Bool,-    entryRepoName :: Maybe Text,-    entryTags :: [Text],-    entryKind :: RunnableKind+  { name :: !Text,+    desc :: !Text,+    source :: !Text,+    isError :: !Bool,+    repoName :: !(Maybe Text),+    tags :: ![Text],+    kind :: !RunnableKind   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  toEntry :: DiscoveredModule -> Entry toEntry = toEntryWithOrigin Map.empty  toEntryWithOrigin :: Map FilePath (Maybe OriginInfo) -> DiscoveredModule -> Entry toEntryWithOrigin origins dm =-  let (originName, originVer, originTags) = case Map.lookup dm.discoveredDir origins of-        Just (Just info) -> (info.originRepoName, info.originVersion, info.originTags)+  let (originName, originVer, tags) = case Map.lookup (dm ^. #dir) origins of+        Just (Just info) -> (info ^. #repoName, info ^. #version, info ^. #tags)         _ -> (Nothing, Nothing, [])-      srcLabel = sourceLabelWithOrigin dm.discoveredSource originName originVer-   in case dm.discoveredResult of+      srcLabel = sourceLabelWithOrigin (dm ^. #source) originName originVer+   in case dm ^. #result of         Right m ->           Entry-            { entryName = m.name.unModuleName,-              entryDesc = maybe "(no description)" id m.description,-              entrySource = srcLabel,-              entryIsError = False,-              entryRepoName = originName,-              entryTags = originTags,-              entryKind = KindModule+            { name = m ^. #name . #unModuleName,+              desc = maybe "(no description)" id (m ^. #description),+              source = srcLabel,+              isError = False,+              repoName = originName,+              tags = tags,+              kind = KindModule             }         Left err ->           Entry-            { entryName = dirName dm.discoveredDir,-              entryDesc = "[error: " <> briefError err <> "]",-              entrySource = srcLabel,-              entryIsError = True,-              entryRepoName = originName,-              entryTags = originTags,-              entryKind = KindModule+            { name = dirName (dm ^. #dir),+              desc = "[error: " <> briefError err <> "]",+              source = srcLabel,+              isError = True,+              repoName = originName,+              tags = tags,+              kind = KindModule             }  sourceLabelWithOrigin :: ModuleSource -> Maybe Text -> Maybe Text -> Text@@ -278,13 +280,13 @@  formatEntry :: Bool -> Int -> Int -> Entry -> Text formatEntry color maxNameLen maxDescLen entry =-  let name = entry.entryName-      desc = entry.entryDesc-      src = entry.entrySource+  let name = (entry ^. #name)+      desc = (entry ^. #desc)+      src = (entry ^. #source)       paddedName = name <> T.replicate (maxNameLen - T.length name + 3) " "       paddedDesc = desc <> T.replicate (maxDescLen - T.length desc + 3) " "       srcTag = "(" <> src <> ")"-      colorDesc = if color && entry.entryIsError then red desc else desc+      colorDesc = if color && entry ^. #isError then red desc else desc       colorSrc = if color then dim srcTag else srcTag       colorPaddedDesc = colorDesc <> T.replicate (maxDescLen - T.length desc + 3) " "-   in "  " <> paddedName <> (if color && entry.entryIsError then colorPaddedDesc else paddedDesc) <> colorSrc+   in "  " <> paddedName <> (if color && entry ^. #isError then colorPaddedDesc else paddedDesc) <> colorSrc
+ src/Seihou/CLI/Manifest.hs view
@@ -0,0 +1,19 @@+module Seihou.CLI.Manifest+  ( ManifestCommand (..),+    handleManifest,+  )+where++import Seihou.CLI.ManifestUpgrade (ManifestUpgradeOpts, handleManifestUpgrade)+import Seihou.Prelude++-- | Subcommand selector for the @seihou manifest@ group. Reserves space for+-- future operations on @.seihou\/manifest.json@ — inspection, repair — without+-- another CLI restructuring pass.+data ManifestCommand+  = ManifestUpgrade ManifestUpgradeOpts+  deriving stock (Eq, Show, Generic)++-- | Dispatch the selected @manifest@ subcommand to its handler.+handleManifest :: ManifestCommand -> IO ()+handleManifest (ManifestUpgrade opts) = handleManifestUpgrade opts
+ src/Seihou/CLI/ManifestGuard.hs view
@@ -0,0 +1,407 @@+-- | Compare what @.seihou\/manifest.json@ records against what is actually+-- installed on this machine, before anything is generated.+--+-- The manifest is checked into version control (see+-- docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md),+-- so the copy of a module a developer has locally is not necessarily the copy+-- the manifest describes. Without a check, a developer whose install cache+-- lags behind the manifest regenerates every file from the older module and+-- rewrites the manifest to name it — a silent regression that looks like an+-- ordinary diff in code review.+--+-- This module answers "should we generate from what is here?". Answering+-- "where is it?" is 'Seihou.Core.ArtifactRef'.+--+-- The comparison itself ('judgeArtifact') is pure so it can be tested without+-- a filesystem; 'checkAppliedArtifacts' is the IO shell that locates each+-- recorded artifact and reads its version and provenance.+module Seihou.CLI.ManifestGuard+  ( -- * Verdicts+    ArtifactVerdict (..),+    ArtifactCheck (..),+    judgeArtifact,++    -- * Checking a manifest against this machine+    checkAppliedArtifacts,+    checkAppliedArtifactsFor,+    blockingChecks,++    -- * Rendering+    formatGuardRefusal,+    formatGuardOverride,+    summarizeCheck,+  )+where++import Data.Generics.Labels ()+import Data.List (nubBy)+import Data.Maybe (fromMaybe)+import Data.Set qualified as Set+import Data.Text qualified as T+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactRef+  ( ArtifactRefError,+    renderArtifactRefError,+    resolveArtifactOrigin,+  )+import Seihou.Core.Types+  ( AppliedModule (..),+    ArtifactOrigin (..),+    Manifest (..),+    Module (..),+    ModuleName (..),+  )+import Seihou.Core.Version (parseVersion)+import Seihou.Dhall.Eval (evalModuleFromFile)+import Seihou.Prelude++-- ----------------------------------------------------------------------------+-- Verdicts+-- ----------------------------------------------------------------------------++-- | What the guard concluded about one applied artifact.+data ArtifactVerdict+  = -- | Local copy matches or is newer than what the manifest records,+    -- and the origin agrees. Nothing to say.+    ArtifactOk+  | -- | Local copy is strictly older than the recorded version.+    -- Fields: recorded version, local version.+    ArtifactStale !Text !Text+  | -- | A module of this name is installed, but from a different origin+    -- than the manifest records. Fields: recorded origin, local origin.+    ArtifactOriginMismatch !ArtifactOrigin !ArtifactOrigin+  | -- | The recorded artifact is not installed on this machine at all.+    ArtifactUnresolvable !ArtifactRefError+  | -- | Either side has a version string that 'parseVersion' rejects, so+    -- no ordering can be established. Fields: recorded, local.+    ArtifactVersionIncomparable !(Maybe Text) !(Maybe Text)+  | -- | The recorded origin carries no provenance seihou can check against+    -- what was found, so identity cannot be verified. The version was+    -- still compared and did not indicate a downgrade.+    ArtifactUnverifiableOrigin+  deriving stock (Eq, Show, Generic)++-- | One artifact's guard result, ready for rendering.+--+-- The recorded origin is carried alongside the verdict rather than inside+-- it: it is a property of the artifact that was checked, not of the+-- conclusion, and every rendered block wants it.+data ArtifactCheck = ArtifactCheck+  { name :: !ModuleName,+    origin :: !ArtifactOrigin,+    verdict :: !ArtifactVerdict+  }+  deriving stock (Eq, Show, Generic)++-- | How much the recorded origin and the origin of the copy found locally+-- agree.+data OriginRelation+  = -- | Both sides carry provenance and it is the same provenance.+    OriginMatches+  | -- | Both sides carry provenance and it disagrees.+    OriginDiffers+  | -- | At least one side carries no provenance, so identity is unknowable.+    OriginUnverifiable+  deriving stock (Eq, Show)++-- | Compare one recorded artifact against what was found locally.+--+-- @recordedOrigin@ and @recordedVersion@ come from the manifest.+-- @localOrigin@ and @localVersion@ come from the artifact actually found on+-- this machine — the origin by reading @.seihou-origin.json@ beside it, the+-- version from its @module.dhall@.+--+-- Identity is checked before version, because a differing origin URL means a+-- different module and its version number is not comparable to the recorded+-- one at all. When identity cannot be disproved but also cannot be confirmed,+-- the version comparison still runs: a version does come from the artifact+-- itself, so "older than recorded" is meaningful even when "the same module"+-- is not provable.+judgeArtifact ::+  ArtifactOrigin ->+  Maybe Text ->+  ArtifactOrigin ->+  Maybe Text ->+  ArtifactVerdict+judgeArtifact recordedOrigin recordedVersion localOrigin localVersion =+  case originRelation recordedOrigin localOrigin of+    OriginDiffers -> ArtifactOriginMismatch recordedOrigin localOrigin+    OriginMatches -> fromMaybe ArtifactOk versionVerdict+    OriginUnverifiable -> fromMaybe ArtifactUnverifiableOrigin versionVerdict+  where+    versionVerdict = judgeVersion recordedVersion localVersion++-- | The version half of the comparison. 'Nothing' means "nothing to report".+judgeVersion :: Maybe Text -> Maybe Text -> Maybe ArtifactVerdict+judgeVersion recorded@(Just rawRecorded) local@(Just rawLocal)+  | Just parsedRecorded <- parseVersion rawRecorded,+    Just parsedLocal <- parseVersion rawLocal =+      if parsedLocal < parsedRecorded+        then Just (ArtifactStale rawRecorded rawLocal)+        else Nothing+  | otherwise = Just (ArtifactVersionIncomparable recorded local)+judgeVersion recorded local = Just (ArtifactVersionIncomparable recorded local)++-- | Decide how much the two origins agree.+--+-- A 'RemoteOrigin' on both sides is the only case where identity can be+-- confirmed or refuted outright. A 'RemoteOrigin' recorded against a locally+-- discovered copy with no provenance (a personal module shadowing an installed+-- one) is honestly unverifiable rather than a mismatch — a developer who+-- deliberately shadows a module should not be told they have the wrong one.+-- A recorded 'ProjectOrigin' resolves against the project root and nowhere+-- else, so anything but the same project path is a genuine inconsistency.+originRelation :: ArtifactOrigin -> ArtifactOrigin -> OriginRelation+originRelation recorded local = case (recorded, local) of+  (RemoteOrigin recordedUrl _ _, RemoteOrigin localUrl _ _)+    | normalizeOriginUrl recordedUrl == normalizeOriginUrl localUrl -> OriginMatches+    | otherwise -> OriginDiffers+  (RemoteOrigin {}, _) -> OriginUnverifiable+  (ProjectOrigin recordedPath, ProjectOrigin localPath)+    | normalizeProjectPath recordedPath == normalizeProjectPath localPath -> OriginMatches+    | otherwise -> OriginDiffers+  (ProjectOrigin {}, _) -> OriginDiffers+  (LocalOrigin {}, _) -> OriginUnverifiable++-- | Reduce a git URL to a form two spellings of the same repository share.+--+-- @https:\/\/host\/repo@, @https:\/\/host\/repo.git@ and+-- @https:\/\/host\/repo\/@ all name the same repository, and a manifest+-- written by a developer who typed one of them must not read as a different+-- module to a developer who typed another.+normalizeOriginUrl :: Text -> Text+normalizeOriginUrl =+  dropTrailingSlashes . dropGitSuffix . dropTrailingSlashes . T.strip+  where+    dropTrailingSlashes = T.dropWhileEnd (== '/')+    dropGitSuffix url = fromMaybe url (T.stripSuffix ".git" url)++-- | Reduce a project-relative path to a comparable form. The manifest stores+-- these with forward slashes; @.\/@ prefixes and trailing slashes are noise.+normalizeProjectPath :: FilePath -> FilePath+normalizeProjectPath =+  dropWhileEnd' (== '/') . dropDotPrefix . dropWhileEnd' (== '/')+  where+    dropDotPrefix path = fromMaybe path (stripPrefix' "./" path)+    stripPrefix' prefix path =+      if take (length prefix) path == prefix+        then Just (drop (length prefix) path)+        else Nothing+    dropWhileEnd' p = reverse . dropWhile p . reverse++-- ----------------------------------------------------------------------------+-- Checking a manifest against this machine+-- ----------------------------------------------------------------------------++-- | Check every module recorded in the manifest against this machine.+--+-- @projectRoot@ is the absolute directory holding @.seihou@. @searchPaths@ is+-- normally 'Seihou.Core.Module.defaultSearchPaths'. Returns one+-- 'ArtifactCheck' per distinct recorded module, in manifest order,+-- deduplicated by module name — two instances of the same module with+-- different parent variables resolve to the same directory and would produce+-- the same verdict twice.+checkAppliedArtifacts ::+  FilePath ->+  [FilePath] ->+  Manifest ->+  IO [ArtifactCheck]+checkAppliedArtifacts projectRoot searchPaths =+  checkAppliedArtifactsFor projectRoot searchPaths Nothing++-- | 'checkAppliedArtifacts' restricted to a subset of module names.+--+-- 'Nothing' means "every applied module" and is what @seihou status@ wants.+-- @'Just' names@ keeps only modules whose name is in the set, which is what+-- @seihou run@ wants: a stale module unrelated to the composition being+-- generated must not block the run, exactly as+-- 'Seihou.CLI.PendingMigrations.detectPendingMigrations' already treats an+-- unrelated pending migration.+checkAppliedArtifactsFor ::+  FilePath ->+  [FilePath] ->+  Maybe (Set ModuleName) ->+  Manifest ->+  IO [ArtifactCheck]+checkAppliedArtifactsFor projectRoot searchPaths mFilter manifest =+  traverse checkOne (dedupeByName (filter wanted (manifest ^. #modules)))+  where+    wanted applied = case mFilter of+      Nothing -> True+      Just names -> Set.member (applied ^. #name) names++    dedupeByName = nubBy (\a b -> a ^. #name == b ^. #name)++    checkOne applied = do+      let recordedOrigin = applied ^. #origin+      resolved <- resolveArtifactOrigin projectRoot searchPaths "module.dhall" recordedOrigin+      verdict <- case resolved of+        Left refErr -> pure (ArtifactUnresolvable refErr)+        Right directory -> do+          localOrigin <- detectArtifactOrigin projectRoot directory+          localVersion <- localModuleVersion directory+          pure (judgeArtifact recordedOrigin (applied ^. #moduleVersion) localOrigin localVersion)+      pure+        ArtifactCheck+          { name = applied ^. #name,+            origin = recordedOrigin,+            verdict = verdict+          }++-- | The version the locally installed @module.dhall@ declares.+--+-- A module that does not evaluate yields 'Nothing', which becomes+-- 'ArtifactVersionIncomparable'. That is deliberate: a broken @module.dhall@+-- is a separate problem, and the generation path reports it far better than+-- the guard could.+localModuleVersion :: FilePath -> IO (Maybe Text)+localModuleVersion directory = do+  result <- evalModuleFromFile (directory </> "module.dhall")+  pure $ case result of+    Left _ -> Nothing+    Right modul -> modul ^. #version++-- | Whether any verdict is severe enough to stop the command.+--+-- 'ArtifactStale', 'ArtifactOriginMismatch' and 'ArtifactUnresolvable' block:+-- each one means generating now would produce files from something other than+-- what the project records. 'ArtifactVersionIncomparable' and+-- 'ArtifactUnverifiableOrigin' are reported but never block, because neither+-- is evidence of a problem — only evidence that seihou cannot prove there+-- isn't one.+blockingChecks :: [ArtifactCheck] -> [ArtifactCheck]+blockingChecks = filter (isBlocking . (^. #verdict))+  where+    isBlocking = \case+      ArtifactStale {} -> True+      ArtifactOriginMismatch {} -> True+      ArtifactUnresolvable {} -> True+      ArtifactOk -> False+      ArtifactVersionIncomparable {} -> False+      ArtifactUnverifiableOrigin -> False++-- ----------------------------------------------------------------------------+-- Rendering+-- ----------------------------------------------------------------------------++-- | Render blocking verdicts as the multi-line refusal message, one block per+-- artifact, followed by a paragraph naming the escape hatch.+formatGuardRefusal :: [ArtifactCheck] -> Text+formatGuardRefusal [] = ""+formatGuardRefusal checks =+  T.intercalate "\n\n" (map (refusalBlock "✗ Refusing to run") checks)+    <> "\n\n"+    <> T.intercalate+      "\n"+      [ "To proceed anyway — pinning this project to what is installed here —",+        "re-run with --allow-downgrade."+      ]+    <> "\n"++-- | The same blocks, printed when @--allow-downgrade@ was passed. A+-- deliberate downgrade should still be visible in the terminal; silently+-- honouring the flag would hide exactly the change this module exists to+-- make legible.+formatGuardOverride :: [ArtifactCheck] -> Text+formatGuardOverride [] = ""+formatGuardOverride checks =+  T.intercalate "\n\n" (map (refusalBlock "! Proceeding anyway (--allow-downgrade)") checks) <> "\n"++-- | One artifact's block, under a caller-supplied lead-in. The lead-in+-- carries its own status symbol, because a refusal and a deliberate override+-- print the same body but are not the same news.+refusalBlock :: Text -> ArtifactCheck -> Text+refusalBlock leadIn check = case check ^. #verdict of+  ArtifactStale recordedVersion localVersion ->+    T.intercalate "\n" $+      [ leadIn <> ": your local copy of '" <> label <> "' is older than the",+        "  version this project expects.",+        "",+        "  Recorded in .seihou/manifest.json:  " <> recordedVersion,+        "  Installed on this machine:          " <> localVersion+      ]+        <> originLine+        <> [ "",+             "  Update your local copy first:",+             "    seihou upgrade " <> label+           ]+  ArtifactOriginMismatch recorded local ->+    T.intercalate "\n" $+      [ leadIn <> ": '" <> label <> "' is installed from a different source",+        "  than this project records.",+        "",+        "  Recorded in .seihou/manifest.json:  " <> originDescription recorded,+        "  Installed on this machine:          " <> originDescription local,+        "",+        "  These are different artifacts that happen to share a name."+      ]+        <> case recorded of+          RemoteOrigin url _ _ ->+            [ "  Install the one this project records:",+              "    seihou install " <> url+            ]+          _ -> []+  ArtifactUnresolvable refErr ->+    leadIn <> ".\n\n" <> renderArtifactRefError refErr+  ArtifactVersionIncomparable recorded local ->+    T.intercalate+      "\n"+      [ "! '" <> label <> "' cannot be version-checked against this project.",+        "",+        "  Recorded in .seihou/manifest.json:  " <> describeVersion recorded,+        "  Installed on this machine:          " <> describeVersion local+      ]+  ArtifactUnverifiableOrigin ->+    T.intercalate+      "\n"+      [ "! '" <> label <> "' has no recorded provenance, so seihou cannot confirm",+        "  the copy installed here is the one this project was generated from."+      ]+  ArtifactOk -> ""+  where+    label = check ^. #name . #unModuleName++    originLine = case check ^. #origin of+      RemoteOrigin url _ _ -> ["  Origin: " <> url]+      _ -> []++    describeVersion = fromMaybe "(none recorded)"++-- | A one-line summary of anything worth mentioning, for reporting commands+-- like @seihou status@ that must never fail on a verdict. 'Nothing' means+-- there is nothing to say.+summarizeCheck :: ArtifactCheck -> Maybe Text+summarizeCheck check = case check ^. #verdict of+  ArtifactOk -> Nothing+  ArtifactStale recordedVersion localVersion ->+    Just $+      label+        <> ": this project expects "+        <> recordedVersion+        <> " but "+        <> localVersion+        <> " is installed here (run 'seihou upgrade "+        <> label+        <> "')"+  ArtifactOriginMismatch recorded local ->+    Just $+      label+        <> ": this project records "+        <> originDescription recorded+        <> " but "+        <> originDescription local+        <> " is installed here"+  ArtifactUnresolvable _ ->+    Just (label <> ": recorded in the manifest but not installed on this machine")+  ArtifactVersionIncomparable _ _ ->+    Just (label <> ": versions cannot be compared, so staleness is unknown")+  ArtifactUnverifiableOrigin ->+    Just (label <> ": no recorded provenance, so its identity cannot be verified")+  where+    label = check ^. #name . #unModuleName++-- | How to name an origin in a comparison line.+originDescription :: ArtifactOrigin -> Text+originDescription (RemoteOrigin url _ _) = url+originDescription (ProjectOrigin path) = T.pack path <> " (inside this project)"+originDescription (LocalOrigin artifact) = artifact <> " (no recorded provenance)"
+ src/Seihou/CLI/ManifestUpgrade.hs view
@@ -0,0 +1,659 @@+-- | Convert a @.seihou\/manifest.json@ written before schema version 6 into+-- the portable form every current command expects.+--+-- Schema-5-and-earlier manifests record, for each applied artifact, the+-- absolute directory that artifact occupied on the machine that ran seihou —+-- entries like @\/Users\/shinzui\/.config\/seihou\/installed\/haskell-base@.+-- That string is meaningless in any other clone, which is why+-- docs\/adr\/0001-manifest-is-a-checked-in-machine-independent-artifact.md+-- forbids it and why+-- 'Seihou.Manifest.Types.checkManifestVersion' refuses such a manifest+-- outright rather than misreading it.+--+-- This module turns those paths into 'ArtifactOrigin' values. Doing so+-- requires inference — the recorded path belongs to somebody else's machine,+-- so the upstream URL has to be recovered from what is installed here — and+-- inference that happens silently inside a file that is committed to git is+-- exactly what this initiative exists to remove. So the conversion is an+-- explicit command with a printed report rather than an automatic upgrade on+-- first read, and every entry says how confident it is.+--+-- The document is manipulated as an 'Aeson.Value' rather than decoded into+-- mirror records. The upgrade only needs to find three keys and replace them;+-- every other field — resolved variables, file records, baseline references,+-- command receipts, blueprint migration receipts — must survive untouched,+-- and walking the 'Aeson.Value' guarantees that where decode-and-re-encode+-- would risk dropping a key some later schema version added.+module Seihou.CLI.ManifestUpgrade+  ( -- * Reading a legacy manifest+    LegacyRef (..),+    LegacyManifest (..),+    readLegacyManifest,++    -- * Inferring a portable origin+    InferenceOutcome (..),+    inferredOrigin,+    inferOriginFromLegacyPath,++    -- * Rewriting the document+    UpgradeReportEntry (..),+    UpgradeResult (..),+    applyUpgrade,+    formatUpgradeReport,++    -- * The command+    ManifestUpgradeOpts (..),+    UpgradeOutcome (..),+    manifestRelativePath,+    formatUpgradeRefusal,+    runManifestUpgrade,+    handleManifestUpgrade,+  )+where++import Control.Monad (unless)+import Data.Aeson qualified as Aeson+import Data.Aeson.Key (Key)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy qualified as LBS+import Data.Foldable (toList)+import Data.Generics.Labels ()+import Data.List (foldl')+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Vector qualified as V+import Seihou.CLI.ManifestGuard+  ( ArtifactCheck,+    blockingChecks,+    checkAppliedArtifacts,+    summarizeCheck,+  )+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactRef (resolveArtifactOrigin)+import Seihou.Core.Module (defaultSearchPaths)+import Seihou.Core.Types (ArtifactOrigin (..), Manifest)+import Seihou.Manifest.Types (currentManifestVersion)+import Seihou.Prelude+import System.Directory (doesFileExist, getCurrentDirectory, renamePath)+import System.Exit (exitFailure)+import Text.Read (readMaybe)++-- ----------------------------------------------------------------------------+-- Reading a legacy manifest+-- ----------------------------------------------------------------------------++-- | One legacy artifact reference found in a schema-5-or-earlier manifest.+--+-- @jsonPointer@ locates the reference inside the document so the rewriter can+-- put the converted origin back in the right place, and so the report can say+-- which record it came from. It is a list of object keys and array indices+-- ending in the key that holds the path, for example+-- @["modules", "0", "source"]@ or+-- @["applications", "0", "instances", "1", "source"]@.+--+-- @definitionFile@ is the file that must be present for a directory to count+-- as this artifact — @module.dhall@ for a module, @recipe.dhall@ for an+-- application whose target is a recipe. Inference needs it because it looks+-- the artifact up by name in the local search paths.+data LegacyRef = LegacyRef+  { jsonPointer :: ![Text],+    artifactName :: !Text,+    legacyPath :: !FilePath,+    recordedVersion :: !(Maybe Text),+    definitionFile :: !FilePath+  }+  deriving stock (Eq, Show, Generic)++-- | Every legacy reference in a document, together with the document itself+-- so the rewriter can operate on it directly.+data LegacyManifest = LegacyManifest+  { schemaVersion :: !Int,+    document :: !Aeson.Value,+    refs :: ![LegacyRef]+  }+  deriving stock (Eq, Show, Generic)++-- | Parse a manifest document that has not yet been upgraded.+--+-- Returns 'Nothing' when the document's @version@ is already at or above the+-- current schema version, so callers can treat "nothing to do" as an ordinary+-- outcome rather than an error. A manifest from a /newer/ seihou is also+-- 'Nothing': there is nothing here to convert, and complaining about it is+-- 'Seihou.Manifest.Types.checkManifestVersion''s job.+readLegacyManifest :: LBS.ByteString -> Either String (Maybe LegacyManifest)+readLegacyManifest bytes = do+  value <- Aeson.eitherDecode bytes+  fields <- case value of+    Aeson.Object fields -> Right fields+    _ -> Left "manifest is not a JSON object"+  schemaVersion <- case KeyMap.lookup "version" fields of+    Just (Aeson.Number n) -> Right (truncate n :: Int)+    Just _ -> Left "manifest 'version' is not a number"+    Nothing -> Left "manifest has no 'version' field"+  pure $+    if schemaVersion >= currentManifestVersion+      then Nothing+      else+        Just+          LegacyManifest+            { schemaVersion = schemaVersion,+              document = value,+              refs = collectRefs value+            }++-- | Every machine-specific path recorded in a legacy document, in the order a+-- reader meets them.+--+-- Three keys hold such a path: @source@ inside each entry of @modules@,+-- @targetSource@ on each application, and @source@ inside each of an+-- application's @instances@. Everything else in the format is already+-- portable.+collectRefs :: Aeson.Value -> [LegacyRef]+collectRefs value =+  concatMap moduleRef (withIndices (arrayAt value "modules"))+    <> concatMap applicationRefs (withIndices (arrayAt value "applications"))+  where+    moduleRef (index, element) =+      mkRef+        ["modules", index, "source"]+        "module.dhall"+        (textAt element "name")+        (textAt element "source")+        (textAt element "version")++    applicationRefs (index, element) =+      mkRef+        ["applications", index, "targetSource"]+        (targetDefinitionFile element)+        (objectAt element "target" >>= \target -> textAt target "name")+        (textAt element "targetSource")+        (textAt element "targetVersion")+        <> concatMap (instanceRef index) (withIndices (arrayAt element "instances"))++    instanceRef applicationIndex (index, element) =+      mkRef+        ["applications", applicationIndex, "instances", index, "source"]+        "module.dhall"+        (textAt element "name")+        (textAt element "source")+        (textAt element "version")++-- | An application's target is either a module or a recipe, and the two are+-- discovered by different definition files.+targetDefinitionFile :: Aeson.Value -> FilePath+targetDefinitionFile application =+  case objectAt application "target" >>= \target -> textAt target "kind" of+    Just "recipe" -> "recipe.dhall"+    _ -> "module.dhall"++-- | Build a reference, or nothing when the record lacks a name or a path.+--+-- A record with no @source@ is not an error: a hand-edited manifest, or a+-- record a future field made optional, simply has nothing to convert.+mkRef ::+  [Text] ->+  FilePath ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  [LegacyRef]+mkRef pointer definitionFile mName mSource mVersion =+  case (mName, mSource) of+    (Just name, Just source) ->+      [ LegacyRef+          { jsonPointer = pointer,+            artifactName = name,+            legacyPath = T.unpack source,+            recordedVersion = mVersion,+            definitionFile = definitionFile+          }+      ]+    _ -> []++-- ----------------------------------------------------------------------------+-- Inferring a portable origin+-- ----------------------------------------------------------------------------++-- | How confident the upgrade is about a converted origin.+--+-- The distinction is not decoration: it is what the printed report shows the+-- developer, and it is the difference between a manifest entry that names its+-- upstream and one that admits it cannot.+data InferenceOutcome+  = -- | The artifact resolved locally and its install metadata gave a URL.+    -- Strongest result.+    InferredFromLocalInstall !ArtifactOrigin+  | -- | The legacy path names a directory inside the project, so it converts+    -- to a 'ProjectOrigin' by path arithmetic alone. Exact rather than+    -- inferred: a project-relative path means the same thing in every clone.+    InferredFromProjectPath !ArtifactOrigin+  | -- | Nothing local matched, or what matched carries no provenance; fell+    -- back to 'LocalOrigin' with only the recorded name. The developer can+    -- improve this by reinstalling from the real upstream and re-running the+    -- upgrade.+    InferredAsUnverifiable !ArtifactOrigin+  deriving stock (Eq, Show, Generic)++-- | The converted origin, whatever the confidence.+inferredOrigin :: InferenceOutcome -> ArtifactOrigin+inferredOrigin (InferredFromLocalInstall origin) = origin+inferredOrigin (InferredFromProjectPath origin) = origin+inferredOrigin (InferredAsUnverifiable origin) = origin++-- | Convert one legacy reference into a portable origin.+--+-- @projectRoot@ is the absolute directory holding @.seihou@. @searchPaths@ is+-- normally 'Seihou.Core.Module.defaultSearchPaths'.+--+-- Inference proceeds in three steps.+--+-- First, path arithmetic that needs no local state. The recorded path was+-- written by another machine, so its project-root prefix is that machine's+-- checkout, not this one — which is why the test is on the /suffix/: a path+-- ending in @.seihou\/modules\/\<name\>@ names a project-local artifact in+-- every clone. Containment inside this machine's project root is checked+-- second, as confirmation, for a layout the suffix test does not recognise.+--+-- Second, a local lookup by name through @searchPaths@, which is exactly what+-- 'Seihou.Core.ArtifactRef.resolveArtifactOrigin' does for a 'LocalOrigin'.+-- What is found is classified by 'detectArtifactOrigin', so an installed copy+-- with a @.seihou-origin.json@ yields the upstream URL the legacy path had+-- thrown away.+--+-- Third, 'LocalOrigin' carrying only the recorded name — the honest+-- representation of "this came from somewhere on that developer's machine and+-- we cannot say where".+inferOriginFromLegacyPath ::+  FilePath ->+  [FilePath] ->+  LegacyRef ->+  IO InferenceOutcome+inferOriginFromLegacyPath projectRoot searchPaths ref =+  case projectModuleSuffix (ref ^. #legacyPath) of+    Just relative -> pure (InferredFromProjectPath (ProjectOrigin relative))+    Nothing -> do+      recorded <- detectArtifactOrigin projectRoot (ref ^. #legacyPath)+      case recorded of+        ProjectOrigin _ -> pure (InferredFromProjectPath recorded)+        _ -> fromLocalLookup+  where+    name = ref ^. #artifactName++    fromLocalLookup = do+      resolved <-+        resolveArtifactOrigin+          projectRoot+          searchPaths+          (ref ^. #definitionFile)+          (LocalOrigin name)+      case resolved of+        Left _ -> pure (InferredAsUnverifiable (LocalOrigin name))+        Right directory -> do+          found <- detectArtifactOrigin projectRoot directory+          pure $ case found of+            RemoteOrigin {} -> InferredFromLocalInstall found+            ProjectOrigin {} -> InferredFromProjectPath found+            LocalOrigin {} -> InferredAsUnverifiable found++-- | The project-relative form of a legacy path that names an artifact under+-- @.seihou\/modules\/@, whichever machine's checkout it was written on.+projectModuleSuffix :: FilePath -> Maybe FilePath+projectModuleSuffix path = case reverse (pathSegments path) of+  (name : "modules" : ".seihou" : _) -> Just (".seihou/modules/" <> name)+  _ -> Nothing++-- | Whether a legacy path has the shape of an entry in the install cache,+-- @\<xdg-config\>\/seihou\/installed\/\<name\>@.+--+-- A path with that shape says the original author had the artifact installed+-- from an upstream, so when inference still falls back to 'LocalOrigin' the+-- report can say the URL was lost rather than that there never was one.+legacyPathWasInstalled :: FilePath -> Bool+legacyPathWasInstalled path = case reverse (pathSegments path) of+  (_ : "installed" : "seihou" : _) -> True+  _ -> False++-- | Split a recorded path into its segments, tolerating either separator: the+-- path may have been written by a machine that is not this one.+pathSegments :: FilePath -> [FilePath]+pathSegments = filter (not . null) . foldr split [[]]+  where+    split character segments@(current : rest)+      | character == '/' || character == '\\' = [] : segments+      | otherwise = (character : current) : rest+    split _ [] = []++-- ----------------------------------------------------------------------------+-- Rewriting the document+-- ----------------------------------------------------------------------------++-- | One line of the upgrade report.+data UpgradeReportEntry = UpgradeReportEntry+  { artifactName :: !Text,+    legacyPath :: !FilePath,+    outcome :: !InferenceOutcome+  }+  deriving stock (Eq, Show, Generic)++-- | An upgraded document plus the reviewable account of how it was reached.+data UpgradeResult = UpgradeResult+  { fromVersion :: !Int,+    entries :: ![UpgradeReportEntry],+    upgradedDocument :: !Aeson.Value+  }+  deriving stock (Eq, Show, Generic)++-- | Convert a legacy manifest. Pure given the inferences, so the report and+-- the resulting bytes can both be asserted on without a filesystem.+--+-- Each reference's recorded path is deleted and the portable origin written in+-- its place — @source@ becomes @origin@, @targetSource@ becomes+-- @targetOrigin@ — and the document's @version@ is set to the current schema+-- version. Nothing else in the document is touched.+applyUpgrade :: LegacyManifest -> [(LegacyRef, InferenceOutcome)] -> UpgradeResult+applyUpgrade legacy conversions =+  UpgradeResult+    { fromVersion = legacy ^. #schemaVersion,+      entries = dedupeEntries (map reportEntry conversions),+      upgradedDocument = setSchemaVersion (foldl' rewrite (legacy ^. #document) conversions)+    }+  where+    rewrite document (ref, outcome) =+      replaceAt (ref ^. #jsonPointer) (Aeson.toJSON (inferredOrigin outcome)) document++    reportEntry (ref, outcome) =+      UpgradeReportEntry+        { artifactName = ref ^. #artifactName,+          legacyPath = ref ^. #legacyPath,+          outcome = outcome+        }++-- | One line per distinct artifact-and-path pair, in first-seen order.+--+-- The same module typically appears three times — once in @modules@, once as+-- an application's target, once as an instance — and the report should show it+-- once. Two records naming the same artifact at /different/ paths stay+-- separate, because that is a real thing the developer should see.+dedupeEntries :: [UpgradeReportEntry] -> [UpgradeReportEntry]+dedupeEntries = go []+  where+    go _ [] = []+    go seen (entry : rest)+      | key entry `elem` seen = go seen rest+      | otherwise = entry : go (key entry : seen) rest++    key entry = (entry ^. #artifactName, entry ^. #legacyPath)++-- | Replace the key at the end of a pointer with its portable counterpart.+replaceAt :: [Text] -> Aeson.Value -> Aeson.Value -> Aeson.Value+replaceAt [] _ document = document+replaceAt pointer origin document =+  updateAt (init pointer) (renameKey (last pointer)) document+  where+    renameKey legacyKey (Aeson.Object fields) =+      Aeson.Object+        ( KeyMap.insert+            (Key.fromText (portableKey legacyKey))+            origin+            (KeyMap.delete (Key.fromText legacyKey) fields)+        )+    renameKey _ other = other++-- | The schema-6 name of a key that used to hold an absolute path.+portableKey :: Text -> Text+portableKey "source" = "origin"+portableKey "targetSource" = "targetOrigin"+portableKey other = other++-- | Apply a function to the value a pointer names, leaving the document+-- unchanged when the pointer does not lead anywhere.+updateAt :: [Text] -> (Aeson.Value -> Aeson.Value) -> Aeson.Value -> Aeson.Value+updateAt [] f value = f value+updateAt (step : rest) f value = case value of+  Aeson.Object fields ->+    let name = Key.fromText step+     in case KeyMap.lookup name fields of+          Just child -> Aeson.Object (KeyMap.insert name (updateAt rest f child) fields)+          Nothing -> value+  Aeson.Array elements ->+    case readMaybe (T.unpack step) of+      Just index+        | index >= 0 && index < V.length elements ->+            Aeson.Array (elements V.// [(index, updateAt rest f (elements V.! index))])+      _ -> value+  _ -> value++setSchemaVersion :: Aeson.Value -> Aeson.Value+setSchemaVersion (Aeson.Object fields) =+  Aeson.Object (KeyMap.insert "version" (Aeson.toJSON currentManifestVersion) fields)+setSchemaVersion other = other++-- | Render the conversion account shown in the terminal, without the closing+-- line — whether the file was written is the caller's news to deliver.+formatUpgradeReport :: UpgradeResult -> Text+formatUpgradeReport result =+  T.unlines (header : "" : concatMap entryLines (result ^. #entries))+  where+    header =+      "Reading "+        <> T.pack manifestRelativePath+        <> " (schema version "+        <> T.pack (show (result ^. #fromVersion))+        <> ")"++    nameColumn =+      maximum (5 : map (T.length . (^. #artifactName)) (result ^. #entries)) + 5++    entryLines entry =+      [ "  " <> T.justifyLeft nameColumn ' ' (entry ^. #artifactName) <> T.pack (entry ^. #legacyPath),+        T.replicate (nameColumn - 1) " " <> "→  " <> describeOutcome (entry ^. #outcome)+      ]+        <> map (\note -> T.replicate (nameColumn + 2) " " <> note) (outcomeNotes entry)+        <> [""]++    describeOutcome outcome = case inferredOrigin outcome of+      RemoteOrigin url _ _ -> "remote " <> url+      ProjectOrigin path -> "project " <> T.pack path+      LocalOrigin name -> "local " <> name <> "  (no upstream recorded)"++    outcomeNotes entry = case entry ^. #outcome of+      InferredAsUnverifiable _+        | legacyPathWasInstalled (entry ^. #legacyPath) ->+            [ "was installed from an upstream on the original machine, but no",+              "local copy is available here to recover the URL"+            ]+      _ -> []++-- ----------------------------------------------------------------------------+-- The command+-- ----------------------------------------------------------------------------++-- | Where a project's manifest lives, relative to the project root. Also the+-- name the report prints, so the two can never drift apart.+manifestRelativePath :: FilePath+manifestRelativePath = ".seihou" </> "manifest.json"++-- | Flags parsed for @seihou manifest upgrade@.+data ManifestUpgradeOpts = ManifestUpgradeOpts+  { dryRun :: !Bool,+    -- | Write even when the converted manifest names artifacts this machine+    -- cannot satisfy. For the developer who is upgrading a manifest on a+    -- machine that deliberately does not have every artifact installed.+    force :: !Bool+  }+  deriving stock (Eq, Show, Generic)++-- | Terminal outcome of an upgrade run, decoupled from printing and exit codes+-- so it can be asserted on directly.+data UpgradeOutcome+  = -- | The manifest is already at the current schema version.+    UpgradeNotNeeded+  | -- | @--dry-run@: the document was converted and thrown away. Carries any+    -- check that would have blocked a real write.+    UpgradeWouldWrite UpgradeResult ![ArtifactCheck]+  | -- | The converted document was written over the manifest.+    UpgradeWritten UpgradeResult+  | -- | The conversion succeeded but writing it would leave the project+    -- naming artifacts this machine cannot satisfy, so nothing was written.+    UpgradeBlocked UpgradeResult ![ArtifactCheck]+  | -- | Nothing was written; carries the message to show the user.+    UpgradeFailed Text+  deriving stock (Eq, Show, Generic)++-- | Testable core of @seihou manifest upgrade@: read the manifest in the+-- current directory, infer an origin for every recorded path, rewrite the+-- document, and — unless this is a dry run — write it back.+runManifestUpgrade :: ManifestUpgradeOpts -> IO UpgradeOutcome+runManifestUpgrade opts = do+  projectRoot <- getCurrentDirectory+  let manifestPath = projectRoot </> manifestRelativePath+  present <- doesFileExist manifestPath+  if not present+    then+      pure+        ( UpgradeFailed+            ( "No "+                <> T.pack manifestRelativePath+                <> " here. Run this from the root of a project seihou has generated into."+            )+        )+    else do+      bytes <- LBS.readFile manifestPath+      case readLegacyManifest bytes of+        Left err -> pure (UpgradeFailed (T.pack manifestRelativePath <> " could not be read: " <> T.pack err))+        Right Nothing -> pure UpgradeNotNeeded+        Right (Just legacy) -> do+          searchPaths <- defaultSearchPaths+          conversions <-+            traverse+              (\ref -> (ref,) <$> inferOriginFromLegacyPath projectRoot searchPaths ref)+              (legacy ^. #refs)+          let result = applyUpgrade legacy conversions+          case validateUpgrade result of+            Left err -> pure (UpgradeFailed err)+            Right manifest -> do+              blocking <-+                if opts ^. #force+                  then pure []+                  else blockingChecks <$> checkAppliedArtifacts projectRoot searchPaths manifest+              if opts ^. #dryRun+                then pure (UpgradeWouldWrite result blocking)+                else+                  if null blocking+                    then do+                      writeDocument manifestPath (result ^. #upgradedDocument)+                      pure (UpgradeWritten result)+                    else pure (UpgradeBlocked result blocking)++-- | Decode the converted document with the ordinary manifest decoder, which+-- turns the write into a correctness check: whatever is about to land on disk+-- is proven readable by every command that will read it.+validateUpgrade :: UpgradeResult -> Either Text Manifest+validateUpgrade result =+  case Aeson.fromJSON (result ^. #upgradedDocument) of+    Aeson.Error err ->+      Left+        ( "The converted manifest is not one this build can read, so nothing was\n\+          \written. This is a bug in 'seihou manifest upgrade'; please report it.\n\n\+          \  "+            <> T.pack err+        )+    Aeson.Success manifest -> Right manifest++-- | Write the converted document, atomically.+--+-- The bytes are the rewritten 'Aeson.Value' rather than a re-encoded+-- 'Manifest', so any field this build does not know about survives the round+-- trip. That rules out reusing 'Seihou.Effect.ManifestStore.writeManifest',+-- which encodes a typed manifest, so the write-to-temp-then-rename it performs+-- is replicated here.+writeDocument :: FilePath -> Aeson.Value -> IO ()+writeDocument manifestPath document = do+  let temporaryPath = manifestPath <> ".tmp"+  LBS.writeFile temporaryPath (Aeson.encode document)+  renamePath temporaryPath manifestPath++-- | Explain why an upgrade this machine cannot satisfy was not written.+--+-- The blocking verdicts are the guard's, but the remedy is this command's, so+-- the wording is here rather than reusing+-- 'Seihou.CLI.ManifestGuard.formatGuardRefusal' — that one ends by naming+-- @--allow-downgrade@, which is a flag on @seihou run@ and @seihou migrate@,+-- not on this command.+formatUpgradeRefusal :: Text -> [ArtifactCheck] -> Text+formatUpgradeRefusal leadIn checks =+  T.unlines $+    [leadIn, ""]+      <> ["  " <> summary | Just summary <- map summarizeCheck checks]+      <> [ "",+           "Upgrading now would record what this machine can see rather than what",+           "the project uses: an artifact that is missing or stale here converts to",+           "an origin seihou had to guess at, and that guess would be committed.",+           "",+           "Install or upgrade the artifacts above and run this again, or re-run",+           "with --force to accept the conversions exactly as shown."+         ]++-- | Print the outcome and exit non-zero on failure.+handleManifestUpgrade :: ManifestUpgradeOpts -> IO ()+handleManifestUpgrade opts = do+  outcome <- runManifestUpgrade opts+  case outcome of+    UpgradeNotNeeded ->+      TIO.putStrLn+        ( "✓ "+            <> T.pack manifestRelativePath+            <> " is already at schema version "+            <> T.pack (show currentManifestVersion)+            <> "; nothing to do."+        )+    UpgradeWouldWrite result blocking -> do+      TIO.putStr (formatUpgradeReport result)+      unless (null blocking) $+        TIO.putStr (formatUpgradeRefusal "! Without --force, this upgrade would be refused." blocking)+      TIO.putStrLn "--dry-run: nothing was written."+    UpgradeBlocked result blocking -> do+      TIO.putStr (formatUpgradeReport result)+      TIO.putStr+        ( formatUpgradeRefusal+            ("✗ Refusing to write " <> T.pack manifestRelativePath <> ".")+            blocking+        )+      exitFailure+    UpgradeWritten result -> do+      TIO.putStr (formatUpgradeReport result)+      TIO.putStrLn+        ( "✓ Upgraded "+            <> T.pack manifestRelativePath+            <> " to schema version "+            <> T.pack (show currentManifestVersion)+            <> "."+        )+      TIO.putStrLn ("  Review the diff and commit it: git diff " <> T.pack manifestRelativePath)+    UpgradeFailed message -> do+      TIO.putStrLn message+      exitFailure++-- ----------------------------------------------------------------------------+-- Small JSON accessors+-- ----------------------------------------------------------------------------++-- | Pair every element of a list with its index, rendered as the text an+-- array position takes inside a pointer.+withIndices :: [a] -> [(Text, a)]+withIndices = zip (map (T.pack . show) [(0 :: Int) ..])++objectAt :: Aeson.Value -> Key -> Maybe Aeson.Value+objectAt (Aeson.Object fields) name = KeyMap.lookup name fields+objectAt _ _ = Nothing++textAt :: Aeson.Value -> Key -> Maybe Text+textAt value name = case objectAt value name of+  Just (Aeson.String text) -> Just text+  _ -> Nothing++arrayAt :: Aeson.Value -> Key -> [Aeson.Value]+arrayAt value name = case objectAt value name of+  Just (Aeson.Array elements) -> toList elements+  _ -> []
src/Seihou/CLI/Migrate.hs view
@@ -21,12 +21,13 @@ 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 GHC.Generics (Generic) import Seihou.CLI.CommitMessage (generateCommitMessage) import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo) import Seihou.CLI.InstallShared@@ -35,7 +36,16 @@     installModuleDir,     readOriginInfo,   )+import Seihou.CLI.ManifestGuard+  ( ArtifactCheck,+    blockingChecks,+    checkAppliedArtifactsFor,+    formatGuardOverride,+    formatGuardRefusal,+  )+import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.CLI.Style (bold, dim, green, red, useColor, yellow)+import Seihou.Core.ArtifactRef (ArtifactRefError, renderArtifactRefError) import Seihou.Core.Migration   ( Migration (..),     MigrationOp (..),@@ -43,6 +53,7 @@     MigrationPlanError (..),     planMigrationChain,   )+import Seihou.Core.Module (defaultSearchPaths) import Seihou.Core.Registry   ( Registry (..),     RegistryEntry (..),@@ -70,7 +81,7 @@     executeMigration,   ) import Seihou.Prelude-import System.Directory (doesFileExist)+import System.Directory (doesFileExist, getCurrentDirectory) import System.Exit (ExitCode (..), exitFailure, exitSuccess) import System.FilePath (takeFileName, (</>)) import System.IO (stderr)@@ -83,27 +94,27 @@ -- | Options for @seihou migrate@: applies module-declared migrations to -- the current project's working tree and manifest. data MigrateOpts = MigrateOpts-  { migrateModule :: ModuleName,+  { 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.-    migrateTo :: Maybe Text,-    migrateDryRun :: Bool,+    to :: !(Maybe Text),+    dryRun :: !Bool,     -- | Proceed even when the plan touches files the user has edited     -- since they were generated. Mirrors @seihou remove --force@.-    migrateForce :: Bool,-    migrateJson :: Bool,-    migrateVerbose :: Bool,+    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).-    migrateNoFetch :: Bool,+    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@@ -111,10 +122,23 @@     -- generated by 'Seihou.CLI.CommitMessage.generateCommitMessage'.     -- Has no effect for dry-run or no-op outcomes. Has no effect     -- outside a git work tree.-    migrateCommit :: Bool,-    -- | Custom commit message; implies @migrateCommit = True@.+    commit :: !Bool,+    -- | Custom commit message; implies @commit = True@.     -- When 'Nothing', the AI-generated message is used.-    migrateCommitMessage :: Maybe Text+    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) @@ -136,6 +160,13 @@   | 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.@@ -166,7 +197,7 @@ handleMigrate :: MigrateOpts -> IO () handleMigrate opts = do   let manifestPath = ".seihou" </> "manifest.json"-      modName = opts.migrateModule+      modName = (opts ^. #module_)    manifestRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest   manifest <- case manifestRes of@@ -178,14 +209,34 @@     Nothing -> die (MigrateModuleNotApplied modName)     Just am -> pure am -  _fromV <- case applied.moduleVersion >>= parseVersion of+  _fromV <- case applied ^. #moduleVersion >>= parseVersion of     Just v -> pure v-    Nothing -> case applied.moduleVersion of+    Nothing -> case applied ^. #moduleVersion of       Nothing -> die (MigrateNoRecordedVersion modName)       Just t -> die (MigrateUnparseableManifestVersion t) -  result <- runMigrate opts manifest applied.source+  -- 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@@ -193,13 +244,13 @@       TIO.putStrLn $         applyColor colorEnabled green "✓"           <> " "-          <> modName.unModuleName+          <> modName ^. #unModuleName           <> " is already at version "           <> renderVersion toV           <> "; nothing to do."       exitSuccess     Right (MigrateDryRunOK plan fromV toV) -> do-      if opts.migrateJson+      if opts ^. #json         then LBS.putStr (encodePretty (planToJson plan))         else do           renderPlan colorEnabled plan fromV toV@@ -207,21 +258,21 @@           TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)"       exitSuccess     Right (MigrateApplied plan manifest' fromV toV) -> do-      if opts.migrateJson+      if opts ^. #json         then LBS.putStr (encodePretty (planToJson plan))         else renderPlan colorEnabled plan fromV toV       runEff $         runFilesystem $           runManifestStore manifestPath $             writeManifest manifest'-      when (opts.migrateCommit || isJust opts.migrateCommitMessage) $+      when (opts ^. #commit || isJust (opts ^. #commitMessage)) $         commitMigratedFiles opts manifestPath plan-      unless opts.migrateJson $ do+      unless (opts ^. #json) $ do         TIO.putStrLn ""         TIO.putStrLn $           applyColor colorEnabled green "✓"             <> " Migrated "-            <> applyColor colorEnabled bold modName.unModuleName+            <> applyColor colorEnabled bold (modName ^. #unModuleName)             <> " "             <> renderVersion fromV             <> " → "@@ -232,7 +283,7 @@ -- 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.migrateNoFetch@:+-- Behavior depends on @opts.noFetch@: -- --   * @True@ — operate purely on the supplied @installedDir@. This is --     the legacy behavior used by @seihou upgrade --with-migrations@,@@ -251,7 +302,7 @@   FilePath ->   IO (Either MigrateError MigrateResult) runMigrate opts manifest installedDir-  | opts.migrateNoFetch = runMigrateLocal opts manifest installedDir+  | (opts ^. #noFetch) = runMigrateLocal opts manifest installedDir   | otherwise = runMigrateWithFetch opts manifest installedDir  -- | Plan and (optionally) execute a migration chain using @sourceDir@@@ -265,10 +316,10 @@   FilePath ->   IO (Either MigrateError MigrateResult) runMigrateLocal opts manifest sourceDir = do-  let modName = opts.migrateModule+  let modName = (opts ^. #module_)   case findApplied manifest modName of     Nothing -> pure (Left (MigrateModuleNotApplied modName))-    Just applied -> case applied.moduleVersion of+    Just applied -> case applied ^. #moduleVersion of       Nothing -> pure (Left (MigrateNoRecordedVersion modName))       Just fromText ->         case parseVersion fromText of@@ -300,8 +351,8 @@                     Left e -> pure (Left e)                     Right toV ->                       case planMigrationChain-                        modName.unModuleName-                        sourceModule.migrations+                        (modName ^. #unModuleName)+                        (sourceModule ^. #migrations)                         fromV                         toV of                         Left e -> pure (Left (MigratePlanFailed e))@@ -337,19 +388,19 @@       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+      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.migrateModule of+          case findRemoteModuleDir cloneDir contents (opts ^. #module_) of             Nothing -> do               note opts $                 "  module '"-                  <> opts.migrateModule.unModuleName+                  <> opts ^. #module_ . #unModuleName                   <> "' not present in remote; using locally installed copy."               runMigrateLocal opts manifest installedDir             Just (moduleDir, tags) -> do@@ -370,7 +421,7 @@               -- and no-op outcomes leave it untouched.               case result of                 Right (MigrateApplied {})-                  | not opts.migrateDryRun ->+                  | not (opts ^. #dryRun) ->                       refreshInstalledFromClone moduleDir installedDir o tags                 _ -> pure ()               pure result@@ -400,13 +451,13 @@ resultStepCount :: MigrateResult -> Int resultStepCount = \case   MigrateNoOp {} -> 0-  MigrateApplied execPlan _ _ _ -> length execPlan.planSource.planSteps-  MigrateDryRunOK execPlan _ _ -> length execPlan.planSource.planSteps+  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.migrateJson (TIO.putStrLn msg)+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@@ -420,8 +471,8 @@ 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)+    case filter (\e -> e ^. #name == modName) (registry ^. #modules) of+      (entry : _) -> Just (cloneDir </> entry ^. #path, entry ^. #tags)       [] -> Nothing   SingleRecipe _ -> Nothing   SingleBlueprint _ -> Nothing@@ -449,9 +500,9 @@       installModuleDir         moduleDir         installedName-        origin.sourceUrl-        origin.repoName-        modul.version+        (origin ^. #sourceUrl)+        (origin ^. #repoName)+        (modul ^. #version)         tags  -- ----------------------------------------------------------------------------@@ -476,13 +527,13 @@   Module ->   Maybe MigrationPlan pendingChainFor applied installed = do-  fromText <- applied.moduleVersion+  fromText <- (applied ^. #moduleVersion)   fromV <- parseVersion fromText-  toText <- installed.version+  toText <- (installed ^. #version)   toV <- parseVersion toText   case planMigrationChain-    applied.name.unModuleName-    installed.migrations+    (applied ^. #name . #unModuleName)+    (installed ^. #migrations)     fromV     toV of     Right (Just plan) -> Just plan@@ -498,8 +549,8 @@ -- print. -- -- The plan from the gap-tolerant walker is always one shape — an--- ordered list of in-window migrations plus the supplied @planFrom@--- and @planTo@. The dispatcher branches only on @planFrom == planTo@+-- 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 ->@@ -507,13 +558,13 @@   MigrationPlan ->   IO (Either MigrateError MigrateResult) dispatchPlan opts manifest plan-  | plan.planFrom == plan.planTo = pure (Right (MigrateNoOp plan.planTo))+  | 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 @planTo@.+-- manifest's recorded @moduleVersion@ to @to@. applyOrDryRun ::   MigrateOpts ->   Manifest ->@@ -527,19 +578,19 @@   case classifyResult of     Left err -> pure (Left (MigrateExecFailed err))     Right executedPlan ->-      if opts.migrateDryRun-        then pure (Right (MigrateDryRunOK executedPlan plan.planFrom plan.planTo))+      if opts ^. #dryRun+        then pure (Right (MigrateDryRunOK executedPlan (plan ^. #from) (plan ^. #to)))         else do           now <- getCurrentTime           execRes <-             runEff $               runFilesystem $                 runProcessIO $-                  executeMigration opts.migrateForce executedPlan manifest now+                  executeMigration (opts ^. #force) executedPlan manifest now           case execRes of             Left err -> pure (Left (MigrateExecFailed err))             Right manifest' ->-              pure (Right (MigrateApplied executedPlan manifest' plan.planFrom plan.planTo))+              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@@ -555,7 +606,7 @@   ExecutedMigrationPlan ->   IO () commitMigratedFiles opts manifestPath plan = do-  let touched = concatMap pathsForOp plan.planOps+  let touched = concatMap pathsForOp (plan ^. #ops)       filesToStage = touched ++ [manifestPath]   inGit <- runEff $ runProcessIO isGitRepo   when inGit $ do@@ -566,11 +617,11 @@       case addExit of         ExitFailure _ -> TIO.hPutStrLn stderr ("git add failed: " <> addErr)         ExitSuccess -> do-          msg <- case opts.migrateCommitMessage of+          msg <- case opts ^. #commitMessage of             Just m -> pure m             Nothing -> do               diffText <- runEff $ runProcessIO gitDiffCached-              generateCommitMessage [opts.migrateModule] diffText+              generateCommitMessage [opts ^. #module_] diffText           (cExit, _, cErr) <- runEff $ runProcessIO $ gitCommit msg           case cExit of             ExitSuccess -> pure ()@@ -587,11 +638,11 @@ resolveTarget ::   MigrateOpts -> Module -> ModuleName -> FilePath -> Either MigrateError Version resolveTarget opts installedModule modName installedDhall =-  case opts.migrateTo of+  case opts ^. #to of     Just t -> case parseVersion t of       Just v -> Right v       Nothing -> Left (MigrateUnparseableTargetVersion t)-    Nothing -> case installedModule.version of+    Nothing -> case installedModule ^. #version of       Nothing -> Left (MigrateInstalledModuleHasNoVersion modName installedDhall)       Just t -> case parseVersion t of         Just v -> Right v@@ -599,34 +650,34 @@  findApplied :: Manifest -> ModuleName -> Maybe AppliedModule findApplied m name =-  case filter (\am -> am.name == name) m.modules of+  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 @planFrom@ and @planTo@; the manifest will land at--- @planTo@ even when 'planSteps' is empty.+-- 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.planSource+  let src = (plan ^. #source)   TIO.putStrLn $     "Migration plan: "-      <> applyColor c bold (src.planModule)+      <> applyColor c bold (src ^. #module_)       <> "  "       <> renderVersion fromV       <> " → "       <> renderVersion toV-  if null src.planSteps+  if null (src ^. #steps)     then TIO.putStrLn "  (no migration ops)"-    else mapM_ (renderStep c) src.planSteps+    else mapM_ (renderStep c) (src ^. #steps)   let conflictCount =         length-          [ () | inst <- plan.planOps, isConflict inst+          [ () | inst <- plan ^. #ops, isConflict inst           ]       affectedCount =         length-          [ () | inst <- plan.planOps, touchesFs inst+          [ () | inst <- plan ^. #ops, touchesFs inst           ]   TIO.putStrLn ""   TIO.putStrLn $@@ -644,8 +695,8 @@  renderStep :: Bool -> Migration -> IO () renderStep c step = do-  TIO.putStrLn $ "  " <> step.from <> " → " <> step.to <> ":"-  mapM_ (renderOp c) step.ops+  TIO.putStrLn $ "  " <> step ^. #from <> " → " <> step ^. #to <> ":"+  mapM_ (renderOp c) (step ^. #ops)  renderOp :: Bool -> MigrationOp -> IO () renderOp c op = case op of@@ -669,20 +720,20 @@  planToJson :: ExecutedMigrationPlan -> Aeson.Value planToJson plan =-  let src = plan.planSource+  let src = (plan ^. #source)    in object-        [ "module" .= plan.planModule.unModuleName,-          "from" .= renderVersion src.planFrom,-          "to" .= renderVersion src.planTo,+        [ "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+                   [ "from" .= (step ^. #from),+                     "to" .= (step ^. #to),+                     "ops" .= map opToJson (step ^. #ops)                    ]-               | step <- src.planSteps+               | step <- src ^. #steps                ],-          "operations" .= map instToJson plan.planOps+          "operations" .= map instToJson (plan ^. #ops)         ]  opToJson :: MigrationOp -> Aeson.Value@@ -747,16 +798,16 @@ 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."+  "module '" <> modName ^. #unModuleName <> "' is not applied in this project." renderError (MigrateNoRecordedVersion modName) =   "module '"-    <> modName.unModuleName+    <> 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+    <> modName ^. #unModuleName     <> "' at "     <> T.pack path     <> " has no version field; either pass --to or add a version to its module.dhall."@@ -768,6 +819,10 @@   "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) =
src/Seihou/CLI/PendingMigrations.hs view
@@ -4,10 +4,12 @@   ) where +import Data.Generics.Labels () import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as T import Seihou.CLI.Migrate (pendingChainFor)+import Seihou.CLI.Shared (resolveAppliedArtifactDir) import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types   ( AppliedModule (..),@@ -17,7 +19,6 @@ import Seihou.Core.Version (renderVersion) import Seihou.Dhall.Eval (evalModuleFromFile) import Seihou.Prelude-import System.Directory (doesFileExist)  -- | Detect pending migrations across applied modules in a manifest. --@@ -48,19 +49,23 @@     (mapM check candidates)   where     candidates = case mFilter of-      Nothing -> manifest.modules-      Just names -> filter (\am -> Set.member am.name names) manifest.modules+      Nothing -> (manifest ^. #modules)+      Just names -> filter (\am -> Set.member (am ^. #name) names) (manifest ^. #modules) +    -- The manifest records a portable origin, so the module has to be located+    -- on this machine first. A module that does not resolve here is skipped+    -- like any other read failure: detection is best-effort, and the command+    -- that actually needs the module reports the resolution error properly.     check am = do-      let dhallFile = am.source </> "module.dhall"-      exists <- doesFileExist dhallFile-      if not exists-        then pure (am.name, Nothing)-        else do+      resolved <- resolveAppliedArtifactDir "module.dhall" (am ^. #origin)+      case resolved of+        Left _ -> pure (am ^. #name, Nothing)+        Right directory -> do+          let dhallFile = directory </> "module.dhall"           r <- evalModuleFromFile dhallFile           case r of-            Left _ -> pure (am.name, Nothing)-            Right installed -> pure (am.name, pendingChainFor am installed)+            Left _ -> pure (am ^. #name, Nothing)+            Right installed -> pure (am ^. #name, pendingChainFor am installed)  -- | Format the user-facing refusal message that @seihou run@ prints -- when it detects pending migrations and the user has not opted into@@ -79,11 +84,11 @@   where     renderEntry (name, plan) =       "  "-        <> name.unModuleName+        <> name ^. #unModuleName         <> ": "-        <> renderVersion plan.planFrom+        <> renderVersion (plan ^. #from)         <> " -> "-        <> renderVersion plan.planTo+        <> renderVersion (plan ^. #to)         <> " ("-        <> T.pack (show (length plan.planSteps))+        <> T.pack (show (length (plan ^. #steps)))         <> " step(s))"
src/Seihou/CLI/PromptRender.hs view
@@ -7,7 +7,9 @@   ) where +import Control.Lens ((^.)) import Data.FileEmbed (embedFile)+import Data.Generics.Labels () import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe)@@ -38,17 +40,17 @@   T.Text renderPromptSystemPrompt ctx prompt resolved renderedPrompt userPrompt =   substitute-    [ ("cwd", ctx.cwd),+    [ ("cwd", ctx ^. #cwd),       ("seihou_project_state", formatSeihouProjectState ctx),       ("manifest_state", formatManifestState ctx),       ("module_dhall_state", formatModuleDhallState ctx),       ("local_modules", formatLocalModules ctx),       ("available_modules", formatAvailableModules ctx),-      ("prompt_name", prompt.name.unModuleName),-      ("prompt_version", fromMaybe "(unspecified)" prompt.version),-      ("prompt_description", fromMaybe "(no description)" prompt.description),-      ("reference_files", formatReferenceFiles prompt.files),-      ("prompt_guidance", formatPromptGuidance resolved prompt.guidance),+      ("prompt_name", prompt ^. #name . #unModuleName),+      ("prompt_version", fromMaybe "(unspecified)" (prompt ^. #version)),+      ("prompt_description", fromMaybe "(no description)" (prompt ^. #description)),+      ("reference_files", formatReferenceFiles (prompt ^. #files)),+      ("prompt_guidance", formatPromptGuidance resolved (prompt ^. #guidance)),       ("prompt_body", renderedPrompt),       ("user_prompt", fromMaybe "(no one-off user instruction)" userPrompt)     ]@@ -57,7 +59,7 @@ renderPromptBody :: Map VarName ResolvedVar -> T.Text -> T.Text renderPromptBody resolved tpl =   substitute-    [(vn.unVarName, varValueToText rv.value) | (vn, rv) <- Map.toList resolved]+    [(vn ^. #unVarName, varValueToText (rv ^. #value)) | (vn, rv) <- Map.toList resolved]     tpl  formatPromptGuidance :: Map VarName ResolvedVar -> [PromptGuidance] -> T.Text@@ -66,18 +68,18 @@     [] -> "(no prompt guidance)"     selectedGuidance -> T.intercalate "\n\n" (map render selectedGuidance)   where-    bindings = Map.map (.value) resolved+    bindings = Map.map (^. #value) resolved      selected g =-      case g.condition of+      case g ^. #condition of         Nothing -> True         Just cond -> evalExpr bindings cond      render g =       T.unlines-        [ "### " <> g.title,+        [ "### " <> g ^. #title,           "",-          g.body+          g ^. #body         ]  varValueToText :: VarValue -> T.Text
src/Seihou/CLI/Registry/Sync.hs view
@@ -10,10 +10,10 @@   ) where +import Data.Generics.Labels () import Data.Maybe (mapMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO-import GHC.Generics (Generic) import Seihou.Core.Registry   ( EntryKind (..),     Registry (..),@@ -44,9 +44,9 @@  -- | Flags parsed for the @seihou registry sync-versions@ subcommand. data SyncVersionsOpts = SyncVersionsOpts-  { syncVersionsDir :: Maybe FilePath,-    syncVersionsDryRun :: Bool,-    syncVersionsCheck :: Bool+  { dir :: !(Maybe FilePath),+    dryRun :: !Bool,+    check :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -75,7 +75,7 @@ -- when appropriate, and returns a structured outcome. runSync :: SyncVersionsOpts -> IO SyncOutcome runSync opts = do-  let targetDir = maybe "." id opts.syncVersionsDir+  let targetDir = maybe "." id (opts ^. #dir)   dirExists <- doesDirectoryExist targetDir   if not dirExists     then pure (SyncFailure ("target directory does not exist: " <> T.pack targetDir))@@ -85,13 +85,13 @@         MultiModule reg -> do           lookups <- resolveOnDiskVersions targetDir reg           let report = computeRegistrySync reg lookups-          let checkMode = opts.syncVersionsCheck-              dryRun = opts.syncVersionsDryRun && not checkMode+          let checkMode = (opts ^. #check)+              dryRun = opts ^. #dryRun && not checkMode               writeMode = not checkMode && not dryRun           action <-             if writeMode               then do-                let rendered = renderRegistryDhall report.syncUpdated+                let rendered = renderRegistryDhall (report ^. #updated)                 TIO.writeFile (targetDir </> "seihou-registry.dhall") rendered                 pure Wrote               else@@ -114,39 +114,39 @@   Registry ->   IO [(EntryKind, ModuleName, Maybe Text)] resolveOnDiskVersions repoRoot reg = do-  modulePairs <- mapM (loadModule repoRoot) reg.modules-  recipePairs <- mapM (loadRecipe repoRoot) reg.recipes-  blueprintPairs <- mapM (loadBlueprint repoRoot) reg.blueprints-  promptPairs <- mapM (loadPrompt repoRoot) reg.prompts+  modulePairs <- mapM (loadModule repoRoot) (reg ^. #modules)+  recipePairs <- mapM (loadRecipe repoRoot) (reg ^. #recipes)+  blueprintPairs <- mapM (loadBlueprint repoRoot) (reg ^. #blueprints)+  promptPairs <- mapM (loadPrompt repoRoot) (reg ^. #prompts)   pure (concat modulePairs <> concat recipePairs <> concat blueprintPairs <> concat promptPairs)   where     loadModule :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)]     loadModule root entry = do-      let path = root </> entry.path </> "module.dhall"+      let path = root </> entry ^. #path </> "module.dhall"       decoded <- evalModuleFromFile path       case decoded of-        Right m -> pure [(ModuleEntry, entry.name, moduleVersion m)]+        Right m -> pure [(ModuleEntry, entry ^. #name, moduleVersion m)]         Left _ -> pure []     loadRecipe :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)]     loadRecipe root entry = do-      let path = root </> entry.path </> "recipe.dhall"+      let path = root </> entry ^. #path </> "recipe.dhall"       decoded <- evalRecipeFromFile path       case decoded of-        Right r -> pure [(RecipeEntry, entry.name, recipeVersion r)]+        Right r -> pure [(RecipeEntry, entry ^. #name, recipeVersion r)]         Left _ -> pure []     loadBlueprint :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)]     loadBlueprint root entry = do-      let path = root </> entry.path </> "blueprint.dhall"+      let path = root </> entry ^. #path </> "blueprint.dhall"       decoded <- evalBlueprintFromFile path       case decoded of-        Right b -> pure [(BlueprintEntry, entry.name, blueprintVersion b)]+        Right b -> pure [(BlueprintEntry, entry ^. #name, blueprintVersion b)]         Left _ -> pure []     loadPrompt :: FilePath -> RegistryEntry -> IO [(EntryKind, ModuleName, Maybe Text)]     loadPrompt root entry = do-      let path = root </> entry.path </> "prompt.dhall"+      let path = root </> entry ^. #path </> "prompt.dhall"       decoded <- evalAgentPromptFromFile path       case decoded of-        Right p -> pure [(PromptEntry, entry.name, promptVersion p)]+        Right p -> pure [(PromptEntry, entry ^. #name, promptVersion p)]         Left _ -> pure []  -- | Extract the @version@ field from a 'Module' by pattern match. A direct@@ -191,7 +191,7 @@ -- The first entry in 'syncDiffs' appears first, preserving registry order. renderSyncReport :: SyncReport -> Text renderSyncReport report-  | null report.syncDiffs =+  | null (report ^. #diffs) =       "Registry is empty.\n"   | otherwise =       T.unlines $@@ -200,23 +200,23 @@             <> ["", summary report]   where     header = "Updated seihou-registry.dhall:"-    rows = map renderRow report.syncDiffs+    rows = map renderRow (report ^. #diffs)      renderRow :: SyncDiff -> Text     renderRow diff =-      let label = kindPrefix diff.diffKind <> diff.diffName.unModuleName <> ":"+      let label = kindPrefix (diff ^. #kind) <> diff ^. #name . #unModuleName <> ":"           padded = padRight labelWidth label-          old = renderVersion diff.diffOld-          new = renderVersion diff.diffNew-          arrow = case diff.diffStatus of+          old = renderVersion (diff ^. #old)+          new = renderVersion (diff ^. #new)+          arrow = case diff ^. #status of             SyncInSync -> " == " <> new <> " (no change)"-            SyncOrphan -> " ?? " <> old <> " (" <> entryFile diff.diffKind <> " missing)"+            SyncOrphan -> " ?? " <> old <> " (" <> entryFile (diff ^. #kind) <> " missing)"             _ -> " -> " <> new        in padded <> old <> arrow -    labelWidth = maximum (24 : map diffLabelWidth report.syncDiffs)+    labelWidth = maximum (24 : map diffLabelWidth (report ^. #diffs))     diffLabelWidth d =-      T.length (kindPrefix d.diffKind <> d.diffName.unModuleName) + 2+      T.length (kindPrefix (d ^. #kind) <> d ^. #name . #unModuleName) + 2  kindPrefix :: EntryKind -> Text kindPrefix ModuleEntry = "modules."@@ -241,9 +241,9 @@  summary :: SyncReport -> Text summary report =-  let updated = length [d | d <- report.syncDiffs, changesVersion d.diffStatus]-      orphans = length [d | d <- report.syncDiffs, d.diffStatus == SyncOrphan]-      unchanged = length [d | d <- report.syncDiffs, d.diffStatus == SyncInSync]+  let updated = length [d | d <- report ^. #diffs, changesVersion (d ^. #status)]+      orphans = length [d | d <- report ^. #diffs, d ^. #status == SyncOrphan]+      unchanged = length [d | d <- report ^. #diffs, d ^. #status == SyncInSync]       base =         T.pack (show updated)           <> " "@@ -266,11 +266,11 @@ anyDrift :: SyncReport -> Bool anyDrift report =   any-    ( \d -> case d.diffStatus of+    ( \d -> case d ^. #status of         SyncInSync -> False         _ -> True     )-    report.syncDiffs+    (report ^. #diffs)  -- | Soft-warning pass: compare each registry entry's 'version' with the -- on-disk module.dhall / recipe.dhall and return one warning per out-of-sync@@ -284,4 +284,4 @@ checkRegistryVersionDrift repoRoot reg = do   lookups <- resolveOnDiskVersions repoRoot reg   let report = computeRegistrySync reg lookups-  pure (mapMaybe formatDriftWarning report.syncDiffs)+  pure (mapMaybe formatDriftWarning (report ^. #diffs))
src/Seihou/CLI/Registry/Validate.hs view
@@ -7,9 +7,9 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO-import GHC.Generics (Generic) import Seihou.CLI.Registry.Sync (resolveOnDiskVersions) import Seihou.Core.Registry   ( RegistryValidationIssue (..),@@ -28,7 +28,7 @@  -- | Flags parsed for the @seihou registry validate@ subcommand. data ValidateRegistryOpts = ValidateRegistryOpts-  { validateRegistryDir :: Maybe FilePath+  { validateRegistryDir :: !(Maybe FilePath)   }   deriving stock (Eq, Show, Generic) @@ -45,7 +45,7 @@ -- resolves each entry's on-disk version, and produces the unified report. runValidate :: ValidateRegistryOpts -> IO ValidateOutcome runValidate opts = do-  let target = maybe "." id opts.validateRegistryDir+  let target = maybe "." id (opts ^. #validateRegistryDir)   dirExists <- doesDirectoryExist target   if not dirExists     then pure (ValidateFailed ("target directory does not exist: " <> T.pack target))@@ -82,37 +82,37 @@ -- line on failure. renderValidationReport :: RegistryValidationReport -> Text renderValidationReport r-  | null r.reportIssues =+  | null (r ^. #issues) =       T.unlines         [ "OK: "-            <> T.pack (show r.reportModuleCount)+            <> T.pack (show (r ^. #moduleCount))             <> " "-            <> pluralize r.reportModuleCount "module" "modules"+            <> pluralize (r ^. #moduleCount) "module" "modules"             <> ", "-            <> T.pack (show r.reportRecipeCount)+            <> T.pack (show (r ^. #recipeCount))             <> " "-            <> pluralize r.reportRecipeCount "recipe" "recipes"+            <> pluralize (r ^. #recipeCount) "recipe" "recipes"             <> ", "-            <> T.pack (show r.reportBlueprintCount)+            <> T.pack (show (r ^. #blueprintCount))             <> " "-            <> pluralize r.reportBlueprintCount "blueprint" "blueprints"+            <> pluralize (r ^. #blueprintCount) "blueprint" "blueprints"             <> ", "-            <> T.pack (show r.reportPromptCount)+            <> T.pack (show (r ^. #promptCount))             <> " "-            <> pluralize r.reportPromptCount "prompt" "prompts"+            <> pluralize (r ^. #promptCount) "prompt" "prompts"             <> ", all versions in sync."         ]   | otherwise =       T.unlines $         ["errors:"]-          <> map (("  " <>) . formatValidationIssue) r.reportIssues+          <> map (("  " <>) . formatValidationIssue) (r ^. #issues)           <> [""]           <> [summary r]  summary :: RegistryValidationReport -> Text summary r =-  let n = length r.reportIssues-      hasVersionDrift = any isVersionMismatch r.reportIssues+  let n = length (r ^. #issues)+      hasVersionDrift = any isVersionMismatch (r ^. #issues)       base = T.pack (show n) <> " " <> pluralize n "error" "errors"       tail_ =         if hasVersionDrift
src/Seihou/CLI/RemoteVersion.hs view
@@ -5,6 +5,7 @@   ) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Registry (Registry (..), RegistryEntry (..), RepoContents (..), discoverRepoContents) import Seihou.Core.Types (Module (..), ModuleName (..))@@ -59,7 +60,7 @@     MultiModule registry -> case findEntry registry of       Nothing -> pure (Left (EntryNotFound name))       Just entry ->-        readModuleDhallVersion (clonedRepoPath </> entry.path </> "module.dhall")+        readModuleDhallVersion (clonedRepoPath </> entry ^. #path </> "module.dhall")     SingleRecipe _ -> pure (Left (RegistryNotFound clonedRepoPath))     SingleBlueprint _ -> pure (Left (RegistryNotFound clonedRepoPath))     SinglePrompt _ -> pure (Left (RegistryNotFound clonedRepoPath))@@ -67,7 +68,7 @@   where     findEntry :: Registry -> Maybe RegistryEntry     findEntry registry =-      case filter (\e -> e.name == name) registry.modules of+      case filter (\e -> e ^. #name == name) (registry ^. #modules) of         (entry : _) -> Just entry         [] -> Nothing @@ -81,7 +82,7 @@       result <- evalModuleFromFile path       case result of         Left err -> pure (Left (ParseFailed (T.pack (show err))))-        Right modul -> pure (Right modul.version)+        Right modul -> pure (Right (modul ^. #version))  -- | Render a 'FetchError' as a single-line human-readable message suitable -- for printing in CLI output ("could not determine remote version: ...").
src/Seihou/CLI/SavePrompted.hs view
@@ -5,6 +5,7 @@ where  import Control.Monad (when)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Composition.Instance (ModuleInstance)@@ -28,8 +29,8 @@             | vs <- Map.elems resolved             ]       promptedOnly rv =-        case rv.source of-          FromPrompt -> Just (varValueToText rv.value)+        case rv ^. #source of+          FromPrompt -> Just (varValueToText (rv ^. #value))           _ -> Nothing    in [ (vn, val, existing)       | (vn, val) <- allPrompted,
src/Seihou/CLI/SchemaVersion.hs view
@@ -9,11 +9,11 @@  -- | Raw URL for the seihou-schema package.dhall at a pinned commit schemaUrl :: Text-schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/2dffa0592be47835a60784b89a289226ba990aa8/package.dhall"+schemaUrl = "https://raw.githubusercontent.com/shinzui/seihou-schema/0e1b875efcf2b4e4b98d93595ea627290459e3ad/package.dhall"  -- | SHA256 integrity hash for the schema import schemaHash :: Text-schemaHash = "sha256:01b6f873520459f3958baa34d3f97a49a4263b9a7225a758cddca5ab3a911f61"+schemaHash = "sha256:356829d4e2b333ce157615dd7eccd0cd4765f3ef0d94ef637fa8c97398d3b92c"  -- | Complete Dhall import line for use in generated modules schemaImportLine :: Text
src/Seihou/CLI/Shared.hs view
@@ -7,19 +7,37 @@     logIO,     unwrapConfig,     shortenHome,+    resolveAppliedArtifactDir,   ) where +import Data.Generics.Labels () import Data.List (isPrefixOf) import Data.Map.Strict qualified as Map import Data.Text qualified as T+import Seihou.Core.ArtifactRef (ArtifactRefError, resolveArtifactOrigin)+import Seihou.Core.Module (defaultSearchPaths) import Seihou.Core.Types import Seihou.Effect.Logger (Logger, logError) import Seihou.Effect.LoggerInterp (runLoggerIO) import Seihou.Prelude-import System.Directory (getHomeDirectory)+import System.Directory (getCurrentDirectory, getHomeDirectory) import System.Exit (exitFailure) +-- | Locate, on this machine, the artifact an origin recorded in the manifest+-- names.+--+-- Every command that re-reads an artifact after the fact goes through here,+-- so they all search the same places and all fail with the same wording. The+-- project root is the current working directory, which is what the commands+-- already assume when they build the manifest path as+-- @.seihou\/manifest.json@.+resolveAppliedArtifactDir :: FilePath -> ArtifactOrigin -> IO (Either ArtifactRefError FilePath)+resolveAppliedArtifactDir definitionFile origin = do+  projectRoot <- getCurrentDirectory+  searchPaths <- defaultSearchPaths+  resolveArtifactOrigin projectRoot searchPaths definitionFile origin+ -- | Format a 'VarError' for display in CLI output. formatVarError :: VarError -> Text formatVarError (MissingRequiredVar (VarName n)) = "missing required variable: " <> n@@ -44,9 +62,9 @@ formatBlueprintRefusal name =   T.intercalate     "\n"-    [ "'" <> name.unModuleName <> "' is a blueprint, not a module or recipe.",+    [ "'" <> name ^. #unModuleName <> "' is a blueprint, not a module or recipe.",       "Blueprints must be run interactively via:",-      "  seihou agent run " <> name.unModuleName+      "  seihou agent run " <> name ^. #unModuleName     ]  -- | Derive the namespace from a module name by taking the prefix before the first hyphen.
src/Seihou/CLI/StatusRender.hs view
@@ -1,10 +1,13 @@ module Seihou.CLI.StatusRender   ( formatStatus,+    formatArtifactChecks,     formatBlueprintMigrations,     ModuleAdvice (..),   ) where +import Control.Lens (to, (^.))+import Data.Generics.Labels () import Data.List (intersperse, nub) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map@@ -13,6 +16,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Time.Format (defaultTimeLocale, formatTime)+import Seihou.CLI.ManifestGuard (ArtifactCheck, summarizeCheck) import Seihou.CLI.Style (dim, green, red, yellow) import Seihou.CLI.VersionCompare   ( OutdatedEntry (..),@@ -62,7 +66,7 @@     ["Seihou Status:", ""]       ++ recipeSection manifest       ++ blueprintSection manifest-      ++ formatBlueprintMigrations manifest.blueprintMigrations+      ++ formatBlueprintMigrations (manifest ^. #blueprintMigrations)       ++ appliedSection color manifest mEntries pendings       ++ trackedSection color tracked       ++ varsSection manifest@@ -70,10 +74,10 @@       ++ recommendedActionsSection adviceList   where     entryMap = case mEntries of-      Just es -> Map.fromList [(e.moduleName, e) | e <- es]+      Just es -> Map.fromList [(e ^. #moduleName, e) | e <- es]       Nothing -> Map.empty     pendingMap =-      Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings]+      Map.fromList [(name ^. #unModuleName, plan) | (name, plan) <- pendings]     adviceList = projectAdviceList manifest entryMap pendingMap  -- ---------------------------------------------------------------------------@@ -81,12 +85,12 @@ -- ---------------------------------------------------------------------------  recipeSection :: Manifest -> [Text]-recipeSection manifest = case manifest.recipe of+recipeSection manifest = case manifest ^. #recipe of   Nothing -> []   Just ar ->     [ "Recipe: "-        <> ar.name.unRecipeName-        <> maybe "" (\v -> " v" <> v) ar.recipeVersion,+        <> ar ^. #name . #unRecipeName+        <> maybe "" (\v -> " v" <> v) (ar ^. #recipeVersion),       ""     ] @@ -98,18 +102,18 @@ -- two empty-baseline placeholders. -- Prompt line: present only when the user passed a positional prompt. blueprintSection :: Manifest -> [Text]-blueprintSection manifest = case manifest.blueprint of+blueprintSection manifest = case manifest ^. #blueprint of   Nothing -> []   Just ab ->     let header =           "Blueprint: "-            <> ab.name.unModuleName-            <> maybe "" (\v -> " v" <> v) ab.blueprintVersion+            <> ab ^. #name . #unModuleName+            <> maybe "" (\v -> " v" <> v) (ab ^. #blueprintVersion)             <> " (applied "-            <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" ab.appliedAt)+            <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" (ab ^. #appliedAt))             <> ")"         baselineLine = "  Baseline: " <> renderBaseline ab-        promptLines = case ab.userPrompt of+        promptLines = case ab ^. #userPrompt of           Nothing -> []           Just p -> ["  Prompt: \"" <> p <> "\""]      in [header, baselineLine] ++ promptLines ++ [""]@@ -125,14 +129,14 @@   where     renderReceipt receipt =       "  "-        <> receipt.name.unModuleName-        <> maybe "" (\version -> " v" <> version) receipt.blueprintVersion+        <> receipt ^. #name . #unModuleName+        <> maybe "" (\version -> " v" <> version) (receipt ^. #blueprintVersion)         <> ": "-        <> receipt.fromVersion+        <> receipt ^. #fromVersion         <> " -> "-        <> receipt.toVersion+        <> receipt ^. #toVersion         <> " (applied "-        <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" receipt.appliedAt)+        <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" (receipt ^. #appliedAt))         <> ")"  -- | Render the baseline body for the blueprint section. Three cases:@@ -140,10 +144,10 @@ -- all, or one or more baseline modules were applied. renderBaseline :: AppliedBlueprint -> Text renderBaseline ab-  | ab.noBaseline = "(none -- --no-baseline)"-  | null ab.baselineModules = "(none declared)"+  | (ab ^. #noBaseline) = "(none -- --no-baseline)"+  | null (ab ^. #baselineModules) = "(none declared)"   | otherwise =-      T.intercalate ", " (map (.unModuleName) ab.baselineModules)+      T.intercalate ", " (map (^. #unModuleName) (ab ^. #baselineModules))  appliedSection ::   Bool ->@@ -157,21 +161,21 @@     ++ [""]   where     entryMap = case mEntries of-      Just es -> Map.fromList [(e.moduleName, e) | e <- es]+      Just es -> Map.fromList [(e ^. #moduleName, e) | e <- es]       Nothing -> Map.empty     pendingMap =-      Map.fromList [(name.unModuleName, plan) | (name, plan) <- pendings]+      Map.fromList [(name ^. #unModuleName, plan) | (name, plan) <- pendings]     moduleLines-      | null manifest.modules = ["  (none)"]-      | otherwise = renderRows Set.empty manifest.modules+      | null (manifest ^. #modules) = ["  (none)"]+      | otherwise = renderRows Set.empty (manifest ^. #modules)     renderRows _ [] = []     renderRows seen (am : rest) =-      let name = am.name.unModuleName+      let name = (am ^. #name . #unModuleName)           annotation = lookupEntry mEntries entryMap am           headerLine = formatModuleLine color annotation am           hintLines             | Set.member name seen = []-            | null manifest.applications = formatAdvice color (rowProjectAdvice entryMap pendingMap am)+            | null (manifest ^. #applications) = formatAdvice color (rowProjectAdvice entryMap pendingMap am)             | otherwise = maybe [] (formatPendingDetail color) (Map.lookup name pendingMap)        in headerLine : hintLines <> renderRows (Set.insert name seen) rest @@ -184,18 +188,18 @@       )     ++ [""]   where-    maxPathLen = maximum (map (length . (.path)) tracked)-    maxModLen = maximum (map (T.length . displayModuleName . (.moduleName)) tracked)+    maxPathLen = maximum (map (length . (^. #path)) tracked)+    maxModLen = maximum (map (T.length . displayModuleName . (^. #moduleName)) tracked)  varsSection :: Manifest -> [Text] varsSection manifest =-  ["Variables: " <> T.pack (show (Map.size manifest.vars)) <> " resolved"]+  ["Variables: " <> T.pack (show (Map.size (manifest ^. #vars))) <> " resolved"]  updateSummarySection :: Maybe [OutdatedEntry] -> [Text] updateSummarySection Nothing = [] updateSummarySection (Just entries) =   let total = length entries-      outdated = length (filter (\e -> e.status == OutdatedSt) entries)+      outdated = length (filter (\e -> e ^. #status == OutdatedSt) entries)    in [ "",         T.pack (show total)           <> " module(s) checked, "@@ -212,6 +216,22 @@     [] -> []     cmds -> ["", "Recommended actions:"] ++ map ("  " <>) cmds +-- | Render the manifest guard's non-@ArtifactOk@ verdicts as a trailing+-- advisory block.+--+-- @seihou status@ is a reporting command and must never fail because of a+-- verdict — this block is precisely what lets a developer discover a stale or+-- mismatched module *before* @seihou run@ refuses to use it. Returns the empty+-- text when every artifact is healthy, so the section disappears entirely+-- rather than printing a reassuring "0 problems".+formatArtifactChecks :: Bool -> [ArtifactCheck] -> Text+formatArtifactChecks color checks = case mapMaybe summarizeCheck checks of+  [] -> ""+  summaries ->+    T.unlines $+      ["", applyColor color yellow "Artifacts that differ from what this project records:"]+        ++ map ("  " <>) summaries+ adviceCommand :: ModuleAdvice -> Maybe Text adviceCommand AdviceNone = Nothing adviceCommand (AdviceProjectUpdate target _) = Just ("seihou update " <> target)@@ -234,21 +254,21 @@   AppliedModule ->   UpdateAnnotation lookupEntry Nothing _ _ = NoCheck-lookupEntry (Just _) m am = case Map.lookup am.name.unModuleName m of+lookupEntry (Just _) m am = case Map.lookup (am ^. #name . #unModuleName) m of   Just e -> Entry e   Nothing -> NoOrigin  formatModuleLine :: Bool -> UpdateAnnotation -> AppliedModule -> Text formatModuleLine color annotation am =-  let verText = case am.moduleVersion of+  let verText = case am ^. #moduleVersion of         Just v -> "  " <> applyColor color green ("v" <> v)         Nothing -> ""       appliedText =         "    (applied "-          <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" am.appliedAt)+          <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" (am ^. #appliedAt))           <> ")"       parentVarsText =-        let m = am.parentVars.unParentVars+        let m = (am ^. #parentVars . #unParentVars)          in if Map.null m               then ""               else@@ -256,7 +276,7 @@                       T.concat                         ( intersperse                             ", "-                            [ vn.unVarName <> "=" <> v+                            [ vn ^. #unVarName <> "=" <> v                             | (vn, v) <- Map.toAscList m                             ]                         )@@ -267,7 +287,7 @@         NoOrigin -> "  " <> applyColor color dim "(no origin)"         Entry e -> "  " <> renderEntry color e    in "  "-        <> am.name.unModuleName+        <> am ^. #name . #unModuleName         <> parentVarsText         <> verText         <> appliedText@@ -288,11 +308,11 @@ projectPlanSummary :: Text -> MigrationPlan -> Text projectPlanSummary target plan =   "Pending migration: "-    <> renderVersion plan.planFrom+    <> renderVersion (plan ^. #from)     <> " -> "-    <> renderVersion plan.planTo+    <> renderVersion (plan ^. #to)     <> " ("-    <> T.pack (show (length plan.planSteps))+    <> T.pack (show (length (plan ^. #steps)))     <> " step(s)). Run: seihou update "     <> target @@ -303,11 +323,11 @@         color         yellow         ( "Pending migration: "-            <> renderVersion plan.planFrom+            <> renderVersion (plan ^. #from)             <> " -> "-            <> renderVersion plan.planTo+            <> renderVersion (plan ^. #to)             <> " ("-            <> T.pack (show (length plan.planSteps))+            <> T.pack (show (length (plan ^. #steps)))             <> " step(s))"         )   ]@@ -322,9 +342,9 @@     then AdviceProjectUpdate name pending     else AdviceNone   where-    name = applied.name.unModuleName+    name = (applied ^. #name . #unModuleName)     pending = Map.lookup name pendingMap-    outdated = maybe False ((== OutdatedSt) . (.status)) (Map.lookup name entryMap)+    outdated = maybe False ((== OutdatedSt) . (^. #status)) (Map.lookup name entryMap)     actionable = outdated || isJust pending  projectAdviceList ::@@ -333,32 +353,32 @@   Map Text MigrationPlan ->   [ModuleAdvice] projectAdviceList manifest entryMap pendingMap-  | null manifest.applications =-      map (rowProjectAdvice entryMap pendingMap) (deduplicateModules manifest.modules)+  | null (manifest ^. #applications) =+      map (rowProjectAdvice entryMap pendingMap) (deduplicateModules (manifest ^. #modules))   | otherwise =-      let applicationAdvice = mapMaybe adviceForApplication manifest.applications+      let applicationAdvice = mapMaybe adviceForApplication (manifest ^. #applications)        in applicationAdvice <> [AdviceProjectUpdateAll | length applicationAdvice > 1]   where     adviceForApplication application =-      let names = map (.name.unModuleName) application.instances+      let names = map (^. #name . #unModuleName) (application ^. #instances)           pending = listToMaybe (mapMaybe (`Map.lookup` pendingMap) names)-          outdated = any (maybe False ((== OutdatedSt) . (.status)) . (`Map.lookup` entryMap)) names+          outdated = any (maybe False ((== OutdatedSt) . (^. #status)) . (`Map.lookup` entryMap)) names        in if outdated || isJust pending-            then Just (AdviceProjectUpdate (targetText application.target) pending)+            then Just (AdviceProjectUpdate (targetText (application ^. #target)) pending)             else Nothing  deduplicateModules :: [AppliedModule] -> [AppliedModule]-deduplicateModules = Map.elems . Map.fromList . map (\applied -> (applied.name.unModuleName, applied))+deduplicateModules = Map.elems . Map.fromList . map (\applied -> (applied ^. #name . #unModuleName, applied))  targetText :: AppliedTarget -> Text-targetText (AppliedModuleTarget name) = name.unModuleName-targetText (AppliedRecipeTarget name) = name.unRecipeName+targetText (AppliedModuleTarget name) = (name ^. #unModuleName)+targetText (AppliedRecipeTarget name) = (name ^. #unRecipeName)  renderEntry :: Bool -> OutdatedEntry -> Text-renderEntry color e = case e.status of+renderEntry color e = case e ^. #status of   UpToDate -> applyColor color dim "up to date"   OutdatedSt ->-    let avail = maybe "?" id e.availableVersion+    let avail = maybe "?" id (e ^. #availableVersion)         txt = "outdated: " <> avail <> " available"      in applyColor color red txt   Unversioned -> applyColor color dim "unversioned"@@ -366,12 +386,12 @@  formatTrackedFile :: Bool -> Int -> Int -> TrackedFile -> Text formatTrackedFile color maxPathLen maxModLen tf =-  let path = T.pack tf.path-      modName = displayModuleName tf.moduleName+  let path = T.pack (tf ^. #path)+      modName = displayModuleName (tf ^. #moduleName)       paddedPath = path <> T.replicate (maxPathLen - T.length path + 3) " "       paddedMod = modName <> T.replicate (maxModLen - T.length modName + 3) " "-      label = statusLabel tf.status-      colored = applyColor color (statusColor tf.status) label+      label = statusLabel (tf ^. #status)+      colored = applyColor color (statusColor (tf ^. #status)) label    in "  " <> paddedPath <> paddedMod <> colored  displayModuleName :: ModuleName -> Text
src/Seihou/CLI/Style.hs view
@@ -13,6 +13,7 @@   ) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Core.Types (DiffResult (..), Module (..), ModuleName (..), VarName (..), VarValue (..))@@ -71,7 +72,10 @@   where     fileLines = [l | l@(FilePreview {}) <- lines']     nonFileLines = [l | l <- lines', not (isFilePreview' l)]-    maxPathLen = maximum (0 : map (T.length . T.pack . (.previewPath)) fileLines)+    -- PreviewLine is a sum type and `path` lives only in FilePreview, so this+    -- is a pattern match rather than a #path read: generic-lens can only build+    -- a lens for a field that every constructor has.+    maxPathLen = maximum (0 : [T.length (T.pack p) | FilePreview {path = p} <- lines'])  renderColorLine :: Int -> PreviewLine -> Text renderColorLine maxPath (FilePreview status path annotation mMod) =@@ -79,7 +83,7 @@       pathText = T.pack path       pathPad = T.replicate (maxPath - T.length pathText) " "       modSuffix = case mMod of-        Just mn -> ", " <> mn.unModuleName+        Just mn -> ", " <> (mn ^. #unModuleName)         Nothing -> ""    in "    " <> tag <> "  " <> colorFn pathText <> pathPad <> "  " <> dim ("(" <> annotation <> modSuffix <> ")") renderColorLine _ other = renderNonFileColor other@@ -90,9 +94,9 @@ renderNonFileColor (CommandPreview cmd mOwner) =   "    " <> dim "run" <> "    " <> dim cmd <> ownerSuffix mOwner   where-    ownerSuffix = maybe "" (\owner -> "  " <> dim ("(" <> owner.unModuleName <> ")"))+    ownerSuffix = maybe "" (\owner -> "  " <> dim ("(" <> owner ^. #unModuleName <> ")")) renderNonFileColor (OrphanPreview path modName') =-  "    " <> magenta "[orphaned]" <> "  " <> magenta (T.pack path) <> "  " <> dim ("(orphaned from " <> modName'.unModuleName <> ")")+  "    " <> magenta "[orphaned]" <> "  " <> magenta (T.pack path) <> "  " <> dim ("(orphaned from " <> modName' ^. #unModuleName <> ")") renderNonFileColor _ = ""  isFilePreview' :: PreviewLine -> Bool@@ -122,7 +126,7 @@     header =       bold         ( "Generation Plan ("-            <> T.intercalate " + " (map (cyan . (.unModuleName)) modNames)+            <> T.intercalate " + " (map (cyan . (^. #unModuleName)) modNames)             <> "):"         ) @@ -172,7 +176,7 @@ renderReportColor False report = renderReportPlain report renderReportColor True report =   T.unlines $-    [ "Validating module at " <> T.pack report.reportPath <> "...",+    [ "Validating module at " <> T.pack (report ^. #path) <> "...",       ""     ]       ++ dhallLine'@@ -181,52 +185,52 @@       ++ [""]       ++ [resultLine']   where-    m = report.reportModule+    m = (report ^. #module_)      dhallLine' =-      if report.reportDhallOk+      if report ^. #dhallOk         then ["  " <> green "\x2713" <> " module.dhall evaluates successfully"]         else           ["  " <> bold (red "\x2717") <> " module.dhall failed to evaluate"]-            ++ case report.reportDhallError of+            ++ case report ^. #dhallError of               Just errText -> ["      " <> dim errText]               Nothing -> []      summaryLines' =-      if report.reportDhallOk+      if report ^. #dhallOk         then-          [ "  " <> green "\x2713" <> " Module name: " <> cyan m.name.unModuleName,-            "  " <> green "\x2713" <> " " <> T.pack (show (length m.vars)) <> " variables declared",-            "  " <> green "\x2713" <> " " <> T.pack (show (length m.prompts)) <> " prompts defined",-            "  " <> green "\x2713" <> " " <> T.pack (show (length m.steps)) <> " steps defined"+          [ "  " <> green "\x2713" <> " Module name: " <> cyan (m ^. #name . #unModuleName),+            "  " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #vars))) <> " variables declared",+            "  " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #prompts))) <> " prompts defined",+            "  " <> green "\x2713" <> " " <> T.pack (show (length (m ^. #steps))) <> " steps defined"           ]         else [] -    checkLines' = concatMap renderCheckColor (report.reportChecks)+    checkLines' = concatMap renderCheckColor (report ^. #checks)      renderCheckColor c-      | null (c.diagDetails) =-          ["  " <> green "\x2713" <> " " <> c.diagLabel]-      | c.diagSeverity == DiagWarning =-          ("  " <> yellow "\x26A0" <> " " <> yellow (c.diagLabel))-            : map (\d -> "      " <> dim d) (c.diagDetails)+      | null (c ^. #details) =+          ["  " <> green "\x2713" <> " " <> c ^. #label]+      | c ^. #severity == DiagWarning =+          ("  " <> yellow "\x26A0" <> " " <> yellow (c ^. #label))+            : map (\d -> "      " <> dim d) (c ^. #details)       | otherwise =-          ("  " <> bold (red "\x2717") <> " " <> red (c.diagLabel))-            : map (\d -> "      " <> dim d) (c.diagDetails)+          ("  " <> bold (red "\x2717") <> " " <> red (c ^. #label))+            : map (\d -> "      " <> dim d) (c ^. #details)      errorCount =       length         [ ()-        | c <- report.reportChecks,-          c.diagSeverity == DiagError,-          not (null (c.diagDetails))+        | c <- report ^. #checks,+          c ^. #severity == DiagError,+          not (null (c ^. #details))         ] -    dhallFailed = not (report.reportDhallOk)+    dhallFailed = not (report ^. #dhallOk)     totalErrors = errorCount + (if dhallFailed then 1 else 0)      resultLine'       | totalErrors > 0 =           bold (red (T.pack (show totalErrors) <> " error(s) found.")) <> " Module is invalid."       | otherwise =-          green ("Module '" <> m.name.unModuleName <> "' is valid.")+          green ("Module '" <> m ^. #name . #unModuleName <> "' is valid.")
src/Seihou/CLI/Update.hs view
@@ -19,9 +19,10 @@   ) where -import Control.Exception (SomeException, displayException, try)+import Control.Exception (SomeException, displayException, toException, try) import Control.Monad (foldM, forM, forM_, when) import Data.Foldable (traverse_)+import Data.Generics.Labels () import Data.List (find, isPrefixOf) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList)@@ -48,6 +49,8 @@     resolveWithPromptPermission,   ) import Seihou.Core.Application (buildAppliedComposition, replaceAppliedComposition)+import Seihou.Core.ArtifactOriginDetect (detectArtifactOrigin)+import Seihou.Core.ArtifactRef (renderArtifactRefError, resolveArtifactOrigin) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable) import Seihou.Core.Types import Seihou.Core.Version (parseVersion)@@ -110,20 +113,20 @@         Left err -> pure (Left err)         Right manifest -> do           now <- getCurrentTime-          seeded <- selectAndSeedLegacy request manifest now+          seeded <- selectAndSeedLegacy request projectRoot manifest now           case seeded of             Left err -> pure (Left err)             Right (selected, seedWarnings) -> do-              staged <- stageCandidateSources sessionDirectory selected+              staged <- stageCandidateSources sessionDirectory projectRoot installedDirectory selected               case staged of                 Left err -> pure (Left err)                 Right (catalog, sourceWarnings) -> do-                  plannedApplicationsResult <- traverse (planApplication request installedDirectory catalog now) selected+                  plannedApplicationsResult <- traverse (planApplication request projectRoot catalog now) selected                   case sequence plannedApplicationsResult of                     Left err -> pure (Left err)                     Right plannedApplications -> do                       let applicationInputs =-                            [ (Just previous, planned.modulesInOrder)+                            [ (Just previous, planned ^. #modulesInOrder)                             | (previous, planned) <- zip selected plannedApplications                             ]                       stagedMigrations <- planAndStageMigrations projectRoot manifest catalog applicationInputs@@ -131,31 +134,31 @@                         Left err -> pure (Left err)                         Right migrationStage -> do                           let (operations, owners, compositionWarnings) = combineApplicationPlans plannedApplications-                              selectedIds = Set.fromList (map (.candidate.applicationId) plannedApplications)-                          stageRoot <- materializeStagedProject sessionDirectory projectRoot migrationStage.filesystem operations+                              selectedIds = Set.fromList (map (^. #candidate . #applicationId) plannedApplications)+                          stageRoot <- materializeStagedProject sessionDirectory projectRoot (migrationStage ^. #filesystem) operations                           reconciliationResult <-                             runEff $                               runFilesystem $                                 runBaselineStore baselineDirectory $-                                  planReconciliation stageRoot migrationStage.manifest selectedIds operations owners+                                  planReconciliation stageRoot (migrationStage ^. #manifest) selectedIds operations owners                           case reconciliationResult of                             Left err -> pure (Left (UpdateReconciliationFailed err))                             Right reconciliation -> do-                              evidence <- versionEvidence catalog selected plannedApplications+                              evidence <- versionEvidence (request ^. #allowDowngrade) projectRoot catalog selected plannedApplications                               case evidence of                                 Left err -> pure (Left err)                                 Right (versionChanges, versionWarnings) -> do                                   let usedArtifacts = artifactsUsedBy catalog plannedApplications-                                      priorReceipts = Map.unions (map (.commandReceipts) selected)-                                      commandPlan = planCommands request.commandPolicy priorReceipts operations+                                      priorReceipts = Map.unions (map (^. #commandReceipts) selected)+                                      commandPlan = planCommands (request ^. #commandPolicy) priorReceipts operations                                       warnings =                                         seedWarnings                                           <> sourceWarnings-                                          <> migrationStage.warnings+                                          <> migrationStage ^. #warnings                                           <> compositionWarnings                                           <> versionWarnings                                       inputChanges = summarizeInputChanges seedWarnings plannedApplications-                                      transactionTargets = transactionTargetPaths manifest reconciliation migrationStage.plans+                                      transactionTargets = transactionTargetPaths manifest reconciliation (migrationStage ^. #plans)                                   observedProjectHashes <-                                     observePaths                                       projectRoot@@ -168,17 +171,17 @@                                             baselineDirectory,                                             installedDirectory,                                             originalManifest = manifest,-                                            candidateHashes = Map.fromList [(artifact.originalDirectory, artifact.contentHash) | artifact <- usedArtifacts],+                                            candidateHashes = Map.fromList [(artifact ^. #originalDirectory, artifact ^. #contentHash) | artifact <- usedArtifacts],                                             observedProjectHashes,                                             transactionTargets                                           }                                   pure                                     ( Right                                         UpdatePlan-                                          { applications = map (.candidate) plannedApplications,+                                          { applications = map (^. #candidate) plannedApplications,                                             versionChanges,                                             inputChanges,-                                            migrations = migrationStage.plans,+                                            migrations = migrationStage ^. #plans,                                             reconciliation,                                             commandPlan,                                             candidateArtifacts = usedArtifacts,@@ -191,8 +194,8 @@  applyProjectUpdate :: UpdatePlan -> IO (Either UpdateError UpdateResult) applyProjectUpdate plan =-  Directory.withCurrentDirectory plan.snapshot.projectRoot $ do-    recovery <- recoverAtEntry plan.snapshot.projectRoot+  Directory.withCurrentDirectory (plan ^. #snapshot . #projectRoot) $ do+    recovery <- recoverAtEntry (plan ^. #snapshot . #projectRoot)     case recovery of       Left err -> pure (Left err)       Right () -> do@@ -200,11 +203,11 @@         if not (Set.null stale)           then pure (Left (UpdatePlanStale stale))           else-            if plan.request.dryRun+            if plan ^. #request . #dryRun               then pure (Right (dryRunResult plan))               else-                if not (Set.null (unresolvedPaths plan.reconciliation))-                  then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths plan.reconciliation)))+                if not (Set.null (unresolvedPaths (plan ^. #reconciliation)))+                  then pure (Left (UpdateHasUnresolvedPaths (unresolvedPaths (plan ^. #reconciliation))))                   else                     if isStructuredNoOp plan                       then pure (Right (noOpResult plan))@@ -212,40 +215,40 @@  applyAcceptedPlan :: UpdatePlan -> IO (Either UpdateError UpdateResult) applyAcceptedPlan plan = do-  transactionResult <- beginUpdateTransaction plan.snapshot.projectRoot plan.snapshot.transactionTargets+  transactionResult <- beginUpdateTransaction (plan ^. #snapshot . #projectRoot) (plan ^. #snapshot . #transactionTargets)   case transactionResult of     Left err -> pure (Left (UpdateTransactionFailed err))     Right transaction -> do-      backupResult <- prepareServiceBackups transaction plan.snapshot.installedDirectory plan.migrations plan.candidateArtifacts+      backupResult <- prepareServiceBackups transaction (plan ^. #snapshot . #installedDirectory) (plan ^. #migrations) (plan ^. #candidateArtifacts)       case backupResult of         Left err -> abortUpdate transaction err         Right () -> do           now <- getCurrentTime-          migrated <- runRealMigrations now plan.snapshot.originalManifest plan.migrations+          migrated <- runRealMigrations now (plan ^. #snapshot . #originalManifest) (plan ^. #migrations)           case migrated of             Left err -> abortUpdate transaction err             Right migratedManifest -> do               actualReconciliation <- planActualReconciliation plan migratedManifest               case actualReconciliation of                 Left err -> abortUpdate transaction err-                Right actual -> case reapplyPlannedResolutions plan.reconciliation actual of+                Right actual -> case reapplyPlannedResolutions (plan ^. #reconciliation) actual of                   Left _ ->                     abortUpdate                       transaction                       ( UpdateChangedAfterMigrationCommand-                          (reconciliationSummary plan.reconciliation)+                          (reconciliationSummary (plan ^. #reconciliation))                           (reconciliationSummary actual)                       )                   Right resolvedActual-                    | resolvedActual /= plan.reconciliation ->+                    | resolvedActual /= plan ^. #reconciliation ->                         abortUpdate                           transaction                           ( UpdateChangedAfterMigrationCommand-                              (reconciliationSummary plan.reconciliation)+                              (reconciliationSummary (plan ^. #reconciliation))                               (reconciliationSummary resolvedActual)                           )                     | otherwise -> do-                        let reconciliationManifest = migratedManifest {genAt = now}+                        let reconciliationManifest = (migratedManifest & #genAt .~ now)                         appliedFiles <- applyReconciliation transaction resolvedActual reconciliationManifest                         case appliedFiles of                           Left err -> abortUpdate transaction (UpdateTransactionFailed err)@@ -253,7 +256,7 @@                             commandResult <-                               runEff $                                 runProcessIO $-                                  executeCommandPlan now plan.commandPlan+                                  executeCommandPlan now (plan ^. #commandPlan)                             case commandResult of                               Left err ->                                 abortUpdate@@ -265,11 +268,11 @@                                 case markerResult of                                   Left err -> abortUpdate transaction err                                   Right () -> do-                                    publication <- publishCandidates plan.candidateArtifacts+                                    publication <- publishCandidates (plan ^. #candidateArtifacts)                                     case publication of                                       Left err -> abortUpdate transaction err                                       Right () -> do-                                        written <- writeManifestIO plan.snapshot.manifestPath finalManifest+                                        written <- writeManifestIO (plan ^. #snapshot . #manifestPath) finalManifest                                         case written of                                           Left err -> abortUpdate transaction err                                           Right () -> finishCommitted transaction plan finalManifest completedReceipts@@ -281,56 +284,56 @@   UTCTime ->   AppliedComposition ->   IO (Either UpdateError PlannedApplication)-planApplication request installedDirectory catalog now previous = do+planApplication request projectRoot catalog now previous = do   fallback <- defaultSearchPaths   case candidateRoot catalog previous of     Left err -> pure (Left err)     Right (primary, recipeAdditional, recipeOverrides, targetArtifact) -> do-      let allAdditional = recipeAdditional <> previous.additionalModules-      loaded <- loadComposition (catalog.searchRoot : fallback) primary allAdditional+      let allAdditional = recipeAdditional <> (previous ^. #additionalModules)+      loaded <- loadComposition (catalog ^. #searchRoot : fallback) primary allAdditional       case loaded of-        Left err -> pure (Left (CandidateLoadFailed primary.unModuleName err))+        Left err -> pure (Left (CandidateLoadFailed (primary ^. #unModuleName) err))         Right modulesInOrder -> do           let savedValues-                | request.reconfigure = Map.empty+                | (request ^. #reconfigure) = Map.empty                 | otherwise = savedInstanceValues previous-              namespace = fromMaybe (deriveNamespace primary) previous.namespace-              context = fromMaybe "" previous.context+              namespace = fromMaybe (deriveNamespace primary) (previous ^. #namespace)+              context = fromMaybe "" (previous ^. #context)           resolved <- resolveApplicationValues request namespace context savedValues recipeOverrides modulesInOrder           case resolved of             Left err -> pure (Left err)             Right resolvedValues -> do               compiled <-                 compileComposedPlan-                  [ (instanceId, modul, directory, Map.map (.value) (resolvedValues Map.! instanceId))+                  [ (instanceId, modul, directory, Map.map (^. #value) (resolvedValues Map.! instanceId))                   | (instanceId, modul, directory) <- modulesInOrder                   ]               case compiled of                 Left errors -> pure (Left (UpdateCompositionFailed errors))                 Right (operations, compositionWarnings, rawOwners) -> do-                  let targetSource = publishedArtifactSource installedDirectory targetArtifact-                      candidate0 =-                        ( buildAppliedComposition-                            previous.target-                            targetSource-                            targetArtifact.version-                            previous.additionalModules-                            (Just namespace)-                            previous.context-                            modulesInOrder-                            resolvedValues-                            now-                        )-                          { applicationId = previous.applicationId-                          }+                  targetOrigin <- publishedArtifactOrigin projectRoot targetArtifact+                  originedModules <- traverse (withInstanceOrigin projectRoot catalog) modulesInOrder+                  let candidate0 =+                        buildAppliedComposition+                          (previous ^. #target)+                          targetOrigin+                          (targetArtifact ^. #version)+                          (previous ^. #additionalModules)+                          (Just namespace)+                          (previous ^. #context)+                          originedModules+                          resolvedValues+                          now+                          & #applicationId+                          .~ (previous ^. #applicationId)                       candidate =                         setCompositionState-                          (map (publishInstanceSource installedDirectory catalog) candidate0.instances)-                          previous.commandReceipts+                          (candidate0 ^. #instances)+                          (previous ^. #commandReceipts)                           candidate0                       desiredOwners =                         Map.map-                          (\owner -> DesiredFileOwner owner (Set.singleton candidate.applicationId))+                          (\owner -> DesiredFileOwner owner (Set.singleton (candidate ^. #applicationId)))                           rawOwners                       renderedWarnings = map compositionWarning compositionWarnings                   pure@@ -352,19 +355,19 @@   CandidateCatalog ->   AppliedComposition ->   Either UpdateError (ModuleName, [ModuleName], Map VarName Text, CandidateArtifact)-candidateRoot catalog previous = case previous.target of+candidateRoot catalog previous = case previous ^. #target of   AppliedModuleTarget name -> do-    artifact <- lookupArtifact catalog CandidateModule name.unModuleName+    artifact <- lookupArtifact catalog CandidateModule (name ^. #unModuleName)     Right (name, [], Map.empty, artifact)   AppliedRecipeTarget name -> do-    artifact <- lookupArtifact catalog CandidateRecipe name.unRecipeName-    recipe <- maybe (Left (CandidateArtifactMissing CandidateRecipe name.unRecipeName)) Right artifact.recipeDefinition-    (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid name.unRecipeName) (expandRecipe recipe)+    artifact <- lookupArtifact catalog CandidateRecipe (name ^. #unRecipeName)+    recipe <- maybe (Left (CandidateArtifactMissing CandidateRecipe (name ^. #unRecipeName))) Right (artifact ^. #recipeDefinition)+    (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid (name ^. #unRecipeName)) (expandRecipe recipe)     Right (primary, additional, overrides, artifact)  lookupArtifact :: CandidateCatalog -> CandidateArtifactKind -> Text -> Either UpdateError CandidateArtifact lookupArtifact catalog kind name =-  maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) catalog.artifacts)+  maybe (Left (CandidateArtifactMissing kind name)) Right (Map.lookup (kind, name) (catalog ^. #artifacts))  resolveApplicationValues ::   UpdateRequest ->@@ -380,10 +383,10 @@   case configs of     Left err -> pure (Left err)     Right (localConfig, namespaceConfig, contextConfig, globalConfig) -> do-      let cli = Map.fromList [(VarName name, value) | (name, value) <- request.varOverrides]+      let cli = Map.fromList [(VarName name, value) | (name, value) <- request ^. #varOverrides]           overrides = Map.union cli recipeOverrides           env = Map.fromList [(T.pack key, T.pack value) | (key, value) <- envPairs]-          promptPermission = case request.promptPolicy of+          promptPermission = case request ^. #promptPolicy of             AllowPrompts -> PromptsAllowed             ForbidPrompts -> PromptsForbidden       result <-@@ -421,27 +424,28 @@  selectAndSeedLegacy ::   UpdateRequest ->+  FilePath ->   Manifest ->   UTCTime ->   IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))-selectAndSeedLegacy request manifest now = case selectApplications request.selection manifest of+selectAndSeedLegacy request projectRoot manifest now = case selectApplications (request ^. #selection) manifest of   Left err -> pure (Left err)   Right (RecordedSelection selected) -> pure (Right (selected, []))-  Right (LegacySelection name) -> seedLegacyApplication request manifest now name+  Right (LegacySelection name) -> seedLegacyApplication request projectRoot manifest now name  seedLegacyApplication ::-  UpdateRequest -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))-seedLegacyApplication request manifest now requested = do+  UpdateRequest -> FilePath -> Manifest -> UTCTime -> Text -> IO (Either UpdateError ([AppliedComposition], [UpdateWarning]))+seedLegacyApplication request projectRoot manifest now requested = do   searchPaths <- defaultSearchPaths   discovered <- discoverRunnable searchPaths (ModuleName requested)   case discovered of     Left err -> pure (Left (CandidateLoadFailed requested err))     Right runnable -> do       let root = case runnable of-            RunnableModule modul directory -> Right (AppliedModuleTarget modul.name, modul.name, [], Map.empty, directory, modul.version)+            RunnableModule modul directory -> Right (AppliedModuleTarget (modul ^. #name), modul ^. #name, [], Map.empty, directory, modul ^. #version)             RunnableRecipe recipe directory -> do               (primary, additional, overrides, _, _) <- first (CandidateRepositoryInvalid requested) (expandRecipe recipe)-              Right (AppliedRecipeTarget recipe.name, primary, additional, overrides, directory, recipe.version)+              Right (AppliedRecipeTarget (recipe ^. #name), primary, additional, overrides, directory, recipe ^. #version)             _ -> Left (CandidateArtifactMissing CandidateModule requested)       case root of         Left err -> pure (Left err)@@ -456,9 +460,18 @@               case resolved of                 Left err -> pure (Left err)                 Right resolvedValues -> do+                  targetOrigin <- detectArtifactOrigin projectRoot targetSource+                  originedModules <-+                    traverse+                      (\(instanceId, modul, directory) -> (instanceId,modul,) <$> detectArtifactOrigin projectRoot directory)+                      modulesInOrder                   let provisional0 =-                        buildAppliedComposition target targetSource targetVersion [] (Just namespace) Nothing modulesInOrder resolvedValues now-                      provisional = provisional0 {instances = map (restoreLegacyVersion manifest) provisional0.instances}+                        buildAppliedComposition target targetOrigin targetVersion [] (Just namespace) Nothing originedModules resolvedValues now+                      provisional =+                        ( provisional0+                            & #instances+                            %~ map (restoreLegacyVersion manifest)+                        )                   pure (Right ([provisional], warnings))  legacySavedValues ::@@ -467,48 +480,48 @@   (SavedInstanceValues, [UpdateWarning]) legacySavedValues manifest modulesInOrder = (saved, warnings)   where-    declarations = [(instanceId, declaration) | (instanceId, modul, _) <- modulesInOrder, declaration <- modul.vars]-    counts = Map.fromListWith (+) [(declaration.name, 1 :: Int) | (_, declaration) <- declarations]+    declarations = [(instanceId, declaration) | (instanceId, modul, _) <- modulesInOrder, declaration <- modul ^. #vars]+    counts = Map.fromListWith (+) [(declaration ^. #name, 1 :: Int) | (_, declaration) <- declarations]     saved =       Map.fromListWith         Map.union-        [ (instanceId, Map.singleton declaration.name value)+        [ (instanceId, Map.singleton (declaration ^. #name) value)         | (instanceId, declaration) <- declarations,-          Map.lookup declaration.name counts == Just 1,-          Just value <- [Map.lookup declaration.name manifest.vars]+          Map.lookup (declaration ^. #name) counts == Just 1,+          Just value <- [Map.lookup (declaration ^. #name) (manifest ^. #vars)]         ]     ambiguous =       [ AmbiguousLegacyValue name       | (name, count) <- Map.toAscList counts,         count > 1,-        Map.member name manifest.vars+        Map.member name (manifest ^. #vars)       ]     missing =-      [ MissingLegacyValue declaration.name+      [ MissingLegacyValue (declaration ^. #name)       | (_, declaration) <- declarations,-        declaration.required,-        Map.notMember declaration.name manifest.vars+        declaration ^. #required,+        Map.notMember (declaration ^. #name) (manifest ^. #vars)       ]     warnings = ambiguous <> missing  restoreLegacyVersion :: Manifest -> AppliedInstanceState -> AppliedInstanceState restoreLegacyVersion manifest state =-  case find (\applied -> applied.name == state.name && applied.parentVars == state.parentVars) manifest.modules of+  case find (\applied -> applied ^. #name == state ^. #name && applied ^. #parentVars == state ^. #parentVars) (manifest ^. #modules) of     Nothing -> state     Just applied ->       AppliedInstanceState-        { name = state.name,-          parentVars = state.parentVars,-          source = applied.source,-          moduleVersion = applied.moduleVersion,-          resolvedVars = state.resolvedVars+        { name = state ^. #name,+          parentVars = state ^. #parentVars,+          origin = applied ^. #origin,+          moduleVersion = applied ^. #moduleVersion,+          resolvedVars = state ^. #resolvedVars         }  savedInstanceValues :: AppliedComposition -> SavedInstanceValues savedInstanceValues application =   Map.fromList-    [ (ModuleInstance state.name state.parentVars, state.resolvedVars)-    | state <- application.instances+    [ (ModuleInstance (state ^. #name) (state ^. #parentVars), state ^. #resolvedVars)+    | state <- application ^. #instances     ]  combineApplicationPlans ::@@ -518,22 +531,22 @@   where     addApplication (operations, owners, warnings) application =       let crossWarnings =-            [ CrossApplicationLastWriter path prior.moduleName next.moduleName-            | (path, next) <- Map.toAscList application.desiredOwners,+            [ CrossApplicationLastWriter path (prior ^. #moduleName) (next ^. #moduleName)+            | (path, next) <- Map.toAscList (application ^. #desiredOwners),               Just prior <- [Map.lookup path owners],-              prior.moduleName /= next.moduleName+              prior ^. #moduleName /= next ^. #moduleName             ]-          mergedOwners = Map.unionWith mergeOwner application.desiredOwners owners-       in (operations <> application.operations, mergedOwners, warnings <> crossWarnings)+          mergedOwners = Map.unionWith mergeOwner (application ^. #desiredOwners) owners+       in (operations <> application ^. #operations, mergedOwners, warnings <> crossWarnings)     mergeOwner newest prior =-      DesiredFileOwner newest.moduleName (Set.union newest.applicationIds prior.applicationIds)+      DesiredFileOwner (newest ^. #moduleName) (Set.union (newest ^. #applicationIds) (prior ^. #applicationIds))  materializeStagedProject :: FilePath -> FilePath -> PureFS -> [Operation] -> IO FilePath materializeStagedProject sessionDirectory projectRoot filesystem operations = do   let stageRoot = sessionDirectory </> "staged-project"   Directory.createDirectoryIfMissing True stageRoot-  forM_ (Map.toAscList filesystem.files) $ \(path, content) -> writeStageFile stageRoot path content-  forM_ (Set.toAscList filesystem.dirs) $ \path -> Directory.createDirectoryIfMissing True (stageRoot </> path)+  forM_ (Map.toAscList (filesystem ^. #files)) $ \(path, content) -> writeStageFile stageRoot path content+  forM_ (Set.toAscList (filesystem ^. #dirs)) $ \path -> Directory.createDirectoryIfMissing True (stageRoot </> path)   forM_ (Set.toAscList (Set.fromList (mapMaybe operationDestination operations))) $ \path -> do     stagedExists <- Directory.doesFileExist (stageRoot </> path)     when (not stagedExists) $ do@@ -554,45 +567,58 @@ operationDestination _ = Nothing  versionEvidence ::+  -- | Whether @--allow-downgrade@ was passed.+  Bool ->+  FilePath ->   CandidateCatalog ->   [AppliedComposition] ->   [PlannedApplication] ->   IO (Either UpdateError ([VersionChange], [UpdateWarning]))-versionEvidence catalog previousApplications plannedApplications = do+versionEvidence allowDowngrade projectRoot catalog previousApplications plannedApplications = do   evidence <- fmap concat $ sequence (zipWith applicationEvidence previousApplications plannedApplications)   pure $ do     changes <- sequence evidence     let actualChanges = filter isActualChange changes-    traverse_ validateVersionChange actualChanges+    traverse_ (validateVersionChange allowDowngrade) actualChanges     let unique = Map.elems (Map.fromList [(versionKey change, change) | change <- actualChanges])         warnings =-          [ SameVersionContentChanged change.name+          [ SameVersionContentChanged (change ^. #name)           | change <- unique,-            change.sameVersionContentChanged,-            isJust change.fromVersion+            change ^. #sameVersionContentChanged,+            isJust (change ^. #fromVersion)           ]     Right (unique, warnings)   where     applicationEvidence previous planned = do-      instanceEvidence <- traverse (instanceVersionEvidence previous) planned.modulesInOrder+      instanceEvidence <- traverse (instanceVersionEvidence previous) (planned ^. #modulesInOrder)       targetEvidence <- targetVersionEvidence previous       pure (targetEvidence : instanceEvidence)      instanceVersionEvidence previous (instanceId, candidateModule, _) = do-      let prior = find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) previous.instances+      let prior = find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (previous ^. #instances)       case prior of-        Nothing -> pure (Right (VersionChange candidateModule.name.unModuleName Nothing candidateModule.version False))-        Just old -> compareArtifact old.name.unModuleName old.moduleVersion candidateModule.version old.source CandidateModule+        Nothing -> pure (Right (VersionChange (candidateModule ^. #name . #unModuleName) Nothing (candidateModule ^. #version) False))+        Just old -> compareArtifact (old ^. #name . #unModuleName) (old ^. #moduleVersion) (candidateModule ^. #version) (old ^. #origin) CandidateModule -    targetVersionEvidence previous = case previous.target of+    targetVersionEvidence previous = case previous ^. #target of       AppliedModuleTarget _ -> pure (Right (VersionChange "" Nothing Nothing False))-      AppliedRecipeTarget name -> compareArtifact name.unRecipeName previous.targetVersion (candidateVersion CandidateRecipe name.unRecipeName) previous.targetSource CandidateRecipe+      AppliedRecipeTarget name -> compareArtifact (name ^. #unRecipeName) (previous ^. #targetVersion) (candidateVersion CandidateRecipe (name ^. #unRecipeName)) (previous ^. #targetOrigin) CandidateRecipe -    candidateVersion kind name = (.version) =<< Map.lookup (kind, name) catalog.artifacts+    candidateVersion kind name = (^. #version) =<< Map.lookup (kind, name) (catalog ^. #artifacts) -    compareArtifact name fromVersion toVersion oldSource kind = do-      oldHashResult <- try @SomeException (hashArtifactDirectory oldSource)-      let candidateHash = (.contentHash) <$> Map.lookup (kind, name) catalog.artifacts+    -- The manifest records no path, so the already-applied artifact has to be+    -- located from its recorded origin before its content can be hashed. A+    -- resolution failure keeps the existing conservative behaviour of treating+    -- the artifact as changed: this produces an advisory warning, not a+    -- correctness gate. Aborting on a stale or missing artifact is the job of+    -- docs/plans/78-refuse-accidental-module-downgrades-and-origin-mismatches.md.+    compareArtifact name fromVersion toVersion oldOrigin kind = do+      searchPaths <- defaultSearchPaths+      resolved <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) oldOrigin+      oldHashResult <- case resolved of+        Left refErr -> pure (Left (toException (userError (T.unpack (renderArtifactRefError refErr)))))+        Right oldSource -> try @SomeException (hashArtifactDirectory oldSource)+      let candidateHash = (^. #contentHash) <$> Map.lookup (kind, name) (catalog ^. #artifacts)           changed = case (oldHashResult, candidateHash) of             (Right oldHash, Just newHash) -> oldHash /= newHash             _ -> True@@ -606,34 +632,46 @@               }         ) -    versionKey change = (change.name, change.fromVersion, change.toVersion, change.sameVersionContentChanged)+    definitionFileFor CandidateModule = "module.dhall"+    definitionFileFor CandidateRecipe = "recipe.dhall"++    versionKey change = (change ^. #name, change ^. #fromVersion, change ^. #toVersion, change ^. #sameVersionContentChanged)     isActualChange change =-      not (T.null change.name)-        && (change.fromVersion /= change.toVersion || change.sameVersionContentChanged)+      not (T.null (change ^. #name))+        && (change ^. #fromVersion /= change ^. #toVersion || change ^. #sameVersionContentChanged) -validateVersionChange :: VersionChange -> Either UpdateError ()-validateVersionChange change-  | T.null change.name = Right ()-  | otherwise = case (change.fromVersion, change.toVersion) of+-- | Refuse a candidate that would move the project to a lower version than+-- the manifest records, unless @--allow-downgrade@ was passed.+--+-- @fromVersion@ is the version @.seihou\/manifest.json@ records for the+-- already-applied artifact and @toVersion@ is the candidate's. Note what this+-- does *not* need to guard: the candidate is cloned from the origin URL the+-- manifest itself records (see 'Seihou.CLI.Update.Source.remoteProvenance'),+-- never from whatever happens to be installed on this machine, so an update+-- cannot silently substitute a same-named artifact from a different source.+validateVersionChange :: Bool -> VersionChange -> Either UpdateError ()+validateVersionChange allowDowngrade change+  | T.null (change ^. #name) = Right ()+  | otherwise = case (change ^. #fromVersion, change ^. #toVersion) of       (Just fromText, Just toText) -> do-        fromVersion <- maybe (Left (CandidateVersionInvalid change.name fromText)) Right (parseVersion fromText)-        toVersion <- maybe (Left (CandidateVersionInvalid change.name toText)) Right (parseVersion toText)-        if toVersion < fromVersion-          then Left (CandidateDowngrade change.name change.fromVersion change.toVersion)+        fromVersion <- maybe (Left (CandidateVersionInvalid (change ^. #name) fromText)) Right (parseVersion fromText)+        toVersion <- maybe (Left (CandidateVersionInvalid (change ^. #name) toText)) Right (parseVersion toText)+        if toVersion < fromVersion && not allowDowngrade+          then Left (CandidateDowngrade (change ^. #name) (change ^. #fromVersion) (change ^. #toVersion))           else Right ()       _ -> Right ()  artifactsUsedBy :: CandidateCatalog -> [PlannedApplication] -> [CandidateArtifact]-artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys catalog.artifacts keys)+artifactsUsedBy catalog planned = Map.elems (Map.restrictKeys (catalog ^. #artifacts) keys)   where     keys =       Set.fromList $         concatMap applicationKeys planned     applicationKeys application =-      targetKey application.candidate.target-        : [(CandidateModule, modul.name.unModuleName) | (_, modul, _) <- application.modulesInOrder]-    targetKey (AppliedModuleTarget name) = (CandidateModule, name.unModuleName)-    targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name.unRecipeName)+      targetKey (application ^. #candidate . #target)+        : [(CandidateModule, modul ^. #name . #unModuleName) | (_, modul, _) <- application ^. #modulesInOrder]+    targetKey (AppliedModuleTarget name) = (CandidateModule, name ^. #unModuleName)+    targetKey (AppliedRecipeTarget name) = (CandidateRecipe, name ^. #unRecipeName)  summarizeInputChanges :: [UpdateWarning] -> [PlannedApplication] -> InputChangeSummary summarizeInputChanges seedWarnings planned =@@ -648,19 +686,19 @@           ambiguousLegacy = [name | AmbiguousLegacyValue name <- seedWarnings]         }     summarizeApplication summary application =-      let prior = maybe Map.empty savedInstanceValues application.previous-          candidateValues = application.resolvedValues+      let prior = maybe Map.empty savedInstanceValues (application ^. #previous)+          candidateValues = (application ^. #resolvedValues)           resolvedList =             [ (instanceId, name, value)             | (instanceId, values) <- Map.toList candidateValues,               (name, value) <- Map.toList values             ]-          reusedCount = length [() | (_, _, value) <- resolvedList, value.source == FromApplication]+          reusedCount = length [() | (_, _, value) <- resolvedList, value ^. #source == FromApplication]           overriddenCount =             length               [ ()               | (instanceId, name, value) <- resolvedList,-                value.source == FromCLI,+                value ^. #source == FromCLI,                 Map.member name (Map.findWithDefault Map.empty instanceId prior)               ]           newCount =@@ -677,22 +715,25 @@                 Map.notMember name (Map.findWithDefault Map.empty instanceId candidateValues)               ]        in summary-            { reused = summary.reused + reusedCount,-              overridden = summary.overridden + overriddenCount,-              newlyResolved = summary.newlyResolved + newCount,-              removed = summary.removed + removedCount-            }+            & #reused+            %~ (+ reusedCount)+            & #overridden+            %~ (+ overriddenCount)+            & #newlyResolved+            %~ (+ newCount)+            & #removed+            %~ (+ removedCount)  transactionTargetPaths :: Manifest -> ReconciliationPlan -> [PlannedUpdateMigration] -> Set FilePath transactionTargetPaths manifest reconciliation migrations =-  Map.keysSet reconciliation.files `Set.union` Set.fromList (concatMap migrationTargets migrations)+  Map.keysSet (reconciliation ^. #files) `Set.union` Set.fromList (concatMap migrationTargets migrations)   where-    migrationTargets migration = concatMap targets migration.stagedPlan.planOps+    migrationTargets migration = concatMap targets (migration ^. #stagedPlan . #ops)     targets (MoveFileInst source destination _) = [source, destination]     targets (DeleteFileInst path _) = [path]     targets (MoveDirInst source destination) =-      concatMap (moveDirectoryTarget source destination) (Map.keys manifest.files)-    targets (DeleteDirInst path) = filter (isPathAtOrBelow path) (Map.keys manifest.files)+      concatMap (moveDirectoryTarget source destination) (Map.keys (manifest ^. #files))+    targets (DeleteDirInst path) = filter (isPathAtOrBelow path) (Map.keys (manifest ^. #files))     targets RunCommandInst {} = []     moveDirectoryTarget source destination path       | isPathAtOrBelow source path = [path, replacePrefix source destination path]@@ -721,27 +762,27 @@ stalePlanPaths plan = do   currentProject <-     observePaths-      plan.snapshot.projectRoot-      (Map.keysSet plan.snapshot.observedProjectHashes)-  candidateChecks <- forM (Map.toAscList plan.snapshot.candidateHashes) $ \(path, expected) -> do+      (plan ^. #snapshot . #projectRoot)+      (Map.keysSet (plan ^. #snapshot . #observedProjectHashes))+  candidateChecks <- forM (Map.toAscList (plan ^. #snapshot . #candidateHashes)) $ \(path, expected) -> do     current <- try @SomeException (hashArtifactDirectory path)     pure $ case current of       Right actual | actual == expected -> []       _ -> [path]   let projectChanges =         Map.keysSet-          (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) plan.snapshot.observedProjectHashes)+          (Map.filterWithKey (\path observed -> Map.lookup path currentProject /= Just observed) (plan ^. #snapshot . #observedProjectHashes))   pure (Set.union projectChanges (Set.fromList (concat candidateChecks)))  planActualReconciliation :: UpdatePlan -> Manifest -> IO (Either UpdateError ReconciliationPlan) planActualReconciliation plan manifest = do-  let (operations, owners, _) = combineApplicationPlans plan.plannedApplications-      selected = Set.fromList (map (.applicationId) plan.applications)+  let (operations, owners, _) = combineApplicationPlans (plan ^. #plannedApplications)+      selected = Set.fromList (map (^. #applicationId) (plan ^. #applications))   result <-     runEff $       runFilesystem $-        runBaselineStore plan.snapshot.baselineDirectory $-          planReconciliation plan.snapshot.projectRoot manifest selected operations owners+        runBaselineStore (plan ^. #snapshot . #baselineDirectory) $+          planReconciliation (plan ^. #snapshot . #projectRoot) manifest selected operations owners   pure (first UpdateReconciliationFailed result)  -- | Reapply choices gathered after the initial read-only plan to the@@ -753,10 +794,10 @@   ReconciliationPlan ->   Either ReconciliationError ReconciliationPlan reapplyPlannedResolutions planned actual =-  foldM reapplyOne actual (Map.toAscList planned.files)+  foldM reapplyOne actual (Map.toAscList (planned ^. #files))   where     reapplyOne actual (path, FileConflict _ _ _ _ _ _ (Just resolved)) =-      resolveFileConflict path resolved.choice actual+      resolveFileConflict path (resolved ^. #choice) actual     reapplyOne actual (path, FileOrphanEdited _ _ _ _ (Just choice)) =       resolveEditedOrphan path choice actual     reapplyOne actual _ = Right actual@@ -767,13 +808,13 @@   where     go current [] = pure (Right current)     go current (migration : rest) = do-      classified <- classifyMigration current migration.sourcePlan+      classified <- classifyMigration current (migration ^. #sourcePlan)       case classified of-        Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err))+        Left err -> pure (Left (UpdateMigrationFailed (migration ^. #moduleName) err))         Right executable -> do           executed <- executeMigration False executable current now           case executed of-            Left err -> pure (Left (UpdateMigrationFailed migration.moduleName err))+            Left err -> pure (Left (UpdateMigrationFailed (migration ^. #moduleName) err))             Right next -> go next rest  buildFinalManifest :: UTCTime -> UpdatePlan -> Manifest -> [CommandReceipt] -> Manifest@@ -781,64 +822,64 @@   Manifest     { version = currentManifestVersion,       genAt = now,-      modules = updateAppliedModules filesManifest.modules filesManifest.applications plan.plannedApplications now,-      vars = Map.union candidateVars filesManifest.vars,-      files = filesManifest.files,-      applications = foldl' (flip replaceAppliedComposition) filesManifest.applications finalApplications,+      modules = updateAppliedModules (filesManifest ^. #modules) (filesManifest ^. #applications) (plan ^. #plannedApplications) now,+      vars = Map.union candidateVars (filesManifest ^. #vars),+      files = filesManifest ^. #files,+      applications = foldl' (flip replaceAppliedComposition) (filesManifest ^. #applications) finalApplications,       recipe = updatedRecipe,-      blueprint = filesManifest.blueprint,-      blueprintMigrations = filesManifest.blueprintMigrations+      blueprint = filesManifest ^. #blueprint,+      blueprintMigrations = filesManifest ^. #blueprintMigrations     }   where-    finalApplications = map finalizeApplication plan.plannedApplications+    finalApplications = map finalizeApplication (plan ^. #plannedApplications)     finalizeApplication application =-      let priorReceipts = maybe Map.empty (.commandReceipts) application.previous-          applicationPlan = planCommands plan.request.commandPolicy priorReceipts application.operations+      let priorReceipts = maybe Map.empty (^. #commandReceipts) (application ^. #previous)+          applicationPlan = planCommands (plan ^. #request . #commandPolicy) priorReceipts (application ^. #operations)           receipts = finalizeCommandReceipts applicationPlan completedReceipts priorReceipts-       in setCompositionState application.candidate.instances receipts application.candidate+       in setCompositionState (application ^. #candidate . #instances) receipts (application ^. #candidate)     candidateVars =       Map.unions-        [ Map.map (varValueToText . (.value)) values-        | application <- plan.plannedApplications,-          values <- Map.elems application.resolvedValues+        [ Map.map (varValueToText . (^. #value)) values+        | application <- plan ^. #plannedApplications,+          values <- Map.elems (application ^. #resolvedValues)         ]     updatedRecipe =-      foldl' updateRecipe filesManifest.recipe finalApplications-    updateRecipe current application = case application.target of-      AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application.targetVersion, appliedAt = now}+      foldl' updateRecipe (filesManifest ^. #recipe) finalApplications+    updateRecipe current application = case application ^. #target of+      AppliedRecipeTarget name -> Just AppliedRecipe {name, recipeVersion = application ^. #targetVersion, appliedAt = now}       AppliedModuleTarget _ -> current  updateAppliedModules :: [AppliedModule] -> [AppliedComposition] -> [PlannedApplication] -> UTCTime -> [AppliedModule] updateAppliedModules existing recordedApplications applications now =-  let modulesInOrder = concatMap (.modulesInOrder) applications-      candidateKeys = Set.fromList [(instanceId.instanceModule, instanceId.instanceParentVars) | (instanceId, _, _) <- modulesInOrder]-      selectedIds = Set.fromList (map (.candidate.applicationId) applications)+  let modulesInOrder = concatMap (^. #modulesInOrder) applications+      candidateKeys = Set.fromList [(instanceId ^. #module_, instanceId ^. #parentVars) | (instanceId, _, _) <- modulesInOrder]+      selectedIds = Set.fromList (map (^. #candidate . #applicationId) applications)       priorSelectedKeys =         Set.fromList-          [ (state.name, state.parentVars)+          [ (state ^. #name, state ^. #parentVars)           | application <- applications,-            previous <- maybeToList application.previous,-            state <- previous.instances+            previous <- maybeToList (application ^. #previous),+            state <- previous ^. #instances           ]       protectedKeys =         Set.fromList-          [ (state.name, state.parentVars)+          [ (state ^. #name, state ^. #parentVars)           | application <- recordedApplications,-            Set.notMember application.applicationId selectedIds,-            state <- application.instances+            Set.notMember (application ^. #applicationId) selectedIds,+            state <- application ^. #instances           ]       replacedOrRemoved key =         Set.member key candidateKeys           || (Set.member key priorSelectedKeys && Set.notMember key protectedKeys)-      retained = filter (not . replacedOrRemoved . (\applied -> (applied.name, applied.parentVars))) existing+      retained = filter (not . replacedOrRemoved . (\applied -> (applied ^. #name, applied ^. #parentVars))) existing       updated =         [ AppliedModule-            { name = instanceId.instanceModule,-              parentVars = instanceId.instanceParentVars,-              source = publishInstanceDirectory application instanceId,-              moduleVersion = modul.version,+            { name = instanceId ^. #module_,+              parentVars = instanceId ^. #parentVars,+              origin = publishedInstance application instanceId ^. #origin,+              moduleVersion = modul ^. #version,               appliedAt = now,-              removal = modul.removal+              removal = modul ^. #removal             }         | (application, instanceId, modul) <- deduplicateInstances applications         ]@@ -848,67 +889,75 @@       where         expand application =           [ (application, instanceId, modul)-          | (instanceId, modul, _) <- application.modulesInOrder+          | (instanceId, modul, _) <- application ^. #modulesInOrder           ]         go _ [] = []         go seen (entry@(_, instanceId, _) : rest)           | Set.member key seen = go seen rest           | otherwise = entry : go (Set.insert key seen) rest           where-            key = (instanceId.instanceModule, instanceId.instanceParentVars)+            key = (instanceId ^. #module_, instanceId ^. #parentVars) -    publishInstanceDirectory application instanceId =-      case find (\state -> state.name == instanceId.instanceModule && state.parentVars == instanceId.instanceParentVars) application.candidate.instances of-        Just state -> state.source+    publishedInstance application instanceId =+      case find (\state -> state ^. #name == instanceId ^. #module_ && state ^. #parentVars == instanceId ^. #parentVars) (application ^. #candidate . #instances) of+        Just state -> state         Nothing -> error "candidate application lost a loaded module instance"  setCompositionState :: [AppliedInstanceState] -> Map CommandFingerprint CommandReceipt -> AppliedComposition -> AppliedComposition setCompositionState instances receipts composition =   AppliedComposition-    { applicationId = composition.applicationId,-      target = composition.target,-      targetSource = composition.targetSource,-      targetVersion = composition.targetVersion,-      additionalModules = composition.additionalModules,-      namespace = composition.namespace,-      context = composition.context,+    { applicationId = composition ^. #applicationId,+      target = composition ^. #target,+      targetOrigin = composition ^. #targetOrigin,+      targetVersion = composition ^. #targetVersion,+      additionalModules = composition ^. #additionalModules,+      namespace = composition ^. #namespace,+      context = composition ^. #context,       instances,       commandReceipts = receipts,-      appliedAt = composition.appliedAt+      appliedAt = composition ^. #appliedAt     } -publishInstanceSource :: FilePath -> CandidateCatalog -> AppliedInstanceState -> AppliedInstanceState-publishInstanceSource installedDirectory catalog state =-  case Map.lookup (CandidateModule, state.name.unModuleName) catalog.artifacts of-    Nothing -> state-    Just artifact ->-      AppliedInstanceState-        { name = state.name,-          parentVars = state.parentVars,-          source = publishedArtifactSource installedDirectory artifact,-          moduleVersion = state.moduleVersion,-          resolvedVars = state.resolvedVars-        }+-- | The portable manifest identity an artifact will have once this update+-- publishes it.+--+-- A candidate staged from a git URL is recorded against that URL directly:+-- its staging directory is a temporary clone that no other machine will ever+-- see, so classifying the directory would produce a meaningless answer. A+-- candidate with no URL is classified from the directory it actually came+-- from.+publishedArtifactOrigin :: FilePath -> CandidateArtifact -> IO ArtifactOrigin+publishedArtifactOrigin projectRoot artifact = case artifact ^. #sourceUrl of+  Just url -> pure (RemoteOrigin url (artifact ^. #name) (artifact ^. #repoName))+  Nothing -> detectArtifactOrigin projectRoot (artifact ^. #originalDirectory) -publishedArtifactSource :: FilePath -> CandidateArtifact -> FilePath-publishedArtifactSource installedDirectory artifact =-  if isJust artifact.sourceUrl-    then installedDirectory </> T.unpack artifact.name-    else artifact.originalDirectory+-- | Pair one loaded module instance with the portable origin to record for+-- it. Modules this update stages take the staged candidate's published+-- identity; anything else is classified from the directory discovery found.+withInstanceOrigin ::+  FilePath ->+  CandidateCatalog ->+  (ModuleInstance, Module, FilePath) ->+  IO (ModuleInstance, Module, ArtifactOrigin)+withInstanceOrigin projectRoot catalog (instanceId, modul, directory) = do+  origin <- case Map.lookup (CandidateModule, instanceId ^. #module_ . #unModuleName) (catalog ^. #artifacts) of+    Just artifact -> publishedArtifactOrigin projectRoot artifact+    Nothing -> detectArtifactOrigin projectRoot directory+  pure (instanceId, modul, origin)  publishCandidates :: [CandidateArtifact] -> IO (Either UpdateError ()) publishCandidates artifacts = do   result <- try @SomeException $-    forM_ artifacts $ \artifact -> case artifact.sourceUrl of+    forM_ artifacts $ \artifact -> case artifact ^. #sourceUrl of       Nothing -> pure ()       Just sourceUrl ->         installModuleDir-          artifact.originalDirectory-          (T.unpack artifact.name)+          (artifact ^. #originalDirectory)+          (T.unpack (artifact ^. #name))           sourceUrl-          artifact.repoName-          artifact.version-          artifact.tags+          (artifact ^. #repoName)+          (artifact ^. #version)+          (artifact ^. #tags)   pure $ first (UpdateCachePublicationFailed . T.pack . displayException) result  setCommitMarkers :: UpdateTransaction -> Manifest -> IO (Either UpdateError ())@@ -953,7 +1002,7 @@     try @SomeException $       runEff $         runFilesystem $-          runBaselineStore plan.snapshot.baselineDirectory $+          runBaselineStore (plan ^. #snapshot . #baselineDirectory) $             pruneBaselines (manifestBaselineRefs manifest)   let cleanupWarnings = case completion of         Left err -> [RecoveryCleanupDeferred (T.pack (show err))]@@ -961,35 +1010,35 @@       pruneWarnings = case pruneResult of         Left err -> [BaselinePruneFailed (T.pack (displayException err))]         Right _ -> []-      summary = summarizeCommandPlan plan.commandPlan-      originalBaselineRefs = manifestBaselineRefs plan.snapshot.originalManifest+      summary = summarizeCommandPlan (plan ^. #commandPlan)+      originalBaselineRefs = manifestBaselineRefs (plan ^. #snapshot . #originalManifest)       finalBaselineRefs = manifestBaselineRefs manifest       changedBaselineRefs =         (originalBaselineRefs Set.\\ finalBaselineRefs)           `Set.union` (finalBaselineRefs Set.\\ originalBaselineRefs)       baselinePaths =         Set.map-          (\ref -> ".seihou" </> "baselines" </> T.unpack ref.unBaselineRef.unSHA256)+          (\ref -> ".seihou" </> "baselines" </> T.unpack (ref ^. #unBaselineRef . #unSHA256))           changedBaselineRefs       touched =-        plan.snapshot.transactionTargets+        (plan ^. #snapshot . #transactionTargets)           `Set.union` baselinePaths           `Set.union` Set.singleton (".seihou" </> "manifest.json")   pure     ( Right         UpdateResult-          { updatedApplications = map (.applicationId) plan.applications,+          { updatedApplications = map (^. #applicationId) (plan ^. #applications),             manifest,-            versions = plan.versionChanges,-            fileSummary = reconciliationSummary plan.reconciliation,+            versions = plan ^. #versionChanges,+            fileSummary = reconciliationSummary (plan ^. #reconciliation),             commandSummary =               CommandSummary                 { executed = length completedReceipts,-                  skippedUnchanged = summary.skippedUnchanged,-                  skippedDisabled = summary.skippedDisabled+                  skippedUnchanged = summary ^. #skippedUnchanged,+                  skippedDisabled = summary ^. #skippedDisabled                 },             touchedPaths = touched,-            warnings = plan.warnings <> cleanupWarnings <> pruneWarnings+            warnings = plan ^. #warnings <> cleanupWarnings <> pruneWarnings           }     ) @@ -1011,51 +1060,68 @@ dryRunResult :: UpdatePlan -> UpdateResult dryRunResult plan =   (noOpResult plan)-    { versions = plan.versionChanges,-      fileSummary = reconciliationSummary plan.reconciliation,-      commandSummary = commandSummaryForPlan plan.commandPlan,-      warnings = plan.warnings-    }+    & #versions+    .~ plan+    ^. #versionChanges+    & #fileSummary+    .~ reconciliationSummary (plan ^. #reconciliation)+    & #commandSummary+    .~ commandSummaryForPlan (plan ^. #commandPlan)+    & #warnings+    .~ plan+    ^. #warnings  noOpResult :: UpdatePlan -> UpdateResult noOpResult plan =   UpdateResult     { updatedApplications = [],-      manifest = plan.snapshot.originalManifest,+      manifest = plan ^. #snapshot . #originalManifest,       versions = [],-      fileSummary = reconciliationSummary plan.reconciliation,+      fileSummary = reconciliationSummary (plan ^. #reconciliation),       commandSummary = CommandSummary 0 0 0,       touchedPaths = Set.empty,-      warnings = plan.warnings+      warnings = plan ^. #warnings     }  commandSummaryForPlan :: CommandPlan -> CommandSummary commandSummaryForPlan commandPlan =   let summary = summarizeCommandPlan commandPlan-   in CommandSummary summary.willRun summary.skippedUnchanged summary.skippedDisabled+   in CommandSummary (summary ^. #willRun) (summary ^. #skippedUnchanged) (summary ^. #skippedDisabled)  isUpdateNoOp :: UpdatePlan -> Bool isUpdateNoOp plan =-  null plan.versionChanges-    && null plan.migrations-    && plan.inputChanges.overridden == 0-    && plan.inputChanges.newlyResolved == 0-    && plan.inputChanges.removed == 0-    && (summarizeCommandPlan plan.commandPlan).willRun == 0-    && all unchangedFile (Map.elems plan.reconciliation.files)-    && and (zipWith sameApplication (mapMaybe (.previous) plan.plannedApplications) plan.applications)+  null (plan ^. #versionChanges)+    && null (plan ^. #migrations)+    && plan ^. #inputChanges . #overridden == 0+    && plan ^. #inputChanges . #newlyResolved == 0+    && plan ^. #inputChanges . #removed == 0+    && (summarizeCommandPlan (plan ^. #commandPlan)) ^. #willRun == 0+    && all unchangedFile (Map.elems (plan ^. #reconciliation . #files))+    && and (zipWith sameApplication (mapMaybe (^. #previous) (plan ^. #plannedApplications)) (plan ^. #applications))   where     unchangedFile FileUnchanged {} = True     unchangedFile _ = False+    -- Compare only what the manifest actually records. Anything derived from+    -- where an artifact happens to sit on this machine would differ between a+    -- decoded application and a freshly loaded candidate, and would report+    -- every re-run as a change.     sameApplication previous candidate =-      previous.target == candidate.target-        && previous.targetSource == candidate.targetSource-        && previous.targetVersion == candidate.targetVersion-        && previous.additionalModules == candidate.additionalModules-        && previous.namespace == candidate.namespace-        && previous.context == candidate.context-        && previous.instances == candidate.instances-        && previous.commandReceipts == candidate.commandReceipts+      previous ^. #target == candidate ^. #target+        && previous ^. #targetOrigin == candidate ^. #targetOrigin+        && previous ^. #targetVersion == candidate ^. #targetVersion+        && previous ^. #additionalModules == candidate ^. #additionalModules+        && previous ^. #namespace == candidate ^. #namespace+        && previous ^. #context == candidate ^. #context+        && length (previous ^. #instances) == length (candidate ^. #instances)+        && and (zipWith sameInstance (previous ^. #instances) (candidate ^. #instances))+        && previous ^. #commandReceipts == (candidate ^. #commandReceipts)++    sameInstance previous candidate =+      previous ^. #name == candidate ^. #name+        && previous ^. #parentVars == candidate ^. #parentVars+        && previous ^. #origin == candidate ^. #origin+        && previous ^. #moduleVersion == candidate ^. #moduleVersion+        && previous ^. #resolvedVars == candidate ^. #resolvedVars  isStructuredNoOp :: UpdatePlan -> Bool isStructuredNoOp = isUpdateNoOp
src/Seihou/CLI/Update/Interaction.hs view
@@ -10,6 +10,7 @@  import Control.Exception (IOException, try) import Control.Monad (foldM)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as T@@ -49,7 +50,7 @@   UpdatePlan ->   Either InteractionError UpdatePlan applyResolutionDecisions decisions plan = do-  reconciliation <- foldM applyOne plan.reconciliation decisions+  reconciliation <- foldM applyOne (plan ^. #reconciliation) decisions   pure plan {reconciliation}   where     applyOne current (ResolveFile path choice) =@@ -60,7 +61,7 @@ forceResolveUpdatePlan :: UpdatePlan -> Either InteractionError UpdatePlan forceResolveUpdatePlan plan = applyResolutionDecisions decisions plan   where-    decisions = concatMap forceOne (Map.toAscList plan.reconciliation.files)+    decisions = concatMap forceOne (Map.toAscList (plan ^. #reconciliation . #files))     forceOne (path, FileConflict _ _ _ reason _ _ Nothing) = case reason of       MergeDriverUnavailable _ -> []       _ -> [ResolveFile path AcceptGenerated]@@ -75,9 +76,9 @@ resolveInteractively mode plan   | Set.null remaining = pure (Right plan)   | mode == NonInteractive = pure (Left (InteractionRequired remaining))-  | otherwise = go plan (Map.toAscList plan.reconciliation.files)+  | otherwise = go plan (Map.toAscList (plan ^. #reconciliation . #files))   where-    remaining = unresolvedPaths plan.reconciliation+    remaining = unresolvedPaths (plan ^. #reconciliation)     go current [] = pure (Right current)     go current ((path, reconciliation) : rest) = case reconciliation of       FileConflict _ currentText markers reason _ _ Nothing -> do
src/Seihou/CLI/Update/Migrations.hs view
@@ -7,6 +7,7 @@ where  import Control.Monad (guard)+import Data.Generics.Labels () import Data.List (find) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe)@@ -32,21 +33,22 @@ import System.FilePath (takeDirectory)  data StagedMigrations = StagedMigrations-  { plans :: [PlannedUpdateMigration],-    manifest :: Manifest,-    filesystem :: PureFS,-    warnings :: [UpdateWarning]+  { plans :: ![PlannedUpdateMigration],+    manifest :: !Manifest,+    filesystem :: !PureFS,+    warnings :: ![UpdateWarning]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data Transition = Transition-  { moduleName :: ModuleName,-    originUrl :: Maybe Text,-    fromVersion :: Text,-    toVersion :: Text,-    candidateModule :: Module,-    sourceDirectory :: FilePath+  { moduleName :: !ModuleName,+    originUrl :: !(Maybe Text),+    fromVersion :: !Text,+    toVersion :: !Text,+    candidateModule :: !Module,+    sourceDirectory :: !FilePath   }+  deriving stock (Generic)  -- | Deduplicate equal module transitions and simulate them against a complete -- snapshot of tracked project text. Shell commands are mocked as successful@@ -70,9 +72,9 @@                 stageAll manifest [] planned     (finalManifest, stagedPlans) <- stageResult     let warnings =-          [ MigrationCommandNotSimulated plannedMigration.moduleName command+          [ MigrationCommandNotSimulated (plannedMigration ^. #moduleName) command           | plannedMigration <- stagedPlans,-            RunCommandInst command _ <- plannedMigration.stagedPlan.planOps+            RunCommandInst command _ <- plannedMigration ^. #stagedPlan . #ops           ]     Right       StagedMigrations@@ -86,19 +88,19 @@ stageAll manifest completed ((transition, sourcePlan) : rest) = do   classified <- classifyMigration manifest sourcePlan   case classified of-    Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err))+    Left err -> pure (Left (UpdateMigrationStageFailed (transition ^. #moduleName) err))     Right stagedPlan -> do-      executed <- executeMigration False stagedPlan manifest manifest.genAt+      executed <- executeMigration False stagedPlan manifest (manifest ^. #genAt)       case executed of-        Left err -> pure (Left (UpdateMigrationStageFailed transition.moduleName err))+        Left err -> pure (Left (UpdateMigrationStageFailed (transition ^. #moduleName) err))         Right nextManifest ->           let planned =                 PlannedUpdateMigration-                  { moduleName = transition.moduleName,-                    sourceDirectory = transition.sourceDirectory,+                  { moduleName = transition ^. #moduleName,+                    sourceDirectory = transition ^. #sourceDirectory,                     sourcePlan,                     stagedPlan,-                    containsCommands = any isCommand stagedPlan.planOps+                    containsCommands = any isCommand (stagedPlan ^. #ops)                   }            in stageAll nextManifest (planned : completed) rest   where@@ -114,7 +116,7 @@       priorByModule =         Map.fromListWith           Set.union-          [ ((transition.moduleName, transition.originUrl), Set.singleton transition.fromVersion)+          [ ((transition ^. #moduleName, transition ^. #originUrl), Set.singleton (transition ^. #fromVersion))           | transition <- raw           ]   case [ (name, Set.toAscList versions)@@ -129,15 +131,15 @@       mapMaybe (transitionFor previous) candidates      transitionFor previous (instanceId, candidateModule, sourceDirectory) = do-      prior <- find (matches instanceId) previous.instances-      fromVersion <- prior.moduleVersion-      toVersion <- candidateModule.version+      prior <- find (matches instanceId) (previous ^. #instances)+      fromVersion <- (prior ^. #moduleVersion)+      toVersion <- (candidateModule ^. #version)       guard (fromVersion /= toVersion)-      let artifact = Map.lookup (CandidateModule, candidateModule.name.unModuleName) catalog.artifacts+      let artifact = Map.lookup (CandidateModule, candidateModule ^. #name . #unModuleName) (catalog ^. #artifacts)       pure         Transition-          { moduleName = candidateModule.name,-            originUrl = artifact >>= (.sourceUrl),+          { moduleName = candidateModule ^. #name,+            originUrl = artifact >>= (^. #sourceUrl),             fromVersion,             toVersion,             candidateModule,@@ -145,8 +147,8 @@           }      matches instanceId state =-      state.name == instanceId.instanceModule-        && state.parentVars == instanceId.instanceParentVars+      state ^. #name == instanceId ^. #module_+        && state ^. #parentVars == (instanceId ^. #parentVars)  deduplicateTransitions :: [Transition] -> [Transition] deduplicateTransitions = go Set.empty@@ -157,28 +159,28 @@       | otherwise = transition : go (Set.insert (transitionKey transition) seen) rest      transitionKey transition =-      ( transition.moduleName,-        transition.originUrl,-        transition.fromVersion,-        transition.toVersion+      ( transition ^. #moduleName,+        transition ^. #originUrl,+        transition ^. #fromVersion,+        transition ^. #toVersion       )  planTransition :: Transition -> Either UpdateError (Transition, MigrationPlan) planTransition transition = do   fromVersion <-     maybe-      (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.fromVersion))+      (Left (CandidateVersionInvalid (transition ^. #moduleName . #unModuleName) (transition ^. #fromVersion)))       Right-      (parseVersion transition.fromVersion)+      (parseVersion (transition ^. #fromVersion))   toVersion <-     maybe-      (Left (CandidateVersionInvalid transition.moduleName.unModuleName transition.toVersion))+      (Left (CandidateVersionInvalid (transition ^. #moduleName . #unModuleName) (transition ^. #toVersion)))       Right-      (parseVersion transition.toVersion)+      (parseVersion (transition ^. #toVersion))   planned <-     first-      (UpdateMigrationPlanFailed transition.moduleName)-      (planMigrationChain transition.moduleName.unModuleName transition.candidateModule.migrations fromVersion toVersion)+      (UpdateMigrationPlanFailed (transition ^. #moduleName))+      (planMigrationChain (transition ^. #moduleName . #unModuleName) (transition ^. #candidateModule . #migrations) fromVersion toVersion)   case planned of     Nothing -> error "planTransition received unequal versions but no migration plan"     Just sourcePlan -> Right (transition, sourcePlan)@@ -186,17 +188,17 @@ commandMocks :: (Transition, MigrationPlan) -> [ProcessMock] commandMocks (_, sourcePlan) =   [ ProcessMock-      { mockCommand = "/bin/sh",-        mockArgs = ["-c", command],-        mockResult = (ExitSuccess, "", "")+      { command = "/bin/sh",+        args = ["-c", command],+        result = (ExitSuccess, "", "")       }-  | migration <- sourcePlan.planSteps,-    RunCommand command _ <- migration.ops+  | migration <- sourcePlan ^. #steps,+    RunCommand command _ <- migration ^. #ops   ]  snapshotTrackedFiles :: FilePath -> Manifest -> IO PureFS snapshotTrackedFiles projectRoot manifest = do-  files <- fmap Map.fromList . fmap concat $ traverse readTracked (Map.keys manifest.files)+  files <- fmap Map.fromList . fmap concat $ traverse readTracked (Map.keys (manifest ^. #files))   let directories =         Set.fromList           [ directory@@ -217,7 +219,7 @@     parents path = takeWhile (\directory -> directory /= "." && directory /= "") (iterate takeDirectory (takeDirectory path))  migrationTouchedPaths :: [PlannedUpdateMigration] -> Set FilePath-migrationTouchedPaths = Set.fromList . concatMap (concatMap touched . (.stagedPlan.planOps))+migrationTouchedPaths = Set.fromList . concatMap (concatMap touched . (^. #stagedPlan . #ops))   where     touched (MoveFileInst source destination _) = [source, destination]     touched (MoveDirInst source destination) = [source, destination]@@ -226,7 +228,7 @@     touched RunCommandInst {} = []  migrationTouchesDirectories :: PlannedUpdateMigration -> Bool-migrationTouchesDirectories migration = any touchesDirectory migration.stagedPlan.planOps+migrationTouchesDirectories migration = any touchesDirectory (migration ^. #stagedPlan . #ops)   where     touchesDirectory MoveDirInst {} = True     touchesDirectory DeleteDirInst {} = True
src/Seihou/CLI/Update/Recovery.hs view
@@ -11,6 +11,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.List (isPrefixOf, sortOn) import Data.Maybe (catMaybes, isJust) import Data.Ord (Down (..))@@ -30,19 +31,19 @@   deriving stock (Eq, Show)  data ServiceBackup = ServiceBackup-  { scope :: BackupScope,-    target :: FilePath,-    backupName :: Maybe FilePath+  { scope :: !BackupScope,+    target :: !FilePath,+    backupName :: !(Maybe FilePath)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data ServiceJournal = ServiceJournal-  { version :: Int,-    installedRoot :: FilePath,-    entries :: [ServiceBackup],-    expectedManifest :: Maybe Manifest+  { version :: !Int,+    installedRoot :: !FilePath,+    entries :: ![ServiceBackup],+    expectedManifest :: !(Maybe Manifest)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance ToJSON BackupScope where   toJSON ProjectDirectory = Aeson.String "project-directory"@@ -57,9 +58,9 @@ instance ToJSON ServiceBackup where   toJSON entry =     Aeson.object-      [ "scope" .= entry.scope,-        "target" .= entry.target,-        "backup" .= entry.backupName+      [ "scope" .= (entry ^. #scope),+        "target" .= (entry ^. #target),+        "backup" .= (entry ^. #backupName)       ]  instance FromJSON ServiceBackup where@@ -69,10 +70,10 @@ instance ToJSON ServiceJournal where   toJSON journal =     Aeson.object-      [ "version" .= journal.version,-        "installedRoot" .= journal.installedRoot,-        "entries" .= journal.entries,-        "expectedManifest" .= journal.expectedManifest+      [ "version" .= (journal ^. #version),+        "installedRoot" .= (journal ^. #installedRoot),+        "entries" .= (journal ^. #entries),+        "expectedManifest" .= (journal ^. #expectedManifest)       ]  instance FromJSON ServiceJournal where@@ -99,18 +100,18 @@   let projectDirectories = normalizeDirectories (concatMap migrationDirectories migrations)       installedNames =         Set.toAscList . Set.fromList $-          [ T.unpack artifact.name+          [ T.unpack (artifact ^. #name)           | artifact <- artifacts,-            isJust artifact.sourceUrl+            isJust (artifact ^. #sourceUrl)           ]       requests =         map (ProjectDirectory,) projectDirectories           <> map (InstalledArtifact,) installedNames-      backupRoot = transaction.transactionDirectory </> "service-backups"+      backupRoot = transaction ^. #transactionDirectory </> "service-backups"   result <- try @SomeException $ do     Directory.createDirectoryIfMissing True backupRoot     entries <- forM (zip [0 :: Int ..] requests) $ \(index, (scope, target)) -> do-      fullTarget <- resolveTarget transaction.projectRoot installedRoot scope target+      fullTarget <- resolveTarget (transaction ^. #projectRoot) installedRoot scope target       exists <- Directory.doesDirectoryExist fullTarget       if exists         then do@@ -120,7 +121,7 @@           pure ServiceBackup {scope, target, backupName = Just backupName}         else pure ServiceBackup {scope, target, backupName = Nothing}     writeServiceJournal-      transaction.transactionDirectory+      (transaction ^. #transactionDirectory)       ServiceJournal         { version = 1,           installedRoot,@@ -131,7 +132,7 @@  setServiceExpectedManifest :: UpdateTransaction -> Manifest -> IO (Either UpdateError ()) setServiceExpectedManifest transaction expected = do-  current <- readServiceJournal transaction.transactionDirectory+  current <- readServiceJournal (transaction ^. #transactionDirectory)   case current of     Left err -> pure (Left err)     Right Nothing -> pure (Right ())@@ -139,17 +140,17 @@       result <-         try @SomeException $           writeServiceJournal-            transaction.transactionDirectory-            journal {expectedManifest = Just expected}+            (transaction ^. #transactionDirectory)+            (journal & #expectedManifest ?~ expected)       pure $ first (UpdateManifestWriteFailed . T.pack . displayException) result  restoreServiceBackups :: UpdateTransaction -> IO (Either UpdateError ()) restoreServiceBackups transaction = do-  current <- readServiceJournal transaction.transactionDirectory+  current <- readServiceJournal (transaction ^. #transactionDirectory)   case current of     Left err -> pure (Left err)     Right Nothing -> pure (Right ())-    Right (Just journal) -> restoreJournal transaction.projectRoot transaction.transactionDirectory journal+    Right (Just journal) -> restoreJournal (transaction ^. #projectRoot) (transaction ^. #transactionDirectory) journal  -- | Restore or accept every service journal before the core transaction -- recovery pass. A durable matching manifest means cache/directory publication@@ -173,7 +174,7 @@               Left err -> pure (Just (Left err))               Right Nothing -> pure Nothing               Right (Just journal) -> do-                committed <- manifestMatches projectRoot journal.expectedManifest+                committed <- manifestMatches projectRoot (journal ^. #expectedManifest)                 if committed                   then pure (Just (Right ()))                   else Just <$> restoreJournal projectRoot transactionDirectory journal@@ -181,11 +182,11 @@ restoreJournal :: FilePath -> FilePath -> ServiceJournal -> IO (Either UpdateError ()) restoreJournal projectRoot transactionDirectory journal = do   result <- try @SomeException $-    forM_ (sortOn (Down . pathDepth . (.target)) journal.entries) $ \entry -> do-      fullTarget <- resolveTarget projectRoot journal.installedRoot entry.scope entry.target+    forM_ (sortOn (Down . pathDepth . (^. #target)) (journal ^. #entries)) $ \entry -> do+      fullTarget <- resolveTarget projectRoot (journal ^. #installedRoot) (entry ^. #scope) (entry ^. #target)       targetExists <- Directory.doesPathExist fullTarget       when targetExists (Directory.removePathForcibly fullTarget)-      case entry.backupName of+      case entry ^. #backupName of         Nothing -> pure ()         Just backupName -> do           validateBackupName backupName@@ -214,7 +215,7 @@   [] -> False  migrationDirectories :: PlannedUpdateMigration -> [FilePath]-migrationDirectories migration = concatMap directories migration.stagedPlan.planOps+migrationDirectories migration = concatMap directories (migration ^. #stagedPlan . #ops)   where     directories (MoveDirInst source destination) = [source, destination]     directories (DeleteDirInst path) = [path]
src/Seihou/CLI/Update/Render.hs view
@@ -13,6 +13,7 @@  import Data.Aeson (Value, encode, object, (.=)) import Data.ByteString.Lazy (ByteString)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Set qualified as Set@@ -74,26 +75,26 @@ renderUpdateHuman _ (UpdatePlanOutput (UpdatePlanView plan)) =   T.unlines $     versionLines plan-      <> [ renderInputs plan.inputChanges,-           "Migrations:  " <> count (length plan.migrations) <> migrationCaveat plan,-           renderFiles (reconciliationSummary plan.reconciliation),-           renderCommands (summarizeCommandPlan plan.commandPlan)+      <> [ renderInputs (plan ^. #inputChanges),+           "Migrations:  " <> count (length (plan ^. #migrations)) <> migrationCaveat plan,+           renderFiles (reconciliationSummary (plan ^. #reconciliation)),+           renderCommands (summarizeCommandPlan (plan ^. #commandPlan))          ]-      <> conflictLines plan.reconciliation-      <> warningLines plan.warnings+      <> conflictLines (plan ^. #reconciliation)+      <> warningLines (plan ^. #warnings) renderUpdateHuman _ (UpdateAppliedOutput (UpdateResultView result)) =   T.unlines $-    [ "Updated " <> count (length result.updatedApplications) <> " application(s).",-      renderFiles result.fileSummary,+    [ "Updated " <> count (length (result ^. #updatedApplications)) <> " application(s).",+      renderFiles (result ^. #fileSummary),       "Commands:    "-        <> count result.commandSummary.executed+        <> count (result ^. #commandSummary . #executed)         <> " executed; "-        <> count result.commandSummary.skippedUnchanged+        <> count (result ^. #commandSummary . #skippedUnchanged)         <> " unchanged skipped; "-        <> count result.commandSummary.skippedDisabled+        <> count (result ^. #commandSummary . #skippedDisabled)         <> " disabled"     ]-      <> warningLines result.warnings+      <> warningLines (result ^. #warnings) renderUpdateHuman _ (UpdateFailedOutput (UpdateErrorView err)) =   "Update failed [" <> errorCode err <> "]: " <> errorMessage err <> "\n" @@ -106,29 +107,29 @@     [ "schemaVersion" .= (1 :: Int),       "outcome" .= ("plan" :: Text),       "alreadyUpToDate" .= planLooksUnchanged plan,-      "applications" .= map applicationIdText plan.applications,-      "versions" .= map versionValue plan.versionChanges,-      "inputs" .= inputValue plan.inputChanges,-      "migrations" .= map migrationValue plan.migrations,-      "files" .= map fileValue (Map.toAscList plan.reconciliation.files),-      "commands" .= map commandValue plan.commandPlan.commands,-      "warnings" .= map warningText plan.warnings+      "applications" .= map applicationIdText (plan ^. #applications),+      "versions" .= map versionValue (plan ^. #versionChanges),+      "inputs" .= inputValue (plan ^. #inputChanges),+      "migrations" .= map migrationValue (plan ^. #migrations),+      "files" .= map fileValue (Map.toAscList (plan ^. #reconciliation . #files)),+      "commands" .= map commandValue (plan ^. #commandPlan . #commands),+      "warnings" .= map warningText (plan ^. #warnings)     ] outputValue (UpdateAppliedOutput (UpdateResultView result)) =   object     [ "schemaVersion" .= (1 :: Int),       "outcome" .= ("applied" :: Text),-      "applications" .= map (.unApplicationId) result.updatedApplications,-      "versions" .= map versionValue result.versions,-      "files" .= summaryValue result.fileSummary,+      "applications" .= map (^. #unApplicationId) (result ^. #updatedApplications),+      "versions" .= map versionValue (result ^. #versions),+      "files" .= summaryValue (result ^. #fileSummary),       "commands"         .= object-          [ "executed" .= result.commandSummary.executed,-            "skippedUnchanged" .= result.commandSummary.skippedUnchanged,-            "skippedDisabled" .= result.commandSummary.skippedDisabled+          [ "executed" .= (result ^. #commandSummary . #executed),+            "skippedUnchanged" .= (result ^. #commandSummary . #skippedUnchanged),+            "skippedDisabled" .= (result ^. #commandSummary . #skippedDisabled)           ],-      "touchedPaths" .= Set.toAscList result.touchedPaths,-      "warnings" .= map warningText result.warnings+      "touchedPaths" .= Set.toAscList (result ^. #touchedPaths),+      "warnings" .= map warningText (result ^. #warnings)     ] outputValue (UpdateFailedOutput (UpdateErrorView err)) =   object@@ -139,70 +140,70 @@  versionLines :: UpdatePlan -> [Text] versionLines plan-  | null plan.versionChanges = ["Versions:    unchanged"]-  | otherwise = map renderVersionChange plan.versionChanges+  | null (plan ^. #versionChanges) = ["Versions:    unchanged"]+  | otherwise = map renderVersionChange (plan ^. #versionChanges)  renderVersionChange :: VersionChange -> Text renderVersionChange change =-  change.name+  change ^. #name     <> "  "-    <> fromMaybe "unversioned" change.fromVersion+    <> fromMaybe "unversioned" (change ^. #fromVersion)     <> " -> "-    <> fromMaybe "unversioned" change.toVersion-    <> if change.sameVersionContentChanged then " (content changed at same version)" else ""+    <> fromMaybe "unversioned" (change ^. #toVersion)+    <> if change ^. #sameVersionContentChanged then " (content changed at same version)" else ""  renderInputs :: InputChangeSummary -> Text renderInputs summary =   "Inputs:      "-    <> count summary.reused+    <> count (summary ^. #reused)     <> " reused; "-    <> count summary.overridden+    <> count (summary ^. #overridden)     <> " overridden; "-    <> count summary.newlyResolved+    <> count (summary ^. #newlyResolved)     <> " newly resolved; "-    <> count summary.removed+    <> count (summary ^. #removed)     <> " removed"  renderFiles :: ReconciliationSummary -> Text renderFiles summary =   "Files:       "-    <> count summary.creates+    <> count (summary ^. #creates)     <> " created; "-    <> count summary.updates+    <> count (summary ^. #updates)     <> " updated; "-    <> count summary.merged+    <> count (summary ^. #merged)     <> " merged; "-    <> count summary.unchanged+    <> count (summary ^. #unchanged)     <> " unchanged; "-    <> count summary.conflicts+    <> count (summary ^. #conflicts)     <> " conflicts; "-    <> count summary.safeDeletes+    <> count (summary ^. #safeDeletes)     <> " deleted; "-    <> count summary.editedOrphans+    <> count (summary ^. #editedOrphans)     <> " edited orphans"  renderCommands summary =   "Commands:    "-    <> count summary.willRun+    <> count (summary ^. #willRun)     <> " will run; "-    <> count summary.skippedUnchanged+    <> count (summary ^. #skippedUnchanged)     <> " unchanged skipped; "-    <> count summary.skippedDisabled+    <> count (summary ^. #skippedDisabled)     <> " disabled"  migrationCaveat plan-  | any (.containsCommands) plan.migrations = " (includes non-simulatable commands)"+  | any (^. #containsCommands) (plan ^. #migrations) = " (includes non-simulatable commands)"   | otherwise = ""  conflictLines :: ReconciliationPlan -> [Text]-conflictLines reconciliation = concatMap renderOne (Map.toAscList reconciliation.files)+conflictLines reconciliation = concatMap renderOne (Map.toAscList (reconciliation ^. #files))   where     renderOne (path, FileConflict _ _ _ reason _ _ resolution) =       [ "Conflict:    "           <> T.pack path           <> " ("           <> T.pack (show reason)-          <> maybe "; unresolved" (("; " <>) . resolutionText . (.choice)) resolution+          <> maybe "; unresolved" (("; " <>) . resolutionText . (^. #choice)) resolution           <> ")"       ]     renderOne (path, FileOrphanEdited _ _ _ _ choice) =@@ -218,30 +219,30 @@ versionValue :: VersionChange -> Value versionValue change =   object-    [ "name" .= change.name,-      "from" .= change.fromVersion,-      "to" .= change.toVersion,-      "sameVersionContentChanged" .= change.sameVersionContentChanged+    [ "name" .= (change ^. #name),+      "from" .= (change ^. #fromVersion),+      "to" .= (change ^. #toVersion),+      "sameVersionContentChanged" .= (change ^. #sameVersionContentChanged)     ]  inputValue :: InputChangeSummary -> Value inputValue summary =   object-    [ "reused" .= summary.reused,-      "overridden" .= summary.overridden,-      "newlyResolved" .= summary.newlyResolved,-      "removed" .= summary.removed,-      "ambiguousLegacy" .= map (.unVarName) summary.ambiguousLegacy+    [ "reused" .= (summary ^. #reused),+      "overridden" .= (summary ^. #overridden),+      "newlyResolved" .= (summary ^. #newlyResolved),+      "removed" .= (summary ^. #removed),+      "ambiguousLegacy" .= map (^. #unVarName) (summary ^. #ambiguousLegacy)     ]  migrationValue :: PlannedUpdateMigration -> Value migrationValue migration =   object-    [ "module" .= migration.moduleName.unModuleName,-      "from" .= showText migration.sourcePlan.planFrom,-      "to" .= showText migration.sourcePlan.planTo,-      "steps" .= length migration.sourcePlan.planSteps,-      "containsCommands" .= migration.containsCommands+    [ "module" .= (migration ^. #moduleName . #unModuleName),+      "from" .= showText (migration ^. #sourcePlan . #from),+      "to" .= showText (migration ^. #sourcePlan . #to),+      "steps" .= length (migration ^. #sourcePlan . #steps),+      "containsCommands" .= (migration ^. #containsCommands)     ]  fileValue :: (FilePath, FileReconciliation) -> Value@@ -264,21 +265,21 @@ classification FileAlreadyAbsent {} = "alreadyAbsent"  resolutionFor :: FileReconciliation -> Maybe Text-resolutionFor (FileConflict _ _ _ _ _ _ resolution) = resolutionText . (.choice) <$> resolution+resolutionFor (FileConflict _ _ _ _ _ _ resolution) = resolutionText . (^. #choice) <$> resolution resolutionFor (FileOrphanEdited _ _ _ _ choice) = orphanChoiceText <$> choice resolutionFor _ = Nothing  commandValue :: PlannedCommand -> Value commandValue planned =   object-    [ "fingerprint" .= fingerprintText planned.fingerprint,-      "status" .= dispositionText planned.disposition,-      "module" .= commandModule planned.operation,-      "command" .= commandText planned.operation+    [ "fingerprint" .= fingerprintText (planned ^. #fingerprint),+      "status" .= dispositionText (planned ^. #disposition),+      "module" .= commandModule (planned ^. #operation),+      "command" .= commandText (planned ^. #operation)     ]  commandModule :: Operation -> Maybe Text-commandModule RunCommandOp {moduleName} = Just moduleName.unModuleName+commandModule RunCommandOp {moduleName} = Just (moduleName ^. #unModuleName) commandModule _ = Nothing  commandText :: Operation -> Maybe Text@@ -305,18 +306,18 @@ summaryValue :: ReconciliationSummary -> Value summaryValue summary =   object-    [ "created" .= summary.creates,-      "updated" .= summary.updates,-      "merged" .= summary.merged,-      "unchanged" .= summary.unchanged,-      "conflicts" .= summary.conflicts,-      "safeDeletes" .= summary.safeDeletes,-      "editedOrphans" .= summary.editedOrphans,-      "sharedOwnership" .= summary.sharedOwnership+    [ "created" .= (summary ^. #creates),+      "updated" .= (summary ^. #updates),+      "merged" .= (summary ^. #merged),+      "unchanged" .= (summary ^. #unchanged),+      "conflicts" .= (summary ^. #conflicts),+      "safeDeletes" .= (summary ^. #safeDeletes),+      "editedOrphans" .= (summary ^. #editedOrphans),+      "sharedOwnership" .= (summary ^. #sharedOwnership)     ]  applicationIdText :: AppliedComposition -> Text-applicationIdText application = application.applicationId.unApplicationId+applicationIdText application = (application ^. #applicationId . #unApplicationId)  fingerprintText :: CommandFingerprint -> Text fingerprintText (CommandFingerprint (SHA256 value)) = value@@ -334,6 +335,7 @@ errorCode CandidateCloneFailed {} = "candidate_clone_failed" errorCode CandidateRepositoryInvalid {} = "candidate_repository_invalid" errorCode CandidateArtifactMissing {} = "candidate_artifact_missing"+errorCode CandidateArtifactUnresolved {} = "candidate_artifact_unresolved" errorCode CandidateArtifactAmbiguous {} = "candidate_artifact_ambiguous" errorCode CandidateLoadFailed {} = "candidate_load_failed" errorCode CandidateDowngrade {} = "candidate_downgrade"@@ -367,9 +369,9 @@   "Path "     <> T.pack path     <> " is also owned by application(s) "-    <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList required))+    <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList required))     <> ". Select every owner or run seihou update with no targets. Selected: "-    <> T.intercalate ", " (map (.unApplicationId) (Set.toAscList selected))+    <> T.intercalate ", " (map (^. #unApplicationId) (Set.toAscList selected)) errorMessage (UpdateHasUnresolvedPaths paths) =   "Resolve these paths before apply: " <> T.intercalate ", " (map T.pack (Set.toAscList paths)) errorMessage (UpdatePlanStale paths) =@@ -378,13 +380,13 @@  planLooksUnchanged :: UpdatePlan -> Bool planLooksUnchanged plan =-  null plan.versionChanges-    && null plan.migrations-    && plan.inputChanges.overridden == 0-    && plan.inputChanges.newlyResolved == 0-    && plan.inputChanges.removed == 0-    && (summarizeCommandPlan plan.commandPlan).willRun == 0-    && all isUnchanged (Map.elems plan.reconciliation.files)+  null (plan ^. #versionChanges)+    && null (plan ^. #migrations)+    && plan ^. #inputChanges . #overridden == 0+    && plan ^. #inputChanges . #newlyResolved == 0+    && plan ^. #inputChanges . #removed == 0+    && (summarizeCommandPlan (plan ^. #commandPlan)) ^. #willRun == 0+    && all isUnchanged (Map.elems (plan ^. #reconciliation . #files))   where     isUnchanged FileUnchanged {} = True     isUnchanged _ = False
src/Seihou/CLI/Update/Selection.hs view
@@ -7,6 +7,7 @@ where  import Control.Monad (foldM)+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Seihou.CLI.Update.Types@@ -24,34 +25,34 @@ selectApplications :: UpdateSelection -> Manifest -> Either UpdateError SelectedApplications selectApplications selection manifest = case selection of   AllRecordedApplications-    | null manifest.applications -> Left NoRecordedApplications-    | otherwise -> Right (RecordedSelection manifest.applications)+    | null (manifest ^. #applications) -> Left NoRecordedApplications+    | otherwise -> Right (RecordedSelection (manifest ^. #applications))   NamedUpdateTargets names-    | null manifest.applications -> case nubOrd names of+    | null (manifest ^. #applications) -> case nubOrd names of         [name] -> Right (LegacySelection name)         _ -> Left LegacyUpdateRequiresOneTarget     | otherwise -> do         selectedIds <- foldM selectName Set.empty (nubOrd names)-        let selected = filter ((`Set.member` selectedIds) . (.applicationId)) manifest.applications+        let selected = filter ((`Set.member` selectedIds) . (^. #applicationId)) (manifest ^. #applications)         ensureOwnershipClosure manifest selectedIds         Right (RecordedSelection selected)   where     selectName selected name =-      let exact = filter ((== name) . targetName) manifest.applications+      let exact = filter ((== name) . targetName) (manifest ^. #applications)           matches =             if null exact-              then filter (containsModule name) manifest.applications+              then filter (containsModule name) (manifest ^. #applications)               else exact        in if null matches             then Left (UpdateTargetNotFound name (availableTargets manifest))-            else Right (foldl' (flip (Set.insert . (.applicationId))) selected matches)+            else Right (foldl' (flip (Set.insert . (^. #applicationId))) selected matches)  ensureOwnershipClosure :: Manifest -> Set ApplicationId -> Either UpdateError () ensureOwnershipClosure manifest selected =   case [ (path, selectedOwners, missingOwners)-       | (path, record) <- Map.toAscList manifest.files,-         let selectedOwners = Set.intersection selected record.applicationIds,-         let missingOwners = record.applicationIds Set.\\ selected,+       | (path, record) <- Map.toAscList (manifest ^. #files),+         let selectedOwners = Set.intersection selected (record ^. #applicationIds),+         let missingOwners = (record ^. #applicationIds) Set.\\ selected,          not (Set.null selectedOwners),          not (Set.null missingOwners)        ] of@@ -60,21 +61,21 @@     [] -> Right ()  targetName :: AppliedComposition -> Text-targetName application = case application.target of-  AppliedModuleTarget name -> name.unModuleName-  AppliedRecipeTarget name -> name.unRecipeName+targetName application = case application ^. #target of+  AppliedModuleTarget name -> (name ^. #unModuleName)+  AppliedRecipeTarget name -> (name ^. #unRecipeName)  availableTargets :: Manifest -> [Text]-availableTargets manifest = nubOrd (map targetName manifest.applications <> instanceNames)+availableTargets manifest = nubOrd (map targetName (manifest ^. #applications) <> instanceNames)   where     instanceNames =-      [ state.name.unModuleName-      | application <- manifest.applications,-        state <- application.instances+      [ state ^. #name . #unModuleName+      | application <- manifest ^. #applications,+        state <- application ^. #instances       ]  containsModule :: Text -> AppliedComposition -> Bool-containsModule name = any ((== name) . (.name.unModuleName)) . (.instances)+containsModule name = any ((== name) . (^. #name . #unModuleName)) . (^. #instances)  nubOrd :: (Ord a) => [a] -> [a] nubOrd = go Set.empty
src/Seihou/CLI/Update/Source.hs view
@@ -8,6 +8,7 @@ import Control.Monad (foldM, forM) import Data.ByteString qualified as BS import Data.Foldable (traverse_)+import Data.Generics.Labels () import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Text qualified as T@@ -15,10 +16,10 @@   ( OriginInfo (..),     cloneRepo,     copyDirectoryRecursive,-    readOriginInfo,   ) import Seihou.CLI.Update.Types-import Seihou.Core.Module (validateModule)+import Seihou.Core.ArtifactRef (ArtifactRefError, resolveArtifactOrigin)+import Seihou.Core.Module (defaultSearchPaths, validateModule) import Seihou.Core.Recipe (validateRecipe) import Seihou.Core.Registry (Registry (..), RegistryEntry (..), validateRegistry) import Seihou.Core.Types@@ -29,27 +30,37 @@ import System.Exit (ExitCode (..)) import System.Process (readProcessWithExitCode) +-- | One artifact an update has to obtain before it can re-plan.+--+-- @sourceDirectory@ is where the currently-applied copy lives on this+-- machine, resolved from the manifest's recorded origin. It is only consulted+-- for artifacts with no remote to clone from, so a resolution failure is+-- carried rather than raised: an artifact that will be cloned does not need+-- to exist locally at all. data ArtifactRequirement = ArtifactRequirement-  { kind :: CandidateArtifactKind,-    name :: Text,-    sourceDirectory :: FilePath,-    origin :: Maybe OriginInfo+  { kind :: !CandidateArtifactKind,+    name :: !Text,+    sourceDirectory :: !(Either ArtifactRefError FilePath),+    origin :: !(Maybe OriginInfo)   }+  deriving stock (Generic)  -- | Clone every distinct remote once, validate its complete module/recipe -- catalog, and materialize a name-keyed temporary search root. Local artifacts -- remain a fallback and are called out explicitly. stageCandidateSources ::   FilePath ->+  FilePath ->+  FilePath ->   [AppliedComposition] ->   IO (Either UpdateError (CandidateCatalog, [UpdateWarning]))-stageCandidateSources sessionRoot selected = do-  requirements <- requirementsFor selected+stageCandidateSources sessionRoot projectRoot installedDirectory selected = do+  requirements <- requirementsFor projectRoot installedDirectory selected   let remoteOrigins =         Map.fromList-          [ (origin.sourceUrl, origin)+          [ (origin ^. #sourceUrl, origin)           | requirement <- requirements,-            Just origin <- [requirement.origin]+            Just origin <- [requirement ^. #origin]           ]       clonesRoot = sessionRoot </> "clones"       searchRoot = sessionRoot </> "search"@@ -72,27 +83,45 @@             localWarnings           ) -requirementsFor :: [AppliedComposition] -> IO [ArtifactRequirement]-requirementsFor applications = concat <$> mapM applicationRequirements applications+requirementsFor :: FilePath -> FilePath -> [AppliedComposition] -> IO [ArtifactRequirement]+requirementsFor projectRoot installedDirectory applications = concat <$> mapM applicationRequirements applications   where     applicationRequirements application = do-      targetOrigin <- readOriginInfo application.targetSource-      instanceRequirements <- forM application.instances $ \state -> do-        origin <- readOriginInfo state.source-        pure-          ArtifactRequirement-            { kind = CandidateModule,-              name = state.name.unModuleName,-              sourceDirectory = state.source,-              origin-            }-      let targetRequirement = case application.target of-            AppliedModuleTarget name ->-              ArtifactRequirement CandidateModule name.unModuleName application.targetSource targetOrigin-            AppliedRecipeTarget name ->-              ArtifactRequirement CandidateRecipe name.unRecipeName application.targetSource targetOrigin+      targetRequirement <-+        requirement+          ( case application ^. #target of+              AppliedModuleTarget name -> (CandidateModule, name ^. #unModuleName)+              AppliedRecipeTarget name -> (CandidateRecipe, name ^. #unRecipeName)+          )+          (application ^. #targetOrigin)+      instanceRequirements <-+        forM (application ^. #instances) $ \state ->+          requirement (CandidateModule, state ^. #name . #unModuleName) (state ^. #origin)       pure (targetRequirement : instanceRequirements) +    requirement (kind, name) origin = do+      searchPaths <- defaultSearchPaths+      sourceDirectory <- resolveArtifactOrigin projectRoot searchPaths (definitionFileFor kind) origin+      pure ArtifactRequirement {kind, name, sourceDirectory, origin = remoteProvenance origin}++definitionFileFor :: CandidateArtifactKind -> FilePath+definitionFileFor CandidateModule = "module.dhall"+definitionFileFor CandidateRecipe = "recipe.dhall"++-- | Recover the remote-provenance view an update needs from the manifest's+-- portable origin.+--+-- Before schema version 6 this was read from the @.seihou-origin.json@ file+-- beside the absolute path the manifest recorded — that is, from whatever the+-- machine that ran the command happened to have installed. Taking it from the+-- manifest instead is both portable and more authoritative: it is the+-- project's own record of what it was generated from. The installed-at+-- version is deliberately not reconstructed here; nothing in staging reads it.+remoteProvenance :: ArtifactOrigin -> Maybe OriginInfo+remoteProvenance (RemoteOrigin url _ repo) = Just (OriginInfo url repo Nothing)+remoteProvenance (ProjectOrigin _) = Nothing+remoteProvenance (LocalOrigin _) = Nothing+ stageRemoteOrigins ::   FilePath ->   FilePath ->@@ -150,8 +179,8 @@   Registry ->   IO (Either UpdateError [CandidateArtifact]) discoverRegistryArtifacts url revision repoRoot registry = do-  modules <- traverse (loadRemoteModule url (Just registry.repoName) revision repoRoot) registry.modules-  recipes <- traverse (loadRemoteRecipe url (Just registry.repoName) revision repoRoot) registry.recipes+  modules <- traverse (loadRemoteModule url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #modules)+  recipes <- traverse (loadRemoteRecipe url (Just (registry ^. #repoName)) revision repoRoot) (registry ^. #recipes)   pure ((<>) <$> sequence modules <*> sequence recipes)  discoverSingleArtifact ::@@ -164,21 +193,21 @@   hasModule <- Directory.doesFileExist (repoRoot </> "module.dhall")   hasRecipe <- Directory.doesFileExist (repoRoot </> "recipe.dhall")   if hasModule-    then fmap (fmap (: [])) (loadModuleArtifact (Just url) origin.repoName [] revision repoRoot)+    then fmap (fmap (: [])) (loadModuleArtifact (Just url) (origin ^. #repoName) [] revision repoRoot)     else       if hasRecipe-        then fmap (fmap (: [])) (loadRecipeArtifact (Just url) origin.repoName [] revision repoRoot)+        then fmap (fmap (: [])) (loadRecipeArtifact (Just url) (origin ^. #repoName) [] revision repoRoot)         else pure (Left (CandidateRepositoryInvalid url ["repository contains no module, recipe, or registry"]))  loadRemoteModule ::   Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) loadRemoteModule url repoName revision repoRoot entry =-  loadModuleArtifact (Just url) repoName entry.tags revision (repoRoot </> entry.path)+  loadModuleArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot </> entry ^. #path)  loadRemoteRecipe ::   Text -> Maybe Text -> Maybe Text -> FilePath -> RegistryEntry -> IO (Either UpdateError CandidateArtifact) loadRemoteRecipe url repoName revision repoRoot entry =-  loadRecipeArtifact (Just url) repoName entry.tags revision (repoRoot </> entry.path)+  loadRecipeArtifact (Just url) repoName (entry ^. #tags) revision (repoRoot </> entry ^. #path)  loadModuleArtifact ::   Maybe Text -> Maybe Text -> [Text] -> Maybe Text -> FilePath -> IO (Either UpdateError CandidateArtifact)@@ -189,15 +218,15 @@     Right modul -> do       validated <- validateModule directory modul       case validated of-        Left err -> pure (Left (CandidateLoadFailed modul.name.unModuleName err))+        Left err -> pure (Left (CandidateLoadFailed (modul ^. #name . #unModuleName) err))         Right candidateModule -> do           contentHash <- hashArtifactDirectory directory           pure             ( Right                 CandidateArtifact                   { kind = CandidateModule,-                    name = candidateModule.name.unModuleName,-                    version = candidateModule.version,+                    name = candidateModule ^. #name . #unModuleName,+                    version = candidateModule ^. #version,                     originalDirectory = directory,                     sourceDirectory = directory,                     sourceUrl,@@ -224,8 +253,8 @@           ( Right               CandidateArtifact                 { kind = CandidateRecipe,-                  name = validated.name.unRecipeName,-                  version = validated.version,+                  name = validated ^. #name . #unRecipeName,+                  version = validated ^. #version,                   originalDirectory = directory,                   sourceDirectory = directory,                   sourceUrl,@@ -246,22 +275,27 @@ stageLocalRequirements searchRoot initial = go initial []   where     go artifacts warnings [] = pure (Right (artifacts, reverse warnings))-    go artifacts warnings (requirement : rest) = case requirement.origin of+    go artifacts warnings (requirement : rest) = case requirement ^. #origin of       Just _ -> go artifacts warnings rest       Nothing-        | Map.member (requirement.kind, requirement.name) artifacts -> go artifacts warnings rest-        | otherwise -> do-            loaded <- case requirement.kind of-              CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing requirement.sourceDirectory-              CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing requirement.sourceDirectory-            case loaded of-              Left err -> pure (Left err)-              Right candidate -> do-                inserted <- insertCandidate searchRoot (Right artifacts) candidate-                case inserted of-                  Left err -> pure (Left err)-                  Right artifacts' ->-                    go artifacts' (LocalArtifactHasNoRemote requirement.name : warnings) rest+        | Map.member (requirement ^. #kind, requirement ^. #name) artifacts -> go artifacts warnings rest+        | otherwise -> case requirement ^. #sourceDirectory of+            -- There is no remote to fall back on and no local copy either, so+            -- the update cannot proceed. Report the resolution failure with+            -- its own wording rather than a generic "artifact missing".+            Left refErr -> pure (Left (CandidateArtifactUnresolved refErr))+            Right directory -> do+              loaded <- case requirement ^. #kind of+                CandidateModule -> loadModuleArtifact Nothing Nothing [] Nothing directory+                CandidateRecipe -> loadRecipeArtifact Nothing Nothing [] Nothing directory+              case loaded of+                Left err -> pure (Left err)+                Right candidate -> do+                  inserted <- insertCandidate searchRoot (Right artifacts) candidate+                  case inserted of+                    Left err -> pure (Left err)+                    Right artifacts' ->+                      go artifacts' (LocalArtifactHasNoRemote (requirement ^. #name) : warnings) rest  insertCandidate ::   FilePath ->@@ -275,17 +309,17 @@       pure         ( Left             ( CandidateArtifactAmbiguous-                candidate.kind-                candidate.name-                (map (maybe "local" id . (.sourceUrl)) [existing, candidate])+                (candidate ^. #kind)+                (candidate ^. #name)+                (map (maybe "local" id . (^. #sourceUrl)) [existing, candidate])             )         )     Nothing -> do-      let destination = searchRoot </> T.unpack candidate.name+      let destination = searchRoot </> T.unpack (candidate ^. #name)       Directory.createDirectoryIfMissing True destination-      copied <- try @SomeException (copyDirectoryRecursive candidate.sourceDirectory destination)+      copied <- try @SomeException (copyDirectoryRecursive (candidate ^. #sourceDirectory) destination)       pure $ case copied of-        Left err -> Left (CandidateRepositoryInvalid candidate.name [T.pack (displayException err)])+        Left err -> Left (CandidateRepositoryInvalid (candidate ^. #name) [T.pack (displayException err)])         Right () ->           Right             ( Map.insert@@ -294,23 +328,23 @@                 artifacts             )   where-    key = (candidate.kind, candidate.name)+    key = (candidate ^. #kind, candidate ^. #name)  setCandidateSource :: FilePath -> CandidateArtifact -> CandidateArtifact setCandidateSource directory candidate =   CandidateArtifact-    { kind = candidate.kind,-      name = candidate.name,-      version = candidate.version,-      originalDirectory = candidate.originalDirectory,+    { kind = candidate ^. #kind,+      name = candidate ^. #name,+      version = candidate ^. #version,+      originalDirectory = candidate ^. #originalDirectory,       sourceDirectory = directory,-      sourceUrl = candidate.sourceUrl,-      repoName = candidate.repoName,-      tags = candidate.tags,-      sourceRevision = candidate.sourceRevision,-      contentHash = candidate.contentHash,-      moduleDefinition = candidate.moduleDefinition,-      recipeDefinition = candidate.recipeDefinition+      sourceUrl = candidate ^. #sourceUrl,+      repoName = candidate ^. #repoName,+      tags = candidate ^. #tags,+      sourceRevision = candidate ^. #sourceRevision,+      contentHash = candidate ^. #contentHash,+      moduleDefinition = candidate ^. #moduleDefinition,+      recipeDefinition = candidate ^. #recipeDefinition     }  verifyRemoteRequirements ::@@ -319,13 +353,13 @@   Either UpdateError () verifyRemoteRequirements requirements artifacts = traverse_ verify requirements   where-    verify requirement = case Map.lookup (requirement.kind, requirement.name) artifacts of-      Nothing -> Left (CandidateArtifactMissing requirement.kind requirement.name)-      Just candidate -> case requirement.origin of+    verify requirement = case Map.lookup (requirement ^. #kind, requirement ^. #name) artifacts of+      Nothing -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name))+      Just candidate -> case requirement ^. #origin of         Nothing -> Right ()         Just origin-          | candidate.sourceUrl == Just origin.sourceUrl -> Right ()-          | otherwise -> Left (CandidateArtifactMissing requirement.kind requirement.name)+          | candidate ^. #sourceUrl == Just (origin ^. #sourceUrl) -> Right ()+          | otherwise -> Left (CandidateArtifactMissing (requirement ^. #kind) (requirement ^. #name))  gitRevision :: FilePath -> IO (Maybe Text) gitRevision directory = do
src/Seihou/CLI/Update/Types.hs view
@@ -26,6 +26,7 @@     CommandPolicy,   ) import Seihou.Composition.Instance (ModuleInstance)+import Seihou.Core.ArtifactRef (ArtifactRefError) import Seihou.Core.Migration (MigrationPlan, MigrationPlanError) import Seihou.Core.Types import Seihou.Engine.Migrate (ExecutedMigrationPlan, MigrationExecError)@@ -49,31 +50,36 @@   deriving stock (Eq, Show)  data UpdateRequest = UpdateRequest-  { selection :: UpdateSelection,-    varOverrides :: [(Text, Text)],-    reconfigure :: Bool,-    promptPolicy :: PromptPolicy,-    commandPolicy :: CommandPolicy,-    dryRun :: Bool+  { selection :: !UpdateSelection,+    varOverrides :: ![(Text, Text)],+    reconfigure :: !Bool,+    promptPolicy :: !PromptPolicy,+    commandPolicy :: !CommandPolicy,+    dryRun :: !Bool,+    -- | When 'True', accept a candidate artifact whose version is lower+    -- than the version @.seihou\/manifest.json@ records, instead of+    -- failing with 'CandidateDowngrade'. The default is 'False', so an+    -- update never moves a project backwards by accident.+    allowDowngrade :: !Bool   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data VersionChange = VersionChange-  { name :: Text,-    fromVersion :: Maybe Text,-    toVersion :: Maybe Text,-    sameVersionContentChanged :: Bool+  { name :: !Text,+    fromVersion :: !(Maybe Text),+    toVersion :: !(Maybe Text),+    sameVersionContentChanged :: !Bool   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data InputChangeSummary = InputChangeSummary-  { reused :: Int,-    overridden :: Int,-    newlyResolved :: Int,-    removed :: Int,-    ambiguousLegacy :: [VarName]+  { reused :: !Int,+    overridden :: !Int,+    newlyResolved :: !Int,+    removed :: !Int,+    ambiguousLegacy :: ![VarName]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data CandidateArtifactKind = CandidateModule | CandidateRecipe   deriving stock (Eq, Ord, Show)@@ -81,61 +87,61 @@ -- | One validated artifact staged for this update session. The source path is -- temporary for remote candidates and must not escape 'withProjectUpdate'. data CandidateArtifact = CandidateArtifact-  { kind :: CandidateArtifactKind,-    name :: Text,-    version :: Maybe Text,-    originalDirectory :: FilePath,-    sourceDirectory :: FilePath,-    sourceUrl :: Maybe Text,-    repoName :: Maybe Text,-    tags :: [Text],-    sourceRevision :: Maybe Text,-    contentHash :: SHA256,-    moduleDefinition :: Maybe Module,-    recipeDefinition :: Maybe Recipe+  { kind :: !CandidateArtifactKind,+    name :: !Text,+    version :: !(Maybe Text),+    originalDirectory :: !FilePath,+    sourceDirectory :: !FilePath,+    sourceUrl :: !(Maybe Text),+    repoName :: !(Maybe Text),+    tags :: ![Text],+    sourceRevision :: !(Maybe Text),+    contentHash :: !SHA256,+    moduleDefinition :: !(Maybe Module),+    recipeDefinition :: !(Maybe Recipe)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data CandidateCatalog = CandidateCatalog-  { searchRoot :: FilePath,-    artifacts :: Map (CandidateArtifactKind, Text) CandidateArtifact,-    clonedOrigins :: Map Text FilePath+  { searchRoot :: !FilePath,+    artifacts :: !(Map (CandidateArtifactKind, Text) CandidateArtifact),+    clonedOrigins :: !(Map Text FilePath)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data PlannedUpdateMigration = PlannedUpdateMigration-  { moduleName :: ModuleName,-    sourceDirectory :: FilePath,-    sourcePlan :: MigrationPlan,-    stagedPlan :: ExecutedMigrationPlan,-    containsCommands :: Bool+  { moduleName :: !ModuleName,+    sourceDirectory :: !FilePath,+    sourcePlan :: !MigrationPlan,+    stagedPlan :: !ExecutedMigrationPlan,+    containsCommands :: !Bool   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Internal, renderer-neutral material retained so apply can re-plan after -- migration commands without reusing parser state. data PlannedApplication = PlannedApplication-  { previous :: Maybe AppliedComposition,-    candidate :: AppliedComposition,-    modulesInOrder :: [(ModuleInstance, Module, FilePath)],-    resolvedValues :: Map ModuleInstance (Map VarName ResolvedVar),-    operations :: [Operation],-    desiredOwners :: Map FilePath DesiredFileOwner+  { previous :: !(Maybe AppliedComposition),+    candidate :: !AppliedComposition,+    modulesInOrder :: ![(ModuleInstance, Module, FilePath)],+    resolvedValues :: !(Map ModuleInstance (Map VarName ResolvedVar)),+    operations :: ![Operation],+    desiredOwners :: !(Map FilePath DesiredFileOwner)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data UpdateSnapshot = UpdateSnapshot-  { sessionDirectory :: FilePath,-    projectRoot :: FilePath,-    manifestPath :: FilePath,-    baselineDirectory :: FilePath,-    installedDirectory :: FilePath,-    originalManifest :: Manifest,-    candidateHashes :: Map FilePath SHA256,-    observedProjectHashes :: Map FilePath (Maybe SHA256),-    transactionTargets :: Set FilePath+  { sessionDirectory :: !FilePath,+    projectRoot :: !FilePath,+    manifestPath :: !FilePath,+    baselineDirectory :: !FilePath,+    installedDirectory :: !FilePath,+    originalManifest :: !Manifest,+    candidateHashes :: !(Map FilePath SHA256),+    observedProjectHashes :: !(Map FilePath (Maybe SHA256)),+    transactionTargets :: !(Set FilePath)   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data UpdateWarning   = LocalArtifactHasNoRemote Text@@ -150,37 +156,37 @@   deriving stock (Eq, Show)  data UpdatePlan = UpdatePlan-  { applications :: [AppliedComposition],-    versionChanges :: [VersionChange],-    inputChanges :: InputChangeSummary,-    migrations :: [PlannedUpdateMigration],-    reconciliation :: ReconciliationPlan,-    commandPlan :: CommandPlan,-    candidateArtifacts :: [CandidateArtifact],-    warnings :: [UpdateWarning],-    request :: UpdateRequest,-    snapshot :: UpdateSnapshot,-    plannedApplications :: [PlannedApplication]+  { applications :: ![AppliedComposition],+    versionChanges :: ![VersionChange],+    inputChanges :: !InputChangeSummary,+    migrations :: ![PlannedUpdateMigration],+    reconciliation :: !ReconciliationPlan,+    commandPlan :: !CommandPlan,+    candidateArtifacts :: ![CandidateArtifact],+    warnings :: ![UpdateWarning],+    request :: !UpdateRequest,+    snapshot :: !UpdateSnapshot,+    plannedApplications :: ![PlannedApplication]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data CommandSummary = CommandSummary-  { executed :: Int,-    skippedUnchanged :: Int,-    skippedDisabled :: Int+  { executed :: !Int,+    skippedUnchanged :: !Int,+    skippedDisabled :: !Int   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data UpdateResult = UpdateResult-  { updatedApplications :: [ApplicationId],-    manifest :: Manifest,-    versions :: [VersionChange],-    fileSummary :: ReconciliationSummary,-    commandSummary :: CommandSummary,-    touchedPaths :: Set FilePath,-    warnings :: [UpdateWarning]+  { updatedApplications :: ![ApplicationId],+    manifest :: !Manifest,+    versions :: ![VersionChange],+    fileSummary :: !ReconciliationSummary,+    commandSummary :: !CommandSummary,+    touchedPaths :: !(Set FilePath),+    warnings :: ![UpdateWarning]   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  data UpdateError   = UpdateManifestMissing FilePath@@ -192,6 +198,9 @@   | CandidateCloneFailed Text Text   | CandidateRepositoryInvalid Text [Text]   | CandidateArtifactMissing CandidateArtifactKind Text+  | -- | An artifact the manifest records could not be located on this+    -- machine and has no remote to fetch it from.+    CandidateArtifactUnresolved ArtifactRefError   | CandidateArtifactAmbiguous CandidateArtifactKind Text [Text]   | CandidateLoadFailed Text ModuleLoadError   | CandidateDowngrade Text (Maybe Text) (Maybe Text)
src/Seihou/CLI/VersionCompare.hs view
@@ -6,8 +6,11 @@   ) where +import Control.Lens ((^.)) import Data.Aeson (ToJSON (..), object, (.=))+import Data.Generics.Labels () import Data.Text (Text)+import GHC.Generics (Generic) import Seihou.Core.Version (parseVersion)  -- | Status of a module with respect to available updates.@@ -22,20 +25,20 @@ -- @seihou outdated@ command (which formats them as a table) and -- @seihou status@ (which folds them into per-row annotations). data OutdatedEntry = OutdatedEntry-  { moduleName :: Text,-    installedVersion :: Maybe Text,-    availableVersion :: Maybe Text,-    status :: OutdatedStatus+  { moduleName :: !Text,+    installedVersion :: !(Maybe Text),+    availableVersion :: !(Maybe Text),+    status :: !OutdatedStatus   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance ToJSON OutdatedEntry where   toJSON e =     object-      [ "module" .= e.moduleName,-        "installed" .= e.installedVersion,-        "available" .= e.availableVersion,-        "status" .= statusText e.status+      [ "module" .= (e ^. #moduleName),+        "installed" .= (e ^. #installedVersion),+        "available" .= (e ^. #availableVersion),+        "status" .= statusText (e ^. #status)       ]     where       statusText UpToDate = "up to date" :: Text@@ -45,10 +48,10 @@  -- | Summary statistics for an update check. data CheckStats = CheckStats-  { checkedCount :: Int,-    skippedNoOrigin :: Int+  { checkedCount :: !Int,+    skippedNoOrigin :: !Int   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Compare installed and available version strings. compareVersions :: Maybe Text -> Maybe Text -> OutdatedStatus
src/Seihou/Effect/FzfInterp.hs view
@@ -4,6 +4,7 @@   ) where +import Data.Generics.Labels () import Seihou.Effect.Fzf (Fzf (..)) import Seihou.Fzf (FzfConfig, FzfResult (..), isFzfUsable) import Seihou.Fzf qualified as Fzf@@ -22,6 +23,6 @@   SelectOne _ candidates ->     pure $       if idx >= 0 && idx < length candidates-        then FzfSelected (candidates !! idx).candidateValue+        then FzfSelected ((candidates !! idx) ^. #value)         else FzfNoMatch   IsFzfAvailable -> pure True
src/Seihou/Fzf.hs view
@@ -24,10 +24,13 @@ where  import Control.Exception (SomeException, try)+import Control.Lens ((&), (.~), (?~), (^.))+import Data.Generics.Labels () 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 GHC.Generics (Generic) import System.Directory (findExecutable) import System.Exit (ExitCode (..)) import System.IO (IOMode (..), hClose, hIsTerminalDevice, openFile, stdin)@@ -42,12 +45,12 @@  -- | Runtime configuration for fzf, detected once at CLI startup. data FzfConfig = FzfConfig-  { fzfBinary :: !FilePath,-    fzfAvailable :: !Bool,+  { binary :: !FilePath,+    available :: !Bool,     stdinIsTerminal :: !Bool,     ttyAvailable :: !Bool   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  -- | Detect fzf availability and terminal state. detectFzfConfig :: IO FzfConfig@@ -57,8 +60,8 @@   ttyOk <- checkTtyAvailable   pure     FzfConfig-      { fzfBinary = maybe "fzf" id mFzf,-        fzfAvailable = case mFzf of Nothing -> False; Just _ -> True,+      { binary = maybe "fzf" id mFzf,+        available = case mFzf of Nothing -> False; Just _ -> True,         stdinIsTerminal = stdinTerm,         ttyAvailable = ttyOk       }@@ -73,28 +76,31 @@  -- | Whether fzf can be used for interactive selection. isFzfUsable :: FzfConfig -> Bool-isFzfUsable cfg = cfg.fzfAvailable && (cfg.stdinIsTerminal || cfg.ttyAvailable)+isFzfUsable cfg = cfg ^. #available && (cfg ^. #stdinIsTerminal || cfg ^. #ttyAvailable)  -- | Composable fzf options. Combine with '<>'. data FzfOpts = FzfOpts-  { fzfPrompt :: !(Maybe Text),-    fzfHeader :: !(Maybe Text),-    fzfPreview :: !(Maybe Text),-    fzfHeight :: !(Maybe Text),-    fzfAnsi :: !Bool,-    fzfNoSort :: !Bool+  { prompt :: !(Maybe Text),+    header :: !(Maybe Text),+    preview :: !(Maybe Text),+    height :: !(Maybe Text),+    ansi :: !Bool,+    noSort :: !Bool   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Generic, Show)  instance Semigroup FzfOpts where   a <> b =     FzfOpts-      { fzfPrompt = b.fzfPrompt <|> a.fzfPrompt,-        fzfHeader = b.fzfHeader <|> a.fzfHeader,-        fzfPreview = b.fzfPreview <|> a.fzfPreview,-        fzfHeight = b.fzfHeight <|> a.fzfHeight,-        fzfAnsi = a.fzfAnsi || b.fzfAnsi,-        fzfNoSort = a.fzfNoSort || b.fzfNoSort+      { -- (<|>) below is local to this instance and carries no fixity+        -- declaration, so it defaults to infixl 9 -- tighter than (^.) at+        -- infixl 8. Hence the parentheses.+        prompt = (b ^. #prompt) <|> (a ^. #prompt),+        header = (b ^. #header) <|> (a ^. #header),+        preview = (b ^. #preview) <|> (a ^. #preview),+        height = (b ^. #height) <|> (a ^. #height),+        ansi = a ^. #ansi || b ^. #ansi,+        noSort = a ^. #noSort || b ^. #noSort       }     where       (<|>) :: Maybe a -> Maybe a -> Maybe a@@ -105,41 +111,41 @@   mempty = FzfOpts Nothing Nothing Nothing Nothing False False  withPrompt :: Text -> FzfOpts-withPrompt p = mempty {fzfPrompt = Just p}+withPrompt p = mempty & #prompt ?~ p  withHeader :: Text -> FzfOpts-withHeader h = mempty {fzfHeader = Just h}+withHeader h = mempty & #header ?~ h  withHeight :: Text -> FzfOpts-withHeight h = mempty {fzfHeight = Just h}+withHeight h = mempty & #height ?~ h  withAnsi :: FzfOpts-withAnsi = mempty {fzfAnsi = True}+withAnsi = mempty & #ansi .~ True  withNoSort :: FzfOpts-withNoSort = mempty {fzfNoSort = True}+withNoSort = mempty & #noSort .~ True  withPreview :: Text -> FzfOpts-withPreview p = mempty {fzfPreview = Just p}+withPreview p = mempty & #preview ?~ p  -- | Convert options to fzf CLI arguments. optsToArgs :: FzfOpts -> [String] optsToArgs opts =   concat-    [ maybe [] (\p -> ["--prompt", T.unpack p]) opts.fzfPrompt,-      maybe [] (\h -> ["--header", T.unpack h]) opts.fzfHeader,-      maybe [] (\p -> ["--preview", T.unpack p]) opts.fzfPreview,-      maybe [] (\h -> ["--height", T.unpack h]) opts.fzfHeight,-      ["--ansi" | opts.fzfAnsi],-      ["--no-sort" | opts.fzfNoSort]+    [ maybe [] (\p -> ["--prompt", T.unpack p]) (opts ^. #prompt),+      maybe [] (\h -> ["--header", T.unpack h]) (opts ^. #header),+      maybe [] (\p -> ["--preview", T.unpack p]) (opts ^. #preview),+      maybe [] (\h -> ["--height", T.unpack h]) (opts ^. #height),+      ["--ansi" | opts ^. #ansi],+      ["--no-sort" | opts ^. #noSort]     ]  -- | A selectable candidate with display text and an associated value. data Candidate a = Candidate-  { candidateDisplay :: !Text,-    candidateValue :: !a+  { display :: !Text,+    value :: !a   }-  deriving stock (Functor)+  deriving stock (Functor, Generic)  -- | Result of an fzf selection. data FzfResult a@@ -160,12 +166,12 @@   | not (isFzfUsable cfg) = pure (FzfError "fzf is not available")   | otherwise = do       let indexed = zip [0 :: Int ..] candidates-          valueMap = Map.fromList [(i, c.candidateValue) | (i, c) <- indexed]-          inputLines = [show i <> "\t" <> T.unpack c.candidateDisplay | (i, c) <- indexed]+          valueMap = Map.fromList [(i, c ^. #value) | (i, c) <- indexed]+          inputLines = [show i <> "\t" <> T.unpack (c ^. #display) | (i, c) <- indexed]           args = ["-1", "--with-nth=2.."] ++ optsToArgs opts        let processSpec =-            (proc cfg.fzfBinary args)+            (proc (cfg ^. #binary) args)               { std_in = CreatePipe,                 std_out = CreatePipe,                 std_err = Inherit,
src/Seihou/Fzf/Selector/Module.hs view
@@ -6,6 +6,7 @@   ) where +import Data.Generics.Labels () import Data.Maybe (mapMaybe) import Data.Text qualified as T import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..), defaultSearchPaths, discoverAllModules, discoverAllRunnables)@@ -17,37 +18,37 @@ -- | Format a discovered module as an fzf candidate. -- Returns 'Nothing' for modules that failed to load. formatModuleCandidate :: DiscoveredModule -> Maybe (Candidate ModuleName)-formatModuleCandidate dm = case dm.discoveredResult of+formatModuleCandidate dm = case dm ^. #result of   Left _ -> Nothing   Right m ->-    let nameText = m.name.unModuleName-        descText = maybe "" (\d -> "  " <> d) m.description-        sourceTag = case dm.discoveredSource of+    let nameText = (m ^. #name . #unModuleName)+        descText = maybe "" (\d -> "  " <> d) (m ^. #description)+        sourceTag = case dm ^. #source of           SourceProject -> "[project]"           SourceUser -> "[user]"           SourceInstalled -> "[installed]"         display = nameText <> descText <> "  " <> sourceTag-     in Just Candidate {candidateDisplay = display, candidateValue = m.name}+     in Just Candidate {display = display, value = m ^. #name}  -- | Format a discovered runnable (module or recipe) as an fzf candidate. -- Returns 'Nothing' for items that failed to load. formatRunnableCandidate :: DiscoveredRunnable -> Maybe (Candidate ModuleName) formatRunnableCandidate dr-  | dr.drIsError = Nothing+  | (dr ^. #isError) = Nothing   | otherwise =-      let nameText = dr.drName-          descText = maybe "" (\d -> "  " <> d) dr.drDescription-          kindTag = case dr.drKind of+      let nameText = (dr ^. #name)+          descText = maybe "" (\d -> "  " <> d) (dr ^. #description)+          kindTag = case dr ^. #kind of             KindModule -> ""             KindRecipe -> " [recipe]"             KindBlueprint -> " [blueprint]"             KindPrompt -> " [prompt]"-          sourceTag = case dr.drSource of+          sourceTag = case dr ^. #source of             SourceProject -> "[project]"             SourceUser -> "[user]"             SourceInstalled -> "[installed]"           display = nameText <> descText <> kindTag <> "  " <> sourceTag-       in Just Candidate {candidateDisplay = display, candidateValue = ModuleName nameText}+       in Just Candidate {display = display, value = ModuleName nameText}  -- | Default fzf options for module selection. defaultModuleOpts :: FzfOpts
test/Main.hs view
@@ -6,6 +6,8 @@ import Seihou.CLI.AgentLaunchSpec qualified as AgentLaunchSpec import Seihou.CLI.AgentMigrateE2ESpec qualified as AgentMigrateE2ESpec import Seihou.CLI.AgentModelsSpec qualified as AgentModelsSpec+import Seihou.CLI.AgentTraceE2ESpec qualified as AgentTraceE2ESpec+import Seihou.CLI.AgentTraceSpec qualified as AgentTraceSpec import Seihou.CLI.AppliedBlueprintMigrationSpec qualified as AppliedBlueprintMigrationSpec import Seihou.CLI.AppliedBlueprintSpec qualified as AppliedBlueprintSpec import Seihou.CLI.BlueprintMigrationSpec qualified as BlueprintMigrationSpec@@ -18,6 +20,8 @@ import Seihou.CLI.InitSpec qualified as InitSpec import Seihou.CLI.InstallHistorySpec qualified as InstallHistorySpec import Seihou.CLI.ListSpec qualified as ListSpec+import Seihou.CLI.ManifestGuardSpec qualified as ManifestGuardSpec+import Seihou.CLI.ManifestUpgradeSpec qualified as ManifestUpgradeSpec import Seihou.CLI.MigrateSpec qualified as MigrateSpec import Seihou.CLI.PendingMigrationSpec qualified as PendingMigrationSpec import Seihou.CLI.PromptRenderSpec qualified as PromptRenderSpec@@ -26,6 +30,7 @@ import Seihou.CLI.RemoteVersionSpec qualified as RemoteVersionSpec import Seihou.CLI.RunBlueprintRefusalSpec qualified as RunBlueprintRefusalSpec import Seihou.CLI.SavePromptedSpec qualified as SavePromptedSpec+import Seihou.CLI.SharedManifestE2ESpec qualified as SharedManifestE2ESpec import Seihou.CLI.StatusSpec qualified as StatusSpec import Seihou.CLI.UpdateE2ESpec qualified as UpdateE2ESpec import Seihou.CLI.UpdateInteractionSpec qualified as UpdateInteractionSpec@@ -45,6 +50,8 @@         AgentConfigSpec.tests,         AgentConfigShowSpec.tests,         AgentModelsSpec.tests,+        AgentTraceSpec.tests,+        AgentTraceE2ESpec.tests,         AppliedBlueprintSpec.tests,         AppliedBlueprintMigrationSpec.tests,         BlueprintMigrationSpec.tests,@@ -57,6 +64,8 @@         InitSpec.tests,         InstallHistorySpec.tests,         ListSpec.tests,+        ManifestGuardSpec.tests,+        ManifestUpgradeSpec.tests,         MigrateSpec.tests,         PendingMigrationSpec.tests,         PromptRenderSpec.tests,@@ -65,6 +74,7 @@         RemoteVersionSpec.tests,         RunBlueprintRefusalSpec.tests,         SavePromptedSpec.tests,+        SharedManifestE2ESpec.tests,         StatusSpec.tests,         UpgradeSpec.tests,         UpdateSpec.tests,
test/Seihou/CLI/AgentCompletionSpec.hs view
@@ -3,10 +3,22 @@ import Baikai qualified import Baikai.Model qualified as BaikaiModel import Baikai.Response qualified as BaikaiResponse+import Baikai.Trace.Sink (TraceSink, silent)+import Control.Exception (throwIO)+import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy.Char8 qualified as BL8+import Data.Generics.Labels () import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as V import Seihou.CLI.AgentCompletion+import Seihou.CLI.AgentTrace (traceSinkFor)+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Test.Tasty (TestTree) import Test.Tasty.Hspec (testSpec)@@ -35,22 +47,46 @@             && "openai" `Text.isInfixOf` err         Right _ -> False +  describe "trace setting text helpers" $ do+    it "parses every accepted setting case-insensitively" $ do+      traceFromText "off" `shouldBe` Right TraceOff+      traceFromText "FILE" `shouldBe` Right TraceFile+      traceFromText "  stdout  " `shouldBe` Right TraceStdout+      traceFromText "StdErr" `shouldBe` Right TraceStderr++    it "names every accepted setting in the failure message" $+      traceFromText "syslog" `shouldSatisfy` \case+        Left err ->+          "off" `Text.isInfixOf` err+            && "file" `Text.isInfixOf` err+            && "stdout" `Text.isInfixOf` err+            && "stderr" `Text.isInfixOf` err+        Right _ -> False++    it "round-trips through traceToText" $+      traverse (traceFromText . traceToText) [TraceOff, TraceFile, TraceStdout, TraceStderr]+        `shouldBe` Right [TraceOff, TraceFile, TraceStdout, TraceStderr]+   describe "model construction" $ do     it "defaults to the Claude CLI provider with no explicit model" $       defaultAgentModelConfig         `shouldBe` AgentModelConfig-          { agentProvider = AgentProviderClaudeCli,-            agentModel = Nothing,-            agentEffort = Nothing+          { provider = AgentProviderClaudeCli,+            model = Nothing,+            effort = Nothing,+            trace = TraceOff,+            tracePath = Nothing           }      it "builds a Claude CLI model using the CLI API tag" $ do       let model =             buildBaikaiModel               AgentModelConfig-                { agentProvider = AgentProviderClaudeCli,-                  agentModel = Just "sonnet",-                  agentEffort = Nothing+                { provider = AgentProviderClaudeCli,+                  model = Just "sonnet",+                  effort = Nothing,+                  trace = TraceOff,+                  tracePath = Nothing                 }       BaikaiModel.api model `shouldBe` Baikai.AnthropicMessagesCli       BaikaiModel.provider model `shouldBe` "anthropic"@@ -60,9 +96,11 @@       let model =             buildBaikaiModel               AgentModelConfig-                { agentProvider = AgentProviderCodexCli,-                  agentModel = Just "gpt-5",-                  agentEffort = Nothing+                { provider = AgentProviderCodexCli,+                  model = Just "gpt-5",+                  effort = Nothing,+                  trace = TraceOff,+                  tracePath = Nothing                 }       BaikaiModel.api model `shouldBe` Baikai.OpenAICompletionsCli       BaikaiModel.provider model `shouldBe` "openai"@@ -72,17 +110,81 @@     it "preserves rendered prompts and resolved model configuration" $ do       let config =             AgentModelConfig-              { agentProvider = AgentProviderCodexCli,-                agentModel = Just "gpt-5",-                agentEffort = Nothing+              { provider = AgentProviderCodexCli,+                model = Just "gpt-5",+                effort = Nothing,+                trace = TraceOff,+                tracePath = Nothing               }-      buildAgentCompletionRequest config "system" (Just "user")-        `shouldBe` AgentCompletionRequest-          { completionSystemPrompt = "system",-            completionInitialPrompt = Just "user",-            completionModelConfig = config-          }+          req = buildAgentCompletionRequest config "system" (Just "user")+      -- AgentCompletionRequest has no Eq: it carries a TraceSink, which wraps a+      -- streamly fold. Compare the inspectable fields instead.+      (req ^. #systemPrompt) `shouldBe` "system"+      (req ^. #initialPrompt) `shouldBe` Just "user"+      (req ^. #modelConfig) `shouldBe` config +  -- These drive the real Baikai.Trace.withTrace path against a stub provider+  -- registered under the anthropic-messages tag. They exist because withTrace+  -- reports provider failures as an error-shaped Response rather than by+  -- throwing, the way completeRequest did: without the responseError branch in+  -- runAgentCompletionWith, every one of these failures would be reported as+  -- "Provider returned no assistant text." and the real message would be lost.+  describe "runAgentCompletionWith" $ do+    it "returns the assistant text of a successful call" $ do+      result <- runStub (const (pure (okResponse "hello from the stub"))) Nothing+      result `shouldBe` Right "hello from the stub"++    -- The regression test for the whole swap. Delete the responseError branch+    -- in runAgentCompletionWith and this fails with the empty-text message.+    it "reports the provider's message when the response is error-shaped" $ do+      result <- runStub (\m -> pure (failedResponse m "invalid x-api-key")) Nothing+      result `shouldSatisfy` \case+        Left err -> "invalid x-api-key" `Text.isInfixOf` err+        Right _ -> False++    it "does not mistake a provider error for missing assistant text" $ do+      result <- runStub (\m -> pure (failedResponse m "model not found")) Nothing+      result `shouldSatisfy` \case+        Left err -> not ("Provider returned no assistant text." `Text.isInfixOf` err)+        Right _ -> False++    -- ...and the empty-text guard must still fire for a genuinely empty+    -- success, rather than being shadowed by the new branch.+    it "still reports a successful but empty response as missing text" $ do+      result <- runStub (const (pure (okResponse ""))) Nothing+      result `shouldBe` Left "Provider returned no assistant text."++    it "reports a thrown provider exception, which withTrace still propagates" $ do+      result <- runStub (const (throwIO (Baikai.providerError "connection reset"))) Nothing+      result `shouldSatisfy` \case+        Left err -> "connection reset" `Text.isInfixOf` err+        Right _ -> False++    it "writes a correlated start/finish pair to a file sink" $+      withSystemTempDirectory "seihou-completion-trace" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        _ <- runStub (const (pure (okResponse "traced"))) (Just sink)+        events <- traceEvents path+        map fst events `shouldBe` ["call_started", "call_finished"]+        case map snd events of+          [a, b] -> a `shouldBe` b+          other -> expectationFailure ("expected two events, got " <> show (length other))++    it "writes a start/fail pair when the call fails" $+      withSystemTempDirectory "seihou-completion-trace-fail" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        _ <- runStub (\m -> pure (failedResponse m "rate limited")) (Just sink)+        events <- traceEvents path+        map fst events `shouldBe` ["call_started", "call_failed"]++    it "writes nothing when tracing is off" $+      withSystemTempDirectory "seihou-completion-trace-off" $ \root -> do+        let path = root </> "trace.jsonl"+        _ <- runStub (const (pure (okResponse "untraced"))) Nothing+        doesFileExist path `shouldReturn` False+   describe "responseText" $ do     it "extracts and joins assistant text blocks only" $ do       let resp =@@ -102,3 +204,79 @@                     }               }       responseText resp `shouldBe` "hello\nworld"++-- | Run a completion against a stub provider that returns whatever the given+-- action produces, optionally reporting to a trace sink.+--+-- The stub registers under the @anthropic-messages@ tag, which is what+-- 'buildBaikaiModel' selects for 'AgentProviderAnthropic'. It supplies both+-- provider fields the way the real CLI providers do — a direct @complete@ and+-- a @stream@ lifted from it — because 'Baikai.Trace.withTrace' dispatches+-- through @stream@, not @complete@.+--+-- Registration mutates Baikai's process-global registry. That is safe here+-- because the test binary is not built with @-threaded@, so tasty runs these+-- sequentially; a stub is always registered immediately before the call that+-- uses it.+runStub ::+  (Baikai.Model -> IO BaikaiResponse.Response) ->+  Maybe TraceSink ->+  IO (Either Text.Text Text.Text)+runStub respond sink =+  runAgentCompletionWith registerStub request+  where+    registerStub =+      Baikai.registerApiProvider+        Baikai.ApiProvider+          { Baikai.apiTag = Baikai.AnthropicMessages,+            Baikai.complete = \m _ _ -> respond m,+            Baikai.stream = Baikai.liftCompleteToStream (\m _ _ -> respond m)+          }+    request =+      buildAgentCompletionRequestWith+        (maybe silent id sink)+        AgentModelConfig+          { provider = AgentProviderAnthropic,+            model = Just "stub-model",+            effort = Nothing,+            trace = maybe TraceOff (const TraceFile) sink,+            tracePath = Nothing+          }+        "system"+        (Just "user")++-- | A successful response carrying one assistant text block.+okResponse :: Text.Text -> BaikaiResponse.Response+okResponse body =+  BaikaiResponse.emptyResponse+    { BaikaiResponse.message =+        Baikai.AssistantPayload+          { Baikai.content = V.singleton (Baikai.AssistantText (Baikai.TextContent body)),+            Baikai.usage = Baikai.zeroUsage,+            Baikai.stopReason = Baikai.Stop,+            Baikai.errorMessage = Nothing,+            Baikai.timestamp = Just epoch+          }+    }++-- | An error-shaped response, the way a conforming provider reports an in-band+-- failure: @stopReason = ErrorReason@ plus the provider's message.+failedResponse :: Baikai.Model -> Text.Text -> BaikaiResponse.Response+failedResponse m message =+  BaikaiResponse.errorResponse m epoch 12 (Baikai.providerError message)++epoch :: UTCTime+epoch = read "2026-07-27 00:00:00 UTC"++-- | The @(kind, eventId)@ of every event in a JSONL trace file, in order.+traceEvents :: FilePath -> IO [(String, String)]+traceEvents path = do+  contents <- BL8.readFile path+  pure+    [ (Text.unpack kind, Text.unpack eventId)+    | line <- BL8.lines contents,+      not (BL8.null line),+      Just (Aeson.Object o) <- [Aeson.decode line],+      Just (Aeson.String kind) <- [KeyMap.lookup (Key.fromString "kind") o],+      Just (Aeson.String eventId) <- [KeyMap.lookup (Key.fromString "eventId") o]+    ]
test/Seihou/CLI/AgentConfigShowSpec.hs view
@@ -3,7 +3,7 @@ import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.Text (Text) import Data.Text qualified as Text-import Seihou.CLI.AgentCompletion (AgentProvider (..))+import Seihou.CLI.AgentCompletion (AgentProvider (..), TraceSetting (..)) import Seihou.CLI.AgentConfig   ( AgentCommandName (..),     AgentConfigSource (..),@@ -53,29 +53,52 @@     it "shows an unset effort as (default) with built-in provenance" $       hasLine ["effort", "(default)", "[built-in default]"] `shouldBe` True +    it "labels a per-command local trace with its concrete key" $+      hasLine ["trace", "file", "[local: agent.run.trace]"] `shouldBe` True++    it "labels a global default trace with the shared key" $+      hasLine ["trace", "stderr", "[global: agent.trace]"] `shouldBe` True++    it "shows an unconfigured trace as off with built-in provenance" $+      hasLine ["trace", "off", "[built-in default]"] `shouldBe` True+     it "includes the precedence legend" $       ("Precedence, highest first:" `Text.isInfixOf` rendered) `shouldBe` True +    it "names the trace environment variable in the legend" $+      ("SEIHOU_AGENT_TRACE" `Text.isInfixOf` rendered) `shouldBe` True++    it "names the trace path key in the legend" $+      ("agent.tracePath" `Text.isInfixOf` rendered) `shouldBe` True+ sample :: [ResolvedCommandConfig] sample =   [ ResolvedCommandConfig       AgentCmdAssist       (ResolvedAgentField AgentProviderCodexCli SourceGlobalCommand)       (ResolvedAgentField Nothing SourceBuiltinDefault)-      (ResolvedAgentField (Just ThinkingHigh) SourceGlobalDefault),+      (ResolvedAgentField (Just ThinkingHigh) SourceGlobalDefault)+      (ResolvedAgentField TraceStderr SourceGlobalDefault)+      Nothing,     ResolvedCommandConfig       AgentCmdBootstrap       (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault)       (ResolvedAgentField (Just "claude-sonnet-5") SourceGlobalDefault)-      (ResolvedAgentField Nothing SourceBuiltinDefault),+      (ResolvedAgentField Nothing SourceBuiltinDefault)+      (ResolvedAgentField TraceOff SourceBuiltinDefault)+      Nothing,     ResolvedCommandConfig       AgentCmdRun       (ResolvedAgentField AgentProviderClaudeCli SourceBuiltinDefault)       (ResolvedAgentField (Just "claude-opus-4-8") SourceLocalCommand)-      (ResolvedAgentField (Just ThinkingMax) SourceLocalCommand),+      (ResolvedAgentField (Just ThinkingMax) SourceLocalCommand)+      (ResolvedAgentField TraceFile SourceLocalCommand)+      (Just "/tmp/trace.jsonl"),     ResolvedCommandConfig       AgentCmdMigrate       (ResolvedAgentField AgentProviderOpenAI SourceLocalCommand)       (ResolvedAgentField (Just "gpt-5-mini") SourceLocalCommand)       (ResolvedAgentField Nothing SourceBuiltinDefault)+      (ResolvedAgentField TraceOff SourceBuiltinDefault)+      Nothing   ]
test/Seihou/CLI/AgentConfigSpec.hs view
@@ -1,11 +1,14 @@ module Seihou.CLI.AgentConfigSpec (tests) where  import Baikai.ThinkingLevel (ThinkingLevel (..))+import Control.Lens ((&), (.~), (?~), (^.))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text import Seihou.CLI.AgentCompletion import Seihou.CLI.AgentConfig+import Seihou.Core.Types (AgentLaunch (..)) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec (testSpec)@@ -18,17 +21,29 @@   describe "resolveAgentModelConfig" $ do     it "uses CLI flags before environment variables" $       resolveAgentModelConfig-        (baseInputs {cliProvider = Just "codex-cli", cliModel = Just "gpt-5", envProvider = Just "anthropic", envModel = Just "claude-sonnet-4-6"})+        ( baseInputs+            & #cliProvider ?~ "codex-cli"+            & #cliModel ?~ "gpt-5"+            & #envProvider ?~ "anthropic"+            & #envModel ?~ "claude-sonnet-4-6"+        )         `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5"))      it "uses environment variables before local config" $       resolveAgentModelConfig-        (baseInputs {envProvider = Just "openai", envModel = Just "gpt-4o", localConfig = config "anthropic" "claude-sonnet-4-6"})+        ( baseInputs+            & #envProvider ?~ "openai"+            & #envModel ?~ "gpt-4o"+            & #localConfig .~ config "anthropic" "claude-sonnet-4-6"+        )         `shouldBe` Right (cfg AgentProviderOpenAI (Just "gpt-4o"))      it "uses local config before global config" $       resolveAgentModelConfig-        (baseInputs {localConfig = config "anthropic" "claude-opus-4-1", globalConfig = config "openai" "gpt-4o-mini"})+        ( baseInputs+            & #localConfig .~ config "anthropic" "claude-opus-4-1"+            & #globalConfig .~ config "openai" "gpt-4o-mini"+        )         `shouldBe` Right (cfg AgentProviderAnthropic (Just "claude-opus-4-1"))      it "pins the deterministic claude-cli default model when nothing is set" $@@ -36,11 +51,11 @@         `shouldBe` Right (cfg AgentProviderClaudeCli (Just "claude-opus-4-8"))      it "pins the deterministic codex-cli default model when only the provider is set" $-      resolveAgentModelConfig (baseInputs {cliProvider = Just "codex-cli"})+      resolveAgentModelConfig (baseInputs & #cliProvider ?~ "codex-cli")         `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5.6-terra"))      it "returns provider diagnostics for invalid provider text" $-      resolveAgentModelConfig (baseInputs {cliProvider = Just "llama"}) `shouldSatisfy` \case+      resolveAgentModelConfig (baseInputs & #cliProvider ?~ "llama") `shouldSatisfy` \case         Left err ->           "Unknown agent provider" `Text.isInfixOf` err             && "claude-cli" `Text.isInfixOf` err@@ -48,51 +63,58 @@         Right _ -> False      it "allows a model-only override while keeping the default provider" $-      resolveAgentModelConfig (baseInputs {cliModel = Just "sonnet"})+      resolveAgentModelConfig (baseInputs & #cliModel ?~ "sonnet")         `shouldBe` Right (cfg AgentProviderClaudeCli (Just "sonnet"))      it "ignores blank higher-precedence values" $       resolveAgentModelConfig-        (baseInputs {cliProvider = Just "  ", envProvider = Just "codex-cli", cliModel = Just "", envModel = Just "gpt-5"})+        ( baseInputs+            & #cliProvider ?~ "  "+            & #envProvider ?~ "codex-cli"+            & #cliModel ?~ ""+            & #envModel ?~ "gpt-5"+        )         `shouldBe` Right (cfg AgentProviderCodexCli (Just "gpt-5"))    describe "resolveAgentModelConfigFor (per-command)" $ do     it "prefers a per-command model over the default in the same scope" $ do       let inputs =-            baseInputs-              { localConfig =-                  Map.fromList-                    [ (agentModelConfigKey, "claude-sonnet-5"),-                      (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")-                    ]-              }+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-sonnet-5"), (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")]+            )       modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand)       modelOf AgentCmdAssist inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault)      it "lets a local default override a global per-command key (project over global)" $ do       let inputs =-            baseInputs-              { localConfig = Map.fromList [(agentModelConfigKey, "claude-sonnet-5")],-                globalConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "gpt-5")]-              }+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-sonnet-5")]+                & #globalConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "gpt-5")]+            )       modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceLocalDefault)      it "prefers a global per-command key over the global default" $ do       let inputs =-            baseInputs-              { globalConfig =-                  Map.fromList-                    [ (agentProviderConfigKey, "anthropic"),-                      (agentCommandProviderConfigKey AgentCmdAssist, "openai")-                    ]-              }+            ( baseInputs+                & #globalConfig .~ Map.fromList [(agentProviderConfigKey, "anthropic"), (agentCommandProviderConfigKey AgentCmdAssist, "openai")]+            )       providerOf AgentCmdAssist inputs `shouldBe` Right (AgentProviderOpenAI, SourceGlobalCommand)       providerOf AgentCmdSetup inputs `shouldBe` Right (AgentProviderAnthropic, SourceGlobalDefault)      it "labels a subcommand CLI flag distinctly from a parent flag" $ do-      providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True})+      providerOf+        AgentCmdAssist+        ( baseInputs+            & #cliProvider ?~ "codex-cli"+            & #cliProviderFromSubcommand .~ True+        )         `shouldBe` Right (AgentProviderCodexCli, SourceCliSubcommand)-      providerOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = False})+      providerOf+        AgentCmdAssist+        ( baseInputs+            & #cliProvider ?~ "codex-cli"+            & #cliProviderFromSubcommand .~ False+        )         `shouldBe` Right (AgentProviderCodexCli, SourceCliParent)      it "falls back to the pinned CLI default model with built-in provenance" $ do@@ -103,27 +125,27 @@       -- With nothing configured, every command resolves to a concrete model for       -- both local CLI providers, so seihou always passes an explicit --model.       modelOf AgentCmdAssist baseInputs `shouldBe` Right (Just "claude-opus-4-8", SourceBuiltinDefault)-      modelOf AgentCmdAssist (baseInputs {cliProvider = Just "codex-cli", cliProviderFromSubcommand = True})+      modelOf+        AgentCmdAssist+        ( baseInputs+            & #cliProvider ?~ "codex-cli"+            & #cliProviderFromSubcommand .~ True+        )         `shouldBe` Right (Just "gpt-5.6-terra", SourceBuiltinDefault)      it "keeps environment variables above per-command config" $ do       let inputs =-            baseInputs-              { envModel = Just "gpt-5",-                localConfig = Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")]-              }+            ( baseInputs+                & #envModel ?~ "gpt-5"+                & #localConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")]+            )       modelOf AgentCmdRun inputs `shouldBe` Right (Just "gpt-5", SourceEnv)      it "resolves migrate from its own per-command keys" $ do       let inputs =-            baseInputs-              { localConfig =-                  Map.fromList-                    [ (agentCommandProviderConfigKey AgentCmdMigrate, "openai"),-                      (agentCommandModelConfigKey AgentCmdMigrate, "gpt-5-mini"),-                      (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")-                    ]-              }+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentCommandProviderConfigKey AgentCmdMigrate, "openai"), (agentCommandModelConfigKey AgentCmdMigrate, "gpt-5-mini"), (agentCommandModelConfigKey AgentCmdRun, "claude-opus-4-8")]+            )       providerOf AgentCmdMigrate inputs `shouldBe` Right (AgentProviderOpenAI, SourceLocalCommand)       modelOf AgentCmdMigrate inputs `shouldBe` Right (Just "gpt-5-mini", SourceLocalCommand)       modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceLocalCommand)@@ -134,63 +156,360 @@      it "prefers a per-command effort over the shared default in the same scope" $ do       let inputs =-            baseInputs-              { localConfig =-                  Map.fromList-                    [ (agentEffortConfigKey, "medium"),-                      (agentCommandEffortConfigKey AgentCmdRun, "max")-                    ]-              }+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentEffortConfigKey, "medium"), (agentCommandEffortConfigKey AgentCmdRun, "max")]+            )       effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingMax, SourceLocalCommand)       effortOf AgentCmdAssist inputs `shouldBe` Right (Just ThinkingMedium, SourceLocalDefault)      it "lets a local default effort override a global per-command effort" $ do       let inputs =-            baseInputs-              { localConfig = Map.fromList [(agentEffortConfigKey, "low")],-                globalConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "max")]-              }+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentEffortConfigKey, "low")]+                & #globalConfig .~ Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "max")]+            )       effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingLow, SourceLocalDefault)      it "keeps the effort environment variable above config" $ do       let inputs =-            baseInputs-              { envEffort = Just "high",-                localConfig = Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "minimal")]-              }+            ( baseInputs+                & #envEffort ?~ "high"+                & #localConfig .~ Map.fromList [(agentCommandEffortConfigKey AgentCmdRun, "minimal")]+            )       effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingHigh, SourceEnv)      it "prefers the subcommand effort flag over everything" $       effortOf         AgentCmdRun-        (baseInputs {cliEffort = Just "xhigh", cliEffortFromSubcommand = True, envEffort = Just "low"})+        ( baseInputs+            & #cliEffort ?~ "xhigh"+            & #cliEffortFromSubcommand .~ True+            & #envEffort ?~ "low"+        )         `shouldBe` Right (Just ThinkingXHigh, SourceCliSubcommand)      it "parses effort case-insensitively" $-      effortOf AgentCmdRun (baseInputs {cliEffort = Just "  MAX  "}) `shouldBe` Right (Just ThinkingMax, SourceCliParent)+      effortOf AgentCmdRun (baseInputs & #cliEffort ?~ "  MAX  ") `shouldBe` Right (Just ThinkingMax, SourceCliParent)      it "returns a diagnostic for an invalid effort value" $-      resolveAgentModelConfigFor AgentCmdRun (baseInputs {cliEffort = Just "ultra"}) `shouldSatisfy` \case+      resolveAgentModelConfigFor AgentCmdRun (baseInputs & #cliEffort ?~ "ultra") `shouldSatisfy` \case         Left err -> "Unknown reasoning effort" `Text.isInfixOf` err && "xhigh" `Text.isInfixOf` err         Right _ -> False +  describe "resolveAgentModelConfigFor (call tracing)" $ do+    it "defaults to tracing off when nothing is configured" $+      traceOf AgentCmdRun baseInputs `shouldBe` Right (TraceOff, SourceBuiltinDefault)++    it "prefers a per-command trace over the shared default in the same scope" $ do+      let inputs =+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stderr"), (agentCommandTraceConfigKey AgentCmdRun, "file")]+            )+      traceOf AgentCmdRun inputs `shouldBe` Right (TraceFile, SourceLocalCommand)+      traceOf AgentCmdAssist inputs `shouldBe` Right (TraceStderr, SourceLocalDefault)++    it "lets a local default trace override a global per-command trace" $ do+      let inputs =+            ( baseInputs+                & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stdout")]+                & #globalConfig .~ Map.fromList [(agentCommandTraceConfigKey AgentCmdRun, "file")]+            )+      traceOf AgentCmdRun inputs `shouldBe` Right (TraceStdout, SourceLocalDefault)++    it "lets a global per-command trace beat a global default" $ do+      let inputs =+            ( baseInputs+                & #globalConfig .~ Map.fromList [(agentTraceConfigKey, "stdout"), (agentCommandTraceConfigKey AgentCmdRun, "file")]+            )+      traceOf AgentCmdRun inputs `shouldBe` Right (TraceFile, SourceGlobalCommand)++    it "keeps the trace environment variable above config" $ do+      let inputs =+            ( baseInputs+                & #envTrace ?~ "stderr"+                & #localConfig .~ Map.fromList [(agentCommandTraceConfigKey AgentCmdRun, "file")]+            )+      traceOf AgentCmdRun inputs `shouldBe` Right (TraceStderr, SourceEnv)++    it "keeps a declared trace above config but below the environment" $ do+      let declared = (baseInputs & #declaredTrace ?~ "file")+      traceOf+        AgentCmdRun+        ( declared+            & #localConfig .~ Map.fromList [(agentTraceConfigKey, "stdout")]+        )+        `shouldBe` Right (TraceFile, SourceArtifactDeclaration)+      traceOf AgentCmdRun (declared & #envTrace ?~ "stderr")+        `shouldBe` Right (TraceStderr, SourceEnv)++    it "prefers the subcommand trace flag over everything" $+      traceOf+        AgentCmdRun+        ( baseInputs+            & #cliTrace ?~ "off"+            & #cliTraceFromSubcommand .~ True+            & #envTrace ?~ "file"+        )+        `shouldBe` Right (TraceOff, SourceCliSubcommand)++    it "attributes a parent `seihou agent` trace flag to that tier" $+      traceOf+        AgentCmdRun+        ( baseInputs+            & #cliTrace ?~ "file"+            & #cliTraceFromSubcommand .~ False+        )+        `shouldBe` Right (TraceFile, SourceCliParent)++    it "parses trace settings case-insensitively" $+      traceOf AgentCmdRun (baseInputs & #cliTrace ?~ "  STDERR  ")+        `shouldBe` Right (TraceStderr, SourceCliParent)++    it "skips a blank trace value in favor of the next tier" $+      traceOf+        AgentCmdRun+        ( baseInputs+            & #cliTrace ?~ "   "+            & #localConfig .~ Map.fromList [(agentTraceConfigKey, "file")]+        )+        `shouldBe` Right (TraceFile, SourceLocalDefault)++    it "returns a diagnostic naming every accepted trace setting" $+      resolveAgentModelConfigFor AgentCmdRun (baseInputs & #cliTrace ?~ "syslog") `shouldSatisfy` \case+        Left err ->+          "Unknown trace setting" `Text.isInfixOf` err+            && "off" `Text.isInfixOf` err+            && "file" `Text.isInfixOf` err+            && "stdout" `Text.isInfixOf` err+            && "stderr" `Text.isInfixOf` err+        Right _ -> False++  describe "resolveTracePath" $ do+    it "is unset when no agent.tracePath is configured" $+      resolveTracePath baseInputs `shouldBe` Nothing++    it "reads the local key before the global key" $+      resolveTracePath+        ( baseInputs+            & #localConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/local.jsonl")]+            & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")]+        )+        `shouldBe` Just "/tmp/local.jsonl"++    it "falls back to the global key" $+      resolveTracePath+        ( baseInputs+            & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")]+        )+        `shouldBe` Just "/tmp/global.jsonl"++    it "treats a blank local path as absent" $+      resolveTracePath+        ( baseInputs+            & #localConfig .~ Map.fromList [(agentTracePathConfigKey, "   ")]+            & #globalConfig .~ Map.fromList [(agentTracePathConfigKey, "/tmp/global.jsonl")]+        )+        `shouldBe` Just "/tmp/global.jsonl"++  describe "artifact-declared launch settings" $ do+    it "beats a per-command local config key" $ do+      let inputs =+            declaring+              (decl Nothing (Just "claude-sonnet-5") Nothing)+              ( baseInputs+                  & #localConfig .~ Map.fromList [(agentCommandModelConfigKey AgentCmdRun, "claude-haiku-4-5")]+              )+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceArtifactDeclaration)++    it "beats both local and global default keys" $ do+      let inputs =+            declaring+              (decl (Just "openai") Nothing (Just "high"))+              ( baseInputs+                  & #localConfig .~ Map.fromList [(agentProviderConfigKey, "anthropic")]+                  & #globalConfig .~ Map.fromList [(agentEffortConfigKey, "low")]+              )+      providerOf AgentCmdRun inputs `shouldBe` Right (AgentProviderOpenAI, SourceArtifactDeclaration)+      effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingHigh, SourceArtifactDeclaration)++    it "loses to a subcommand flag" $ do+      let inputs =+            declaring+              (decl Nothing (Just "claude-sonnet-5") Nothing)+              ( baseInputs+                  & #cliModel ?~ "claude-opus-4-8"+                  & #cliModelFromSubcommand .~ True+              )+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceCliSubcommand)++    it "loses to a parent `seihou agent` flag" $ do+      let inputs =+            declaring+              (decl Nothing (Just "claude-sonnet-5") Nothing)+              ( baseInputs+                  & #cliModel ?~ "claude-opus-4-8"+                  & #cliModelFromSubcommand .~ False+              )+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-opus-4-8", SourceCliParent)++    it "loses to an environment variable" $ do+      let inputs =+            declaring+              (decl Nothing (Just "claude-sonnet-5") (Just "max"))+              ( baseInputs+                  & #envEffort ?~ "low"+              )+      effortOf AgentCmdRun inputs `shouldBe` Right (Just ThinkingLow, SourceEnv)+      -- ...but only for the field the environment names.+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-sonnet-5", SourceArtifactDeclaration)++    it "skips a blank declared value in favor of the next tier" $ do+      let inputs =+            declaring+              (decl Nothing (Just "   ") Nothing)+              ( baseInputs+                  & #localConfig .~ Map.fromList [(agentModelConfigKey, "claude-haiku-4-5")]+              )+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "claude-haiku-4-5", SourceLocalDefault)++    -- Guards the applyProviderDefaultModel interaction: a declaration that only+    -- changes the provider must pick up that provider's pinned default model,+    -- not the previous provider's.+    it "picks up the declared provider's pinned default model" $ do+      let inputs = declaring (decl (Just "codex-cli") Nothing Nothing) baseInputs+      providerOf AgentCmdRun inputs `shouldBe` Right (AgentProviderCodexCli, SourceArtifactDeclaration)+      modelOf AgentCmdRun inputs `shouldBe` Right (Just "gpt-5.6-terra", SourceBuiltinDefault)++    it "returns a diagnostic naming the accepted providers for a bad declared provider" $+      resolveAgentModelConfigFor AgentCmdRun (declaring (decl (Just "llama") Nothing Nothing) baseInputs)+        `shouldSatisfy` \case+          Left err ->+            "Unknown agent provider" `Text.isInfixOf` err+              && "claude-cli" `Text.isInfixOf` err+              && "openai" `Text.isInfixOf` err+          Right _ -> False++    it "returns a diagnostic for a bad declared effort" $+      resolveAgentModelConfigFor AgentCmdRun (declaring (decl Nothing Nothing (Just "ultra")) baseInputs)+        `shouldSatisfy` \case+          Left err -> "Unknown reasoning effort" `Text.isInfixOf` err+          Right _ -> False++    it "labels blueprint-run and migrate declarations as blueprint sources" $ do+      agentConfigSourceLabel AgentCmdRun ModelField SourceArtifactDeclaration `shouldBe` "blueprint: launch.model"+      agentConfigSourceLabel AgentCmdMigrate EffortField SourceArtifactDeclaration `shouldBe` "blueprint: launch.effort"+      agentConfigSourceLabel AgentCmdRun ProviderField SourceArtifactDeclaration `shouldBe` "blueprint: launch.provider"++    it "labels a prompt-run declaration as a prompt source" $+      agentConfigSourceLabel AgentCmdPromptRun ModelField SourceArtifactDeclaration `shouldBe` "prompt: launch.model"++  describe "agentLaunchDeclaration" $ do+    it "treats a missing launch record as declaring nothing" $+      agentLaunchDeclaration Nothing `shouldBe` noAgentLaunchDeclaration++    it "projects the three resolvable fields and drops the reserved mode" $+      agentLaunchDeclaration+        (Just AgentLaunch {provider = Just "codex-cli", model = Just "gpt-5", effort = Just "max", mode = Just "ignored"})+        `shouldBe` AgentLaunchDeclaration+          { provider = Just "codex-cli",+            model = Just "gpt-5",+            effort = Just "max"+          }++  describe "validateAgentLaunchDeclaration" $ do+    it "accepts a declaration that states nothing" $+      validateAgentLaunchDeclaration noAgentLaunchDeclaration `shouldBe` []++    it "accepts valid provider and effort values" $+      validateAgentLaunchDeclaration (decl (Just "codex-cli") (Just "anything-goes") (Just "max")) `shouldBe` []++    it "reports an unknown provider under its key" $+      validateAgentLaunchDeclaration (decl (Just "llama") Nothing Nothing) `shouldSatisfy` \case+        [err] -> "launch.provider: " `Text.isPrefixOf` err && "Unknown agent provider" `Text.isInfixOf` err+        _ -> False++    it "reports an unknown effort under its key" $+      validateAgentLaunchDeclaration (decl Nothing Nothing (Just "ultra")) `shouldSatisfy` \case+        [err] -> "launch.effort: " `Text.isPrefixOf` err && "Unknown reasoning effort" `Text.isInfixOf` err+        _ -> False++    it "reports both invalid values at once" $+      length (validateAgentLaunchDeclaration (decl (Just "llama") Nothing (Just "ultra"))) `shouldBe` 2++    it "does not check the model, which is free-form" $+      validateAgentLaunchDeclaration (decl Nothing (Just "some-private-model-id") Nothing) `shouldBe` []++  describe "formatResolvedAgentProvenance" $ do+    it "names each field's value and source" $ do+      let pending = PendingAgentConfig AgentCmdRun baseInputs+      fmap formatResolvedAgentProvenance (resolvePendingAgentConfig pending (decl Nothing (Just "claude-sonnet-5") (Just "max")))+        `shouldBe` Right+          "provider claude-cli [built-in default], model claude-sonnet-5 [blueprint: launch.model], effort max [blueprint: launch.effort], trace off [built-in default]"++    it "reports an unset effort rather than omitting it" $ do+      let pending = PendingAgentConfig AgentCmdPromptRun baseInputs+      fmap formatResolvedAgentProvenance (resolvePendingAgentConfig pending noAgentLaunchDeclaration)+        `shouldBe` Right+          "provider claude-cli [built-in default], model claude-opus-4-8 [built-in default], effort <unset> [built-in default], trace off [built-in default]"++  describe "resolvePendingAgentConfig" $ do+    it "projects down to the config the launch layer consumes" $ do+      let pending = PendingAgentConfig AgentCmdRun baseInputs+      fmap resolvedAgentModelConfig (resolvePendingAgentConfig pending (decl (Just "codex-cli") Nothing (Just "high")))+        `shouldBe` Right+          AgentModelConfig+            { provider = AgentProviderCodexCli,+              model = Just "gpt-5.6-terra",+              effort = Just ThinkingHigh,+              trace = TraceOff,+              tracePath = Nothing+            }++-- | Build an 'AgentLaunchDeclaration' from the three resolvable fields.+decl :: Maybe Text -> Maybe Text -> Maybe Text -> AgentLaunchDeclaration+decl provider model effort =+  AgentLaunchDeclaration+    { provider = provider,+      model = model,+      effort = effort+    }++-- | Fold a declaration into an inputs record, the way+-- 'resolvePendingAgentConfig' does.+declaring :: AgentLaunchDeclaration -> AgentConfigInputs -> AgentConfigInputs+declaring d inputs =+  inputs+    & #declaredProvider .~ d ^. #provider+    & #declaredModel .~ d ^. #model+    & #declaredEffort .~ d ^. #effort+ providerOf :: AgentCommandName -> AgentConfigInputs -> Either Text (AgentProvider, AgentConfigSource) providerOf c inputs =-  (\(p, _, _) -> (p.resolvedValue, p.resolvedSource)) <$> resolveAgentModelConfigFor c inputs+  (\(p, _, _, _) -> (p ^. #value, p ^. #source)) <$> resolveAgentModelConfigFor c inputs  modelOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe Text, AgentConfigSource) modelOf c inputs =-  (\(_, m, _) -> (m.resolvedValue, m.resolvedSource)) <$> resolveAgentModelConfigFor c inputs+  (\(_, m, _, _) -> (m ^. #value, m ^. #source)) <$> resolveAgentModelConfigFor c inputs  effortOf :: AgentCommandName -> AgentConfigInputs -> Either Text (Maybe ThinkingLevel, AgentConfigSource) effortOf c inputs =-  (\(_, _, e) -> (e.resolvedValue, e.resolvedSource)) <$> resolveAgentModelConfigFor c inputs+  (\(_, _, e, _) -> (e ^. #value, e ^. #source)) <$> resolveAgentModelConfigFor c inputs +traceOf :: AgentCommandName -> AgentConfigInputs -> Either Text (TraceSetting, AgentConfigSource)+traceOf c inputs =+  (\(_, _, _, t) -> (t ^. #value, t ^. #source)) <$> resolveAgentModelConfigFor c inputs+ -- | Build an expected 'AgentModelConfig' with effort unset (the flat resolver -- never sets effort). cfg :: AgentProvider -> Maybe Text -> AgentModelConfig cfg provider model =-  AgentModelConfig {agentProvider = provider, agentModel = model, agentEffort = Nothing}+  AgentModelConfig+    { provider = provider,+      model = model,+      effort = Nothing,+      trace = TraceOff,+      tracePath = Nothing+    }  baseInputs :: AgentConfigInputs baseInputs = baseAgentConfigInputs
test/Seihou/CLI/AgentLaunchSpec.hs view
@@ -1,5 +1,6 @@ module Seihou.CLI.AgentLaunchSpec (tests) where +import Control.Lens ((&), (.~)) import Data.List (nub) import Data.Text qualified as T import Seihou.CLI.AgentLaunch@@ -56,7 +57,7 @@      describe "formatSeihouProjectState" $ do       it "names .seihou/ when initialised" $-        formatSeihouProjectState (baseCtx {seihouInitialized = True})+        formatSeihouProjectState (baseCtx & #seihouInitialized .~ True)           `shouldBe` "Seihou project: .seihou/ directory exists (this is a seihou-managed project)"       it "states 'No .seihou/' when not initialised" $         formatSeihouProjectState baseCtx@@ -64,7 +65,7 @@      describe "formatManifestState" $ do       it "names manifest.json when present" $-        formatManifestState (baseCtx {hasManifest = True})+        formatManifestState (baseCtx & #hasManifest .~ True)           `shouldBe` "Manifest: .seihou/manifest.json exists (modules have been applied here)"       it "reports no manifest otherwise" $         formatManifestState baseCtx@@ -72,7 +73,7 @@      describe "formatModuleDhallState" $ do       it "names module.dhall when present in cwd" $-        formatModuleDhallState (baseCtx {localModuleDhall = True})+        formatModuleDhallState (baseCtx & #localModuleDhall .~ True)           `shouldBe` "Module in cwd: module.dhall found in current directory (user is authoring a module here)"       it "is empty when module.dhall is absent" $         formatModuleDhallState baseCtx `shouldBe` ""@@ -81,7 +82,7 @@       it "is empty when there are no local modules" $         formatLocalModules baseCtx `shouldBe` ""       it "lists local modules with bullet prefixes" $-        formatLocalModules (baseCtx {localModules = ["foo", "bar"]})+        formatLocalModules (baseCtx & #localModules .~ ["foo", "bar"])           `shouldBe` "Local modules:\n  - foo\n  - bar"      describe "formatAvailableModules" $ do@@ -90,7 +91,7 @@           `shouldBe` "Available modules: None discovered"       it "renders entries as 'name — description (source)' lines" $         formatAvailableModules-          (baseCtx {availableModules = [("foo", "the foo module", "user")]})+          (baseCtx & #availableModules .~ [("foo", "the foo module", "user")])           `shouldBe` "Available modules across search paths:\n  - foo — the foo module (user)"    describe "formatBaselineStatus" $ do@@ -151,7 +152,8 @@               files = [],               allowedTools = Nothing,               tags = [],-              migrations = []+              migrations = [],+              launch = Nothing             }     it "renders name, version, description as a three-line block" $       formatBlueprintIdentity (mk (Just "0.1") (Just "a thing"))
test/Seihou/CLI/AgentMigrateE2ESpec.hs view
@@ -1,9 +1,12 @@ module Seihou.CLI.AgentMigrateE2ESpec (tests) where +import Control.Lens ((^.)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Seihou.CLI.SeihouBinary (seihouBinary) import Seihou.Core.Types (AppliedBlueprintMigration (..), Manifest (..)) import Seihou.Manifest.Types (manifestFromJSON) import System.Directory@@ -13,7 +16,7 @@     getPermissions,     setPermissions,   )-import System.Environment (getEnvironment, getExecutablePath)+import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) import System.FilePath (searchPathSeparator, takeDirectory, (</>)) import System.IO.Temp (withSystemTempDirectory)@@ -24,6 +27,108 @@  tests :: IO TestTree tests = testSpec "Agent migrate end-to-end" $ do+  it "exposes non-interactive blueprint runs in help" $ do+    binary <- seihouBinary+    (exitCode, output, _) <- runProcessText binary ["agent", "run", "--help"] Nothing Nothing+    exitCode `shouldBe` ExitSuccess+    output `shouldSatisfy` T.isInfixOf "--batch"+    output `shouldSatisfy` T.isInfixOf "stdin is not a terminal"++  it "automatically uses the batch CLI provider when stdin is not a terminal" $+    withSystemTempDirectory "seihou-agent-run-batch" $ \root -> do+      binary <- seihouBinary+      let blueprintDir = root </> ".seihou" </> "modules" </> "batch-blueprint"+          blueprintPath = blueprintDir </> "blueprint.dhall"+          referencePath = blueprintDir </> "files" </> "reference.md"+          manifestPath = root </> ".seihou" </> "manifest.json"+          xdgHome = root </> "xdg"+          fakeBin = root </> "bin"+          fakeClaude = fakeBin </> "claude"+          launchLog = root </> "agent-launch.args"+          workspaceFile = root </> "batch-ran.txt"+      createDirectoryIfMissing True blueprintDir+      createDirectoryIfMissing True (takeDirectory referencePath)+      createDirectoryIfMissing True xdgHome+      createDirectoryIfMissing True fakeBin+      TIO.writeFile blueprintPath batchBlueprintDhall+      TIO.writeFile referencePath "batch reference"+      TIO.writeFile+        fakeClaude+        "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf 'edited\\n' > \"$SEIHOU_FAKE_WORKSPACE_FILE\"\nprintf '%s\\n' '{\"result\":\"batch complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n"+      permissions <- getPermissions fakeClaude+      -- Permissions comes from `directory` and has no Generic instance, so it+      -- has no #executable label. Record update syntax is the only option.+      setPermissions fakeClaude (permissions {executable = True})++      inherited <- getEnvironment+      let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+          overriddenNames =+            [ "PATH",+              "XDG_CONFIG_HOME",+              "SEIHOU_AGENT_PROVIDER",+              "SEIHOU_AGENT_MODEL",+              "SEIHOU_CONTEXT",+              "SEIHOU_FAKE_AGENT_LOG",+              "SEIHOU_FAKE_WORKSPACE_FILE"+            ]+          environment =+            ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+              : ("XDG_CONFIG_HOME", xdgHome)+              : ("SEIHOU_AGENT_PROVIDER", "claude-cli")+              : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+              : ("SEIHOU_FAKE_WORKSPACE_FILE", workspaceFile)+              : filter (\(key, _) -> key `notElem` overriddenNames) inherited++      (exitCode, output, errorOutput) <-+        runProcessText binary ["agent", "run", "batch-blueprint"] (Just root) (Just environment)+      case exitCode of+        ExitSuccess -> pure ()+        ExitFailure code ->+          expectationFailure $+            "batch run exited "+              <> show code+              <> "\nstdout:\n"+              <> T.unpack output+              <> "\nstderr:\n"+              <> T.unpack errorOutput+      output `shouldSatisfy` T.isInfixOf "batch complete"+      doesFileExist workspaceFile `shouldReturn` True+      doesFileExist manifestPath `shouldReturn` True+      launchArgs <- T.lines <$> TIO.readFile launchLog+      launchArgs `shouldSatisfy` elem "-p"+      launchArgs `shouldSatisfy` elem "--allowedTools"+      launchArgs `shouldSatisfy` elem "--add-dir"+      launchArgs `shouldSatisfy` elem (T.pack (blueprintDir </> "files"))++  -- The two cases below are the end-to-end proof that a blueprint's own launch+  -- declaration reaches the spawned agent process, rather than only reaching+  -- seihou's internal accounting. They read back the argv the fake `claude`+  -- script was called with.+  it "applies a blueprint-declared model and effort to the launched agent" $+    withDeclaredLaunchBlueprint $ \root blueprintName runDeclared -> do+      (exitCode, output, errorOutput, launchArgs) <- runDeclared []+      expectSuccess "declared launch run" exitCode output errorOutput+      output `shouldSatisfy` T.isInfixOf "declared complete"+      launchArgs `shouldSatisfy` elem "--model"+      launchArgs `shouldSatisfy` elem "claude-sonnet-5"+      launchArgs `shouldSatisfy` elem "--effort"+      launchArgs `shouldSatisfy` elem "max"+      -- Sanity: nothing in the environment or config supplied these; they came+      -- from the blueprint, whose directory is under this temp root.+      root `shouldSatisfy` (not . null)+      blueprintName `shouldBe` "declared-launch"++  it "lets a --model flag override the blueprint declaration" $+    withDeclaredLaunchBlueprint $ \_ _ runDeclared -> do+      (exitCode, output, errorOutput, launchArgs) <- runDeclared ["--model", "claude-opus-4-8"]+      expectSuccess "flag override run" exitCode output errorOutput+      launchArgs `shouldSatisfy` elem "claude-opus-4-8"+      launchArgs `shouldNotSatisfy` elem "claude-sonnet-5"+      -- Only the field the flag names moves; effort still comes from the+      -- blueprint.+      launchArgs `shouldSatisfy` elem "--effort"+      launchArgs `shouldSatisfy` elem "max"+   it "exposes the required version window and rerun option in help" $ do     binary <- seihouBinary     (exitCode, output, _) <- runProcessText binary ["agent", "migrate", "--help"] Nothing Nothing@@ -102,6 +207,8 @@       TIO.writeFile blueprintPath migrationBlueprintDhall       TIO.writeFile fakeClaude "#!/bin/sh\nprintf 'called\\n' >> \"$SEIHOU_FAKE_AGENT_LOG\"\nexit 0\n"       permissions <- getPermissions fakeClaude+      -- Permissions comes from `directory` and has no Generic instance, so it+      -- has no #executable label. Record update syntax is the only option.       setPermissions fakeClaude (permissions {executable = True})        inherited <- getEnvironment@@ -135,7 +242,7 @@         case manifestFromJSON beforeResume of           Left err -> expectationFailure err >> fail "unreachable"           Right decoded -> pure decoded-      map (\receipt -> (receipt.fromVersion, receipt.toVersion)) manifest.blueprintMigrations+      map (\receipt -> (receipt ^. #fromVersion, receipt ^. #toVersion)) (manifest ^. #blueprintMigrations)         `shouldBe` [("1.0.0", "2.0.0"), ("2.5.0", "3.0.0")]        (resumeExit, resumeOutput, resumeError) <- runProcessText binary args (Just root) (Just environment)@@ -146,11 +253,6 @@       T.lines <$> TIO.readFile launchLog `shouldReturn` ["called", "called"]       LBS.readFile manifestPath `shouldReturn` beforeResume -seihouBinary :: IO FilePath-seihouBinary = do-  testBinary <- getExecutablePath-  pure (takeDirectory (takeDirectory testBinary) </> "seihou" </> "seihou")- runProcessText ::   FilePath ->   [String] ->@@ -162,6 +264,111 @@   (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command ""   pure (exitCode, T.pack stdoutText, T.pack stderrText) +-- | Fail with the captured streams when a run that was expected to succeed+-- did not.+expectSuccess :: String -> ExitCode -> T.Text -> T.Text -> Expectation+expectSuccess label exitCode output errorOutput = case exitCode of+  ExitSuccess -> pure ()+  ExitFailure code ->+    expectationFailure $+      label+        <> " exited "+        <> show code+        <> "\nstdout:\n"+        <> T.unpack output+        <> "\nstderr:\n"+        <> T.unpack errorOutput++-- | Stand up a scratch project holding a blueprint that declares a model and+-- an effort, with a fake @claude@ first on @PATH@ that records its argv, an+-- empty @XDG_CONFIG_HOME@ so no real user config leaks in, and every+-- @SEIHOU_AGENT_*@ variable scrubbed from the inherited environment. Nothing+-- outside the blueprint supplies a model or effort, so whatever reaches the+-- recorded argv came from the declaration.+--+-- The callback receives the project root, the blueprint's name, and a runner+-- that takes extra @seihou agent run@ arguments and returns the exit code, the+-- two output streams, and the recorded argv lines.+withDeclaredLaunchBlueprint ::+  (FilePath -> T.Text -> ([String] -> IO (ExitCode, T.Text, T.Text, [T.Text])) -> IO a) ->+  IO a+withDeclaredLaunchBlueprint action =+  withSystemTempDirectory "seihou-agent-run-declared-launch" $ \root -> do+    binary <- seihouBinary+    let blueprintDir = root </> ".seihou" </> "modules" </> "declared-launch"+        blueprintPath = blueprintDir </> "blueprint.dhall"+        xdgHome = root </> "xdg"+        fakeBin = root </> "bin"+        fakeClaude = fakeBin </> "claude"+        launchLog = root </> "agent-launch.args"+    createDirectoryIfMissing True blueprintDir+    createDirectoryIfMissing True xdgHome+    createDirectoryIfMissing True fakeBin+    TIO.writeFile blueprintPath declaredLaunchBlueprintDhall+    -- The batch path parses the JSON line, so the fake must keep printing it.+    TIO.writeFile+      fakeClaude+      "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"result\":\"declared complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n"+    permissions <- getPermissions fakeClaude+    -- Permissions comes from `directory` and has no Generic instance, so it+    -- has no #executable label. Record update syntax is the only option.+    setPermissions fakeClaude (permissions {executable = True})++    inherited <- getEnvironment+    let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+        overriddenNames =+          [ "PATH",+            "XDG_CONFIG_HOME",+            "SEIHOU_AGENT_PROVIDER",+            "SEIHOU_AGENT_MODEL",+            "SEIHOU_AGENT_EFFORT",+            "SEIHOU_CONTEXT",+            "SEIHOU_FAKE_AGENT_LOG"+          ]+        environment =+          ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+            : ("XDG_CONFIG_HOME", xdgHome)+            : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+            : filter (\(key, _) -> key `notElem` overriddenNames) inherited+        runDeclared extraArgs = do+          (exitCode, output, errorOutput) <-+            runProcessText+              binary+              (["agent", "run", "declared-launch"] <> extraArgs)+              (Just root)+              (Just environment)+          launchArgs <-+            doesFileExist launchLog >>= \case+              True -> T.lines <$> TIO.readFile launchLog+              False -> pure []+          pure (exitCode, output, errorOutput, launchArgs)+    action root "declared-launch" runDeclared++-- | A blueprint that declares a model and a reasoning effort but no provider,+-- so the provider still comes from the built-in default.+declaredLaunchBlueprintDhall :: T.Text+declaredLaunchBlueprintDhall =+  T.unlines+    [ "{ name = \"declared-launch\"",+      ", version = Some \"1.0.0\"",+      ", description = Some \"Blueprint declaring its own launch settings\"",+      ", prompt = \"Think hard about this repository.\"",+      ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+      ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+      ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+      ", files = [] : List { src : Text, description : Optional Text }",+      ", allowedTools = None (List Text)",+      ", tags = [] : List Text",+      ", migrations = [] : List { from : Text, to : Text, prompt : Text }",+      ", launch = Some",+      "    { provider = None Text",+      "    , model = Some \"claude-sonnet-5\"",+      "    , effort = Some \"max\"",+      "    , mode = None Text",+      "    }",+      "}"+    ]+ migrationBlueprintDhall :: T.Text migrationBlueprintDhall =   T.unlines@@ -187,5 +394,22 @@       "  [ { from = \"2.5.0\", to = \"3.0.0\", prompt = \"Finish the baikai upgrade.\" }",       "  , { from = \"1.0.0\", to = \"2.0.0\", prompt = \"Replace {{library.name}} legacy calls.\" }",       "  ]",+      "}"+    ]++batchBlueprintDhall :: T.Text+batchBlueprintDhall =+  T.unlines+    [ "{ name = \"batch-blueprint\"",+      ", version = Some \"1.0.0\"",+      ", description = Some \"Batch blueprint fixture\"",+      ", prompt = \"Use the mounted reference and update the workspace.\"",+      ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+      ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+      ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+      ", files = [ { src = \"reference.md\", description = Some \"Batch reference\" } ]",+      ", allowedTools = Some [ \"Read\", \"Write\" ]",+      ", tags = [ \"test\" ]",+      ", migrations = [] : List { from : Text, to : Text, prompt : Text }",       "}"     ]
+ test/Seihou/CLI/AgentTraceE2ESpec.hs view
@@ -0,0 +1,215 @@+-- | End-to-end proof that call tracing reaches a JSONL file when it is turned+-- on, and touches nothing at all when it is not.+--+-- These run the real @seihou@ binary against a fake @claude@ first on @PATH@,+-- with an empty @XDG_CONFIG_HOME@ and every @SEIHOU_AGENT_*@ variable scrubbed+-- from the inherited environment, so nothing outside the test configures+-- tracing. The unit specs cover sink construction and the completion path;+-- this covers the wiring between them, which is the part a stale binary or a+-- missed call site would silently break.+module Seihou.CLI.AgentTraceE2ESpec (tests) where++import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy.Char8 qualified as BL8+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.CLI.SeihouBinary (seihouBinary)+import System.Directory+  ( createDirectoryIfMissing,+    doesFileExist,+    executable,+    getPermissions,+    setPermissions,+  )+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath (searchPathSeparator, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)+import Test.Hspec+import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Agent call tracing end-to-end" $ do+  -- The guarantee that tracing is genuinely off by default: no file, anywhere.+  it "creates no trace file when tracing is not configured" $+    withTraceProject $ \root run -> do+      (exitCode, output, errorOutput, _) <- run [] []+      expectSuccess "untraced run" exitCode output errorOutput+      output `shouldSatisfy` T.isInfixOf "traced complete"+      doesFileExist (root </> ".seihou" </> "trace.jsonl") `shouldReturn` False++  it "writes a correlated start/finish pair when SEIHOU_AGENT_TRACE=file" $+    withTraceProject $ \root run -> do+      let tracePath = root </> "trace.jsonl"+      (exitCode, output, errorOutput, _) <-+        run [("SEIHOU_AGENT_TRACE", "file"), ("SEIHOU_AGENT_TRACE_PATH_FIXTURE", tracePath)] []+      expectSuccess "traced run" exitCode output errorOutput+      events <- traceEvents tracePath+      map fst events `shouldBe` ["call_started", "call_finished"]+      case map snd events of+        [started, finished] -> started `shouldBe` finished+        other -> expectationFailure ("expected two events, got " <> show (length other))++  it "lets --trace off override a configured file trace" $+    withTraceProject $ \root run -> do+      let tracePath = root </> "trace.jsonl"+      (exitCode, output, errorOutput, _) <-+        run+          [("SEIHOU_AGENT_TRACE", "file"), ("SEIHOU_AGENT_TRACE_PATH_FIXTURE", tracePath)]+          ["--trace", "off"]+      expectSuccess "flag-disabled run" exitCode output errorOutput+      doesFileExist tracePath `shouldReturn` False++  -- Trace lines must never land in stdout, which callers pipe.+  it "sends --trace stderr to stderr, leaving stdout clean" $+    withTraceProject $ \_ run -> do+      (exitCode, output, errorOutput, _) <- run [] ["--trace", "stderr"]+      expectSuccess "stderr-traced run" exitCode output errorOutput+      errorOutput `shouldSatisfy` T.isInfixOf "START"+      output `shouldNotSatisfy` T.isInfixOf "START"+      output `shouldSatisfy` T.isInfixOf "traced complete"++  it "rejects an unknown trace setting, naming the accepted ones" $+    withTraceProject $ \_ run -> do+      (exitCode, output, errorOutput, _) <- run [] ["--trace", "syslog"]+      exitCode `shouldBe` ExitFailure 1+      (output <> errorOutput) `shouldSatisfy` T.isInfixOf "Unknown trace setting 'syslog'"+      (output <> errorOutput) `shouldSatisfy` T.isInfixOf "off, file, stdout, stderr"++-- | Stand up a scratch project with a trivial blueprint and a fake @claude@+-- that prints the batch JSON line the CLI provider expects.+--+-- The callback receives the project root and a runner taking extra environment+-- entries and extra @seihou agent run@ arguments. When the environment carries+-- @SEIHOU_AGENT_TRACE_PATH_FIXTURE@, that path is written into the project's+-- local config as @agent.tracePath@ before the run, since the path has no flag+-- or environment variable of its own by design.+withTraceProject ::+  (FilePath -> ([(String, String)] -> [String] -> IO (ExitCode, T.Text, T.Text, [T.Text])) -> IO a) ->+  IO a+withTraceProject action =+  withSystemTempDirectory "seihou-agent-trace" $ \root -> do+    binary <- seihouBinary+    let blueprintDir = root </> ".seihou" </> "modules" </> "tracer"+        blueprintPath = blueprintDir </> "blueprint.dhall"+        configPath = root </> ".seihou" </> "config.dhall"+        xdgHome = root </> "xdg"+        fakeBin = root </> "bin"+        fakeClaude = fakeBin </> "claude"+        launchLog = root </> "agent-launch.args"+    createDirectoryIfMissing True blueprintDir+    createDirectoryIfMissing True xdgHome+    createDirectoryIfMissing True fakeBin+    TIO.writeFile blueprintPath tracerBlueprintDhall+    TIO.writeFile+      fakeClaude+      "#!/bin/sh\nprintf '%s\\n' \"$@\" > \"$SEIHOU_FAKE_AGENT_LOG\"\nprintf '%s\\n' '{\"result\":\"traced complete\",\"is_error\":false,\"session_id\":\"fake\"}'\n"+    permissions <- getPermissions fakeClaude+    -- Permissions comes from `directory` and has no Generic instance, so it+    -- has no #executable label. Record update syntax is the only option.+    setPermissions fakeClaude (permissions {executable = True})++    inherited <- getEnvironment+    let inheritedPath = fromMaybe "" (lookup "PATH" inherited)+        overriddenNames =+          [ "PATH",+            "XDG_CONFIG_HOME",+            "SEIHOU_AGENT_PROVIDER",+            "SEIHOU_AGENT_MODEL",+            "SEIHOU_AGENT_EFFORT",+            "SEIHOU_AGENT_TRACE",+            "SEIHOU_CONTEXT",+            "SEIHOU_FAKE_AGENT_LOG"+          ]+        baseEnvironment =+          ("PATH", fakeBin <> [searchPathSeparator] <> inheritedPath)+            : ("XDG_CONFIG_HOME", xdgHome)+            : ("SEIHOU_FAKE_AGENT_LOG", launchLog)+            : filter (\(key, _) -> key `notElem` overriddenNames) inherited+        run extraEnv extraArgs = do+          case lookup "SEIHOU_AGENT_TRACE_PATH_FIXTURE" extraEnv of+            Nothing -> pure ()+            Just tracePath ->+              TIO.writeFile configPath (localConfigDhall (T.pack tracePath))+          (exitCode, output, errorOutput) <-+            runProcessText+              binary+              (["agent", "run", "tracer", "--batch"] <> extraArgs)+              (Just root)+              (Just (extraEnv <> baseEnvironment))+          launchArgs <-+            doesFileExist launchLog >>= \case+              True -> T.lines <$> TIO.readFile launchLog+              False -> pure []+          pure (exitCode, output, errorOutput, launchArgs)+    action root run++runProcessText ::+  FilePath ->+  [String] ->+  Maybe FilePath ->+  Maybe [(String, String)] ->+  IO (ExitCode, T.Text, T.Text)+runProcessText binary args workingDirectory environment = do+  let command = (proc binary args) {cwd = workingDirectory, env = environment}+  (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command ""+  pure (exitCode, T.pack stdoutText, T.pack stderrText)++expectSuccess :: String -> ExitCode -> T.Text -> T.Text -> Expectation+expectSuccess label exitCode output errorOutput = case exitCode of+  ExitSuccess -> pure ()+  ExitFailure code ->+    expectationFailure $+      label+        <> " exited "+        <> show code+        <> "\nstdout:\n"+        <> T.unpack output+        <> "\nstderr:\n"+        <> T.unpack errorOutput++-- | The @(kind, eventId)@ of every event in a JSONL trace file, in order.+--+-- Deliberately not asserting on token counts or cost: @claude-cli@ is+-- subscription-based and reports neither, so those fields are legitimately+-- absent from this fixture's @call_finished@ event.+traceEvents :: FilePath -> IO [(String, String)]+traceEvents path = do+  contents <- BL8.readFile path+  pure+    [ (T.unpack kind, T.unpack eventId)+    | line <- BL8.lines contents,+      not (BL8.null line),+      Just (Aeson.Object o) <- [Aeson.decode line],+      Just (Aeson.String kind) <- [KeyMap.lookup (Key.fromString "kind") o],+      Just (Aeson.String eventId) <- [KeyMap.lookup (Key.fromString "eventId") o]+    ]++-- | A project-local @.seihou/config.dhall@: a plain Dhall record of text+-- values with backtick-escaped dotted keys, which is the shape+-- 'Seihou.Dhall.Config.evalConfigFile' expects.+localConfigDhall :: T.Text -> T.Text+localConfigDhall tracePath =+  "{ `agent.tracePath` = \"" <> tracePath <> "\" }\n"++tracerBlueprintDhall :: T.Text+tracerBlueprintDhall =+  T.unlines+    [ "{ name = \"tracer\"",+      ", version = Some \"1.0.0\"",+      ", description = Some \"Blueprint fixture for call tracing\"",+      ", prompt = \"Say hello.\"",+      ", vars = [] : List { name : Text, type : Text, default : Optional Text, description : Optional Text, required : Bool, validation : Optional Text }",+      ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+      ", baseModules = [] : List { module : Text, vars : List { name : Text, value : Text } }",+      ", files = [] : List { src : Text, description : Optional Text }",+      ", allowedTools = None (List Text)",+      ", tags = [] : List Text",+      ", migrations = [] : List { from : Text, to : Text, prompt : Text }",+      "}"+    ]
+ test/Seihou/CLI/AgentTraceSpec.hs view
@@ -0,0 +1,170 @@+module Seihou.CLI.AgentTraceSpec (tests) where++import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy.Char8 qualified as BL8+import Data.Text qualified as Text+import Data.Time (UTCTime (..), fromGregorian, secondsToDiffTime)+import Seihou.CLI.AgentCompletion (TraceSetting (..))+import Seihou.CLI.AgentTrace+  ( defaultTraceFileName,+    resolveTraceFilePath,+    traceSinkFor,+  )+import Streamly.Data.Stream qualified as Stream+import System.Directory (doesDirectoryExist, doesFileExist)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty (TestTree)+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Seihou.CLI.AgentTrace" spec++spec :: Spec+spec = do+  describe "resolveTraceFilePath" $ do+    it "falls back to the project-local default when nothing is configured" $+      resolveTraceFilePath Nothing `shouldBe` defaultTraceFileName++    it "puts the default inside .seihou/" $+      defaultTraceFileName `shouldBe` ".seihou" </> "trace.jsonl"++    it "uses an explicitly configured path" $+      resolveTraceFilePath (Just "/tmp/seihou-trace.jsonl") `shouldBe` "/tmp/seihou-trace.jsonl"++    -- Blank counts as absent everywhere else in the resolver; a blank+    -- agent.tracePath must not send the sink to "".+    it "treats a blank configured path as absent" $ do+      resolveTraceFilePath (Just "") `shouldBe` defaultTraceFileName+      resolveTraceFilePath (Just "   ") `shouldBe` defaultTraceFileName++  describe "traceSinkFor" $ do+    it "writes nothing anywhere when tracing is off" $+      withSystemTempDirectory "seihou-trace-off" $ \root -> do+        sink <- traceSinkFor TraceOff (Just (root </> "nested" </> "trace.jsonl"))+        feed sink [startEvent]+        doesDirectoryExist (root </> "nested") `shouldReturn` False++    it "creates the trace file's parent directory" $+      withSystemTempDirectory "seihou-trace-mkdir" $ \root -> do+        let path = root </> "deeply" </> "nested" </> "trace.jsonl"+        _ <- traceSinkFor TraceFile (Just path)+        doesDirectoryExist (root </> "deeply" </> "nested") `shouldReturn` True++    it "appends one parseable JSON object per event" $+      withSystemTempDirectory "seihou-trace-file" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        feed sink [startEvent, finishEvent]+        contents <- BL8.readFile path+        let ls = filter (not . BL8.null) (BL8.lines contents)+        length ls `shouldBe` 2+        traverse (Aeson.decode @Aeson.Value) ls `shouldSatisfy` \case+          Just _ -> True+          Nothing -> False++    it "tags each line with the event kind that jq filters on" $+      withSystemTempDirectory "seihou-trace-kind" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        feed sink [startEvent, finishEvent]+        kinds <- traceKinds path+        kinds `shouldBe` ["call_started", "call_finished"]++    it "correlates a start and its finish by eventId" $+      withSystemTempDirectory "seihou-trace-corr" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        feed sink [startEvent, finishEvent]+        ids <- traceField "eventId" path+        ids `shouldBe` ["call-1", "call-1"]++    it "records a failure as call_failed" $+      withSystemTempDirectory "seihou-trace-fail" $ \root -> do+        let path = root </> "trace.jsonl"+        sink <- traceSinkFor TraceFile (Just path)+        feed sink [startEvent, failEvent]+        traceKinds path `shouldReturn` ["call_started", "call_failed"]++    -- The file sink appends rather than truncating, so a second traced run in+    -- the same project accumulates history instead of destroying it.+    it "appends across separately constructed sinks" $+      withSystemTempDirectory "seihou-trace-append" $ \root -> do+        let path = root </> "trace.jsonl"+        first <- traceSinkFor TraceFile (Just path)+        feed first [startEvent, finishEvent]+        second <- traceSinkFor TraceFile (Just path)+        feed second [startEvent, finishEvent]+        kinds <- traceKinds path+        length kinds `shouldBe` 4++    it "creates no file for the stream settings" $+      withSystemTempDirectory "seihou-trace-stream" $ \root -> do+        let path = root </> "trace.jsonl"+        stderrOnly <- traceSinkFor TraceStderr (Just path)+        _ <- pure stderrOnly+        doesFileExist path `shouldReturn` False++-- | Drive a sink's fold over a list of events, the way Baikai's trace bridge+-- drives it over the per-call event channel.+feed :: TraceSink -> [TraceEvent] -> IO ()+feed (TraceSink f) events = Stream.fold f (Stream.fromList events)++-- | The @kind@ tag of every line in a JSONL trace file, in order.+traceKinds :: FilePath -> IO [String]+traceKinds = traceField "kind"++-- | One top-level string field from every line of a JSONL trace file.+traceField :: String -> FilePath -> IO [String]+traceField field path = do+  contents <- BL8.readFile path+  pure+    [ Text.unpack value+    | line <- BL8.lines contents,+      not (BL8.null line),+      Just (Aeson.Object o) <- [Aeson.decode line],+      Just (Aeson.String value) <- [KeyMap.lookup (Key.fromString field) o]+    ]++at :: UTCTime+at = UTCTime (fromGregorian 2026 7 27) (secondsToDiffTime 0)++startEvent :: TraceEvent+startEvent =+  CallStarted+    { eventId = "call-1",+      timestamp = at,+      provider = "anthropic",+      model = "claude-sonnet-4-6",+      maxTokens = 8192,+      promptSummary = "add a health check module"+    }++finishEvent :: TraceEvent+finishEvent =+  CallFinished+    { eventId = "call-1",+      timestamp = at,+      provider = "anthropic",+      model = "claude-sonnet-4-6",+      latencyMs = 7913,+      inputTokens = Just 4211,+      outputTokens = Just 880,+      usd = Just 0.0264+    }++failEvent :: TraceEvent+failEvent =+  CallFailed+    { eventId = "call-1",+      timestamp = at,+      provider = "anthropic",+      model = "claude-sonnet-4-6",+      latencyMs = 120,+      errorMessage = "invalid x-api-key"+    }
test/Seihou/CLI/AppliedBlueprintMigrationSpec.hs view
@@ -1,6 +1,8 @@ module Seihou.CLI.AppliedBlueprintMigrationSpec (tests) where +import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Text qualified as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Seihou.CLI.AppliedBlueprintMigration (recordAppliedBlueprintMigration)@@ -50,8 +52,8 @@       result <- recordAppliedBlueprintMigration manifestPath receipt       result `shouldBe` Right ()       manifest <- readManifestFile manifestPath-      manifest.version `shouldBe` currentManifestVersion-      manifest.blueprintMigrations `shouldBe` [receipt]+      (manifest ^. #version) `shouldBe` currentManifestVersion+      (manifest ^. #blueprintMigrations) `shouldBe` [receipt]    it "upserts the same exact edge and retains unrelated edges" $     withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do@@ -59,14 +61,14 @@           first = mkReceipt "payments" "1.0.0" "2.0.0" fixedTime           second = mkReceipt "payments" "2.5.0" "3.0.0" fixedTime           replacement =-            (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2)-              { blueprintVersion = Just "0.5.0"-              }+            ( (mkReceipt "payments" "1.0.0" "2.0.0" fixedTime2)+                & #blueprintVersion .~ Just "0.5.0"+            )       recordAppliedBlueprintMigration manifestPath first `shouldReturn` Right ()       recordAppliedBlueprintMigration manifestPath second `shouldReturn` Right ()       recordAppliedBlueprintMigration manifestPath replacement `shouldReturn` Right ()       manifest <- readManifestFile manifestPath-      manifest.blueprintMigrations `shouldBe` [replacement, second]+      (manifest ^. #blueprintMigrations) `shouldBe` [replacement, second]    it "returns Left and preserves a corrupt existing manifest" $     withSystemTempDirectory "seihou-blueprint-migration" $ \dir -> do
test/Seihou/CLI/AppliedBlueprintSpec.hs view
@@ -1,6 +1,8 @@ module Seihou.CLI.AppliedBlueprintSpec (tests) where +import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T@@ -60,8 +62,8 @@         res <- recordAppliedBlueprint manifestPath entry         res `shouldBe` Right ()         m <- readManifestFile manifestPath-        m.version `shouldBe` currentManifestVersion-        m.blueprint `shouldBe` Just entry+        (m ^. #version) `shouldBe` currentManifestVersion+        (m ^. #blueprint) `shouldBe` Just entry      it "preserves unrelated manifest fields" $       withSystemTempDirectory "seihou-ab" $ \dir -> do@@ -73,17 +75,17 @@                   appliedAt = fixedTime                 }             seed =-              (emptyManifest fixedTime)-                { recipe = Just seedRecipe,-                  vars = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #recipe .~ Just seedRecipe+                  & #vars .~ Map.empty+              )         LBS.writeFile manifestPath (manifestToJSON seed)         let entry = mkEntry "payments-service" Nothing [] True Nothing         res <- recordAppliedBlueprint manifestPath entry         res `shouldBe` Right ()         m <- readManifestFile manifestPath-        m.recipe `shouldBe` Just seedRecipe-        m.blueprint `shouldBe` Just entry+        (m ^. #recipe) `shouldBe` Just seedRecipe+        (m ^. #blueprint) `shouldBe` Just entry      it "overwrites a prior blueprint entry" $       withSystemTempDirectory "seihou-ab" $ \dir -> do@@ -93,7 +95,7 @@         _ <- recordAppliedBlueprint manifestPath ab1         _ <- recordAppliedBlueprint manifestPath ab2         m <- readManifestFile manifestPath-        m.blueprint `shouldBe` Just ab2+        (m ^. #blueprint) `shouldBe` Just ab2      it "returns Left when the existing manifest is unreadable" $       withSystemTempDirectory "seihou-ab" $ \dir -> do
test/Seihou/CLI/BlueprintMigrationSpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.BlueprintMigrationSpec (tests) where +import Control.Lens (to, (^.))+import Data.Generics.Labels () import Data.IORef import Data.Map.Strict qualified as Map import Data.Text (Text)@@ -73,7 +75,7 @@     it "delimits debug prompts in pending order without any execution callback" $ do       let output =             formatBlueprintMigrationDebugOutput-              (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge.from)+              (\position total edge -> "prompt " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from)               [first, second]       output `shouldSatisfy` T.isInfixOf "===== [1/2] 1.0.0 -> 2.0.0 ====="       output `shouldSatisfy` T.isInfixOf "===== [2/2] 2.0.0 -> 3.0.0 ====="@@ -93,10 +95,10 @@     it "launches and records every edge sequentially" $ do       calls <- newIORef ([] :: [Text])       let launch position total edge = do-            modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge.from])+            modifyIORef' calls (<> ["launch " <> tshow position <> "/" <> tshow total <> " " <> edge ^. #from])             pure (Right ())           record edge = do-            modifyIORef' calls (<> ["record " <> edge.from])+            modifyIORef' calls (<> ["record " <> edge ^. #from])             pure (Right ())       result <- runBlueprintMigrationsWith launch record [first, second]       result `shouldBe` BlueprintMigrationComplete [first, second]@@ -113,20 +115,20 @@       let third = migration "3.0.0" "4.0.0"           migrationPlan =             BlueprintMigrationPlan-              { blueprintPlanName = "payments",-                blueprintPlanFrom = version "1.0.0",-                blueprintPlanTo = version "4.0.0",-                blueprintPlanSteps = [first, second, third]+              { name = "payments",+                from = version "1.0.0",+                to = version "4.0.0",+                steps = [first, second, third]               }           launch _ _ edge = do-            modifyIORef' calls (<> ["launch " <> edge.from])+            modifyIORef' calls (<> ["launch " <> edge ^. #from])             pure $               if edge == second                 then Left (BlueprintMigrationProcessFailure (ExitFailure 17))                 else Right ()           record edge = do-            modifyIORef' calls (<> ["record " <> edge.from])-            modifyIORef' recorded (<> [receipt blueprintName edge.from edge.to])+            modifyIORef' calls (<> ["record " <> edge ^. #from])+            modifyIORef' recorded (<> [receipt blueprintName (edge ^. #from) (edge ^. #to)])             pure (Right ())       result <- runBlueprintMigrationsWith launch record [first, second, third]       result@@ -140,16 +142,16 @@        resumedResult <-         runBlueprintMigrationsWith-          (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge.from]) >> pure (Right ()))+          (\_ _ edge -> modifyIORef' calls (<> ["resume " <> edge ^. #from]) >> pure (Right ()))           record           resumed       resumedResult `shouldBe` BlueprintMigrationComplete [second, third]-      readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName edge.from edge.to) [first, second, third]+      readIORef recorded `shouldReturn` map (\edge -> receipt blueprintName (edge ^. #from) (edge ^. #to)) [first, second, third]      it "stops before the next launch when receipt recording fails" $ do       calls <- newIORef ([] :: [Text])-      let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge.from]) >> pure (Right ())-          record edge = modifyIORef' calls (<> ["record " <> edge.from]) >> pure (Left "disk full")+      let launch _ _ edge = modifyIORef' calls (<> ["launch " <> edge ^. #from]) >> pure (Right ())+          record edge = modifyIORef' calls (<> ["record " <> edge ^. #from]) >> pure (Left "disk full")       result <- runBlueprintMigrationsWith launch record [first, second]       result `shouldBe` BlueprintMigrationRecordFailed first "disk full"       readIORef calls `shouldReturn` ["launch 1.0.0", "record 1.0.0"]@@ -178,10 +180,10 @@ plan :: [BlueprintMigration] -> BlueprintMigrationPlan plan steps =   BlueprintMigrationPlan-    { blueprintPlanName = "payments",-      blueprintPlanFrom = version "1.0.0",-      blueprintPlanTo = version "3.0.0",-      blueprintPlanSteps = steps+    { name = "payments",+      from = version "1.0.0",+      to = version "3.0.0",+      steps = steps     }  receipt :: ModuleName -> Text -> Text -> AppliedBlueprintMigration@@ -234,15 +236,16 @@             files = [],             allowedTools = Nothing,             tags = [],-            migrations = [first, second]+            migrations = [first, second],+            launch = Nothing           }    in PreparedBlueprintExecution-        { preparedBlueprint = blueprint,-          preparedBlueprintDir = "/tmp/payments",-          preparedResolvedVariables = resolved,-          preparedMountedFilesDir = Just "/tmp/payments/files",-          preparedReferenceFiles = "  - guide.md",-          preparedReferenceFilesAccess = "mounted at /tmp/payments/files",-          preparedSharedPrompt = "Shared guidance for baikai.",-          preparedAllowedTools = ["Read"]+        { blueprint = blueprint,+          blueprintDir = "/tmp/payments",+          resolvedVariables = resolved,+          mountedFilesDir = Just "/tmp/payments/files",+          referenceFiles = "  - guide.md",+          referenceFilesAccess = "mounted at /tmp/payments/files",+          sharedPrompt = "Shared guidance for baikai.",+          allowedTools = ["Read"]         }
test/Seihou/CLI/CommandExecutionSpec.hs view
@@ -1,5 +1,6 @@ module Seihou.CLI.CommandExecutionSpec (tests) where +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromJust) import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError)@@ -44,9 +45,9 @@ successMock :: Text -> ProcessMock successMock command =   ProcessMock-    { mockCommand = "sh",-      mockArgs = ["-c", command],-      mockResult = (ExitSuccess, "output", "")+    { command = "sh",+      args = ["-c", command],+      result = (ExitSuccess, "output", "")     }  spec :: Spec@@ -56,15 +57,15 @@       let first = commandOp "echo first" Nothing "app" 0           second = commandOp "echo second" Nothing "app" 0           plan = planCommands RunAllCommands Map.empty [first, WriteFileOp "file" "content" Template, second]-      map (.operation) plan.commands `shouldBe` [first, second]-      map (.disposition) plan.commands `shouldBe` [CommandWillRun, CommandWillRun]+      map (^. #operation) (plan ^. #commands) `shouldBe` [first, second]+      map (^. #disposition) (plan ^. #commands) `shouldBe` [CommandWillRun, CommandWillRun]      it "skips only fingerprints with successful prior receipts in changed-only mode" $ do       let unchanged = commandOp "echo same" Nothing "app" 0           changed = commandOp "echo changed" Nothing "app" 0           prior = Map.singleton (fingerprintOf unchanged) (receiptFor fixedTime unchanged)           plan = planCommands RunChangedCommands prior [unchanged, changed]-      map (.disposition) plan.commands+      map (^. #disposition) (plan ^. #commands)         `shouldBe` [CommandSkippedUnchanged, CommandWillRun]       summarizeCommandPlan plan         `shouldBe` CommandPlanSummary {willRun = 1, skippedUnchanged = 1, skippedDisabled = 0}@@ -74,13 +75,13 @@           second = commandOp "echo same" Nothing "app" 1           prior = Map.singleton (fingerprintOf first) (receiptFor fixedTime first)           plan = planCommands RunChangedCommands prior [first, second]-      map (.disposition) plan.commands+      map (^. #disposition) (plan ^. #commands)         `shouldBe` [CommandSkippedUnchanged, CommandWillRun]      it "marks every command disabled without minting receipts" $ do       let operations = [commandOp "echo one" Nothing "app" 0, commandOp "echo two" Nothing "app" 0]           plan = planCommands DisableCommands Map.empty operations-      map (.disposition) plan.commands+      map (^. #disposition) (plan ^. #commands)         `shouldBe` [CommandSkippedDisabled, CommandSkippedDisabled]    describe "executeCommandPlan" $ do@@ -94,14 +95,14 @@                 executeCommandPlan laterTime plan       case result of         Right receipts -> do-          map (.fingerprint) receipts `shouldBe` map fingerprintOf [first, second]-          map (.completedAt) receipts `shouldBe` [laterTime, laterTime]+          map (^. #fingerprint) receipts `shouldBe` map fingerprintOf [first, second]+          map (^. #completedAt) receipts `shouldBe` [laterTime, laterTime]         Left err -> expectationFailure ("Expected success, got: " <> show err)      it "does not execute skipped commands" $ do       let operation = commandOp "echo skipped" Nothing "app" 0           priorReceipt = receiptFor fixedTime operation-          prior = Map.singleton priorReceipt.fingerprint priorReceipt+          prior = Map.singleton (priorReceipt ^. #fingerprint) priorReceipt           plan = planCommands RunChangedCommands prior [operation]           result = runPureEff $ runProcessPure [] $ executeCommandPlan laterTime plan       result `shouldBe` Right []@@ -112,19 +113,19 @@           plan = planCommands RunAllCommands Map.empty [failing, neverReached]           mocks =             [ ProcessMock-                { mockCommand = "sh",-                  mockArgs = ["-c", "exit 7"],-                  mockResult = (ExitFailure 7, "partial", "boom")+                { command = "sh",+                  args = ["-c", "exit 7"],+                  result = (ExitFailure 7, "partial", "boom")                 },               successMock "echo later"             ]           result = runPureEff $ runProcessPure mocks $ executeCommandPlan laterTime plan       case result of         Left err -> do-          err.exitCode `shouldBe` 7-          err.stdout `shouldBe` "partial"-          err.stderr `shouldBe` "boom"-          err.command.operation `shouldBe` failing+          (err ^. #exitCode) `shouldBe` 7+          (err ^. #stdout) `shouldBe` "partial"+          (err ^. #stderr) `shouldBe` "boom"+          (err ^. #command . #operation) `shouldBe` failing         Right receipts -> expectationFailure ("Expected failure, got receipts: " <> show receipts)    describe "finalizeCommandReceipts" $ do@@ -137,22 +138,22 @@           newChanged = receiptFor laterTime changed           prior =             Map.fromList-              [ (oldUnchanged.fingerprint, oldUnchanged),-                (oldRemoved.fingerprint, oldRemoved)+              [ (oldUnchanged ^. #fingerprint, oldUnchanged),+                (oldRemoved ^. #fingerprint, oldRemoved)               ]           plan = planCommands RunChangedCommands prior [unchanged, changed]           finalized = finalizeCommandReceipts plan [newChanged] prior       finalized         `shouldBe` Map.fromList-          [ (oldUnchanged.fingerprint, oldUnchanged),-            (newChanged.fingerprint, newChanged)+          [ (oldUnchanged ^. #fingerprint, oldUnchanged),+            (newChanged ^. #fingerprint, newChanged)           ]      it "retains only matching old receipts when commands are disabled" $ do       let old = commandOp "echo old" Nothing "app" 0           new = commandOp "echo new" Nothing "app" 0           oldReceipt = receiptFor fixedTime old-          prior = Map.singleton oldReceipt.fingerprint oldReceipt+          prior = Map.singleton (oldReceipt ^. #fingerprint) oldReceipt           plan = planCommands DisableCommands prior [old, new]       finalizeCommandReceipts plan [] prior-        `shouldBe` Map.singleton oldReceipt.fingerprint oldReceipt+        `shouldBe` Map.singleton (oldReceipt ^. #fingerprint) oldReceipt
test/Seihou/CLI/InstallHistorySpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.InstallHistorySpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Text qualified as T import Seihou.CLI.InstallHistory   ( HistoryEntry (..),@@ -25,14 +27,14 @@     it "returns empty history when file does not exist" $ do       withSystemTempDirectory "history-test" $ \tmp -> do         h <- readHistoryFrom (tmp </> "nonexistent.json")-        h.entries `shouldBe` []+        (h ^. #entries) `shouldBe` []      it "returns empty history for malformed JSON" $ do       withSystemTempDirectory "history-test" $ \tmp -> do         let path = tmp </> "bad.json"         writeFile path "not json"         h <- readHistoryFrom path-        h.entries `shouldBe` []+        (h ^. #entries) `shouldBe` []    describe "writeHistoryTo / readHistoryFrom round-trip" $ do     it "round-trips an empty history" $ do@@ -63,8 +65,8 @@         exists <- doesFileExist path         exists `shouldBe` True         h <- readHistoryFrom path-        length h.entries `shouldBe` 1-        (head h.entries).url `shouldBe` "https://github.com/foo/bar.git"+        length (h ^. #entries) `shouldBe` 1+        ((head (h ^. #entries)) ^. #url) `shouldBe` "https://github.com/foo/bar.git"      it "deduplicates by URL, keeping most recent first" $ do       withSystemTempDirectory "history-test" $ \tmp -> do@@ -73,8 +75,8 @@         recordUrlTo path "https://github.com/b/second.git"         recordUrlTo path "https://github.com/a/first.git"         h <- readHistoryFrom path-        length h.entries `shouldBe` 2-        (head h.entries).url `shouldBe` "https://github.com/a/first.git"+        length (h ^. #entries) `shouldBe` 2+        ((head (h ^. #entries)) ^. #url) `shouldBe` "https://github.com/a/first.git"      it "caps history at maxHistoryEntries" $ do       withSystemTempDirectory "history-test" $ \tmp -> do@@ -83,4 +85,4 @@           (\i -> recordUrlTo path ("https://example.com/repo-" <> T.pack (show i) <> ".git"))           [1 .. maxHistoryEntries + 5 :: Int]         h <- readHistoryFrom path-        length h.entries `shouldBe` maxHistoryEntries+        length (h ^. #entries) `shouldBe` maxHistoryEntries
test/Seihou/CLI/ListSpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.ListSpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.CLI.List (Entry (..), ListFilter (..), applyFilters, formatListOutput, formatListOutputEntries, runnableToEntryWithOrigin)@@ -16,7 +18,7 @@ validModule :: String -> String -> ModuleSource -> DiscoveredModule validModule name desc src =   DiscoveredModule-    { discoveredResult =+    { result =         Right           Module             { name = ModuleName (T.pack name),@@ -31,17 +33,17 @@               removal = Nothing,               migrations = []             },-      discoveredSource = src,-      discoveredDir = "/fake/" ++ name+      source = src,+      dir = "/fake/" ++ name     }  -- | A broken discovered module for testing. brokenModule :: String -> ModuleSource -> DiscoveredModule brokenModule name src =   DiscoveredModule-    { discoveredResult = Left (DhallEvalError (ModuleName (T.pack name)) "parse error"),-      discoveredSource = src,-      discoveredDir = "/fake/" ++ name+    { result = Left (DhallEvalError (ModuleName (T.pack name)) "parse error"),+      source = src,+      dir = "/fake/" ++ name     }  -- | Helper to build an Entry for filter tests.  Defaults the kind to a module.@@ -52,13 +54,13 @@ mkEntryK :: RunnableKind -> T.Text -> Maybe T.Text -> [T.Text] -> Entry mkEntryK kind name repo tags =   Entry-    { entryName = name,-      entryDesc = "desc",-      entrySource = "installed",-      entryIsError = False,-      entryRepoName = repo,-      entryTags = tags,-      entryKind = kind+    { name = name,+      desc = "desc",+      source = "installed",+      isError = False,+      repoName = repo,+      tags = tags,+      kind = kind     }  noFilter :: ListFilter@@ -125,19 +127,19 @@       let opts = ListFilter (Just "repo-x") Nothing []           result = applyFilters opts entries       length result `shouldBe` 2-      map (.entryName) result `shouldBe` ["mod-a", "mod-b"]+      map (^. #name) result `shouldBe` ["mod-a", "mod-b"]      it "filters by tag" $ do       let opts = ListFilter Nothing (Just "haskell") []           result = applyFilters opts entries       length result `shouldBe` 2-      map (.entryName) result `shouldBe` ["mod-a", "mod-c"]+      map (^. #name) result `shouldBe` ["mod-a", "mod-c"]      it "combines repo and tag filters with AND" $ do       let opts = ListFilter (Just "repo-x") (Just "haskell") []           result = applyFilters opts entries       length result `shouldBe` 1-      map (.entryName) result `shouldBe` ["mod-a"]+      map (^. #name) result `shouldBe` ["mod-a"]      it "returns empty list when repo filter matches nothing" $ do       let opts = ListFilter (Just "nonexistent") Nothing []@@ -152,7 +154,7 @@     it "excludes modules without origin metadata when repo filter is active" $ do       let opts = ListFilter (Just "repo-x") Nothing []           result = applyFilters opts entries-      all (\e -> e.entryRepoName == Just "repo-x") result `shouldBe` True+      all (\e -> e ^. #repoName == Just "repo-x") result `shouldBe` True    describe "applyFilters (by kind)" $ do     let mixed =@@ -163,35 +165,35 @@             mkEntryK KindModule "mod-b" (Just "repo-x") ["haskell"]           ] -    it "keeps all kinds when filterKinds is empty" $ do+    it "keeps all kinds when kinds is empty" $ do       length (applyFilters (ListFilter Nothing Nothing []) mixed) `shouldBe` 5      it "keeps only modules with --modules" $ do       let result = applyFilters (ListFilter Nothing Nothing [KindModule]) mixed-      map (.entryName) result `shouldBe` ["mod-a", "mod-b"]+      map (^. #name) result `shouldBe` ["mod-a", "mod-b"]      it "keeps only recipes with --recipes" $ do       let result = applyFilters (ListFilter Nothing Nothing [KindRecipe]) mixed-      map (.entryName) result `shouldBe` ["rec-a"]+      map (^. #name) result `shouldBe` ["rec-a"]      it "keeps only blueprints with --blueprints" $ do       let result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) mixed-      map (.entryName) result `shouldBe` ["bp-a"]+      map (^. #name) result `shouldBe` ["bp-a"]      it "keeps only prompts with --prompts" $ do       let result = applyFilters (ListFilter Nothing Nothing [KindPrompt]) mixed-      map (.entryName) result `shouldBe` ["prompt-a"]+      map (^. #name) result `shouldBe` ["prompt-a"]      it "unions kinds when several flags are given" $ do       let result = applyFilters (ListFilter Nothing Nothing [KindModule, KindRecipe]) mixed-      map (.entryName) result `shouldBe` ["mod-a", "rec-a", "mod-b"]+      map (^. #name) result `shouldBe` ["mod-a", "rec-a", "mod-b"]      it "combines kind and repo with AND" $ do       let result = applyFilters (ListFilter (Just "repo-x") Nothing [KindModule]) mixed-      map (.entryName) result `shouldBe` ["mod-b"]+      map (^. #name) result `shouldBe` ["mod-b"]      it "returns empty when kind matches nothing in the set" $ do-      let onlyRecipes = filter (\e -> e.entryKind == KindRecipe) mixed+      let onlyRecipes = filter (\e -> e ^. #kind == KindRecipe) mixed           result = applyFilters (ListFilter Nothing Nothing [KindBlueprint]) onlyRecipes       result `shouldBe` [] @@ -234,34 +236,34 @@     it "tags blueprint entries with [blueprint] in the source label" $ do       let dr =             DiscoveredRunnable-              { drName = "demo",-                drDescription = Just "A new seihou blueprint",-                drKind = KindBlueprint,-                drSource = SourceProject,-                drDir = "/fake/demo",-                drIsError = False,-                drError = Nothing+              { name = "demo",+                description = Just "A new seihou blueprint",+                kind = KindBlueprint,+                source = SourceProject,+                dir = "/fake/demo",+                isError = False,+                error = Nothing               }           entry = runnableToEntryWithOrigin Map.empty dr-      entry.entrySource `shouldBe` "project [blueprint]"-      entry.entryName `shouldBe` "demo"-      entry.entryIsError `shouldBe` False-      entry.entryKind `shouldBe` KindBlueprint+      (entry ^. #source) `shouldBe` "project [blueprint]"+      (entry ^. #name) `shouldBe` "demo"+      (entry ^. #isError) `shouldBe` False+      (entry ^. #kind) `shouldBe` KindBlueprint    describe "runnableToEntryWithOrigin (prompt)" $ do     it "tags prompt entries with [prompt] in the source label" $ do       let dr =             DiscoveredRunnable-              { drName = "review",-                drDescription = Just "Review current changes",-                drKind = KindPrompt,-                drSource = SourceProject,-                drDir = "/fake/review",-                drIsError = False,-                drError = Nothing+              { name = "review",+                description = Just "Review current changes",+                kind = KindPrompt,+                source = SourceProject,+                dir = "/fake/review",+                isError = False,+                error = Nothing               }           entry = runnableToEntryWithOrigin Map.empty dr-      entry.entrySource `shouldBe` "project [prompt]"-      entry.entryName `shouldBe` "review"-      entry.entryIsError `shouldBe` False-      entry.entryKind `shouldBe` KindPrompt+      (entry ^. #source) `shouldBe` "project [prompt]"+      (entry ^. #name) `shouldBe` "review"+      (entry ^. #isError) `shouldBe` False+      (entry ^. #kind) `shouldBe` KindPrompt
+ test/Seihou/CLI/ManifestGuardSpec.hs view
@@ -0,0 +1,183 @@+module Seihou.CLI.ManifestGuardSpec (tests) where++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Seihou.CLI.ManifestGuard+  ( ArtifactCheck (..),+    ArtifactVerdict (..),+    blockingChecks,+    formatGuardRefusal,+    judgeArtifact,+    summarizeCheck,+  )+import Seihou.Core.ArtifactRef (ArtifactRefError (..))+import Seihou.Core.Types+  ( ArtifactOrigin (..),+    ModuleName (..),+  )+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "Seihou.CLI.ManifestGuard" spec++demoUrl :: Text+demoUrl = "https://example.com/demo-modules.git"++otherUrl :: Text+otherUrl = "https://example.com/other-modules.git"++remote :: Text -> ArtifactOrigin+remote url = RemoteOrigin url "demo" (Just "demo-modules")++check :: ArtifactOrigin -> ArtifactVerdict -> ArtifactCheck+check origin verdict =+  ArtifactCheck {name = ModuleName "demo", origin = origin, verdict = verdict}++spec :: Spec+spec = do+  describe "judgeArtifact version comparison" $ do+    it "reports a strictly older local copy as stale" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) (Just "1.4.0")+        `shouldBe` ArtifactStale "2.0.0" "1.4.0"++    it "accepts a newer local copy without comment" $+      judgeArtifact (remote demoUrl) (Just "1.4.0") (remote demoUrl) (Just "2.0.0")+        `shouldBe` ArtifactOk++    it "accepts an equal local copy" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) (Just "2.0.0")+        `shouldBe` ArtifactOk++    it "pads shorter versions with zeros, so 1.4 and 1.4.0 are equal" $+      judgeArtifact (remote demoUrl) (Just "1.4") (remote demoUrl) (Just "1.4.0")+        `shouldBe` ArtifactOk++    it "refuses to order a missing recorded version" $+      judgeArtifact (remote demoUrl) Nothing (remote demoUrl) (Just "1.4.0")+        `shouldBe` ArtifactVersionIncomparable Nothing (Just "1.4.0")++    it "refuses to order a missing local version" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (remote demoUrl) Nothing+        `shouldBe` ArtifactVersionIncomparable (Just "2.0.0") Nothing++    it "refuses to order a non-numeric version rather than guessing" $+      judgeArtifact (remote demoUrl) (Just "1.0.0-rc1") (remote demoUrl) (Just "1.0.0")+        `shouldBe` ArtifactVersionIncomparable (Just "1.0.0-rc1") (Just "1.0.0")++  describe "judgeArtifact identity comparison" $ do+    it "reports a differing origin URL as a mismatch" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (remote otherUrl) (Just "2.0.0")+        `shouldBe` ArtifactOriginMismatch (remote demoUrl) (remote otherUrl)++    it "prefers the mismatch over a version difference" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (remote otherUrl) (Just "1.4.0")+        `shouldBe` ArtifactOriginMismatch (remote demoUrl) (remote otherUrl)++    it "treats a trailing .git as the same repository" $+      judgeArtifact+        (remote "https://example.com/demo-modules")+        (Just "2.0.0")+        (remote "https://example.com/demo-modules.git")+        (Just "2.0.0")+        `shouldBe` ArtifactOk++    it "treats a trailing slash as the same repository" $+      judgeArtifact+        (remote "https://example.com/demo-modules.git")+        (Just "2.0.0")+        (remote "https://example.com/demo-modules/")+        (Just "2.0.0")+        `shouldBe` ArtifactOk++    it "reports a recorded LocalOrigin as unverifiable when versions agree" $+      judgeArtifact (LocalOrigin "demo") (Just "2.0.0") (LocalOrigin "demo") (Just "2.0.0")+        `shouldBe` ArtifactUnverifiableOrigin++    it "still reports staleness under a recorded LocalOrigin" $+      judgeArtifact (LocalOrigin "demo") (Just "2.0.0") (LocalOrigin "demo") (Just "1.4.0")+        `shouldBe` ArtifactStale "2.0.0" "1.4.0"++    it "reports a remote artifact shadowed by an unprovenanced copy as unverifiable" $+      judgeArtifact (remote demoUrl) (Just "2.0.0") (LocalOrigin "demo") (Just "2.0.0")+        `shouldBe` ArtifactUnverifiableOrigin++    it "accepts a project artifact resolved at the recorded path" $+      judgeArtifact+        (ProjectOrigin ".seihou/modules/demo")+        (Just "2.0.0")+        (ProjectOrigin ".seihou/modules/demo")+        (Just "2.0.0")+        `shouldBe` ArtifactOk++    it "reports a project artifact resolved at a different path as a mismatch" $+      judgeArtifact+        (ProjectOrigin ".seihou/modules/demo")+        (Just "2.0.0")+        (ProjectOrigin "vendor/demo")+        (Just "2.0.0")+        `shouldBe` ArtifactOriginMismatch (ProjectOrigin ".seihou/modules/demo") (ProjectOrigin "vendor/demo")++  describe "blockingChecks" $ do+    it "selects exactly the three blocking verdicts" $ do+      let notFound = ArtifactNotFoundLocally (remote demoUrl) ["/nowhere/demo"]+          all' =+            [ check (remote demoUrl) ArtifactOk,+              check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0"),+              check (remote demoUrl) (ArtifactOriginMismatch (remote demoUrl) (remote otherUrl)),+              check (remote demoUrl) (ArtifactUnresolvable notFound),+              check (remote demoUrl) (ArtifactVersionIncomparable Nothing Nothing),+              check (remote demoUrl) ArtifactUnverifiableOrigin+            ]+      map (^. #verdict) (blockingChecks all')+        `shouldBe` [ ArtifactStale "2.0.0" "1.4.0",+                     ArtifactOriginMismatch (remote demoUrl) (remote otherUrl),+                     ArtifactUnresolvable notFound+                   ]++    it "returns nothing when every artifact is fine" $+      blockingChecks [check (remote demoUrl) ArtifactOk] `shouldBe` []++  describe "formatGuardRefusal" $ do+    it "names both versions, the origin, the remedy, and the escape hatch" $ do+      let message = formatGuardRefusal [check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0")]+      message `shouldSatisfy` T.isInfixOf "older than"+      message `shouldSatisfy` T.isInfixOf "2.0.0"+      message `shouldSatisfy` T.isInfixOf "1.4.0"+      message `shouldSatisfy` T.isInfixOf demoUrl+      message `shouldSatisfy` T.isInfixOf "seihou upgrade demo"+      message `shouldSatisfy` T.isInfixOf "--allow-downgrade"++    it "names both URLs on a mismatch and does not talk about versions" $ do+      let message =+            formatGuardRefusal+              [check (remote demoUrl) (ArtifactOriginMismatch (remote demoUrl) (remote otherUrl))]+      message `shouldSatisfy` T.isInfixOf demoUrl+      message `shouldSatisfy` T.isInfixOf otherUrl+      message `shouldSatisfy` T.isInfixOf "different source"+      message `shouldSatisfy` (not . T.isInfixOf "older than")++    it "embeds the resolver's own wording for an unresolvable artifact" $ do+      let notFound = ArtifactNotFoundLocally (remote demoUrl) ["/nowhere/demo"]+          message = formatGuardRefusal [check (remote demoUrl) (ArtifactUnresolvable notFound)]+      message `shouldSatisfy` T.isInfixOf "not"+      message `shouldSatisfy` T.isInfixOf "/nowhere/demo"+      message `shouldSatisfy` T.isInfixOf "seihou install"++    it "is empty when nothing blocks" $+      formatGuardRefusal [] `shouldBe` ""++  describe "summarizeCheck" $ do+    it "says nothing about a healthy artifact" $+      summarizeCheck (check (remote demoUrl) ArtifactOk) `shouldBe` Nothing++    it "reports a stale artifact on one line" $+      summarizeCheck (check (remote demoUrl) (ArtifactStale "2.0.0" "1.4.0"))+        `shouldSatisfy` maybe False (T.isInfixOf "seihou upgrade demo")++    it "reports an unverifiable artifact without implying a fault" $+      summarizeCheck (check (LocalOrigin "demo") ArtifactUnverifiableOrigin)+        `shouldSatisfy` maybe False (T.isInfixOf "cannot be verified")
+ test/Seihou/CLI/ManifestUpgradeSpec.hs view
@@ -0,0 +1,407 @@+module Seihou.CLI.ManifestUpgradeSpec (tests) where++import Control.Lens ((^.))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Vector qualified as V+import Seihou.CLI.ManifestGuard (ArtifactCheck (..), ArtifactVerdict (..))+import Seihou.CLI.ManifestUpgrade+  ( InferenceOutcome (..),+    LegacyManifest (..),+    LegacyRef (..),+    UpgradeReportEntry (..),+    UpgradeResult (..),+    applyUpgrade,+    formatUpgradeRefusal,+    formatUpgradeReport,+    inferOriginFromLegacyPath,+    readLegacyManifest,+  )+import Seihou.Core.ArtifactRef (ArtifactRefError (..))+import Seihou.Core.Types (ArtifactOrigin (..), Manifest (..), ModuleName (..))+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)+import Text.Read (readMaybe)++tests :: IO TestTree+tests = testSpec "Seihou.CLI.ManifestUpgrade" spec++fixturePath :: FilePath+fixturePath = "test/fixtures/legacy-manifest-v5.json"++-- | Every legacy reference the fixture contains, as+-- @(pointer, name, path, version, definition file)@.+expectedRefs :: [([String], String, FilePath, Maybe String, FilePath)]+expectedRefs =+  [ ( ["modules", "0", "source"],+      "haskell-base",+      "/Users/someone-else/.config/seihou/installed/haskell-base",+      Just "1.4.0",+      "module.dhall"+    ),+    ( ["modules", "1", "source"],+      "project-lint",+      "/Users/someone-else/work/myproject/.seihou/modules/project-lint",+      Just "0.2.0",+      "module.dhall"+    ),+    ( ["applications", "0", "targetSource"],+      "haskell-base",+      "/Users/someone-else/.config/seihou/installed/haskell-base",+      Just "1.4.0",+      "module.dhall"+    ),+    ( ["applications", "0", "instances", "0", "source"],+      "haskell-base",+      "/Users/someone-else/.config/seihou/installed/haskell-base",+      Just "1.4.0",+      "module.dhall"+    ),+    ( ["applications", "1", "targetSource"],+      "haskell-service",+      "/Users/someone-else/.config/seihou/installed/haskell-service",+      Just "3.1.0",+      "recipe.dhall"+    ),+    ( ["applications", "1", "instances", "0", "source"],+      "project-lint",+      "/Users/someone-else/work/myproject/.seihou/modules/project-lint",+      Just "0.2.0",+      "module.dhall"+    ),+    ( ["applications", "1", "instances", "1", "source"],+      "scratch-helper",+      "/Users/someone-else/.config/seihou/modules/scratch-helper",+      Nothing,+      "module.dhall"+    )+  ]++describeRef :: LegacyRef -> ([String], String, FilePath, Maybe String, FilePath)+describeRef ref =+  ( map T.unpack (ref ^. #jsonPointer),+    T.unpack (ref ^. #artifactName),+    ref ^. #legacyPath,+    fmap T.unpack (ref ^. #recordedVersion),+    ref ^. #definitionFile+  )++spec :: Spec+spec = do+  describe "readLegacyManifest" $ do+    it "finds every legacy reference in a schema-5 manifest, in document order" $ do+      bytes <- LBS.readFile fixturePath+      case readLegacyManifest bytes of+        Left err -> expectationFailure ("expected a legacy manifest, got: " <> err)+        Right Nothing -> expectationFailure "expected a legacy manifest, got 'nothing to do'"+        Right (Just legacy) -> do+          (legacy ^. #schemaVersion) `shouldBe` 5+          map describeRef (legacy ^. #refs) `shouldBe` expectedRefs++    it "reports nothing to do for a manifest already at the current schema version" $+      readLegacyManifest "{\"version\":6,\"modules\":[]}" `shouldBe` Right Nothing++    it "reports nothing to do for a manifest from a newer seihou" $+      readLegacyManifest "{\"version\":7,\"modules\":[]}" `shouldBe` Right Nothing++    it "rejects a document with no version field" $+      readLegacyManifest "{\"modules\":[]}"+        `shouldBe` Left "manifest has no 'version' field"++  describe "schema versions 1 through 5" $+    -- Version 6's guard made these documents undecodable by the ordinary+    -- manifest decoder, so this is where their positive coverage now lives.+    -- Every field a later schema version added is optional with an empty+    -- default and none of them holds a path, so all five convert identically.+    it "converts every pre-portable-origin schema version the same way" $+      mapM_ convertsCleanly [1 .. 5]++  describe "inferOriginFromLegacyPath" $ do+    it "converts a foreign project path by its .seihou/modules suffix" $ do+      outcome <-+        inferOriginFromLegacyPath+          "/nowhere/this-project"+          []+          (legacyRef "demo" "/Users/someone-else/work/theirproject/.seihou/modules/demo")+      outcome `shouldBe` InferredFromProjectPath (ProjectOrigin ".seihou/modules/demo")++    it "recovers the upstream URL from a locally installed copy" $+      withInstall (Just originJson) $ \projectRoot installRoot -> do+        outcome <-+          inferOriginFromLegacyPath+            projectRoot+            [installRoot]+            (legacyRef "demo" "/Users/someone-else/.config/seihou/installed/demo")+        outcome+          `shouldBe` InferredFromLocalInstall+            (RemoteOrigin "https://example.com/demo-modules.git" "demo" (Just "demo-modules"))++    it "falls back to an unverifiable local origin when nothing is installed here" $+      withSystemTempDirectory "seihou-upgrade" $ \root -> do+        let projectRoot = root </> "project"+            installRoot = root </> "home" </> "seihou" </> "installed"+        createDirectoryIfMissing True projectRoot+        createDirectoryIfMissing True installRoot+        outcome <-+          inferOriginFromLegacyPath+            projectRoot+            [installRoot]+            (legacyRef "demo" "/Users/someone-else/.config/seihou/installed/demo")+        outcome `shouldBe` InferredAsUnverifiable (LocalOrigin "demo")++    it "reports an installed copy with no recorded provenance as unverifiable" $+      withInstall Nothing $ \projectRoot installRoot -> do+        outcome <-+          inferOriginFromLegacyPath+            projectRoot+            [installRoot]+            (legacyRef "demo" "/Users/someone-else/.config/seihou/modules/demo")+        outcome `shouldBe` InferredAsUnverifiable (LocalOrigin "demo")++  describe "applyUpgrade" $ do+    it "replaces every recorded path with its origin and bumps the schema version" $ do+      result <- upgradedFixture+      let document = result ^. #upgradedDocument+      (result ^. #fromVersion) `shouldBe` 5+      documentKeys document `shouldNotContain` ["source"]+      documentKeys document `shouldNotContain` ["targetSource"]+      documentKeys document `shouldContain` ["origin"]+      documentKeys document `shouldContain` ["targetOrigin"]+      lookupPath ["version"] document `shouldBe` Just (Aeson.Number 6)+      lookupPath ["modules", "0", "origin"] document+        `shouldBe` Just (Aeson.toJSON (RemoteOrigin haskellBaseUrl "haskell-base" (Just "seihou-modules")))+      lookupPath ["applications", "1", "instances", "0", "origin"] document+        `shouldBe` Just (Aeson.toJSON (ProjectOrigin ".seihou/modules/project-lint"))++    it "leaves no machine-specific path anywhere in the document" $ do+      result <- upgradedFixture+      -- The invariant of docs/adr/0001: nothing whose meaning depends on the+      -- machine that wrote it. A variable whose *value* happens to name the+      -- other developer is data, not a path, and must survive.+      filter absoluteLooking (documentStrings (result ^. #upgradedDocument))+        `shouldBe` []++    it "preserves every field it does not convert" $ do+      result <- upgradedFixture+      let document = result ^. #upgradedDocument+      lookupPath ["variables", "project.author"] document+        `shouldBe` Just (Aeson.String "someone-else")+      lookupPath ["modules", "0", "parentVars", "project.name"] document+        `shouldBe` Just (Aeson.String "demo")+      lookupPath ["files", "flake.nix", "baseline"] document+        `shouldBe` Just (Aeson.String (T.replicate 64 "2"))+      lookupPath ["blueprintMigrations", "0", "agentSessionId"] document+        `shouldBe` Just (Aeson.String "session-abc")+      lookupPath ["blueprint", "userPrompt"] document+        `shouldBe` Just (Aeson.String "build a service")+      lookupPath+        ["applications", "0", "commandReceipts", T.replicate 64 "4", "command"]+        document+        `shouldBe` Just (Aeson.String "cabal build")++    it "produces a document the ordinary manifest decoder accepts" $ do+      result <- upgradedFixture+      case Aeson.fromJSON (result ^. #upgradedDocument) :: Aeson.Result Manifest of+        Aeson.Error err -> expectationFailure ("upgraded manifest does not decode: " <> err)+        Aeson.Success manifest -> length (manifest ^. #modules) `shouldBe` 2++    it "reports each artifact once even though it appears in three records" $ do+      result <- upgradedFixture+      map (^. #artifactName) (result ^. #entries)+        `shouldBe` ["haskell-base", "project-lint", "haskell-service", "scratch-helper"]++  describe "formatUpgradeReport" $+    it "renders one aligned block per conversion" $+      formatUpgradeReport exampleResult `shouldBe` exampleReport++  describe "formatUpgradeRefusal" $ do+    it "names every blocking artifact and the two ways forward" $ do+      let refusal = formatUpgradeRefusal "✗ Refusing to write .seihou/manifest.json." [missingDemo]+      refusal `shouldSatisfy` T.isInfixOf "✗ Refusing to write .seihou/manifest.json."+      refusal `shouldSatisfy` T.isInfixOf "demo: recorded in the manifest but not installed on this machine"+      refusal `shouldSatisfy` T.isInfixOf "Install or upgrade the artifacts above and run this again"+      refusal `shouldSatisfy` T.isInfixOf "--force"++    it "does not offer --allow-downgrade, which is not a flag on this command" $+      formatUpgradeRefusal "✗" [missingDemo] `shouldSatisfy` (not . T.isInfixOf "--allow-downgrade")++-- | A recorded artifact that is not installed on this machine — the verdict+-- an upgrade run on a fresh clone hits most often.+missingDemo :: ArtifactCheck+missingDemo =+  ArtifactCheck+    { name = ModuleName "demo",+      origin = LocalOrigin "demo",+      verdict = ArtifactUnresolvable (ArtifactNotFoundLocally (LocalOrigin "demo") [])+    }++haskellBaseUrl :: Text+haskellBaseUrl = "https://github.com/shinzui/seihou-modules.git"++-- | A manifest at one of the historical schema versions, carrying only the+-- keys that version is guaranteed to have.+schemaVersionDocument :: Int -> LBS.ByteString+schemaVersionDocument version =+  LBS.fromStrict . TE.encodeUtf8 . T.concat $+    [ "{\"version\":",+      T.pack (show version),+      ",\"generatedAt\":\"2026-07-01T12:00:00Z\"",+      ",\"modules\":[{\"name\":\"demo\"",+      ",\"source\":\"/Users/someone-else/.config/seihou/installed/demo\"",+      ",\"version\":\"1.0.0\",\"appliedAt\":\"2026-07-01T12:00:00Z\"}]",+      ",\"variables\":{},\"files\":{}}"+    ]++-- | One historical schema version reads, converts, and lands on version 6+-- with a portable origin in place of the recorded path.+convertsCleanly :: Int -> Expectation+convertsCleanly version =+  case readLegacyManifest (schemaVersionDocument version) of+    Left err -> expectationFailure ("schema version " <> show version <> " did not read: " <> err)+    Right Nothing -> expectationFailure ("schema version " <> show version <> " reported nothing to do")+    Right (Just legacy) -> do+      (legacy ^. #schemaVersion) `shouldBe` version+      let converted =+            applyUpgrade+              legacy+              [(ref, InferredAsUnverifiable (LocalOrigin "demo")) | ref <- legacy ^. #refs]+          document = converted ^. #upgradedDocument+      lookupPath ["version"] document `shouldBe` Just (Aeson.Number 6)+      lookupPath ["modules", "0", "origin"] document+        `shouldBe` Just (Aeson.toJSON (LocalOrigin "demo"))+      lookupPath ["modules", "0", "version"] document `shouldBe` Just (Aeson.String "1.0.0")+      filter absoluteLooking (documentStrings document) `shouldBe` []++-- | The fixture, converted with a fixed inference for each artifact so the+-- assertions are about the rewrite rather than about this machine.+upgradedFixture :: IO UpgradeResult+upgradedFixture = do+  bytes <- LBS.readFile fixturePath+  case readLegacyManifest bytes of+    Right (Just legacy) ->+      pure (applyUpgrade legacy [(ref, inferenceFor ref) | ref <- legacy ^. #refs])+    other -> fail ("fixture did not read as a legacy manifest: " <> show (fmap (fmap (^. #schemaVersion)) other))+  where+    inferenceFor ref = case ref ^. #artifactName of+      "project-lint" -> InferredFromProjectPath (ProjectOrigin ".seihou/modules/project-lint")+      "scratch-helper" -> InferredAsUnverifiable (LocalOrigin "scratch-helper")+      name -> InferredFromLocalInstall (RemoteOrigin haskellBaseUrl name (Just "seihou-modules"))++exampleResult :: UpgradeResult+exampleResult =+  UpgradeResult+    { fromVersion = 5,+      entries =+        [ UpgradeReportEntry+            { artifactName = "haskell-base",+              legacyPath = "/Users/shinzui/.config/seihou/installed/haskell-base",+              outcome =+                InferredFromLocalInstall (RemoteOrigin haskellBaseUrl "haskell-base" (Just "seihou-modules"))+            },+          UpgradeReportEntry+            { artifactName = "project-lint",+              legacyPath = "/Users/shinzui/work/myproject/.seihou/modules/project-lint",+              outcome = InferredFromProjectPath (ProjectOrigin ".seihou/modules/project-lint")+            },+          UpgradeReportEntry+            { artifactName = "scratch-helper",+              legacyPath = "/Users/other/.config/seihou/modules/scratch-helper",+              outcome = InferredAsUnverifiable (LocalOrigin "scratch-helper")+            }+        ],+      upgradedDocument = Aeson.Null+    }++exampleReport :: Text+exampleReport =+  T.unlines+    [ "Reading .seihou/manifest.json (schema version 5)",+      "",+      "  haskell-base       /Users/shinzui/.config/seihou/installed/haskell-base",+      "                  →  remote https://github.com/shinzui/seihou-modules.git",+      "",+      "  project-lint       /Users/shinzui/work/myproject/.seihou/modules/project-lint",+      "                  →  project .seihou/modules/project-lint",+      "",+      "  scratch-helper     /Users/other/.config/seihou/modules/scratch-helper",+      "                  →  local scratch-helper  (no upstream recorded)",+      ""+    ]++-- | Every object key appearing anywhere in a document.+documentKeys :: Aeson.Value -> [Text]+documentKeys (Aeson.Object fields) =+  map Key.toText (KeyMap.keys fields) <> concatMap documentKeys (KeyMap.elems fields)+documentKeys (Aeson.Array elements) = concatMap documentKeys elements+documentKeys _ = []++-- | Whether a string looks like a path that only means something on the+-- machine that wrote it.+absoluteLooking :: Text -> Bool+absoluteLooking value =+  T.isPrefixOf "/" value+    || T.isPrefixOf "~" value+    || T.isPrefixOf "\\\\" value+    || (T.length value >= 3 && T.index value 1 == ':' && T.index value 2 == '\\')++-- | Every string value appearing anywhere in a document.+documentStrings :: Aeson.Value -> [Text]+documentStrings (Aeson.String text) = [text]+documentStrings (Aeson.Object fields) = concatMap documentStrings (KeyMap.elems fields)+documentStrings (Aeson.Array elements) = concatMap documentStrings elements+documentStrings _ = []++-- | Follow a pointer of object keys and array indices.+lookupPath :: [Text] -> Aeson.Value -> Maybe Aeson.Value+lookupPath [] value = Just value+lookupPath (step : rest) (Aeson.Object fields) =+  KeyMap.lookup (Key.fromText step) fields >>= lookupPath rest+lookupPath (step : rest) (Aeson.Array elements) = do+  index <- readMaybe (T.unpack step)+  element <- elements V.!? index+  lookupPath rest element+lookupPath _ _ = Nothing++-- | A reference to a module, which is all the inference tests need.+legacyRef :: Text -> FilePath -> LegacyRef+legacyRef name path =+  LegacyRef+    { jsonPointer = ["modules", "0", "source"],+      artifactName = name,+      legacyPath = path,+      recordedVersion = Just "1.0.0",+      definitionFile = "module.dhall"+    }++originJson :: String+originJson =+  "{\"sourceUrl\":\"https://example.com/demo-modules.git\"\+  \,\"repoName\":\"demo-modules\"\+  \,\"installedAt\":\"2026-07-01T00:00:00Z\"\+  \,\"version\":\"1.0.0\",\"tags\":[]}"++-- | A project root plus a search path holding an installed @demo@, with or+-- without the @.seihou-origin.json@ that records where it came from.+withInstall :: Maybe String -> (FilePath -> FilePath -> IO a) -> IO a+withInstall mOriginJson action =+  withSystemTempDirectory "seihou-upgrade" $ \root -> do+    let projectRoot = root </> "project"+        installRoot = root </> "home" </> "seihou" </> "installed"+        artifactDir = installRoot </> "demo"+    createDirectoryIfMissing True projectRoot+    createDirectoryIfMissing True artifactDir+    writeFile (artifactDir </> "module.dhall") "{ name = \"demo\" }"+    case mOriginJson of+      Nothing -> pure ()+      Just contents -> writeFile (artifactDir </> ".seihou-origin.json") contents+    action projectRoot installRoot
test/Seihou/CLI/MigrateSpec.hs view
@@ -1,14 +1,17 @@ module Seihou.CLI.MigrateSpec (tests) where  import Control.Exception (bracket_)+import Control.Lens (to, (&), (.~), (?~), (^.)) import Data.Aeson (encode, object, (.=)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () 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 Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError) import Effectful (runEff)+import GHC.Generics (Generic) import Seihou.CLI.Migrate   ( MigrateError (..),     MigrateOpts (..),@@ -19,6 +22,7 @@ import Seihou.Core.Migration (MigrationPlan (..)) import Seihou.Core.Types   ( AppliedModule (..),+    ArtifactOrigin (..),     FileRecord (..),     Manifest (..),     ModuleName (..),@@ -112,44 +116,22 @@ mkManifest :: Text -> FilePath -> [(FilePath, Text)] -> Manifest mkManifest version installedDir entries =   (emptyManifest fixedTime)-    { modules =-        [ AppliedModule-            { name = modName,-              parentVars = emptyParentVars,-              source = installedDir,-              moduleVersion = Just version,-              appliedAt = fixedTime,-              removal = Nothing-            }-        ],-      files =-        Map.fromList-          [ ( path,-              FileRecord-                { hash = hashContent content,-                  moduleName = modName,-                  strategy = Template,-                  generatedAt = fixedTime,-                  baseline = Nothing,-                  applicationIds = mempty-                }-            )-          | (path, content) <- entries-          ]-    }+    & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin (modName ^. #unModuleName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}]+    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = modName, strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries]  defaultOpts :: MigrateOpts defaultOpts =   MigrateOpts-    { migrateModule = modName,-      migrateTo = Nothing,-      migrateDryRun = False,-      migrateForce = False,-      migrateJson = False,-      migrateVerbose = False,-      migrateNoFetch = True,-      migrateCommit = False,-      migrateCommitMessage = Nothing+    { module_ = modName,+      to = Nothing,+      dryRun = False,+      force = False,+      json = False,+      verbose = False,+      noFetch = True,+      commit = False,+      commitMessage = Nothing,+      allowDowngrade = False     }  -- ----------------------------------------------------------------------------@@ -157,11 +139,12 @@ -- ----------------------------------------------------------------------------  data FetchFixture = FetchFixture-  { modName :: Text,-    remoteDir :: FilePath,-    installedDir :: FilePath,-    projectDir :: FilePath+  { modName :: !Text,+    remoteDir :: !FilePath,+    installedDir :: !FilePath,+    projectDir :: !FilePath   }+  deriving stock (Generic)  withFetchFixture :: Text -> Text -> Text -> (FetchFixture -> IO ()) -> IO () withFetchFixture installedVer remoteVer migrationsLit action =@@ -254,31 +237,8 @@ mkManifestAt :: FetchFixture -> Text -> [(FilePath, Text)] -> Manifest mkManifestAt fix version entries =   (emptyManifest fixedTime)-    { modules =-        [ AppliedModule-            { name = ModuleName fix.modName,-              parentVars = emptyParentVars,-              source = fix.installedDir,-              moduleVersion = Just version,-              appliedAt = fixedTime,-              removal = Nothing-            }-        ],-      files =-        Map.fromList-          [ ( path,-              FileRecord-                { hash = hashContent content,-                  moduleName = ModuleName fix.modName,-                  strategy = Template,-                  generatedAt = fixedTime,-                  baseline = Nothing,-                  applicationIds = mempty-                }-            )-          | (path, content) <- entries-          ]-    }+    & #modules .~ [AppliedModule {name = ModuleName (fix ^. #modName), parentVars = emptyParentVars, origin = LocalOrigin (fix ^. #modName), moduleVersion = Just version, appliedAt = fixedTime, removal = Nothing}]+    & #files .~ Map.fromList [(path, FileRecord {hash = hashContent content, moduleName = ModuleName (fix ^. #modName), strategy = Template, generatedAt = fixedTime, baseline = Nothing, applicationIds = mempty}) | (path, content) <- entries]  withSavedEnv :: String -> Maybe String -> IO () -> IO () withSavedEnv key newVal action = do@@ -302,7 +262,7 @@       withSystemTempDirectory "seihou-migrate-cli" $ \dir -> do         let installed = dir </> "installed-demo"         writeInstalledModule installed "2.0.0" emptyMigrationsLit-        let manifest = (emptyManifest fixedTime) {modules = []}+        let manifest = ((emptyManifest fixedTime) & #modules .~ [])         result <-           withCurrentDirectory dir $             runMigrate defaultOpts manifest installed@@ -315,18 +275,9 @@         let installed = dir </> "installed-demo"         writeInstalledModule installed "2.0.0" emptyMigrationsLit         let manifest =-              (emptyManifest fixedTime)-                { modules =-                    [ AppliedModule-                        { name = modName,-                          parentVars = emptyParentVars,-                          source = installed,-                          moduleVersion = Nothing,-                          appliedAt = fixedTime,-                          removal = Nothing-                        }-                    ]-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [AppliedModule {name = modName, parentVars = emptyParentVars, origin = LocalOrigin (modName ^. #unModuleName), moduleVersion = Nothing, appliedAt = fixedTime, removal = Nothing}]+              )         result <-           withCurrentDirectory dir $             runMigrate defaultOpts manifest installed@@ -353,7 +304,7 @@         createDirectoryIfMissing True (dir </> "app")         TIO.writeFile (dir </> "app" </> "Main.hs") "module Main where"         let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")]-            opts = defaultOpts {migrateDryRun = True}+            opts = (defaultOpts & #dryRun .~ True)         result <-           withCurrentDirectory dir $             runMigrate opts manifest installed@@ -377,9 +328,9 @@           Right (MigrateApplied _plan manifest' fromV toV) -> do             renderVersion fromV `shouldBe` "1.0.0"             renderVersion toV `shouldBe` "2.0.0"-            Map.member "src/Main.hs" manifest'.files `shouldBe` True-            Map.member "app/Main.hs" manifest'.files `shouldBe` False-            (head manifest'.modules).moduleVersion `shouldBe` Just "2.0.0"+            Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True+            Map.member "app/Main.hs" (manifest' ^. #files) `shouldBe` False+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "2.0.0"             doesFileExist (dir </> "src" </> "Main.hs") `shouldReturn` True             doesFileExist (dir </> "app" </> "Main.hs") `shouldReturn` False           other -> expectationFailure ("expected MigrateApplied, got: " <> show other)@@ -406,7 +357,7 @@         createDirectoryIfMissing True (dir </> "app")         TIO.writeFile (dir </> "app" </> "Main.hs") "user-edited"         let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "original")]-            opts = defaultOpts {migrateForce = True}+            opts = (defaultOpts & #force .~ True)         result <-           withCurrentDirectory dir $             runMigrate opts manifest installed@@ -414,7 +365,7 @@           Right (MigrateApplied _ manifest' _ _) -> do             doesFileExist (dir </> "src" </> "Main.hs") `shouldReturn` True             doesFileExist (dir </> "app" </> "Main.hs") `shouldReturn` False-            Map.member "src/Main.hs" manifest'.files `shouldBe` True+            Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True           other -> expectationFailure ("expected MigrateApplied, got: " <> show other)      -- ------------------------------------------------------------------@@ -423,22 +374,22 @@     -- ------------------------------------------------------------------     it "fetches a newer remote, refreshes the installed copy, and applies the chain" $       withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do-        TIO.writeFile (fix.projectDir </> "old.txt") "x"+        TIO.writeFile (fix ^. #projectDir </> "old.txt") "x"         let manifest = mkManifestAt fix "1.0.0" [("old.txt", "x")]-            opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName}+            opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName)         result <--          withCurrentDirectory fix.projectDir $-            runMigrate opts manifest fix.installedDir+          withCurrentDirectory (fix ^. #projectDir) $+            runMigrate opts manifest (fix ^. #installedDir)         case result of           Right (MigrateApplied _ manifest' _ _) -> do-            doesFileExist (fix.projectDir </> "old.txt") `shouldReturn` False-            doesFileExist (fix.projectDir </> "new.txt") `shouldReturn` True-            case manifest'.modules of-              (am : _) -> am.moduleVersion `shouldBe` Just "2.0.0"+            doesFileExist (fix ^. #projectDir </> "old.txt") `shouldReturn` False+            doesFileExist (fix ^. #projectDir </> "new.txt") `shouldReturn` True+            case manifest' ^. #modules of+              (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "2.0.0"               [] -> expectationFailure "manifest has no modules"-            Map.member "new.txt" manifest'.files `shouldBe` True-            Map.member "old.txt" manifest'.files `shouldBe` False-            installedBody <- TIO.readFile (fix.installedDir </> "module.dhall")+            Map.member "new.txt" (manifest' ^. #files) `shouldBe` True+            Map.member "old.txt" (manifest' ^. #files) `shouldBe` False+            installedBody <- TIO.readFile (fix ^. #installedDir </> "module.dhall")             T.isInfixOf "2.0.0" installedBody `shouldBe` True           other ->             expectationFailure ("expected MigrateApplied, got: " <> show other)@@ -446,10 +397,10 @@     it "is a no-op when the remote and installed versions match" $       withFetchFixture "1.0.0" "1.0.0" emptyMigrationsLit $ \fix -> do         let manifest = mkManifestAt fix "1.0.0" []-            opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName}+            opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName)         result <--          withCurrentDirectory fix.projectDir $-            runMigrate opts manifest fix.installedDir+          withCurrentDirectory (fix ^. #projectDir) $+            runMigrate opts manifest (fix ^. #installedDir)         case result of           Right (MigrateNoOp _) -> pure ()           other -> expectationFailure ("expected MigrateNoOp, got: " <> show other)@@ -457,10 +408,10 @@     it "ignores a newer remote when --no-fetch is set" $       withFetchFixture "1.0.0" "2.0.0" moveOldToNewLit $ \fix -> do         let manifest = mkManifestAt fix "1.0.0" []-            opts = (defaultOpts {migrateNoFetch = True}) {migrateModule = ModuleName fix.modName}+            opts = defaultOpts & #noFetch .~ True & #module_ .~ ModuleName (fix ^. #modName)         result <--          withCurrentDirectory fix.projectDir $-            runMigrate opts manifest fix.installedDir+          withCurrentDirectory (fix ^. #projectDir) $+            runMigrate opts manifest (fix ^. #installedDir)         case result of           Right (MigrateNoOp _) -> pure ()           other -> expectationFailure ("expected MigrateNoOp, got: " <> show other)@@ -487,16 +438,16 @@         writeInstalledModule installed "2.0.0" twoStepLit         TIO.writeFile (dir </> "a.txt") "x"         let manifest = mkManifest "1.0.0" installed [("a.txt", "x")]-            opts = defaultOpts {migrateTo = Just "1.5.0"}+            opts = defaultOpts & #to .~ Just "1.5.0"         result <-           withCurrentDirectory dir $             runMigrate opts manifest installed         case result of           Right (MigrateApplied _ manifest' _ toV) -> do             renderVersion toV `shouldBe` "1.5.0"-            Map.member "b.txt" manifest'.files `shouldBe` True-            Map.member "c.txt" manifest'.files `shouldBe` False-            (head manifest'.modules).moduleVersion `shouldBe` Just "1.5.0"+            Map.member "b.txt" (manifest' ^. #files) `shouldBe` True+            Map.member "c.txt" (manifest' ^. #files) `shouldBe` False+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "1.5.0"             doesFileExist (dir </> "b.txt") `shouldReturn` True             doesFileExist (dir </> "c.txt") `shouldReturn` False           other -> expectationFailure ("expected MigrateApplied, got: " <> show other)@@ -528,9 +479,9 @@           Right (MigrateApplied _ manifest' fromV toV) -> do             renderVersion fromV `shouldBe` "1.0.0"             renderVersion toV `shouldBe` "3.0.0"-            (head manifest'.modules).moduleVersion `shouldBe` Just "3.0.0"-            Map.member "src/Main.hs" manifest'.files `shouldBe` True-            Map.member "app/Main.hs" manifest'.files `shouldBe` False+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "3.0.0"+            Map.member "src/Main.hs" (manifest' ^. #files) `shouldBe` True+            Map.member "app/Main.hs" (manifest' ^. #files) `shouldBe` False             doesFileExist (dir </> "src" </> "Main.hs") `shouldReturn` True             doesFileExist (dir </> "app" </> "Main.hs") `shouldReturn` False           other ->@@ -547,8 +498,8 @@         case result of           Right (MigrateApplied execPlan manifest' _ toV) -> do             renderVersion toV `shouldBe` "0.3.0"-            null execPlan.planSource.planSteps `shouldBe` True-            (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0"+            null (execPlan ^. #source . #steps) `shouldBe` True+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.3.0"           other -> expectationFailure ("expected MigrateApplied (pure bump), got: " <> show other)      it "Scenario C: orphan-edge entirely outside the window also lands the manifest at target" $@@ -573,8 +524,8 @@         case result of           Right (MigrateApplied execPlan manifest' _ toV) -> do             renderVersion toV `shouldBe` "0.3.0"-            null execPlan.planSource.planSteps `shouldBe` True-            (head manifest'.modules).moduleVersion `shouldBe` Just "0.3.0"+            null (execPlan ^. #source . #steps) `shouldBe` True+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.3.0"           other -> expectationFailure ("expected MigrateApplied (orphan-edge skip), got: " <> show other)      it "User's two-component fixture: 0.2 -> 0.6 with [{0.2->0.3}, {0.5->0.6}]" $@@ -609,8 +560,8 @@         case result of           Right (MigrateApplied execPlan manifest' _ toV) -> do             renderVersion toV `shouldBe` "0.6"-            length execPlan.planSource.planSteps `shouldBe` 2-            (head manifest'.modules).moduleVersion `shouldBe` Just "0.6"+            length (execPlan ^. #source . #steps) `shouldBe` 2+            ((head (manifest' ^. #modules)) ^. #moduleVersion) `shouldBe` Just "0.6"             doesFileExist (dir </> "v3.txt") `shouldReturn` True             doesFileExist (dir </> "v6.txt") `shouldReturn` True             doesFileExist (dir </> "v2.txt") `shouldReturn` False@@ -630,10 +581,10 @@         TIO.writeFile (dir </> "app" </> "Main.hs") "module Main where"         let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")]             opts =-              defaultOpts-                { migrateCommit = True,-                  migrateCommitMessage = Just "chore: migrate"-                }+              ( defaultOpts+                  & #commit .~ True+                  & #commitMessage ?~ "chore: migrate"+              )         withCurrentDirectory dir $ do           createDirectoryIfMissing True (dir </> ".seihou")           runEff $@@ -673,7 +624,7 @@         createDirectoryIfMissing True (dir </> "app")         TIO.writeFile (dir </> "app" </> "Main.hs") "module Main where"         let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")]-            opts = defaultOpts {migrateCommitMessage = Just "chore: migrate"}+            opts = (defaultOpts & #commitMessage ?~ "chore: migrate")         withCurrentDirectory dir $ do           createDirectoryIfMissing True (dir </> ".seihou")           result <- runMigrate opts manifest installed@@ -697,11 +648,11 @@         TIO.writeFile (dir </> "app" </> "Main.hs") "module Main where"         let manifest = mkManifest "1.0.0" installed [("app/Main.hs", "module Main where")]             opts =-              defaultOpts-                { migrateDryRun = True,-                  migrateCommit = True,-                  migrateCommitMessage = Just "chore: migrate"-                }+              ( defaultOpts+                  & #dryRun .~ True+                  & #commit .~ True+                  & #commitMessage ?~ "chore: migrate"+              )         withCurrentDirectory dir $ do           initProjectRepo dir           result <- runMigrate opts manifest installed@@ -733,23 +684,23 @@                 "]"               ]        in withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do-            writeInstalledModule fix.installedDir "0.3" partialLit-            writeOriginJson fix.installedDir (T.pack fix.remoteDir)-            TIO.writeFile (fix.projectDir </> "old.txt") "tracked\n"+            writeInstalledModule (fix ^. #installedDir) "0.3" partialLit+            writeOriginJson (fix ^. #installedDir) (T.pack (fix ^. #remoteDir))+            TIO.writeFile (fix ^. #projectDir </> "old.txt") "tracked\n"             let manifest = mkManifestAt fix "0.1" [("old.txt", "tracked\n")]-                opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName}+                opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName)             result <--              withCurrentDirectory fix.projectDir $-                runMigrate opts manifest fix.installedDir+              withCurrentDirectory (fix ^. #projectDir) $+                runMigrate opts manifest (fix ^. #installedDir)             case result of               Right (MigrateApplied execPlan manifest' _ toV) -> do                 renderVersion toV `shouldBe` "0.3"-                length execPlan.planSource.planSteps `shouldBe` 1-                case manifest'.modules of-                  (am : _) -> am.moduleVersion `shouldBe` Just "0.3"+                length (execPlan ^. #source . #steps) `shouldBe` 1+                case manifest' ^. #modules of+                  (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "0.3"                   [] -> expectationFailure "manifest has no modules"-                doesFileExist (fix.projectDir </> "new.txt") `shouldReturn` True-                doesFileExist (fix.projectDir </> "old.txt") `shouldReturn` False+                doesFileExist (fix ^. #projectDir </> "new.txt") `shouldReturn` True+                doesFileExist (fix ^. #projectDir </> "old.txt") `shouldReturn` False               other ->                 expectationFailure                   ("expected MigrateApplied (local fallback), got: " <> show other)@@ -757,16 +708,16 @@     it "fetch fallback: clone-based plan stands when neither side declares applicable edges" $       withFetchFixture "0.3" "0.3" emptyMigrationsLit $ \fix -> do         let manifest = mkManifestAt fix "0.1" []-            opts = (defaultOpts {migrateNoFetch = False}) {migrateModule = ModuleName fix.modName}+            opts = defaultOpts & #noFetch .~ False & #module_ .~ ModuleName (fix ^. #modName)         result <--          withCurrentDirectory fix.projectDir $-            runMigrate opts manifest fix.installedDir+          withCurrentDirectory (fix ^. #projectDir) $+            runMigrate opts manifest (fix ^. #installedDir)         case result of           Right (MigrateApplied execPlan manifest' _ toV) -> do             renderVersion toV `shouldBe` "0.3"-            null execPlan.planSource.planSteps `shouldBe` True-            case manifest'.modules of-              (am : _) -> am.moduleVersion `shouldBe` Just "0.3"+            null (execPlan ^. #source . #steps) `shouldBe` True+            case manifest' ^. #modules of+              (am : _) -> (am ^. #moduleVersion) `shouldBe` Just "0.3"               [] -> expectationFailure "manifest has no modules"           other ->             expectationFailure ("expected MigrateApplied (no-op-style bump), got: " <> show other)
test/Seihou/CLI/PendingMigrationSpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.PendingMigrationSpec (tests) where +import Control.Lens (to, (&), (.~), (^.))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text)@@ -18,6 +20,7 @@   ) import Seihou.Core.Types   ( AppliedModule (..),+    ArtifactOrigin (..),     Manifest (..),     Module (..),     ModuleName (..),@@ -25,7 +28,7 @@   ) import Seihou.Core.Version qualified import Seihou.Manifest.Types (emptyManifest)-import System.Directory (createDirectoryIfMissing)+import System.Directory (createDirectoryIfMissing, withCurrentDirectory) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec@@ -48,7 +51,7 @@   AppliedModule     { name = ModuleName "demo",       parentVars = emptyParentVars,-      source = "/installed/demo",+      origin = LocalOrigin "demo",       moduleVersion = mver,       appliedAt = fixedTime,       removal = Nothing@@ -107,17 +110,35 @@ emptyMigrationsLit =   "[] : List { from : Text, to : Text, ops : List < MoveFile : { src : Text, dest : Text } | MoveDir : { src : Text, dest : Text } | DeleteFile : { path : Text } | DeleteDir : { path : Text } | RunCommand : { run : Text, workDir : Optional Text } > }" -mkAppliedAt :: Text -> FilePath -> Maybe Text -> AppliedModule-mkAppliedAt name source mver =+-- | An applied module recorded the way the manifest records one: by portable+-- origin, not by path. Detection resolves the origin against the current+-- working directory, so the tests below plant modules under+-- @<project>/.seihou/modules/<name>@ and run inside that project.+mkAppliedAt :: Text -> Maybe Text -> AppliedModule+mkAppliedAt name mver =   AppliedModule     { name = ModuleName name,       parentVars = emptyParentVars,-      source = source,+      origin = ProjectOrigin (projectModulePath name),       moduleVersion = mver,       appliedAt = fixedTime,       removal = Nothing     } +-- | Where a project-origin module lives, relative to the project root.+projectModulePath :: Text -> FilePath+projectModulePath name = ".seihou/modules/" <> T.unpack name++-- | Plant a module inside a scratch project and run the body from the project+-- root, which is what @detectPendingMigrations@ resolves origins against.+withProjectModules :: [(Text, Text, Text)] -> IO a -> IO a+withProjectModules modules body =+  withSystemTempDirectory "seihou-pending-detect" $ \projectRoot -> do+    mapM_+      (\(name, version, migrationsLit) -> writeInstalledModule (projectRoot </> projectModulePath name) name version migrationsLit)+      modules+    withCurrentDirectory projectRoot body+ spec :: Spec spec = do   describe "pendingChainFor" $ do@@ -142,8 +163,8 @@           installed = mkInstalled (Just "2.0.0") [mig]       case pendingChainFor am installed of         Just plan -> do-          plan.planSteps `shouldBe` [mig]-          plan.planTo `shouldBe` parseV "2.0.0"+          (plan ^. #steps) `shouldBe` [mig]+          (plan ^. #to) `shouldBe` parseV "2.0.0"         Nothing -> expectationFailure "expected Just plan"      it "returns Nothing for downgrade (manifest > installed)" $ do@@ -154,16 +175,16 @@     it "returns a partial-cover plan when the chain reaches some intermediate version" $ do       -- master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0,       -- edges=[0.1.0 -> 0.2.0]. Under the gap-tolerant walker the plan-      -- always carries the supplied target as planTo, regardless of+      -- always carries the supplied target as to, regardless of       -- whether the steps reach it.       let am = mkApplied (Just "0.1.0")           mig = Migration "0.1.0" "0.2.0" [DeleteFile "x"]           installed = mkInstalled (Just "0.3.0") [mig]       case pendingChainFor am installed of         Just plan -> do-          plan.planSteps `shouldBe` [mig]-          plan.planFrom `shouldBe` parseV "0.1.0"-          plan.planTo `shouldBe` parseV "0.3.0"+          (plan ^. #steps) `shouldBe` [mig]+          (plan ^. #from) `shouldBe` parseV "0.1.0"+          (plan ^. #to) `shouldBe` parseV "0.3.0"         Nothing -> expectationFailure "expected Just plan with partial cover"      it "returns an empty-steps plan when no edge starts at the manifest version" $ do@@ -171,9 +192,9 @@           installed = mkInstalled (Just "0.3.0") []       case pendingChainFor am installed of         Just plan -> do-          plan.planSteps `shouldBe` []-          plan.planFrom `shouldBe` parseV "0.1.3"-          plan.planTo `shouldBe` parseV "0.3.0"+          (plan ^. #steps) `shouldBe` []+          (plan ^. #from) `shouldBe` parseV "0.1.3"+          (plan ^. #to) `shouldBe` parseV "0.3.0"         Nothing -> expectationFailure "expected Just plan with empty steps"      it "[] vs [orphanEdge] both yield empty-steps plans (window walker)" $ do@@ -186,89 +207,65 @@             mkInstalled (Just "0.3.0") [Migration "0.5.0" "0.6.0" []]       case (pendingChainFor am emptyInstalled, pendingChainFor am orphanInstalled) of         (Just pEmpty, Just pOrphan) -> do-          pEmpty.planSteps `shouldBe` []-          pOrphan.planSteps `shouldBe` []-          pEmpty.planFrom `shouldBe` pOrphan.planFrom-          pEmpty.planTo `shouldBe` pOrphan.planTo+          (pEmpty ^. #steps) `shouldBe` []+          (pOrphan ^. #steps) `shouldBe` []+          (pEmpty ^. #from) `shouldBe` (pOrphan ^. #from)+          (pEmpty ^. #to) `shouldBe` (pOrphan ^. #to)         other ->           expectationFailure             ("expected two Just plans, got: " <> show other)    describe "detectPendingMigrations" $ do     it "with Nothing filter, surfaces every applied module's pending plan" $-      withSystemTempDirectory "seihou-pending-detect" $ \dir -> do-        let aDir = dir </> "demo-a"-            bDir = dir </> "demo-b"-        writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit-        writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit+      withProjectModules [("demo-a", "2.0.0", moveOldToNewLit), ("demo-b", "2.0.0", moveOldToNewLit)] $ do         let manifest =-              (emptyManifest fixedTime)-                { modules =-                    [ mkAppliedAt "demo-a" aDir (Just "1.0.0"),-                      mkAppliedAt "demo-b" bDir (Just "1.0.0")-                    ],-                  files = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [mkAppliedAt "demo-a" (Just "1.0.0"), mkAppliedAt "demo-b" (Just "1.0.0")]+                  & #files .~ Map.empty+              )         result <- detectPendingMigrations manifest Nothing         map fst result `shouldMatchList` [ModuleName "demo-a", ModuleName "demo-b"]      it "with a Just filter, restricts detection to the named modules" $-      withSystemTempDirectory "seihou-pending-detect" $ \dir -> do-        let aDir = dir </> "demo-a"-            bDir = dir </> "demo-b"-        writeInstalledModule aDir "demo-a" "2.0.0" moveOldToNewLit-        writeInstalledModule bDir "demo-b" "2.0.0" moveOldToNewLit+      withProjectModules [("demo-a", "2.0.0", moveOldToNewLit), ("demo-b", "2.0.0", moveOldToNewLit)] $ do         let manifest =-              (emptyManifest fixedTime)-                { modules =-                    [ mkAppliedAt "demo-a" aDir (Just "1.0.0"),-                      mkAppliedAt "demo-b" bDir (Just "1.0.0")-                    ],-                  files = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [mkAppliedAt "demo-a" (Just "1.0.0"), mkAppliedAt "demo-b" (Just "1.0.0")]+                  & #files .~ Map.empty+              )         result <-           detectPendingMigrations             manifest             (Just (Set.singleton (ModuleName "demo-a")))         map fst result `shouldBe` [ModuleName "demo-a"] -    it "skips modules whose installed copy has no module.dhall" $-      withSystemTempDirectory "seihou-pending-detect" $ \dir -> do-        let bogus = dir </> "missing-installed"+    it "skips a module whose recorded origin does not resolve here" $+      withProjectModules [] $ do         let manifest =-              (emptyManifest fixedTime)-                { modules = [mkAppliedAt "demo" bogus (Just "1.0.0")],-                  files = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [mkAppliedAt "demo" (Just "1.0.0")]+                  & #files .~ Map.empty+              )         result <- detectPendingMigrations manifest Nothing         result `shouldBe` []      it "skips modules with no pending chain (manifest already at installed version)" $-      withSystemTempDirectory "seihou-pending-detect" $ \dir -> do-        let modDir = dir </> "demo"-        writeInstalledModule modDir "demo" "1.0.0" emptyMigrationsLit+      withProjectModules [("demo", "1.0.0", emptyMigrationsLit)] $ do         let manifest =-              (emptyManifest fixedTime)-                { modules = [mkAppliedAt "demo" modDir (Just "1.0.0")],-                  files = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [mkAppliedAt "demo" (Just "1.0.0")]+                  & #files .~ Map.empty+              )         result <- detectPendingMigrations manifest Nothing         result `shouldBe` []      it "with a filter selecting only no-chain modules, returns empty" $-      withSystemTempDirectory "seihou-pending-detect" $ \dir -> do-        let withChain = dir </> "with-chain"-            noChain = dir </> "no-chain"-        writeInstalledModule withChain "with-chain" "2.0.0" moveOldToNewLit-        writeInstalledModule noChain "no-chain" "1.0.0" emptyMigrationsLit+      withProjectModules [("with-chain", "2.0.0", moveOldToNewLit), ("no-chain", "1.0.0", emptyMigrationsLit)] $ do         let manifest =-              (emptyManifest fixedTime)-                { modules =-                    [ mkAppliedAt "with-chain" withChain (Just "1.0.0"),-                      mkAppliedAt "no-chain" noChain (Just "1.0.0")-                    ],-                  files = Map.empty-                }+              ( (emptyManifest fixedTime)+                  & #modules .~ [mkAppliedAt "with-chain" (Just "1.0.0"), mkAppliedAt "no-chain" (Just "1.0.0")]+                  & #files .~ Map.empty+              )         result <-           detectPendingMigrations             manifest@@ -279,10 +276,10 @@     it "lists each module's plan summary and the actionable next step" $ do       let plan =             MigrationPlan-              { planModule = "demo",-                planFrom = parseV "1.0.0",-                planTo = parseV "2.0.0",-                planSteps =+              { module_ = "demo",+                from = parseV "1.0.0",+                to = parseV "2.0.0",+                steps =                   [Migration "1.0.0" "2.0.0" [DeleteFile "Setup.hs"]]               }           msg = formatRefusalMessage [(ModuleName "demo", plan)]@@ -294,10 +291,10 @@     it "reports a 0-step pure version-bump entry without doomed vocabulary" $ do       let plan =             MigrationPlan-              { planModule = "demo",-                planFrom = parseV "0.2.0",-                planTo = parseV "0.3.0",-                planSteps = []+              { module_ = "demo",+                from = parseV "0.2.0",+                to = parseV "0.3.0",+                steps = []               }           msg = formatRefusalMessage [(ModuleName "demo", plan)]       msg `shouldSatisfy` T.isInfixOf "demo: 0.2.0 -> 0.3.0 (0 step(s))"
test/Seihou/CLI/Registry/SyncSpec.hs view
@@ -2,6 +2,8 @@  module Seihou.CLI.Registry.SyncSpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -38,9 +40,9 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = False,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = False,+                check = False               }         case outcome of           SyncFailure msg ->@@ -50,7 +52,7 @@         case reloaded of           Left err -> expectationFailure ("failed to reload: " <> show err)           Right reg -> do-            map (.version) reg.modules `shouldBe` [Just "2.0.0", Just "2.0.0"]+            map (^. #version) (reg ^. #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"]      it "leaves the file untouched under --dry-run" $ do       withFixture $ \dir -> do@@ -58,9 +60,9 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = True,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = True,+                check = False               }         case outcome of           SyncSuccess _ WouldWrite -> pure ()@@ -74,14 +76,14 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = False,-                syncVersionsCheck = True+              { dir = Just dir,+                dryRun = False,+                check = True               }         case outcome of           SyncSuccess report Checked -> do             -- first entry missing, second entry stale-            map (.diffStatus) report.syncDiffs+            map (^. #status) (report ^. #diffs)               `shouldBe` [SyncMissing, SyncStale "2.0.0"]           other -> expectationFailure ("expected Checked, got " <> show other)         after <- TIO.readFile (dir </> "seihou-registry.dhall")@@ -92,9 +94,9 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = False,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = False,+                check = False               }         case outcome of           SyncFailure _ -> pure ()@@ -105,9 +107,9 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = False,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = False,+                check = False               }         case outcome of           SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg)@@ -115,16 +117,16 @@         reloaded <- evalRegistryFromFile (dir </> "seihou-registry.dhall")         case reloaded of           Left err -> expectationFailure ("failed to reload: " <> show err)-          Right reg -> map (.version) reg.blueprints `shouldBe` [Just "0.2.0"]+          Right reg -> map (^. #version) (reg ^. #blueprints) `shouldBe` [Just "0.2.0"]      it "renderSyncReport prefixes blueprint rows with blueprints." $ do       withBlueprintFixture $ \dir -> do         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = True,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = True,+                check = False               }         case outcome of           SyncSuccess report _ -> do@@ -137,9 +139,9 @@         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = False,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = False,+                check = False               }         case outcome of           SyncFailure msg -> expectationFailure ("expected success, got: " <> T.unpack msg)@@ -147,16 +149,16 @@         reloaded <- evalRegistryFromFile (dir </> "seihou-registry.dhall")         case reloaded of           Left err -> expectationFailure ("failed to reload: " <> show err)-          Right reg -> map (.version) reg.prompts `shouldBe` [Just "0.2.0"]+          Right reg -> map (^. #version) (reg ^. #prompts) `shouldBe` [Just "0.2.0"]      it "renderSyncReport prefixes prompt rows with prompts." $ do       withPromptFixture $ \dir -> do         outcome <-           runSync             SyncVersionsOpts-              { syncVersionsDir = Just dir,-                syncVersionsDryRun = True,-                syncVersionsCheck = False+              { dir = Just dir,+                dryRun = True,+                check = False               }         case outcome of           SyncSuccess report _ -> do
test/Seihou/CLI/Registry/ValidateSpec.hs view
@@ -2,6 +2,8 @@  module Seihou.CLI.Registry.ValidateSpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -35,9 +37,9 @@         outcome <- runValidate (ValidateRegistryOpts (Just dir))         case outcome of           ValidateOk r -> do-            r.reportIssues `shouldBe` []-            r.reportModuleCount `shouldBe` 2-            r.reportRecipeCount `shouldBe` 0+            (r ^. #issues) `shouldBe` []+            (r ^. #moduleCount) `shouldBe` 2+            (r ^. #recipeCount) `shouldBe` 0           other -> expectationFailure ("expected ValidateOk, got " <> show other)      it "flags both stale and missing version entries" $ do@@ -46,8 +48,8 @@         case outcome of           ValidateOk r -> do             let statuses =-                  [ d.diffStatus-                  | VersionMismatch d <- r.reportIssues+                  [ d ^. #status+                  | VersionMismatch d <- r ^. #issues                   ]             statuses `shouldBe` [SyncMissing, SyncStale "2.0.0"]           other -> expectationFailure ("unexpected outcome: " <> show other)@@ -59,7 +61,7 @@           ValidateOk r -> do             let structurals =                   [ msg-                  | StructuralError msg <- r.reportIssues+                  | StructuralError msg <- r ^. #issues                   ]             any ("missing module.dhall" `T.isInfixOf`) structurals               `shouldBe` True
test/Seihou/CLI/SavePromptedSpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.SavePromptedSpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T@@ -118,7 +120,7 @@           runConsolePure ["y"] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing True entries-      cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")]+      (cwState ^. #local) `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")]      it "does not save when user declines with 'n'" $ do       (((), cwState), _consoleSt) <-@@ -126,7 +128,7 @@           runConsolePure ["n"] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing True entries-      cwState.cwLocal `shouldBe` Map.empty+      (cwState ^. #local) `shouldBe` Map.empty      it "saves without asking when --save-prompted (Just True)" $ do       (((), cwState), consoleSt) <-@@ -134,9 +136,9 @@           runConsolePure [] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted (Just True) True entries-      cwState.cwLocal `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")]+      (cwState ^. #local) `shouldBe` Map.fromList [("project.name", "my-app"), ("license", "MIT")]       -- Should not contain the confirmation prompt-      any (T.isInfixOf "Save prompted values") consoleSt.consoleOutputs `shouldBe` False+      any (T.isInfixOf "Save prompted values") (consoleSt ^. #outputs) `shouldBe` False      it "skips entirely when --no-save-prompted (Just False)" $ do       (((), cwState), consoleSt) <-@@ -144,8 +146,8 @@           runConsolePure [] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted (Just False) True entries-      cwState.cwLocal `shouldBe` Map.empty-      consoleSt.consoleOutputs `shouldBe` []+      (cwState ^. #local) `shouldBe` Map.empty+      (consoleSt ^. #outputs) `shouldBe` []      it "skips in non-interactive mode when no flag given" $ do       (((), cwState), _consoleSt) <-@@ -153,7 +155,7 @@           runConsolePure [] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing False entries-      cwState.cwLocal `shouldBe` Map.empty+      (cwState ^. #local) `shouldBe` Map.empty      it "shows overwrite note for existing values" $ do       let entriesWithOverwrite =@@ -164,7 +166,7 @@           runConsolePure ["y"] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing True entriesWithOverwrite-      any (T.isInfixOf "overwrites current") consoleSt.consoleOutputs `shouldBe` True+      any (T.isInfixOf "overwrites current") (consoleSt ^. #outputs) `shouldBe` True      it "does nothing when entries list is empty" $ do       (((), cwState), consoleSt) <-@@ -172,8 +174,8 @@           runConsolePure [] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing True []-      cwState.cwLocal `shouldBe` Map.empty-      consoleSt.consoleOutputs `shouldBe` []+      (cwState ^. #local) `shouldBe` Map.empty+      (consoleSt ^. #outputs) `shouldBe` []      it "displays confirmation message after saving" $ do       (((), _cwState), consoleSt) <-@@ -181,4 +183,4 @@           runConsolePure ["y"] $             runConfigWriterPure emptyConfigWriterState $               offerSavePrompted Nothing True entries-      any (T.isInfixOf "Saved 2 value(s)") consoleSt.consoleOutputs `shouldBe` True+      any (T.isInfixOf "Saved 2 value(s)") (consoleSt ^. #outputs) `shouldBe` True
+ test/Seihou/CLI/SeihouBinary.hs view
@@ -0,0 +1,52 @@+-- | Locating the @seihou@ executable the end-to-end tests shell out to.+--+-- The test suite declares @build-tool-depends: seihou-cli:seihou@, and cabal+-- used to satisfy that by symlinking the executable next to the test binary at+-- @\<test-build-dir\>\/..\/seihou\/seihou@. Cabal 3.16 no longer creates that+-- symlink, so every end-to-end spec that assumed it went looking for a path+-- that does not exist. We probe the layouts cabal actually produces and report+-- every directory searched when none of them holds the binary, rather than+-- surfacing a bare @posix_spawnp: does not exist@ from deep inside a spec.+--+-- Deliberately absent: a @PATH@ lookup. Falling back to whatever @seihou@ the+-- developer has installed would silently test a different build than the one+-- under test, which is worse than failing.+module Seihou.CLI.SeihouBinary+  ( seihouBinary,+  )+where++import Control.Monad (filterM)+import Data.List (intercalate)+import System.Directory (doesFileExist)+import System.Environment (getExecutablePath)+import System.FilePath (takeDirectory, (</>))++-- | The @seihou@ executable built alongside this test suite.+seihouBinary :: IO FilePath+seihouBinary = do+  candidates <- seihouBinaryCandidates+  found <- filterM doesFileExist candidates+  case found of+    (binary : _) -> pure binary+    [] ->+      fail $+        "Could not find the seihou executable built alongside this test suite.\n"+          <> "Searched:\n"+          <> intercalate "\n" (map ("  " <>) candidates)+          <> "\nBuild it with 'cabal build seihou-cli:seihou' and rerun."++-- | The places cabal has been observed to put the executable, most specific+-- first: the @build-tool-depends@ symlink beside the test binary, then the+-- executable component's own build directory under the same package.+seihouBinaryCandidates :: IO [FilePath]+seihouBinaryCandidates = do+  testBinary <- getExecutablePath+  -- @\<pkg\>/t/seihou-cli-test/build@+  let testBuildDir = takeDirectory (takeDirectory testBinary)+      -- @\<pkg\>@, three levels above @build@+      packageDir = takeDirectory (takeDirectory (takeDirectory testBuildDir))+  pure+    [ testBuildDir </> "seihou" </> "seihou",+      packageDir </> "x" </> "seihou" </> "build" </> "seihou" </> "seihou"+    ]
+ test/Seihou/CLI/SharedManifestE2ESpec.hs view
@@ -0,0 +1,172 @@+-- | The initiative's headline claim, driven end to end through the real+-- binary: two developers can share @.seihou\/manifest.json@ safely.+--+-- Four mechanisms have to hold together for that to be true — the manifest+-- records portable origins, every command resolves them locally, seihou+-- refuses to generate from an artifact older than the manifest records, and a+-- manifest written by an older seihou can be converted. Each has its own unit+-- tests. This spec is what stops them from drifting apart.+module Seihou.CLI.SharedManifestE2ESpec (tests) where++import Control.Lens ((^.))+import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Seihou.CLI.TwoDeveloperFixture+  ( TwoDeveloperFixture (..),+    gitCommitAll,+    gitStatus,+    installModuleVersion,+    moduleSourceUrl,+    prepareTwoDeveloperFixture,+    resetWorkingTree,+    runSeihouAs,+    seihouBinary,+  )+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+import Test.Tasty+import Test.Tasty.Hspec (testSpec)++tests :: IO TestTree+tests = testSpec "shared manifest across developers" spec++spec :: Spec+spec = do+  it "records a portable manifest and refuses a stale developer" $+    withGeneratedProject "seihou-shared-refuse" $ \binary fixture -> do+      manifest <- TIO.readFile (fixture ^. #manifestPath)+      manifest `shouldSatisfy` T.isInfixOf "\"kind\":\"remote\""+      manifest `shouldSatisfy` T.isInfixOf moduleSourceUrl+      manifest `shouldNotSatisfy` T.isInfixOf (T.pack (fixture ^. #homeA))+      manifest `shouldNotSatisfy` T.isInfixOf (T.pack (fixture ^. #homeB))++      (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo"]+      code `shouldSatisfy` (/= ExitSuccess)+      let reported = out <> err+      reported `shouldSatisfy` T.isInfixOf "2.0.0"+      reported `shouldSatisfy` T.isInfixOf "1.4.0"+      reported `shouldSatisfy` T.isInfixOf "seihou upgrade"++      -- The assertion that matters: an exit code proves the command reported+      -- failure, only an unchanged working tree proves it did not write first.+      gitStatus fixture `shouldReturn` ""++  it "proceeds under --allow-downgrade and says so" $+    withGeneratedProject "seihou-shared-allow" $ \binary fixture -> do+      (code, out, err) <-+        runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo", "--allow-downgrade"]+      expectSuccess "developer B's deliberate downgrade" code out err++      -- A deliberate downgrade must still be visible; silently honouring the+      -- flag would hide exactly the change the guard exists to make legible.+      let reported = out <> err+      reported `shouldSatisfy` T.isInfixOf "2.0.0"+      reported `shouldSatisfy` T.isInfixOf "1.4.0"++      manifest <- TIO.readFile (fixture ^. #manifestPath)+      manifest `shouldSatisfy` T.isInfixOf "\"version\":\"1.4.0\""+      TIO.readFile (fixture ^. #projectFile) `shouldReturnSatisfy` T.isInfixOf "demo 1.4.0"++  it "succeeds once the stale developer upgrades locally" $+    withGeneratedProject "seihou-shared-upgrade" $ \binary fixture -> do+      resetWorkingTree fixture+      installModuleVersion (fixture ^. #homeB) (fixture ^. #moduleName) "2.0.0"++      generated <- TIO.readFile (fixture ^. #projectFile)+      (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeB) ["run", "demo"]+      expectSuccess "developer B's run after upgrading" code out err++      -- Regenerating from the same version with the same inputs produces the+      -- same bytes, so the generated file is untouched. The manifest is+      -- rewritten regardless, because every run stamps a fresh 'generatedAt'+      -- and 'appliedAt' — that is the only path git reports.+      status <- gitStatus fixture+      map T.strip (T.lines status) `shouldBe` ["M .seihou/manifest.json"]+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` generated+      manifest <- TIO.readFile (fixture ^. #manifestPath)+      manifest `shouldSatisfy` T.isInfixOf "\"version\":\"2.0.0\""++  it "rejects, upgrades, and then accepts a legacy manifest" $+    withGeneratedProject "seihou-shared-legacy" $ \binary fixture -> do+      TIO.writeFile (fixture ^. #manifestPath) legacyManifest+      gitCommitAll fixture "test: commit a manifest from an older seihou"++      (statusCode, statusOut, statusErr) <- runSeihouAs binary fixture (fixture ^. #homeB) ["status"]+      statusCode `shouldSatisfy` (/= ExitSuccess)+      let rejected = statusOut <> statusErr+      rejected `shouldSatisfy` T.isInfixOf "schema version 5"+      rejected `shouldSatisfy` T.isInfixOf "seihou manifest upgrade"++      before <- LBS.readFile (fixture ^. #manifestPath)+      (dryCode, dryOut, dryErr) <-+        runSeihouAs binary fixture (fixture ^. #homeB) ["manifest", "upgrade", "--dry-run"]+      expectSuccess "the dry-run upgrade" dryCode dryOut dryErr+      dryOut `shouldSatisfy` T.isInfixOf foreignPath+      dryOut `shouldSatisfy` T.isInfixOf ("remote " <> moduleSourceUrl)+      LBS.readFile (fixture ^. #manifestPath) `shouldReturn` before++      (upgradeCode, upgradeOut, upgradeErr) <-+        runSeihouAs binary fixture (fixture ^. #homeB) ["manifest", "upgrade"]+      expectSuccess "the upgrade" upgradeCode upgradeOut upgradeErr+      manifest <- TIO.readFile (fixture ^. #manifestPath)+      manifest `shouldSatisfy` T.isInfixOf "\"kind\":\"remote\""+      manifest `shouldNotSatisfy` T.isInfixOf "someone-else"++      (afterCode, afterOut, afterErr) <- runSeihouAs binary fixture (fixture ^. #homeB) ["status"]+      expectSuccess "status after the upgrade" afterCode afterOut afterErr++-- | Developer A, on 2.0.0, generates the project and commits. Developer B has+-- 1.4.0 installed. Every scenario starts here.+withGeneratedProject :: String -> (FilePath -> TwoDeveloperFixture -> IO ()) -> IO ()+withGeneratedProject label action =+  withSystemTempDirectory label $ \root -> do+    fixture <- prepareTwoDeveloperFixture root "2.0.0" "1.4.0"+    binary <- seihouBinary+    (code, out, err) <- runSeihouAs binary fixture (fixture ^. #homeA) ["run", "demo"]+    expectSuccess "developer A's run" code out err+    gitCommitAll fixture "feat: apply demo 2.0.0"+    action binary fixture++-- | The absolute path a third machine — neither developer's — recorded, the+-- kind of value a schema-5 manifest is full of.+foreignPath :: Text+foreignPath = "/Users/someone-else/.config/seihou/installed/demo"++-- | A manifest as a released seihou wrote them: schema 5, with the module's+-- source recorded as somebody else's absolute path.+--+-- It records 1.4.0, which is what developer B has installed, so the upgrade's+-- own guard is satisfied and the scenario exercises the conversion rather than+-- the refusal.+legacyManifest :: Text+legacyManifest =+  T.concat+    [ "{\"version\":5",+      ",\"generatedAt\":\"2026-07-01T12:00:00Z\"",+      ",\"modules\":[{\"name\":\"demo\",\"source\":\"",+      foreignPath,+      "\",\"version\":\"1.4.0\",\"appliedAt\":\"2026-07-01T12:00:00Z\"}]",+      ",\"variables\":{},\"files\":{},\"applications\":[],\"blueprintMigrations\":[]}"+    ]++expectSuccess :: String -> ExitCode -> Text -> Text -> Expectation+expectSuccess label code out err = case code of+  ExitSuccess -> pure ()+  ExitFailure status ->+    expectationFailure+      ( label+          <> " exited "+          <> show status+          <> "\nstdout:\n"+          <> T.unpack out+          <> "\nstderr:\n"+          <> T.unpack err+      )++shouldReturnSatisfy :: IO Text -> (Text -> Bool) -> Expectation+shouldReturnSatisfy action predicate = action >>= (`shouldSatisfy` predicate)
test/Seihou/CLI/StatusSpec.hs view
@@ -1,10 +1,15 @@ module Seihou.CLI.StatusSpec (tests) where +import Control.Lens (to, (&), (.~)) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime, defaultTimeLocale, parseTimeOrError)-import Seihou.CLI.StatusRender (formatStatus)+import Seihou.CLI.ManifestGuard+  ( ArtifactCheck (..),+    ArtifactVerdict (..),+  )+import Seihou.CLI.StatusRender (formatArtifactChecks, formatStatus) import Seihou.CLI.VersionCompare   ( OutdatedEntry (..),     OutdatedStatus (..),@@ -22,6 +27,7 @@     AppliedInstanceState (..),     AppliedModule (..),     AppliedTarget (..),+    ArtifactOrigin (..),     Manifest (..),     ModuleName (..),     RecipeName (..),@@ -49,7 +55,7 @@   AppliedModule     { name = ModuleName name,       parentVars = emptyParentVars,-      source = "/installed/" <> T.unpack name,+      origin = LocalOrigin name,       moduleVersion = mver,       appliedAt = fixedTime,       removal = Nothing@@ -58,16 +64,15 @@ mkManifest :: [AppliedModule] -> Manifest mkManifest mods =   (emptyManifest fixedTime)-    { modules = mods,-      files = Map.empty-    }+    & #modules .~ mods+    & #files .~ Map.empty  mkApplication :: Text -> [Text] -> AppliedComposition mkApplication target modules =   AppliedComposition     { applicationId = ApplicationId ("app-" <> target),       target = AppliedRecipeTarget (RecipeName target),-      targetSource = "/installed/" <> T.unpack target,+      targetOrigin = LocalOrigin target,       targetVersion = Just "1.0.0",       additionalModules = [],       namespace = Nothing,@@ -81,7 +86,7 @@       AppliedInstanceState         { name = ModuleName name,           parentVars = emptyParentVars,-          source = "/installed/" <> T.unpack name,+          origin = LocalOrigin name,           moduleVersion = Just "1.0.0",           resolvedVars = Map.empty         }@@ -90,10 +95,10 @@ mkPlan :: Text -> Text -> Text -> Int -> MigrationPlan mkPlan modName from to nSteps =   MigrationPlan-    { planModule = modName,-      planFrom = parseV from,-      planTo = parseV to,-      planSteps = replicate nSteps (Migration from to [DeleteFile "x"])+    { module_ = modName,+      from = parseV from,+      to = parseV to,+      steps = replicate nSteps (Migration from to [DeleteFile "x"])     }  parseV :: Text -> Seihou.Core.Version.Version@@ -129,7 +134,7 @@     }  withManifestBlueprint :: Maybe AppliedBlueprint -> Manifest -> Manifest-withManifestBlueprint mb m = m {blueprint = mb}+withManifestBlueprint mb m = m & #blueprint .~ mb  mkBlueprintMigrationReceipt :: Text -> Maybe Text -> Text -> Text -> AppliedBlueprintMigration mkBlueprintMigrationReceipt blueprintName artifactVersion fromVersion toVersion =@@ -213,7 +218,7 @@      it "renders blueprint name, artifact version, exact edge, and timestamp" $ do       let receipt = mkBlueprintMigrationReceipt "payments" (Just "0.4.0") "1.0.0" "2.0.0"-          manifest = (mkManifest []) {blueprintMigrations = [receipt]}+          manifest = ((mkManifest []) & #blueprintMigrations .~ [receipt])           out = formatStatus False manifest [] Nothing []       out `shouldSatisfy` T.isInfixOf "Blueprint migrations:"       out `shouldSatisfy` T.isInfixOf "payments v0.4.0: 1.0.0 -> 2.0.0"@@ -267,7 +272,7 @@    -- Master-plan live-tree fixture: manifest=0.1.0, installed=0.3.0,   -- declared [0.1.0 → 0.2.0]. The chain reaches 0.2 via ops; the-  -- supplied target is 0.3, so planTo = 0.3. Status surfaces the+  -- supplied target is 0.3, so to = 0.3. Status surfaces the   -- single in-window step and points at `seihou update demo` as the   -- remediation.   it "partial-cover plan: chain reaches an intermediate version, target is the user's installed copy" $ do@@ -293,10 +298,10 @@         manifest = mkManifest [am]         plan =           MigrationPlan-            { planModule = "demo",-              planFrom = parseV "0.2.0",-              planTo = parseV "0.3.0",-              planSteps = []+            { module_ = "demo",+              from = parseV "0.2.0",+              to = parseV "0.3.0",+              steps = []             }         out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)]     out `shouldSatisfy` T.isInfixOf "Pending migration: 0.2.0 -> 0.3.0 (0 step(s))"@@ -311,9 +316,9 @@   it "deduplicates repeated instances into one recipe application action" $ do     let duplicate = mkApplied "demo" (Just "1.0.0")         manifest =-          (mkManifest [duplicate, duplicate])-            { applications = [mkApplication "stack" ["demo", "demo"]]-            }+          ( (mkManifest [duplicate, duplicate])+              & #applications .~ [mkApplication "stack" ["demo", "demo"]]+          )         plan = mkPlan "demo" "1.0.0" "2.0.0" 1         out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)]         recommendationLines = filter (== "  seihou update stack") (T.lines out)@@ -324,12 +329,9 @@   it "recommends each affected application plus the whole-project update" $ do     let shared = mkApplied "shared" (Just "1.0.0")         manifest =-          (mkManifest [shared])-            { applications =-                [ mkApplication "stack-one" ["shared"],-                  mkApplication "stack-two" ["shared"]-                ]-            }+          ( (mkManifest [shared])+              & #applications .~ [mkApplication "stack-one" ["shared"], mkApplication "stack-two" ["shared"]]+          )         plan = mkPlan "shared" "1.0.0" "2.0.0" 1         out = formatStatus False manifest [] Nothing [(ModuleName "shared", plan)]         recommendationLines = dropWhile (/= "Recommended actions:") (T.lines out)@@ -346,3 +348,24 @@         plan = mkPlan "demo" "1.0.0" "2.0.0" 1         out = formatStatus False manifest [] Nothing [(ModuleName "demo", plan)]     T.count "seihou update demo" out `shouldBe` 2++  it "reports a stale artifact without failing, and names the remedy" $ do+    let check =+          ArtifactCheck+            { name = ModuleName "demo",+              origin = RemoteOrigin "https://example.com/demo.git" "demo" Nothing,+              verdict = ArtifactStale "2.0.0" "1.4.0"+            }+        out = formatArtifactChecks False [check]+    out `shouldSatisfy` T.isInfixOf "Artifacts that differ from what this project records:"+    out `shouldSatisfy` T.isInfixOf "seihou upgrade demo"++  it "prints nothing at all when every artifact is healthy" $ do+    let check =+          ArtifactCheck+            { name = ModuleName "demo",+              origin = RemoteOrigin "https://example.com/demo.git" "demo" Nothing,+              verdict = ArtifactOk+            }+    formatArtifactChecks False [check] `shouldBe` ""+    formatArtifactChecks False [] `shouldBe` ""
+ test/Seihou/CLI/TwoDeveloperFixture.hs view
@@ -0,0 +1,163 @@+-- | One project shared by two simulated developers, each with their own+-- seihou configuration root.+--+-- Both developers work in the same @projectRoot@ — that is the point, since it+-- models a git checkout they both have. What differs is @homeA@ and @homeB@,+-- each of which becomes @XDG_CONFIG_HOME@ for that developer's invocations, so+-- each has an independent @\<home\>\/seihou\/installed\/@ and+-- @\<home\>\/seihou\/modules\/@. That single variable is the whole difference+-- between two developers as far as seihou is concerned.+module Seihou.CLI.TwoDeveloperFixture+  ( TwoDeveloperFixture (..),+    prepareTwoDeveloperFixture,+    installModuleVersion,+    moduleSourceUrl,+    seihouBinary,+    runSeihouAs,+    gitStatus,+    gitCommitAll,+    resetWorkingTree,+  )+where++import Control.Lens ((^.))+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import Seihou.CLI.SeihouBinary (seihouBinary)+import System.Directory (createDirectoryIfMissing)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess)++data TwoDeveloperFixture = TwoDeveloperFixture+  { projectRoot :: !FilePath,+    manifestPath :: !FilePath,+    projectFile :: !FilePath,+    homeA :: !FilePath,+    homeB :: !FilePath,+    moduleName :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | The URL both developers' installed copies record as their upstream.+--+-- Nothing is ever fetched from it. It exists so the two copies are recognisably+-- the *same* artifact — which is what lets the guard compare their versions+-- rather than reporting an origin mismatch.+moduleSourceUrl :: Text+moduleSourceUrl = "https://example.com/demo-modules.git"++-- | Build the fixture under @root@.+--+-- Installs @demo@ at @versionA@ into developer A's configuration root and at+-- @versionB@ into developer B's, both carrying the same+-- @.seihou-origin.json@ source URL, and initialises @projectRoot@ as a git+-- repository with an initial commit so working-tree assertions are meaningful.+prepareTwoDeveloperFixture :: FilePath -> Text -> Text -> IO TwoDeveloperFixture+prepareTwoDeveloperFixture root versionA versionB = do+  let projectRoot = root </> "project"+      fixture =+        TwoDeveloperFixture+          { projectRoot = projectRoot,+            manifestPath = projectRoot </> ".seihou" </> "manifest.json",+            projectFile = projectRoot </> "README.md",+            homeA = root </> "home-a",+            homeB = root </> "home-b",+            moduleName = "demo"+          }+  createDirectoryIfMissing True projectRoot+  TIO.writeFile (projectRoot </> "PROJECT.md") "a project two developers share\n"+  installModuleVersion (fixture ^. #homeA) (fixture ^. #moduleName) versionA+  installModuleVersion (fixture ^. #homeB) (fixture ^. #moduleName) versionB+  callProcess "git" ["-C", projectRoot, "init", "-q"]+  callProcess "git" ["-C", projectRoot, "config", "user.name", "Seihou Test"]+  callProcess "git" ["-C", projectRoot, "config", "user.email", "test@example.com"]+  gitCommitAll fixture "test: seed the shared project"+  pure fixture++-- | Install one version of a module into a developer's configuration root,+-- replacing whatever was there. Mirrors what @seihou install@ lays down:+-- the module directory, its template files, and the @.seihou-origin.json@+-- recording where it came from.+installModuleVersion :: FilePath -> Text -> Text -> IO ()+installModuleVersion home name version = do+  let installed = home </> "seihou" </> "installed" </> T.unpack name+  createDirectoryIfMissing True (installed </> "files")+  TIO.writeFile (installed </> "module.dhall") (moduleDhall name version)+  TIO.writeFile (installed </> "files" </> "README.tmpl") (readmeTemplate version)+  TIO.writeFile+    (installed </> ".seihou-origin.json")+    ( "{\"sourceUrl\":\""+        <> moduleSourceUrl+        <> "\",\"repoName\":\"demo-modules\",\"version\":\""+        <> version+        <> "\",\"installedAt\":\"2026-07-01T00:00:00Z\",\"tags\":[]}"+    )++-- | The generated file names its version, so a downgrade is visible on disk+-- and not only in the manifest.+readmeTemplate :: Text -> Text+readmeTemplate version = "# {{project.name}}\n\ngenerated by demo " <> version <> "\n"++-- | A module that declares one defaulted variable and generates one file.+--+-- Copied from @moduleDhallWithTemplate@ in+-- "Seihou.CLI.UpdateSpec" so the schema shape stays in step with the rest of+-- the suite. No prompts and no commands: this fixture drives the real binary+-- non-interactively.+moduleDhall :: Text -> Text -> Text+moduleDhall name version =+  T.unlines+    [ "{ name = \"" <> name <> "\"",+      ", version = Some \"" <> version <> "\"",+      ", description = None Text",+      ", vars = [{ name = \"project.name\", type = \"text\", default = Some \"shared\", description = None Text, required = False, validation = None Text }]",+      ", exports = [] : List { var : Text, alias : Optional Text }",+      ", prompts = [] : List { var : Text, text : Text, when : Optional Text, choices : Optional (List Text) }",+      ", steps = [{ strategy = \"template\", src = \"README.tmpl\", dest = \"README.md\", when = None Text, patch = None Text }]",+      ", commands = [] : List { run : Text, workDir : Optional Text, when : Optional Text }",+      ", dependencies = [] : List Text",+      ", removal = None { steps : List { action : Text, dest : Text, src : Optional Text }, commands : List { run : Text, workDir : Optional Text, when : Optional Text } }",+      "}"+    ]++-- | The @seihou@ executable Cabal built for this test run.+--+-- @build-tool-depends: seihou-cli:seihou@ in the test-suite stanza is what puts+-- it at a predictable place beside the test binary.+-- | Run the real binary in the shared project as one of the two developers.+--+-- @home@ becomes @XDG_CONFIG_HOME@, which is the only thing that distinguishes+-- them. The override is unconditional so a test can never reach the+-- developer's own @~\/.config\/seihou\/@.+runSeihouAs :: FilePath -> TwoDeveloperFixture -> FilePath -> [String] -> IO (ExitCode, Text, Text)+runSeihouAs binary fixture home args = do+  inherited <- getEnvironment+  let environment = ("XDG_CONFIG_HOME", home) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited+      command = (proc binary args) {cwd = Just (fixture ^. #projectRoot), env = Just environment}+  (exitCode, stdoutText, stderrText) <- readCreateProcessWithExitCode command ""+  pure (exitCode, T.pack stdoutText, T.pack stderrText)++-- | @git status --porcelain@ in the shared project. Empty means nothing was+-- written.+gitStatus :: TwoDeveloperFixture -> IO Text+gitStatus fixture =+  T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] ""++-- | Commit everything in the shared project, as a developer would before+-- pushing.+gitCommitAll :: TwoDeveloperFixture -> String -> IO ()+gitCommitAll fixture message = do+  callProcess "git" ["-C", fixture ^. #projectRoot, "add", "-A"]+  callProcess "git" ["-C", fixture ^. #projectRoot, "commit", "-qm", message]++-- | Throw away every uncommitted change, putting the shared project back to+-- the last commit.+resetWorkingTree :: TwoDeveloperFixture -> IO ()+resetWorkingTree fixture = do+  callProcess "git" ["-C", fixture ^. #projectRoot, "checkout", "-q", "--", "."]+  callProcess "git" ["-C", fixture ^. #projectRoot, "clean", "-qfd"]
test/Seihou/CLI/UpdateE2ESpec.hs view
@@ -1,13 +1,15 @@ module Seihou.CLI.UpdateE2ESpec (tests) where +import Control.Lens ((^.)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Text qualified as T import Data.Text.IO qualified as TIO+import Seihou.CLI.SeihouBinary (seihouBinary) import Seihou.CLI.UpdateSpec (UpdateFixture (..), prepareUpdateFixture) import System.Directory (doesFileExist)-import System.Environment (getEnvironment, getExecutablePath)+import System.Environment (getEnvironment) import System.Exit (ExitCode (..))-import System.FilePath (takeDirectory, (</>)) import System.IO.Temp (withSystemTempDirectory) import System.Process (CreateProcess (..), callProcess, proc, readCreateProcessWithExitCode, readProcess) import Test.Hspec@@ -23,7 +25,7 @@     withSystemTempDirectory "seihou-update-executable" $ \root -> do       fixture <- prepareUpdateFixture root       binary <- seihouBinary-      TIO.writeFile fixture.projectFile "hello accepted by-user\nkeep\nv1\n"+      TIO.writeFile (fixture ^. #projectFile) "hello accepted by-user\nkeep\nv1\n"       (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--json"]       case exitCode of         ExitSuccess -> pure ()@@ -32,44 +34,44 @@       stdoutText `shouldSatisfy` T.isInfixOf "\"skippedUnchanged\":1"       stdoutText `shouldNotSatisfy` T.isInfixOf "Apply?"       stderrText `shouldNotSatisfy` T.isInfixOf "Apply?"-      TIO.readFile fixture.projectFile `shouldReturn` "hello accepted by-user\nkeep\nv2\n"-      TIO.readFile (fixture.installedModule <> "/module.dhall")+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted by-user\nkeep\nv2\n"+      TIO.readFile (fixture ^. #installedModule <> "/module.dhall")         `shouldReturnSatisfy` T.isInfixOf "Some \"2.0.0\""-      doesFileExist (fixture.projectRoot <> "/command.log") `shouldReturn` False+      doesFileExist (fixture ^. #projectRoot <> "/command.log") `shouldReturn` False       (statusExit, statusOut, _) <- runSeihou binary fixture ["status"]       statusExit `shouldBe` ExitSuccess       statusOut `shouldNotSatisfy` T.isInfixOf "seihou update demo"-      afterApply <- LBS.readFile fixture.manifestPath+      afterApply <- LBS.readFile (fixture ^. #manifestPath)       (noOpExit, noOpOut, noOpErr) <- runSeihou binary fixture ["update", "demo", "--json"]       noOpExit `shouldBe` ExitSuccess       noOpOut `shouldSatisfy` T.isInfixOf "\"alreadyUpToDate\":true"       noOpOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\""       noOpErr `shouldNotSatisfy` T.isInfixOf "Apply?"-      LBS.readFile fixture.manifestPath `shouldReturn` afterApply+      LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterApply    it "keeps project, manifest, and installed cache byte-identical for JSON dry-run" $     withSystemTempDirectory "seihou-update-executable-dry" $ \root -> do       fixture <- prepareUpdateFixture root       binary <- seihouBinary-      beforeProject <- TIO.readFile fixture.projectFile-      beforeManifest <- LBS.readFile fixture.manifestPath-      beforeInstalled <- TIO.readFile (fixture.installedModule <> "/module.dhall")+      beforeProject <- TIO.readFile (fixture ^. #projectFile)+      beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+      beforeInstalled <- TIO.readFile (fixture ^. #installedModule <> "/module.dhall")       (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "--dry-run", "--json"]       exitCode `shouldBe` ExitSuccess       stdoutText `shouldSatisfy` T.isInfixOf "\"outcome\":\"plan\""-      TIO.readFile fixture.projectFile `shouldReturn` beforeProject-      LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-      TIO.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject+      LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+      TIO.readFile (fixture ^. #installedModule <> "/module.dhall") `shouldReturn` beforeInstalled    it "commits exactly the managed update paths with a requested Conventional Commit message" $     withSystemTempDirectory "seihou-update-executable-commit" $ \root -> do       fixture <- prepareUpdateFixture root       binary <- seihouBinary-      callProcess "git" ["-C", fixture.projectRoot, "init", "-q"]-      callProcess "git" ["-C", fixture.projectRoot, "config", "user.name", "Seihou Test"]-      callProcess "git" ["-C", fixture.projectRoot, "config", "user.email", "test@example.com"]-      callProcess "git" ["-C", fixture.projectRoot, "add", "."]-      callProcess "git" ["-C", fixture.projectRoot, "commit", "-qm", "test: record v1 fixture"]+      callProcess "git" ["-C", fixture ^. #projectRoot, "init", "-q"]+      callProcess "git" ["-C", fixture ^. #projectRoot, "config", "user.name", "Seihou Test"]+      callProcess "git" ["-C", fixture ^. #projectRoot, "config", "user.email", "test@example.com"]+      callProcess "git" ["-C", fixture ^. #projectRoot, "add", "."]+      callProcess "git" ["-C", fixture ^. #projectRoot, "commit", "-qm", "test: record v1 fixture"]       (exitCode, stdoutText, stderrText) <-         runSeihou           binary@@ -78,16 +80,16 @@       case exitCode of         ExitSuccess -> pure ()         ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText)-      subject <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "log", "-1", "--pretty=%s"] ""+      subject <- T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "log", "-1", "--pretty=%s"] ""       subject `shouldBe` "chore(seihou): update demo"-      worktree <- T.strip . T.pack <$> readProcess "git" ["-C", fixture.projectRoot, "status", "--porcelain"] ""+      worktree <- T.strip . T.pack <$> readProcess "git" ["-C", fixture ^. #projectRoot, "status", "--porcelain"] ""       worktree `shouldBe` ""    it "retains an edited orphan under --force" $     withSystemTempDirectory "seihou-update-executable-orphan" $ \root -> do       fixture <- prepareUpdateFixture root       binary <- seihouBinary-      let modulePath = fixture.remote <> "/module.dhall"+      let modulePath = fixture ^. #remote <> "/module.dhall"       moduleBody <- TIO.readFile modulePath       TIO.writeFile         modulePath@@ -96,39 +98,39 @@             ", steps = [] : List { strategy : Text, src : Text, dest : Text, when : Optional Text, patch : Optional Text }"             moduleBody         )-      callProcess "git" ["-C", fixture.remote, "add", "module.dhall"]-      callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "remove generated file"]-      TIO.writeFile fixture.projectFile "user-owned orphan\n"+      callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"]+      callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "remove generated file"]+      TIO.writeFile (fixture ^. #projectFile) "user-owned orphan\n"       (exitCode, stdoutText, stderrText) <- runSeihou binary fixture ["update", "demo", "--force", "--json"]       case exitCode of         ExitSuccess -> pure ()         ExitFailure code -> expectationFailure ("update exited " <> show code <> "\nstdout:\n" <> T.unpack stdoutText <> "\nstderr:\n" <> T.unpack stderrText)       stdoutText `shouldSatisfy` T.isInfixOf "\"editedOrphans\":1"-      TIO.readFile fixture.projectFile `shouldReturn` "user-owned orphan\n"-      TIO.readFile fixture.manifestPath `shouldReturnSatisfy` T.isInfixOf "README.md"+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user-owned orphan\n"+      TIO.readFile (fixture ^. #manifestPath) `shouldReturnSatisfy` T.isInfixOf "README.md"    it "reports an unresolved overlap before publishing project, manifest, or cache state" $     withSystemTempDirectory "seihou-update-executable-conflict" $ \root -> do       fixture <- prepareUpdateFixture root       binary <- seihouBinary-      TIO.writeFile (fixture.remote <> "/files/README.tmpl") "candidate {{project.name}}\nkeep\nv2\n"-      callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"]-      callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "overlap"]-      TIO.writeFile fixture.projectFile "user accepted\nkeep\nv1\n"-      beforeManifest <- LBS.readFile fixture.manifestPath-      beforeInstalled <- LBS.readFile (fixture.installedModule <> "/module.dhall")+      TIO.writeFile (fixture ^. #remote <> "/files/README.tmpl") "candidate {{project.name}}\nkeep\nv2\n"+      callProcess "git" ["-C", fixture ^. #remote, "add", "files/README.tmpl"]+      callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "overlap"]+      TIO.writeFile (fixture ^. #projectFile) "user accepted\nkeep\nv1\n"+      beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+      beforeInstalled <- LBS.readFile (fixture ^. #installedModule <> "/module.dhall")       (exitCode, stdoutText, _) <- runSeihou binary fixture ["update", "demo", "--json"]       exitCode `shouldSatisfy` (/= ExitSuccess)       stdoutText `shouldSatisfy` T.isInfixOf "\"code\":\"unresolved_conflicts\""-      TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nkeep\nv1\n"-      LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-      LBS.readFile (fixture.installedModule <> "/module.dhall") `shouldReturn` beforeInstalled+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user accepted\nkeep\nv1\n"+      LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+      LBS.readFile (fixture ^. #installedModule <> "/module.dhall") `shouldReturn` beforeInstalled       (forceExit, forceOut, forceErr) <- runSeihou binary fixture ["update", "demo", "--force", "--json"]       case forceExit of         ExitSuccess -> pure ()         ExitFailure code -> expectationFailure ("forced update exited " <> show code <> "\nstdout:\n" <> T.unpack forceOut <> "\nstderr:\n" <> T.unpack forceErr)       forceOut `shouldSatisfy` T.isInfixOf "\"outcome\":\"applied\""-      TIO.readFile fixture.projectFile `shouldReturn` "candidate accepted\nkeep\nv2\n"+      TIO.readFile (fixture ^. #projectFile) `shouldReturn` "candidate accepted\nkeep\nv2\n"    it "exposes update and its options through the shared Bash, Zsh, and Fish completion protocol" $ do     binary <- seihouBinary@@ -162,16 +164,11 @@       )       ["bash", "zsh", "fish"] -seihouBinary :: IO FilePath-seihouBinary = do-  testBinary <- getExecutablePath-  pure (takeDirectory (takeDirectory testBinary) </> "seihou" </> "seihou")- runSeihou :: FilePath -> UpdateFixture -> [String] -> IO (ExitCode, T.Text, T.Text) runSeihou binary fixture args = do   inherited <- getEnvironment-  let environment = ("XDG_CONFIG_HOME", fixture.xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited-  runProcessText binary args (Just fixture.projectRoot) (Just environment)+  let environment = ("XDG_CONFIG_HOME", fixture ^. #xdgHome) : filter ((/= "XDG_CONFIG_HOME") . fst) inherited+  runProcessText binary args (Just (fixture ^. #projectRoot)) (Just environment)  runProcessText binary args workingDirectory environment = do   let command = (proc binary args) {cwd = workingDirectory, env = environment}
test/Seihou/CLI/UpdateFixture.hs view
@@ -55,7 +55,8 @@             reconfigure = False,             promptPolicy = ForbidPrompts,             commandPolicy = RunChangedCommands,-            dryRun = True+            dryRun = True,+            allowDowngrade = False           },       snapshot =         UpdateSnapshot
test/Seihou/CLI/UpdateInteractionSpec.hs view
@@ -1,5 +1,7 @@ module Seihou.CLI.UpdateInteractionSpec (tests) where +import Control.Lens ((^.))+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Seihou.CLI.Update (UpdatePlan (..))@@ -35,30 +37,30 @@    it "force accepts ordinary generated conflicts" $ do     resolved <- expectResolved conflictPlan (forceResolveUpdatePlan conflictPlan)-    unresolvedPaths resolved.reconciliation `shouldBe` Set.empty-    case Map.lookup "README.md" resolved.reconciliation.files of+    unresolvedPaths (resolved ^. #reconciliation) `shouldBe` Set.empty+    case Map.lookup "README.md" (resolved ^. #reconciliation . #files) of       Just (FileConflict _ _ _ _ _ _ (Just choice)) ->-        choice.choice `shouldBe` AcceptGenerated+        (choice ^. #choice) `shouldBe` AcceptGenerated       other -> expectationFailure ("expected resolved conflict, got " <> show other)    it "force retains edited orphans as tracked state" $ do     resolved <- expectResolved orphanPlan (forceResolveUpdatePlan orphanPlan)-    case Map.lookup "README.md" resolved.reconciliation.files of+    case Map.lookup "README.md" (resolved ^. #reconciliation . #files) of       Just (FileOrphanEdited _ _ _ _ (Just choice)) ->         choice `shouldBe` RetainTrackedOrphan       other -> expectationFailure ("expected resolved orphan, got " <> show other)    it "force leaves merge-driver failures unresolved" $ do     resolved <- expectResolved unavailableConflictPlan (forceResolveUpdatePlan unavailableConflictPlan)-    unresolvedPaths resolved.reconciliation `shouldBe` Set.singleton "README.md"+    unresolvedPaths (resolved ^. #reconciliation) `shouldBe` Set.singleton "README.md"    it "applies explicit keep-current and detach-orphan choices without writing" $ do     kept <- expectResolved conflictPlan (applyResolutionDecisions [ResolveFile "README.md" KeepCurrent] conflictPlan)-    case Map.lookup "README.md" kept.reconciliation.files of-      Just (FileConflict _ _ _ _ _ _ (Just choice)) -> choice.choice `shouldBe` KeepCurrent+    case Map.lookup "README.md" (kept ^. #reconciliation . #files) of+      Just (FileConflict _ _ _ _ _ _ (Just choice)) -> (choice ^. #choice) `shouldBe` KeepCurrent       other -> expectationFailure ("expected keep-current conflict resolution, got " <> show other)     detached <- expectResolved orphanPlan (applyResolutionDecisions [ResolveOrphan "README.md" DetachAndKeepOrphan] orphanPlan)-    case Map.lookup "README.md" detached.reconciliation.files of+    case Map.lookup "README.md" (detached ^. #reconciliation . #files) of       Just (FileOrphanEdited _ _ _ _ (Just choice)) -> choice `shouldBe` DetachAndKeepOrphan       other -> expectationFailure ("expected detached orphan resolution, got " <> show other)
test/Seihou/CLI/UpdateSpec.hs view
@@ -6,7 +6,9 @@ where  import Control.Exception (bracket)+import Control.Lens ((&), (.~), (^.)) import Data.ByteString.Lazy qualified as LBS+import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, listToMaybe) import Data.Set qualified as Set@@ -14,6 +16,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time (UTCTime (..), fromGregorian)+import GHC.Generics (Generic) import Seihou.CLI.CommandExecution (CommandPolicy (..)) import Seihou.CLI.Update (PromptPolicy (..), UpdateRequest (..), UpdateSelection (..), applyProjectUpdate, isUpdateNoOp, withProjectUpdate) import Seihou.CLI.Update.Migrations (StagedMigrations (..), planAndStageMigrations)@@ -43,16 +46,16 @@ spec = do   describe "application selection" $ do     it "selects every application containing a requested bare module" $ do-      let first = application (AppliedModuleTarget "one") [instanceState "shared" "/one/shared"]-          second = application (AppliedRecipeTarget "stack") [instanceState "shared" "/two/shared"]+      let first = application (AppliedModuleTarget "one") [instanceState "shared"]+          second = application (AppliedRecipeTarget "stack") [instanceState "shared"]           manifest :: Manifest           manifest = manifestForApplications [first, second] Map.empty       selectApplications (NamedUpdateTargets ["shared"]) manifest         `shouldBe` Right (RecordedSelection [first, second])      it "keeps manifest order for all applications and deduplicates repeated targets" $ do-      let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"]-          second = application (AppliedModuleTarget "two") [instanceState "two" "/two"]+      let first = application (AppliedModuleTarget "one") [instanceState "one"]+          second = application (AppliedModuleTarget "two") [instanceState "two"]           manifest :: Manifest           manifest = manifestForApplications [first, second] Map.empty       selectApplications AllRecordedApplications manifest@@ -61,14 +64,14 @@         `shouldBe` Right (RecordedSelection [first, second])      it "rejects a partial selection that shares an owned path" $ do-      let first = application (AppliedModuleTarget "one") [instanceState "one" "/one"]-          second = application (AppliedModuleTarget "two") [instanceState "two" "/two"]-          owners = Set.fromList [first.applicationId, second.applicationId]+      let first = application (AppliedModuleTarget "one") [instanceState "one"]+          second = application (AppliedModuleTarget "two") [instanceState "two"]+          owners = Set.fromList [first ^. #applicationId, second ^. #applicationId]           record = FileRecord (hashContent "old") "one" Template testTime Nothing owners           manifest :: Manifest           manifest = manifestForApplications [first, second] (Map.singleton "shared.txt" record)       selectApplications (NamedUpdateTargets ["one"]) manifest-        `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton first.applicationId) (Set.singleton second.applicationId))+        `shouldBe` Left (SharedPathRequiresApplications "shared.txt" (Set.singleton (first ^. #applicationId)) (Set.singleton (second ^. #applicationId)))      it "requires one explicit target to seed a legacy manifest" $ do       selectApplications AllRecordedApplications (emptyManifest testTime) `shouldBe` Left NoRecordedApplications@@ -78,20 +81,24 @@   describe "candidate source staging" $ do     it "keeps local artifacts as an explicit candidate-first fallback" $       withSystemTempDirectory "seihou-update-source" $ \root -> do-        let moduleDirectory = root </> "current" </> "demo"+        let localProjectRoot = root </> "current"+            moduleDirectory = localProjectRoot </> "demo"             sessionDirectory = root </> "session"-            applied = application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory]+            origin = ProjectOrigin "demo"+            applied =+              application (AppliedModuleTarget "demo") [instanceStateFrom "demo" origin]+                & #targetOrigin .~ origin         createDirectoryIfMissing True moduleDirectory         TIO.writeFile (moduleDirectory </> "module.dhall") (moduleDhall "demo" "1.0.0")-        result <- stageCandidateSources sessionDirectory [applied {targetSource = moduleDirectory}]+        result <- stageCandidateSources sessionDirectory localProjectRoot (root </> "installed") [applied]         case result of           Left err -> expectationFailure (show err)           Right (catalog, warnings) -> do             warnings `shouldContain` [LocalArtifactHasNoRemote "demo"]-            let candidate = catalog.artifacts Map.! (CandidateModule, "demo")-            candidate.originalDirectory `shouldBe` moduleDirectory-            candidate.sourceUrl `shouldBe` Nothing-            doesFileExist (catalog.searchRoot </> "demo" </> "module.dhall") `shouldReturn` True+            let candidate = (catalog ^. #artifacts) Map.! (CandidateModule, "demo")+            (candidate ^. #originalDirectory) `shouldBe` moduleDirectory+            (candidate ^. #sourceUrl) `shouldBe` Nothing+            doesFileExist (catalog ^. #searchRoot </> "demo" </> "module.dhall") `shouldReturn` True      it "clones one registry origin once for a recipe and all of its modules" $       withSystemTempDirectory "seihou-update-registry-source" $ \root -> do@@ -102,11 +109,15 @@             recipeDirectory = installed </> "stack"             sessionDirectory = root </> "session"             sourceUrl = T.pack remote+            remoteOrigin name = RemoteOrigin sourceUrl name Nothing             applied =-              (application (AppliedRecipeTarget "stack") [instanceState "one" moduleOne, instanceState "two" moduleTwo])-                { targetSource = recipeDirectory,-                  additionalModules = []-                }+              application+                (AppliedRecipeTarget "stack")+                [ instanceStateFrom "one" (remoteOrigin "one"),+                  instanceStateFrom "two" (remoteOrigin "two")+                ]+                & #targetOrigin .~ remoteOrigin "stack"+                & #additionalModules .~ []         createDirectoryIfMissing True (remote </> "modules" </> "one")         createDirectoryIfMissing True (remote </> "modules" </> "two")         createDirectoryIfMissing True (remote </> "recipes" </> "stack")@@ -118,21 +129,24 @@         callProcess "git" ["-C", remote, "add", "."]         callProcess "git" ["-C", remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "registry"]         mapM_ (writeOrigin sourceUrl) [moduleOne, moduleTwo, recipeDirectory]-        result <- stageCandidateSources sessionDirectory [applied]+        result <- stageCandidateSources sessionDirectory root installed [applied]         case result of           Left err -> expectationFailure (show err)           Right (catalog, _) -> do-            Map.size catalog.clonedOrigins `shouldBe` 1-            Map.keysSet catalog.artifacts+            Map.size (catalog ^. #clonedOrigins) `shouldBe` 1+            Map.keysSet (catalog ^. #artifacts)               `shouldBe` Set.fromList [(CandidateModule, "one"), (CandidateModule, "two"), (CandidateRecipe, "stack")]      it "returns a structured clone error before touching the project" $       withSystemTempDirectory "seihou-update-clone-error" $ \root -> do         let moduleDirectory = root </> "installed" </> "demo"             missingRemote = T.pack (root </> "missing-remote")-            applied = (application (AppliedModuleTarget "demo") [instanceState "demo" moduleDirectory]) {targetSource = moduleDirectory}+            missingOrigin = RemoteOrigin missingRemote "demo" Nothing+            applied =+              application (AppliedModuleTarget "demo") [instanceStateFrom "demo" missingOrigin]+                & #targetOrigin .~ missingOrigin         writeOrigin missingRemote moduleDirectory-        result <- stageCandidateSources (root </> "session") [applied]+        result <- stageCandidateSources (root </> "session") root (root </> "installed") [applied]         result `shouldSatisfy` \case           Left (CandidateCloneFailed url message) -> url == missingRemote && "git clone failed" `T.isInfixOf` message           _ -> False@@ -141,11 +155,11 @@     it "reuses accepted inputs, keeps dry-run read-only, and publishes one coherent update" $       withSystemTempDirectory "seihou-update-e2e" $ \root -> do         fixture <- prepareUpdateFixture root-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do-            beforeManifest <- LBS.readFile fixture.manifestPath-            beforeProject <- TIO.readFile fixture.projectFile-            beforeInstalled <- TIO.readFile (fixture.installedModule </> "module.dhall")+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do+            beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+            beforeProject <- TIO.readFile (fixture ^. #projectFile)+            beforeInstalled <- TIO.readFile (fixture ^. #installedModule </> "module.dhall")             let dryRequest = updateRequest True             dryResult <- withProjectUpdate dryRequest $ \case               Left err -> pure (Left err)@@ -153,9 +167,9 @@             case dryResult of               Left err -> expectationFailure (show err)               Right _ -> pure ()-            LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-            TIO.readFile fixture.projectFile `shouldReturn` beforeProject-            TIO.readFile (fixture.installedModule </> "module.dhall") `shouldReturn` beforeInstalled+            LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+            TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject+            TIO.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled              applied <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)@@ -163,40 +177,40 @@             case applied of               Left err -> expectationFailure (show err)               Right result -> do-                result.versions `shouldSatisfy` any (\change -> change.name == "demo" && change.fromVersion == Just "1.0.0" && change.toVersion == Just "2.0.0")-                result.updatedApplications `shouldBe` [fixture.applicationId]-            TIO.readFile fixture.projectFile `shouldReturn` "hello accepted\nkeep\nv2\n"-            installedBytes <- TIO.readFile (fixture.installedModule </> "module.dhall")+                (result ^. #versions) `shouldSatisfy` any (\change -> change ^. #name == "demo" && change ^. #fromVersion == Just "1.0.0" && change ^. #toVersion == Just "2.0.0")+                (result ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]+            TIO.readFile (fixture ^. #projectFile) `shouldReturn` "hello accepted\nkeep\nv2\n"+            installedBytes <- TIO.readFile (fixture ^. #installedModule </> "module.dhall")             installedBytes `shouldSatisfy` T.isInfixOf "Some \"2.0.0\""-            decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath+            decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)             case decoded of               Left err -> expectationFailure err-              Right manifest -> case manifest.applications of-                updated : _ -> case updated.instances of+              Right manifest -> case manifest ^. #applications of+                updated : _ -> case updated ^. #instances of                   instanceState : _ -> do-                    instanceState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted"-                    instanceState.moduleVersion `shouldBe` Just "2.0.0"+                    (instanceState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted"+                    (instanceState ^. #moduleVersion) `shouldBe` Just "2.0.0"                   [] -> expectationFailure "updated application has no instances"                 [] -> expectationFailure "updated manifest has no applications" -            afterFirstApply <- LBS.readFile fixture.manifestPath+            afterFirstApply <- LBS.readFile (fixture ^. #manifestPath)             noOp <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate plan             case noOp of               Left err -> expectationFailure (show err)-              Right result -> result.updatedApplications `shouldBe` []-            LBS.readFile fixture.manifestPath `shouldReturn` afterFirstApply+              Right result -> (result ^. #updatedApplications) `shouldBe` []+            LBS.readFile (fixture ^. #manifestPath) `shouldReturn` afterFirstApply      it "rejects a plan when its manifest snapshot changes" $       withSystemTempDirectory "seihou-update-stale" $ \root -> do         fixture <- prepareUpdateFixture root-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do             result <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> do-                TIO.appendFile fixture.manifestPath "\n"+                TIO.appendFile (fixture ^. #manifestPath) "\n"                 applyProjectUpdate plan             result `shouldSatisfy` \case               Left (UpdatePlanStale paths) -> Set.member (".seihou" </> "manifest.json") paths@@ -205,96 +219,96 @@     it "plans changed content at the same declared version with an explicit warning" $       withSystemTempDirectory "seihou-update-same-version" $ \root -> do         fixture <- prepareUpdateFixture root-        let modulePath = fixture.remote </> "module.dhall"+        let modulePath = fixture ^. #remote </> "module.dhall"         body <- TIO.readFile modulePath         TIO.writeFile modulePath (T.replace "Some \"2.0.0\"" "Some \"1.0.0\"" body)-        callProcess "git" ["-C", fixture.remote, "add", "module.dhall"]-        callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"]-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do+        callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"]+        callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "same-version content change"]+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do             result <- withProjectUpdate (updateRequest True) pure             case result of               Left err -> expectationFailure (show err)               Right plan -> do                 isUpdateNoOp plan `shouldBe` False-                plan.versionChanges `shouldSatisfy` any (.sameVersionContentChanged)-                plan.warnings `shouldContain` [SameVersionContentChanged "demo"]+                (plan ^. #versionChanges) `shouldSatisfy` any (^. #sameVersionContentChanged)+                (plan ^. #warnings) `shouldContain` [SameVersionContentChanged "demo"]      it "re-expands a candidate recipe and removes dependencies dropped by it" $       withSystemTempDirectory "seihou-update-recipe" $ \root -> do         fixture <- prepareRecipeUpdateFixture root-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.recipeXdgHome) $-          withCurrentDirectory fixture.recipeProjectRoot $ do+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do             result <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate plan             case result of               Left err -> expectationFailure (show err)-              Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.recipeApplicationId]-            decoded <- manifestFromJSON <$> LBS.readFile fixture.recipeManifestPath+              Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]+            decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)             case decoded of               Left err -> expectationFailure err-              Right manifest -> case manifest.applications of+              Right manifest -> case manifest ^. #applications of                 [updated] -> do-                  updated.applicationId `shouldBe` fixture.recipeApplicationId-                  updated.targetVersion `shouldBe` Just "2.0.0"-                  updated.additionalModules `shouldBe` []-                  Set.fromList (map (.name) updated.instances) `shouldBe` Set.fromList ["one", "new"]-                  Set.fromList (map (.name) manifest.modules) `shouldBe` Set.fromList ["one", "new"]+                  (updated ^. #applicationId) `shouldBe` (fixture ^. #applicationId)+                  (updated ^. #targetVersion) `shouldBe` Just "2.0.0"+                  (updated ^. #additionalModules) `shouldBe` []+                  Set.fromList (map (^. #name) (updated ^. #instances)) `shouldBe` Set.fromList ["one", "new"]+                  Set.fromList (map (^. #name) (manifest ^. #modules)) `shouldBe` Set.fromList ["one", "new"]                 other -> expectationFailure ("expected one updated recipe application, got " <> show other)-            doesFileExist (fixture.recipeXdgHome </> "seihou" </> "installed" </> "new" </> "module.dhall") `shouldReturn` True+            doesFileExist (fixture ^. #xdgHome </> "seihou" </> "installed" </> "new" </> "module.dhall") `shouldReturn` True      it "refuses an unresolved three-way conflict without mutating durable state" $       withSystemTempDirectory "seihou-update-conflict" $ \root -> do         fixture <- prepareUpdateFixture root-        TIO.writeFile (fixture.remote </> "files" </> "README.tmpl") "candidate {{project.name}}\nv2\n"-        callProcess "git" ["-C", fixture.remote, "add", "files/README.tmpl"]-        callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"]-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do-            TIO.writeFile fixture.projectFile "user accepted\nv1\n"-            beforeManifest <- LBS.readFile fixture.manifestPath-            beforeInstalled <- LBS.readFile (fixture.installedModule </> "module.dhall")+        TIO.writeFile (fixture ^. #remote </> "files" </> "README.tmpl") "candidate {{project.name}}\nv2\n"+        callProcess "git" ["-C", fixture ^. #remote, "add", "files/README.tmpl"]+        callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "conflicting template"]+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do+            TIO.writeFile (fixture ^. #projectFile) "user accepted\nv1\n"+            beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+            beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")             result <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate plan             result `shouldSatisfy` \case               Left (UpdateHasUnresolvedPaths paths) -> Set.member "README.md" paths               _ -> False-            LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-            TIO.readFile fixture.projectFile `shouldReturn` "user accepted\nv1\n"-            LBS.readFile (fixture.installedModule </> "module.dhall") `shouldReturn` beforeInstalled+            LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+            TIO.readFile (fixture ^. #projectFile) `shouldReturn` "user accepted\nv1\n"+            LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled      it "seeds one explicit legacy target and records it only after success" $       withSystemTempDirectory "seihou-update-legacy" $ \root -> do         fixture <- prepareUpdateFixture root-        decoded <- manifestFromJSON <$> LBS.readFile fixture.manifestPath+        decoded <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)         legacy <- case decoded of           Left err -> expectationFailure err >> pure (emptyManifest testTime)           Right manifest -> pure (withoutApplications manifest)-        LBS.writeFile fixture.manifestPath (manifestToJSON legacy)-        let request = (updateRequest False) {selection = NamedUpdateTargets ["demo"]}-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do+        LBS.writeFile (fixture ^. #manifestPath) (manifestToJSON legacy)+        let request = ((updateRequest False) & #selection .~ NamedUpdateTargets ["demo"])+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do             result <- withProjectUpdate request $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate plan             case result of               Left err -> expectationFailure (show err)-              Right updateResult -> updateResult.updatedApplications `shouldBe` [fixture.applicationId]-            updated <- manifestFromJSON <$> LBS.readFile fixture.manifestPath+              Right updateResult -> (updateResult ^. #updatedApplications) `shouldBe` [fixture ^. #applicationId]+            updated <- manifestFromJSON <$> LBS.readFile (fixture ^. #manifestPath)             case updated of               Left err -> expectationFailure err-              Right manifest -> case manifest.applications of-                [applicationState] -> case applicationState.instances of-                  [moduleState] -> moduleState.resolvedVars `shouldBe` Map.singleton "project.name" "accepted"+              Right manifest -> case manifest ^. #applications of+                [applicationState] -> case applicationState ^. #instances of+                  [moduleState] -> (moduleState ^. #resolvedVars) `shouldBe` Map.singleton "project.name" "accepted"                   other -> expectationFailure ("expected one legacy module instance, got " <> show other)                 other -> expectationFailure ("expected one seeded application, got " <> show other)      it "rolls managed project and cache state back when a candidate command fails" $       withSystemTempDirectory "seihou-update-command-failure" $ \root -> do         fixture <- prepareUpdateFixture root-        let modulePath = fixture.remote </> "module.dhall"+        let modulePath = fixture ^. #remote </> "module.dhall"         body <- TIO.readFile modulePath         TIO.writeFile           modulePath@@ -303,40 +317,40 @@               ", commands = [{ run = \"exit 7\", workDir = None Text, when = None Text }]"               body           )-        callProcess "git" ["-C", fixture.remote, "add", "module.dhall"]-        callProcess "git" ["-C", fixture.remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"]-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do-            beforeManifest <- LBS.readFile fixture.manifestPath-            beforeProject <- TIO.readFile fixture.projectFile-            beforeInstalled <- LBS.readFile (fixture.installedModule </> "module.dhall")+        callProcess "git" ["-C", fixture ^. #remote, "add", "module.dhall"]+        callProcess "git" ["-C", fixture ^. #remote, "-c", "user.name=Seihou Test", "-c", "user.email=test@example.com", "commit", "-qm", "failing command"]+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do+            beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+            beforeProject <- TIO.readFile (fixture ^. #projectFile)+            beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")             result <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate plan             result `shouldSatisfy` \case               Left UpdateCommandFailed {} -> True               _ -> False-            LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-            TIO.readFile fixture.projectFile `shouldReturn` beforeProject-            LBS.readFile (fixture.installedModule </> "module.dhall") `shouldReturn` beforeInstalled+            LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+            TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject+            LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled      it "rolls managed state back when installed-cache publication fails" $       withSystemTempDirectory "seihou-update-cache-failure" $ \root -> do         fixture <- prepareUpdateFixture root-        withSavedEnv "XDG_CONFIG_HOME" (Just fixture.xdgHome) $-          withCurrentDirectory fixture.projectRoot $ do-            beforeManifest <- LBS.readFile fixture.manifestPath-            beforeProject <- TIO.readFile fixture.projectFile-            beforeInstalled <- LBS.readFile (fixture.installedModule </> "module.dhall")+        withSavedEnv "XDG_CONFIG_HOME" (Just (fixture ^. #xdgHome)) $+          withCurrentDirectory (fixture ^. #projectRoot) $ do+            beforeManifest <- LBS.readFile (fixture ^. #manifestPath)+            beforeProject <- TIO.readFile (fixture ^. #projectFile)+            beforeInstalled <- LBS.readFile (fixture ^. #installedModule </> "module.dhall")             result <- withProjectUpdate (updateRequest False) $ \case               Left err -> pure (Left err)               Right plan -> applyProjectUpdate (breakCandidatePublication plan)             result `shouldSatisfy` \case               Left UpdateCachePublicationFailed {} -> True               _ -> False-            LBS.readFile fixture.manifestPath `shouldReturn` beforeManifest-            TIO.readFile fixture.projectFile `shouldReturn` beforeProject-            LBS.readFile (fixture.installedModule </> "module.dhall") `shouldReturn` beforeInstalled+            LBS.readFile (fixture ^. #manifestPath) `shouldReturn` beforeManifest+            TIO.readFile (fixture ^. #projectFile) `shouldReturn` beforeProject+            LBS.readFile (fixture ^. #installedModule </> "module.dhall") `shouldReturn` beforeInstalled    describe "migration staging" $ do     it "preserves parameterized instances while planning their shared transition once" $@@ -345,7 +359,7 @@             parentTwo = ParentVars (Map.singleton "tenant" "two")             instanceOne = ModuleInstance "shared" parentOne             instanceTwo = ModuleInstance "shared" parentTwo-            stateFor parent = AppliedInstanceState "shared" parent "/installed/shared" (Just "1.0.0") Map.empty+            stateFor parent = AppliedInstanceState "shared" parent (LocalOrigin "shared") (Just "1.0.0") Map.empty             previous = application (AppliedModuleTarget "shared") [stateFor parentOne, stateFor parentTwo]             candidate =               Module@@ -362,14 +376,14 @@                   migrations = [Migration "1.0.0" "2.0.0" [RunCommand "true" Nothing]]                 }             appliedModules =-              [ AppliedModule "shared" parentOne "/installed/shared" (Just "1.0.0") testTime Nothing,-                AppliedModule "shared" parentTwo "/installed/shared" (Just "1.0.0") testTime Nothing+              [ AppliedModule "shared" parentOne (LocalOrigin "shared") (Just "1.0.0") testTime Nothing,+                AppliedModule "shared" parentTwo (LocalOrigin "shared") (Just "1.0.0") testTime Nothing               ]             base = emptyManifest testTime             manifest =               Manifest-                { version = base.version,-                  genAt = base.genAt,+                { version = base ^. #version,+                  genAt = base ^. #genAt,                   modules = appliedModules,                   vars = Map.empty,                   files = Map.empty,@@ -384,27 +398,29 @@         case staged of           Left err -> expectationFailure (show err)           Right migrationStage -> do-            length migrationStage.plans `shouldBe` 1-            migrationStage.plans `shouldSatisfy` all (.containsCommands)-            migrationStage.warnings `shouldBe` [MigrationCommandNotSimulated "shared" "true"]-            map (.moduleVersion) migrationStage.manifest.modules `shouldBe` [Just "2.0.0", Just "2.0.0"]+            length (migrationStage ^. #plans) `shouldBe` 1+            (migrationStage ^. #plans) `shouldSatisfy` all (^. #containsCommands)+            (migrationStage ^. #warnings) `shouldBe` [MigrationCommandNotSimulated "shared" "true"]+            map (^. #moduleVersion) (migrationStage ^. #manifest . #modules) `shouldBe` [Just "2.0.0", Just "2.0.0"]  data UpdateFixture = UpdateFixture-  { projectRoot :: FilePath,-    projectFile :: FilePath,-    manifestPath :: FilePath,-    xdgHome :: FilePath,-    installedModule :: FilePath,-    remote :: FilePath,-    applicationId :: ApplicationId+  { projectRoot :: !FilePath,+    projectFile :: !FilePath,+    manifestPath :: !FilePath,+    xdgHome :: !FilePath,+    installedModule :: !FilePath,+    remote :: !FilePath,+    applicationId :: !ApplicationId   }+  deriving stock (Generic)  data RecipeUpdateFixture = RecipeUpdateFixture-  { recipeProjectRoot :: FilePath,-    recipeManifestPath :: FilePath,-    recipeXdgHome :: FilePath,-    recipeApplicationId :: ApplicationId+  { projectRoot :: !FilePath,+    manifestPath :: !FilePath,+    xdgHome :: !FilePath,+    applicationId :: !ApplicationId   }+  deriving stock (Generic)  prepareUpdateFixture :: FilePath -> IO UpdateFixture prepareUpdateFixture root = do@@ -422,19 +438,19 @@       baselineRef = BaselineRef (hashContent baselineContent)       target = AppliedModuleTarget "demo"       applicationId = mkApplicationId target []+      demoOrigin = RemoteOrigin (T.pack remote) "demo" Nothing       app =-        (application target [instanceState "demo" installedModule])+        (application target [instanceStateFrom "demo" demoOrigin])           { applicationId,-            targetSource = installedModule,+            targetOrigin = demoOrigin,             targetVersion = Just "1.0.0",             commandReceipts = Map.singleton commandFingerprint commandReceipt,             instances =-              [ (instanceState "demo" installedModule)-                  { resolvedVars = Map.singleton "project.name" "accepted"-                  }+              [ (instanceStateFrom "demo" demoOrigin)+                  & #resolvedVars .~ Map.singleton "project.name" "accepted"               ]           }-      appliedModule = AppliedModule "demo" emptyParentVars installedModule (Just "1.0.0") testTime Nothing+      appliedModule = AppliedModule "demo" emptyParentVars demoOrigin (Just "1.0.0") testTime Nothing       fileRecord =         FileRecord           (hashContent baselineContent)@@ -444,12 +460,12 @@           (Just baselineRef)           (Set.singleton applicationId)       manifest =-        (emptyManifest testTime)-          { modules = [appliedModule],-            vars = Map.singleton "project.name" "accepted",-            files = Map.singleton "README.md" fileRecord,-            applications = [app]-          }+        ( (emptyManifest testTime)+            & #modules .~ [appliedModule]+            & #vars .~ Map.singleton "project.name" "accepted"+            & #files .~ Map.singleton "README.md" fileRecord+            & #applications .~ [app]+        )   createDirectoryIfMissing True (installedModule </> "files")   TIO.writeFile (installedModule </> "module.dhall") (moduleDhallWithTemplate "demo" "1.0.0" "old-default")   TIO.writeFile (installedModule </> "files" </> "README.tmpl") "hello {{project.name}}\nkeep\nv1\n"@@ -465,7 +481,7 @@   createDirectoryIfMissing True (projectRoot </> ".seihou" </> "baselines")   TIO.writeFile projectFile baselineContent   TIO.writeFile-    (projectRoot </> ".seihou" </> "baselines" </> T.unpack baselineRef.unBaselineRef.unSHA256)+    (projectRoot </> ".seihou" </> "baselines" </> T.unpack (baselineRef ^. #unBaselineRef . #unSHA256))     baselineContent   LBS.writeFile manifestPath (manifestToJSON manifest)   pure UpdateFixture {projectRoot, projectFile, manifestPath, xdgHome, installedModule, remote, applicationId}@@ -486,23 +502,26 @@         AppliedComposition           { applicationId,             target,-            targetSource = installedRecipe,+            targetOrigin = remoteOrigin "stack",             targetVersion = Just "1.0.0",             additionalModules = [],             namespace = Just "one",             context = Nothing,-            instances = [instanceState "old" installedOld, instanceState "one" installedOne],+            instances =+              [ instanceStateFrom "old" (remoteOrigin "old"),+                instanceStateFrom "one" (remoteOrigin "one")+              ],             commandReceipts = Map.empty,             appliedAt = testTime           }       base = emptyManifest testTime       manifest =         Manifest-          { version = base.version,-            genAt = base.genAt,+          { version = base ^. #version,+            genAt = base ^. #genAt,             modules =-              [ AppliedModule "old" emptyParentVars installedOld (Just "1.0.0") testTime Nothing,-                AppliedModule "one" emptyParentVars installedOne (Just "1.0.0") testTime Nothing+              [ AppliedModule "old" emptyParentVars (remoteOrigin "old") (Just "1.0.0") testTime Nothing,+                AppliedModule "one" emptyParentVars (remoteOrigin "one") (Just "1.0.0") testTime Nothing               ],             vars = Map.empty,             files = Map.empty,@@ -512,6 +531,7 @@             blueprintMigrations = []           }       sourceUrl = T.pack remote+      remoteOrigin name = RemoteOrigin sourceUrl name Nothing   createDirectoryIfMissing True installedOne   createDirectoryIfMissing True installedOld   createDirectoryIfMissing True installedRecipe@@ -535,10 +555,10 @@   LBS.writeFile manifestPath (manifestToJSON manifest)   pure     RecipeUpdateFixture-      { recipeProjectRoot = projectRoot,-        recipeManifestPath = manifestPath,-        recipeXdgHome = xdgHome,-        recipeApplicationId = applicationId+      { projectRoot = projectRoot,+        manifestPath = manifestPath,+        xdgHome = xdgHome,+        applicationId = applicationId       }  updateRequest :: Bool -> UpdateRequest@@ -549,7 +569,8 @@       reconfigure = False,       promptPolicy = ForbidPrompts,       commandPolicy = RunChangedCommands,-      dryRun+      dryRun,+      allowDowngrade = False     }  moduleDhallWithTemplate :: Text -> Text -> Text -> Text@@ -583,7 +604,7 @@   AppliedComposition     { applicationId = mkApplicationId target [],       target,-      targetSource = maybe "" (.source) (listToMaybe instances),+      targetOrigin = LocalOrigin targetName,       targetVersion = Just "1.0.0",       additionalModules = [],       namespace = Nothing,@@ -592,13 +613,20 @@       commandReceipts = Map.empty,       appliedAt = testTime     }+  where+    targetName = case target of+      AppliedModuleTarget name -> name ^. #unModuleName+      AppliedRecipeTarget name -> name ^. #unRecipeName -instanceState :: ModuleName -> FilePath -> AppliedInstanceState-instanceState name source =+instanceState :: ModuleName -> AppliedInstanceState+instanceState name = instanceStateFrom name (LocalOrigin (name ^. #unModuleName))++instanceStateFrom :: ModuleName -> ArtifactOrigin -> AppliedInstanceState+instanceStateFrom name origin =   AppliedInstanceState     { name,       parentVars = emptyParentVars,-      source,+      origin,       moduleVersion = Just "1.0.0",       resolvedVars = Map.empty     }@@ -677,61 +705,61 @@ manifestForApplications applicationRecords fileRecords =   let base = emptyManifest testTime    in Manifest-        { version = base.version,-          genAt = base.genAt,-          modules = base.modules,-          vars = base.vars,+        { version = base ^. #version,+          genAt = base ^. #genAt,+          modules = base ^. #modules,+          vars = base ^. #vars,           files = fileRecords,           applications = applicationRecords,-          recipe = base.recipe,-          blueprint = base.blueprint,-          blueprintMigrations = base.blueprintMigrations+          recipe = base ^. #recipe,+          blueprint = base ^. #blueprint,+          blueprintMigrations = base ^. #blueprintMigrations         }  breakCandidatePublication :: UpdatePlan -> UpdatePlan breakCandidatePublication plan =   UpdatePlan-    { applications = plan.applications,-      versionChanges = plan.versionChanges,-      inputChanges = plan.inputChanges,-      migrations = plan.migrations,-      reconciliation = plan.reconciliation,-      commandPlan = plan.commandPlan,-      candidateArtifacts = map breakArtifact plan.candidateArtifacts,-      warnings = plan.warnings,-      request = plan.request,-      snapshot = plan.snapshot,-      plannedApplications = plan.plannedApplications+    { applications = plan ^. #applications,+      versionChanges = plan ^. #versionChanges,+      inputChanges = plan ^. #inputChanges,+      migrations = plan ^. #migrations,+      reconciliation = plan ^. #reconciliation,+      commandPlan = plan ^. #commandPlan,+      candidateArtifacts = map breakArtifact (plan ^. #candidateArtifacts),+      warnings = plan ^. #warnings,+      request = plan ^. #request,+      snapshot = plan ^. #snapshot,+      plannedApplications = plan ^. #plannedApplications     }   where     breakArtifact artifact =       CandidateArtifact-        { kind = artifact.kind,-          name = artifact.name,-          version = artifact.version,-          originalDirectory = plan.snapshot.sessionDirectory </> "missing-publication-source",-          sourceDirectory = artifact.sourceDirectory,-          sourceUrl = artifact.sourceUrl,-          repoName = artifact.repoName,-          tags = artifact.tags,-          sourceRevision = artifact.sourceRevision,-          contentHash = artifact.contentHash,-          moduleDefinition = artifact.moduleDefinition,-          recipeDefinition = artifact.recipeDefinition+        { kind = artifact ^. #kind,+          name = artifact ^. #name,+          version = artifact ^. #version,+          originalDirectory = plan ^. #snapshot . #sessionDirectory </> "missing-publication-source",+          sourceDirectory = artifact ^. #sourceDirectory,+          sourceUrl = artifact ^. #sourceUrl,+          repoName = artifact ^. #repoName,+          tags = artifact ^. #tags,+          sourceRevision = artifact ^. #sourceRevision,+          contentHash = artifact ^. #contentHash,+          moduleDefinition = artifact ^. #moduleDefinition,+          recipeDefinition = artifact ^. #recipeDefinition         }  withoutApplications :: Manifest -> Manifest withoutApplications manifest =   Manifest-    { version = manifest.version,-      genAt = manifest.genAt,-      modules = manifest.modules,-      vars = manifest.vars,-      files = manifest.files,+    { version = manifest ^. #version,+      genAt = manifest ^. #genAt,+      modules = manifest ^. #modules,+      vars = manifest ^. #vars,+      files = manifest ^. #files,       applications = [],-      recipe = manifest.recipe,-      blueprint = manifest.blueprint,-      blueprintMigrations = manifest.blueprintMigrations+      recipe = manifest ^. #recipe,+      blueprint = manifest ^. #blueprint,+      blueprintMigrations = manifest ^. #blueprintMigrations     }  testTime :: UTCTime
test/Seihou/FzfSpec.hs view
@@ -1,5 +1,6 @@ module Seihou.FzfSpec (tests) where +import Data.Generics.Labels () import Data.Text qualified as T import Seihou.Core.Module (DiscoveredModule (..), DiscoveredRunnable (..), ModuleSource (..), RunnableKind (..)) import Seihou.Core.Types@@ -109,17 +110,17 @@       let dm = validModule "test-mod" "A test module" SourceUser       case formatModuleCandidate dm of         Just c -> do-          c.candidateValue `shouldBe` ModuleName "test-mod"-          T.isInfixOf "test-mod" c.candidateDisplay `shouldBe` True-          T.isInfixOf "[user]" c.candidateDisplay `shouldBe` True+          (c ^. #value) `shouldBe` ModuleName "test-mod"+          T.isInfixOf "test-mod" (c ^. #display) `shouldBe` True+          T.isInfixOf "[user]" (c ^. #display) `shouldBe` True         Nothing -> expectationFailure "expected Just"      it "returns Nothing for a failed module" $ do       let dm =             DiscoveredModule-              { discoveredResult = Left (ModuleNotFound (ModuleName "bad") []),-                discoveredSource = SourceProject,-                discoveredDir = "/tmp/bad"+              { result = Left (ModuleNotFound (ModuleName "bad") []),+                source = SourceProject,+                dir = "/tmp/bad"               }       case formatModuleCandidate dm of         Nothing -> pure ()@@ -128,7 +129,7 @@     it "includes description when present" $ do       let dm = validModule "mod" "My description" SourceInstalled       case formatModuleCandidate dm of-        Just c -> T.isInfixOf "My description" c.candidateDisplay `shouldBe` True+        Just c -> T.isInfixOf "My description" (c ^. #display) `shouldBe` True         Nothing -> expectationFailure "expected Just"      it "tags source correctly" $ do@@ -137,32 +138,32 @@           dmInstalled = validModule "m" "d" SourceInstalled       case (formatModuleCandidate dmProject, formatModuleCandidate dmUser, formatModuleCandidate dmInstalled) of         (Just p, Just u, Just i) -> do-          T.isInfixOf "[project]" p.candidateDisplay `shouldBe` True-          T.isInfixOf "[user]" u.candidateDisplay `shouldBe` True-          T.isInfixOf "[installed]" i.candidateDisplay `shouldBe` True+          T.isInfixOf "[project]" (p ^. #display) `shouldBe` True+          T.isInfixOf "[user]" (u ^. #display) `shouldBe` True+          T.isInfixOf "[installed]" (i ^. #display) `shouldBe` True         _ -> expectationFailure "expected all Just"    describe "formatRunnableCandidate" $ do     it "tags prompt candidates with [prompt]" $ do       let dr =             DiscoveredRunnable-              { drName = "review-changes",-                drDescription = Just "Review current changes",-                drKind = KindPrompt,-                drSource = SourceProject,-                drDir = "/tmp/review-changes",-                drIsError = False,-                drError = Nothing+              { name = "review-changes",+                description = Just "Review current changes",+                kind = KindPrompt,+                source = SourceProject,+                dir = "/tmp/review-changes",+                isError = False,+                error = Nothing               }       case formatRunnableCandidate dr of-        Just c -> T.isInfixOf "[prompt]" c.candidateDisplay `shouldBe` True+        Just c -> T.isInfixOf "[prompt]" (c ^. #display) `shouldBe` True         Nothing -> expectationFailure "expected Just"  -- | Helper to create a valid discovered module for testing. validModule :: String -> String -> ModuleSource -> DiscoveredModule validModule name desc src =   DiscoveredModule-    { discoveredResult =+    { result =         Right           Module             { name = ModuleName (T.pack name),@@ -177,6 +178,6 @@               removal = Nothing,               migrations = []             },-      discoveredSource = src,-      discoveredDir = "/tmp/" ++ name+      source = src,+      dir = "/tmp/" ++ name     }