settei-optparse-applicative 0.2.0.0 → 0.3.0.0

raw patch · 7 files changed

+490/−49 lines, 7 filesdep ~setteidep ~settei-envdep ~settei-optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: settei, settei-env, settei-optparse-applicative

API changes (from Hackage documentation)

Files

• CHANGELOG.md +30/−0
• settei-optparse-applicative.cabal +44/−38
• src/Settei/Optparse.hs +107/−8
• test/Settei/OptparseTest.hs +276/−3
• test/compile-fail/OldResolutionDispatch.hs +7/−0
• test/compile-fail/OldValidatedDispatch.hs +7/−0
• test/compile-pass/CheckedDispatch.hs +19/−0

@@ -1,5 +1,35 @@ # Changelog for settei-optparse-applicative +## 0.3.0.0 — 2026-10-21++### Breaking Changes++- `DiagnosticMode` gains `DeploymentContractText` and `DeploymentContractJson`; update+  exhaustive matches.+- Require `prepareDiagnostic` before runtime acquisition. Export `DiagnosticPreparation`+  with rejected, rendered, and runtime-token decisions; `RuntimeDiagnosticMode` stays abstract.+- `resolutionDiagnostic` and `validatedDiagnostic` consume the checked runtime token and+  return `DiagnosticDecision` (`DiagnosticFailure`, `DiagnosticOutput`,+  `DiagnosticContinue`). Only successful normal execution continues; check success now+  checks resolution itself. Migrate with the `settei-upgrade` Seihou blueprint.++### New Features++- Add deployment contract diagnostic flags (`--deployment-contract`,+  `--deployment-contract-json`) and the `contractDiagnostic` rendering selector.+- Add `validatedDiagnostic`: startup and all diagnostic modes consume one validated+  answer. Check success follows application validation. JSON explain failure emits error+  and resolution documents on separate stderr lines, including on base resolution failures.+- Missing contract support (`Nothing`) rejects both contract modes with fixed plain text+  `deployment contract diagnostic is unavailable\n` before any runtime work. Partial+  schema/contract selectors remain rendering utilities, never startup permission.++### Other Changes++- Preserve version-1 successful JSON, bare text-plus-JSON and validated two-JSON failure+  formats, and application-owned warning, stream, and exit policy.+- The `settei` and `settei-env` pins move to `==0.3.0.0`.+ ## 0.2.0.0 — 2026-07-19  - Breaking: replace `ExplainMode` and its parsers with `DiagnosticMode`, which also

@@ -1,62 +1,68 @@-cabal-version:   3.8-name:            settei-optparse-applicative-version:         0.2.0.0-synopsis:        optparse-applicative sources for Settei+cabal-version: 3.8+name: settei-optparse-applicative+version: 0.3.0.0+synopsis: optparse-applicative sources for Settei description:   Parse generic and named command-line overrides into provenance-aware Settei   source fragments while preserving occurrence order. -homepage:        https://github.com/shinzui/settei-bug-reports:     https://github.com/shinzui/settei/issues-license:         BSD-3-Clause-license-file:    LICENSE-author:          shinzui-maintainer:      shinzui-category:        Configuration-build-type:      Simple-tested-with:     GHC ==9.12.4+homepage: https://github.com/shinzui/settei+bug-reports: https://github.com/shinzui/settei/issues+license: BSD-3-Clause+license-file: LICENSE+author: shinzui+maintainer: shinzui+category: Configuration+build-type: Simple+tested-with: ghc ==9.12.4 extra-doc-files: CHANGELOG.md+extra-source-files:+  test/compile-fail/OldResolutionDispatch.hs+  test/compile-fail/OldValidatedDispatch.hs+  test/compile-pass/CheckedDispatch.hs  source-repository head-  type:     git+  type: git   location: https://github.com/shinzui/settei.git  common common-  default-language:   GHC2024+  default-language: GHC2024   default-extensions:     DeriveAnyClass     DuplicateRecordFields     OverloadedLabels     OverloadedStrings -  ghc-options:        -Wall -Wcompat+  ghc-options:+    -Wall+    -Wcompat  library-  import:          common-  hs-source-dirs:  src+  import: common+  hs-source-dirs: src   exposed-modules: Settei.Optparse   build-depends:-    , base                  >=4.21    && <5-    , containers            >=0.6.8   && <0.8-    , generic-lens          >=2.2     && <2.4-    , optparse-applicative  >=0.19    && <0.20-    , settei                ==0.2.0.0-    , text                  >=2.1     && <2.2+    base >=4.21 && <5,+    containers >=0.6.8 && <0.8,+    generic-lens >=2.2 && <2.4,+    optparse-applicative >=0.19 && <0.20,+    settei ==0.3.0.0,+    text >=2.1 && <2.2,  test-suite settei-optparse-applicative-tests-  import:         common-  type:           exitcode-stdio-1.0+  import: common+  type: exitcode-stdio-1.0   hs-source-dirs: test-  main-is:        Main.hs-  other-modules:  Settei.OptparseTest+  main-is: Main.hs+  other-modules: Settei.OptparseTest   build-depends:-    , base                         >=4.21    && <5-    , containers                   >=0.6.8   && <0.8-    , generic-lens                 >=2.2     && <2.4-    , optparse-applicative         >=0.19    && <0.20-    , settei                       ==0.2.0.0-    , settei-env                   ==0.2.0.0-    , settei-optparse-applicative  ==0.2.0.0-    , tasty                        >=1.5     && <1.6-    , tasty-hunit                  >=0.10.2  && <0.11-    , text                         >=2.1     && <2.2+    base >=4.21 && <5,+    containers >=0.6.8 && <0.8,+    generic-lens >=2.2 && <2.4,+    optparse-applicative >=0.19 && <0.20,+    settei ==0.3.0.0,+    settei-env ==0.3.0.0,+    settei-optparse-applicative ==0.3.0.0,+    tasty >=1.5 && <1.6,+    tasty-hunit >=0.10.2 && <0.11,+    text >=2.1 && <2.2,

@@ -1,15 +1,28 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}+ -- | -- Module: Settei.Optparse -- Description: optparse-applicative parsers that produce ordered Settei sources.+--+-- Applications with validators must consume 'validatedDiagnostic' after 'validate',+-- rather than calling 'resolutionDiagnostic' on the pre-validation result. Always+-- use 'prepareDiagnostic' before source acquisition. Only a successful+-- 'DiagnosticContinue' authorizes application startup. module Settei.Optparse   ( CliOverride,     DiagnosticMode (..),+    DiagnosticDecision (..),+    RuntimeDiagnosticMode,+    DiagnosticPreparation (..),+    prepareDiagnostic,+    validatedDiagnostic,     SetteiOptions (..),     cliOverride,     cliOverrideKey,     cliOverrideSpelling,     cliOverrideValue,     cliSources,+    contractDiagnostic,     configPathOptions,     configPathOptionsWith,     diagnosticModeOptions,@@ -51,6 +64,8 @@   | CheckConfig   | DescribeConfigText   | DescribeConfigJson+  | DeploymentContractText+  | DeploymentContractJson   deriving stock (Generic, Eq, Ord, Show)  -- | Reusable configuration and diagnostic command-line options.@@ -143,23 +158,71 @@     Applicative.<|> Options.flag' CheckConfig (Options.long "check-config" <> Options.help "Validate configuration and exit")     Applicative.<|> Options.flag' DescribeConfigText (Options.long "describe-config" <> Options.help "Print the static configuration schema")     Applicative.<|> Options.flag' DescribeConfigJson (Options.long "describe-config-json" <> Options.help "Print the static configuration schema as JSON")+    Applicative.<|> Options.flag' DeploymentContractText (Options.long "deployment-contract" <> Options.help "Print the deployment configuration contract")+    Applicative.<|> Options.flag' DeploymentContractJson (Options.long "deployment-contract-json" <> Options.help "Print the deployment configuration contract as JSON")     Applicative.<|> pure NoDiagnostic --- | Render a diagnostic that must not load configuration sources.+-- | Partial schema rendering selector. Nothing means unhandled, never permission+-- to start. Use 'prepareDiagnostic' for complete dispatch before runtime work. schemaDiagnostic :: DiagnosticMode -> Schema -> Maybe Text schemaDiagnostic mode schema = case mode of   DescribeConfigText -> Just (renderSchemaText schema)   DescribeConfigJson -> Just (renderSchemaJson schema <> "\n")   _ -> Nothing --- | Render a diagnostic available after resolution.-resolutionDiagnostic :: DiagnosticMode -> ResolveResult a -> Maybe Text-resolutionDiagnostic mode result = case mode of-  ExplainText -> Just (renderResolutionText (result ^. #report))-  ExplainJson -> Just (renderResolutionJson (result ^. #report) <> "\n")-  CheckConfig -> Just "configuration valid\n"-  _ -> Nothing+-- | Runtime-only permission returned by 'prepareDiagnostic'. Constructors are private;+-- there is deliberately no Generic or Read instance or unchecked conversion.+-- Use the token for the invocation that produced it; do not cache or reuse it.+data RuntimeDiagnosticMode+  = RuntimeNormal+  | RuntimeCheck+  | RuntimeExplainText+  | RuntimeExplainJson +-- | Complete dispatch before acquiring any runtime inputs.+data DiagnosticPreparation+  = DiagnosticRejected !Text+  | DiagnosticRendered !Text+  | DiagnosticNeedsRuntime !RuntimeDiagnosticMode++-- | Select the mode before inspecting schema or optional contract support.+-- Nothing declares unavailable contract support. Runtime permission authorizes input+-- acquisition and resolution; only 'DiagnosticContinue' authorizes startup.+prepareDiagnostic :: DiagnosticMode -> Schema -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> DiagnosticPreparation+prepareDiagnostic mode schema contract = case mode of+  NoDiagnostic -> DiagnosticNeedsRuntime RuntimeNormal+  CheckConfig -> DiagnosticNeedsRuntime RuntimeCheck+  ExplainText -> DiagnosticNeedsRuntime RuntimeExplainText+  ExplainJson -> DiagnosticNeedsRuntime RuntimeExplainJson+  DescribeConfigText -> DiagnosticRendered (renderSchemaText schema)+  DescribeConfigJson -> DiagnosticRendered (renderSchemaJson schema <> "\n")+  DeploymentContractText -> prepareContract renderContractText+  DeploymentContractJson -> prepareContract ((<> "\n") . renderContractJson)+  where+    prepareContract render = case contract of+      Nothing -> DiagnosticRejected "deployment contract diagnostic is unavailable\n"+      Just (Left errors) -> DiagnosticRejected (renderErrorsText errors)+      Just (Right value) -> DiagnosticRendered (render value)++-- | Dispatch a checked runtime request after resolution. This checks resolution only;+-- applications with invariants must 'validate' and use 'validatedDiagnostic'.+-- Warnings remain on the result for application-owned stream and exit policy.+resolutionDiagnostic :: RuntimeDiagnosticMode -> ResolveResult a -> DiagnosticDecision a+resolutionDiagnostic mode result = case result ^. #answer of+  Left errors -> DiagnosticFailure $ case mode of+    RuntimeNormal -> renderErrorsText errors+    RuntimeCheck -> renderErrorsText errors+    RuntimeExplainText -> renderErrorsText errors <> explanationText+    RuntimeExplainJson -> renderErrorsText errors <> explanationJson+  Right value -> case mode of+    RuntimeNormal -> DiagnosticContinue value+    RuntimeCheck -> DiagnosticOutput "configuration valid\n"+    RuntimeExplainText -> DiagnosticOutput explanationText+    RuntimeExplainJson -> DiagnosticOutput explanationJson+  where+    explanationText = renderResolutionText (result ^. #report)+    explanationJson = renderResolutionJson (result ^. #report) <> "\n"+ -- | Parse the reusable Configuration and Diagnostics option groups. setteiOptions :: Parser SetteiOptions setteiOptions = assemble <$> configurationOptions <*> diagnosticOptions@@ -224,3 +287,39 @@     (\segment child -> RawObject (Map.singleton segment child))     value     (NonEmpty.toList (keySegments key))++-- | Partial contract rendering selector. Nothing means unhandled, never permission+-- to start. Other modes never force the contract; use 'prepareDiagnostic' for dispatch.+contractDiagnostic :: DiagnosticMode -> Either (NonEmpty ConfigError) DeploymentContract -> Maybe (Either (NonEmpty ConfigError) Text)+contractDiagnostic mode contract = case mode of+  DeploymentContractText -> Just (renderContractText <$> contract)+  DeploymentContractJson -> Just ((<> "\n") . renderContractJson <$> contract)+  _ -> Nothing++-- | A complete runtime dispatch decision. No Show or Eq instance because+-- the continue case carries a typed value that may contain secrets.+data DiagnosticDecision a+  = DiagnosticFailure !Text+  | DiagnosticOutput !Text+  | DiagnosticContinue a+  deriving stock (Generic)++-- | Share rejection, provenance, and validation outcomes across startup and modes.+-- Failures go to stderr with the application's resolution exit code; output goes to+-- stdout with exit zero. Continue starts the application with the validated value.+validatedDiagnostic :: RuntimeDiagnosticMode -> ValidatedResult a -> DiagnosticDecision a+validatedDiagnostic mode result =+  case result ^. #answer of+    Left errors -> DiagnosticFailure $ case mode of+      RuntimeExplainText -> renderErrorsText errors <> explanationText+      RuntimeExplainJson -> renderErrorsJson errors <> "\n" <> explanationJson+      RuntimeNormal -> renderErrorsText errors+      RuntimeCheck -> renderErrorsText errors+    Right value -> case mode of+      RuntimeExplainText -> DiagnosticOutput explanationText+      RuntimeExplainJson -> DiagnosticOutput explanationJson+      RuntimeCheck -> DiagnosticOutput "configuration valid\n"+      RuntimeNormal -> DiagnosticContinue value+  where+    explanationText = renderResolutionText (result ^. #report) <> renderValidationText (result ^. #validation)+    explanationJson = renderValidatedResolutionJson (result ^. #report) (result ^. #validation) <> "\n"

@@ -1,6 +1,7 @@ module Settei.OptparseTest (tests) where  import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Text qualified as Text@@ -16,7 +17,28 @@ tests =   testGroup     "Settei.Optparse"-    [ testCase "final repeated --set wins with shadow trace" $ do+    [ preparationTests,+      validationTests,+      testCase "deployment contract modes parse and reject combinations" $ do+        mapM_+          ( \(flag, mode) -> do+              parsed <- expectParse diagnosticModeOptions [flag]+              parsed @?= mode+              mapM_+                (\other -> assertBool "combined diagnostics parsed" (Options.getParseResult (parse diagnosticModeOptions [flag, other]) == Nothing))+                ["--check-config", "--describe-config", "--explain-config-json", if flag == "--deployment-contract" then "--deployment-contract-json" else "--deployment-contract"]+          )+          [("--deployment-contract", DeploymentContractText), ("--deployment-contract-json", DeploymentContractJson)],+      testCase "contract diagnostic is lazy for unrelated modes and preserves failures" $ do+        mapM_+          (\mode -> contractDiagnostic mode (error "contract forced") @?= Nothing)+          [NoDiagnostic, CheckConfig, DescribeConfigText, DescribeConfigJson, ExplainText, ExplainJson]+        let contract = deploymentContract emptyContractInputs (required portSetting)+            errors = DefaultCycle (DefaultCycleProblem (RuleName "loop" :| [])) :| []+        contractDiagnostic DeploymentContractText contract @?= Just (renderContractText <$> contract)+        contractDiagnostic DeploymentContractJson contract @?= Just ((<> "\n") . renderContractJson <$> contract)+        contractDiagnostic DeploymentContractText (Left errors) @?= Just (Left errors),+      testCase "final repeated --set wins with shadow trace" $ do         overrides <- expectParse overrideOptions ["--set", "service.port=9000", "--set", "service.port=9001"]         environment <- environmentPort 8000         let result =@@ -92,8 +114,12 @@             result = resolve defaultResolveOptions [portSource "test" BuiltInSource 8080] (required portSetting)         assertBool "text schema diagnostic missing" (schemaDiagnostic DescribeConfigText schema /= Nothing)         assertBool "JSON schema diagnostic missing" (schemaDiagnostic DescribeConfigJson schema /= Nothing)-        resolutionDiagnostic CheckConfig result @?= Just "configuration valid\n"-        resolutionDiagnostic NoDiagnostic result @?= Nothing,+        case resolutionDiagnostic (runtime CheckConfig) result of+          DiagnosticOutput output -> output @?= "configuration valid\n"+          _ -> fail "expected successful check"+        case resolutionDiagnostic (runtime NoDiagnostic) result of+          DiagnosticContinue value -> value @?= 8080+          _ -> fail "expected startup permission",       testCase "help groups configuration and diagnostics by intent" $ do         let parserInfo = Options.info (setteiOptions Options.<**> Options.helper) Options.fullDesc         case Options.execParserPure Options.defaultPrefs parserInfo ["--help"] of@@ -101,6 +127,9 @@             let (helpText, _) = Options.renderFailure failure "settei-example"             assertBool "Configuration group missing" ("Configuration" `Text.isInfixOf` Text.pack helpText)             assertBool "Diagnostics group missing" ("Diagnostics" `Text.isInfixOf` Text.pack helpText)+            mapM_+              (\flag -> assertBool "contract flag missing from help" (flag `Text.isInfixOf` Text.pack helpText))+              ["--deployment-contract", "--deployment-contract-json"]           _ -> fail "expected --help to produce parser help"     ] @@ -156,3 +185,247 @@  secretSentinel :: Text secretSentinel = "never-render-this-cli-secret"++validationTests :: TestTree+validationTests =+  testGroup+    "validated diagnostics"+    [ testCase "check succeeds only after validation and startup gets the same value" $ do+        case validatedDiagnostic (runtime CheckConfig) passingResult of+          DiagnosticOutput output -> output @?= "configuration valid\n"+          _ -> fail "check did not succeed"+        case validatedDiagnostic (runtime NoDiagnostic) passingResult of+          DiagnosticContinue value -> assertBool "typed value changed" (Right value == validationBase [] ^. #answer)+          _ -> fail "startup did not continue",+      testCase "all runtime modes reject a failing validated result" $+        mapM_+          ( \mode -> case validatedDiagnostic (runtime mode) failingResult of+              DiagnosticFailure output -> do+                assertBool "rule missing" ("pool-covers-workers" `Text.isInfixOf` output)+                assertBool "key missing" ("service.poolSize" `Text.isInfixOf` output)+                assertBool "check falsely succeeded" (not ("configuration valid" `Text.isInfixOf` output))+                safe output+              _ -> fail "invalid configuration accepted"+          )+          modes,+      testCase "text success and failure include provenance and outcomes" $ do+        case validatedDiagnostic (runtime ExplainText) passingResult of+          DiagnosticOutput output -> do+            assertBool "setting missing" ("service.workers = \"4\"" `Text.isInfixOf` output)+            assertBool "outcome missing" ("invariant pool-covers-workers [passed]" `Text.isInfixOf` output)+            safe output+          _ -> fail "explain did not succeed"+        case validatedDiagnostic (runtime ExplainText) failingResult of+          DiagnosticFailure output -> do+            assertBool "origin missing" ("from environment source validation fixture" `Text.isInfixOf` output)+            assertBool "failed trace missing" ("[failed (1 violation)]" `Text.isInfixOf` output)+            safe output+          _ -> fail "explain did not fail",+      testCase "JSON success is one line and failure is two versioned documents" $ do+        case validatedDiagnostic (runtime ExplainJson) passingResult of+          DiagnosticOutput output -> do+            length (Text.lines output) @?= 1+            assertBool "resolution type missing" ("{\"schemaVersion\":1,\"type\":\"settei.resolution\"" `Text.isPrefixOf` output)+            assertBool "invariant array missing" ("\"invariants\":[{\"rule\":\"pool-covers-workers\"" `Text.isInfixOf` output)+            safe output+          _ -> fail "explain did not succeed"+        case validatedDiagnostic (runtime ExplainJson) failingResult of+          DiagnosticFailure output -> case Text.lines output of+            [errors, report] -> do+              assertBool "error document missing" ("{\"schemaVersion\":1,\"type\":\"settei.errors\"" `Text.isPrefixOf` errors)+              assertBool "invariant kind missing" ("\"kind\":\"invariant\"" `Text.isInfixOf` errors)+              assertBool "origin missing" ("\"name\":\"validation fixture\",\"key\":\"service.poolSize\"" `Text.isInfixOf` report)+              assertBool "failed outcome missing" ("\"status\":\"failed\"" `Text.isInfixOf` report)+              safe output+            _ -> fail "expected two JSON documents"+          _ -> fail "explain did not fail",+      testCase "missing and decode failures retain original evidence and not-run outcomes" $+        mapM_+          ( \base -> do+              let result = validate validationRules base+              assertBool "answer changed" (result ^. #answer == base ^. #answer)+              result ^. #report @?= base ^. #report+              result ^. #warnings @?= base ^. #warnings+              fmap (^. #status) (validationOutcomes (result ^. #validation)) @?= [InvariantNotRun]+              case validatedDiagnostic (runtime ExplainText) result of+                DiagnosticFailure output -> do+                  assertBool "not-run trace missing" ("[not run]" `Text.isInfixOf` output)+                  safe output+                _ -> fail "base error accepted"+              case validatedDiagnostic (runtime ExplainJson) result of+                DiagnosticFailure output -> length (Text.lines output) @?= 2+                _ -> fail "base JSON error accepted"+          )+          [ resolve defaultResolveOptions [] validationConfig,+            validationBase [("service.workers", RawText "broken")]+          ],+      testCase "nonempty warnings and provenance survive runtime dispatch" $ do+        let base = validationBase [("unknown.setting", RawText "public")]+            result = validate validationRules base+        assertBool "warning fixture empty" (not (null (base ^. #warnings)))+        result ^. #warnings @?= base ^. #warnings+        result ^. #report @?= base ^. #report+        mapM_+          ( \mode -> case validatedDiagnostic (runtime mode) result of+              DiagnosticContinue value -> assertBool "value changed" (Right value == base ^. #answer)+              DiagnosticOutput output -> safe output+              DiagnosticFailure _ -> fail "valid result rejected"+          )+          [NoDiagnostic, CheckConfig, ExplainText, ExplainJson]+    ]+  where+    passingResult = validate validationRules (validationBase [])+    failingResult = validate validationRules (validationBase [("service.poolSize", RawText "1")])+    modes = [NoDiagnostic, ExplainText, ExplainJson, CheckConfig]+    safe output = assertBool "secret escaped into diagnostic" (not (any (`Text.isInfixOf` output) [validationSentinel, "SETTEI_VALIDATION_SECRET_29"]))++validationSentinel :: Text+validationSentinel = "SETTEI_VALIDATION_SECRET_29\"\\\n秘密"++validationConfig :: Config (Int, Int, Text)+validationConfig =+  (,,)+    <$> required (publicSetting (validKey "service.workers") "workers" boundedIntegralDecoder)+    <*> required (publicSetting (validKey "service.poolSize") "pool" boundedIntegralDecoder)+    <*> required (secretSetting (validKey "service.token") "token" textDecoder)++validationRules :: Validators (Int, Int, Text)+validationRules =+  either (error . Text.unpack . renderValidatorErrorsText) id $+    validators validationConfig [check (InvariantRule "pool-covers-workers") (fmap validKey ["service.poolSize", "service.workers"]) "pool must cover workers" (\(workers, pool, _) -> pool >= workers)]++validationBase :: [(Text, RawValue)] -> ResolveResult (Int, Int, Text)+validationBase changes = resolve defaultResolveOptions [input] validationConfig+  where+    pairs = [("service.workers", RawText "4"), ("service.poolSize", RawText "8"), ("service.token", RawText validationSentinel)]+    input = either (const (error "invalid fixture")) id (sourceFromPairs "validation fixture" EnvironmentSource [(validKey name, value) | (name, value) <- changes <> filter (\(name, _) -> name `notElem` fmap fst changes) pairs])++-- Test-only extraction; production consumers must handle all preparation decisions.+runtime :: DiagnosticMode -> RuntimeDiagnosticMode+runtime mode = case prepareDiagnostic mode (error "schema forced") (error "contract forced") of+  DiagnosticNeedsRuntime token -> token+  DiagnosticRendered _ -> error "expected runtime mode"+  DiagnosticRejected _ -> error "expected runtime mode"++allModes :: [DiagnosticMode]+allModes = [NoDiagnostic, CheckConfig, ExplainText, ExplainJson, DescribeConfigText, DescribeConfigJson, DeploymentContractText, DeploymentContractJson]++-- An exhaustive, independent expectation ensures newly added constructors need tests.+isRuntime :: DiagnosticMode -> Bool+isRuntime = \case+  NoDiagnostic -> True+  CheckConfig -> True+  ExplainText -> True+  ExplainJson -> True+  DescribeConfigText -> False+  DescribeConfigJson -> False+  DeploymentContractText -> False+  DeploymentContractJson -> False++-- Consumer-shaped public API boundary: input acquisition and startup are separate.+consumer :: DiagnosticMode -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> IO (ResolveResult Int) -> IO () -> IO (Int, Text, Text)+consumer mode contract acquire startup =+  case prepareDiagnostic mode (describe (required portSetting)) contract of+    DiagnosticRejected message -> pure (4, "", message)+    DiagnosticRendered output -> pure (0, output, "")+    DiagnosticNeedsRuntime token -> do+      result <- acquire+      case resolutionDiagnostic token result of+        DiagnosticFailure message -> pure (4, "", message)+        DiagnosticOutput output -> pure (0, output, renderWarningsText (result ^. #warnings))+        DiagnosticContinue _ -> startup >> pure (0, "started\n", renderWarningsText (result ^. #warnings))++preparationTests :: TestTree+preparationTests =+  testGroup+    "complete dispatch"+    [ testCase "all eight modes acquire once and start only successful normal execution" $+        mapM_+          ( \mode -> do+              acquisitions <- newIORef (0 :: Int)+              starts <- newIORef (0 :: Int)+              let result = resolve defaultResolveOptions [portSource "fixture" BuiltInSource 8080] (required portSetting)+              (code, output, errors) <- consumer mode supported (modifyIORef' acquisitions (+ 1) >> pure result) (modifyIORef' starts (+ 1))+              code @?= 0+              errors @?= ""+              assertBool "empty output" (not (Text.null output))+              readIORef acquisitions >>= (@?= if isRuntime mode then 1 else 0)+              readIORef starts >>= (@?= if mode == NoDiagnostic then 1 else 0)+          )+          allModes,+      testCase "parsed contract flags reject omitted support before acquisition or startup" $+        mapM_+          ( \flag -> do+              mode <- expectParse diagnosticModeOptions [flag]+              result <- consumer mode Nothing poison poison+              result @?= (4, "", "deployment contract diagnostic is unavailable\n")+              (code, output, errors) <- consumer mode supported poison poison+              code @?= 0+              errors @?= ""+              assertBool "contract missing" ("service.port" `Text.isInfixOf` output)+          )+          ["--deployment-contract", "--deployment-contract-json"],+      testCase "mode selection leaves unrelated schema and contract unevaluated" $ do+        mapM_+          ( \mode -> case prepareDiagnostic mode poisonValue poisonValue of+              DiagnosticNeedsRuntime _ -> pure ()+              _ -> fail "expected runtime permission"+          )+          [NoDiagnostic, CheckConfig, ExplainText, ExplainJson]+        mapM_+          ( \mode -> case prepareDiagnostic mode (describe (required portSetting)) poisonValue of+              DiagnosticRendered output -> assertBool "schema missing" ("service.port" `Text.isInfixOf` output)+              _ -> fail "expected schema"+          )+          [DescribeConfigText, DescribeConfigJson]+        mapM_+          ( \mode -> case prepareDiagnostic mode poisonValue supported of+              DiagnosticRendered output -> assertBool "contract missing" ("service.port" `Text.isInfixOf` output)+              _ -> fail "expected contract"+          )+          [DeploymentContractText, DeploymentContractJson],+      testCase "contract construction errors reject safely before runtime" $+        mapM_+          ( \mode -> do+              let problems = DefaultCycle (DefaultCycleProblem (RuleName "loop" :| [])) :| []+              consumer mode (Just (Left problems)) poison poison >>= (@?= (4, "", renderErrorsText problems))+          )+          [DeploymentContractText, DeploymentContractJson],+      testCase "bare runtime dispatch preserves errors, provenance, JSON, warnings and secrets" $+        mapM_+          ( \mode ->+              mapM_+                ( \base -> do+                    let result = resolutionDiagnostic (runtime mode) base+                    case base ^. #answer of+                      Left problems -> case result of+                        DiagnosticFailure output -> do+                          let suffix = case mode of+                                ExplainText -> renderResolutionText (base ^. #report)+                                ExplainJson -> renderResolutionJson (base ^. #report) <> "\n"+                                _ -> ""+                          output @?= renderErrorsText problems <> suffix+                          assertBool "false success" (not ("configuration valid" `Text.isInfixOf` output))+                          safe output+                        _ -> fail "resolution failure accepted"+                      Right _ -> case result of+                        DiagnosticContinue _ -> mode @?= NoDiagnostic+                        DiagnosticOutput output -> do+                          assertBool "bare JSON gained invariants" (not ("invariants" `Text.isInfixOf` output))+                          safe output+                        DiagnosticFailure _ -> fail "resolution success rejected"+                )+                [validationBase [], resolve defaultResolveOptions [] validationConfig, validationBase [("service.workers", RawText "broken")], validationBase [("unknown.setting", RawText "public")]]+          )+          [NoDiagnostic, CheckConfig, ExplainText, ExplainJson],+      testCase "normal failure never starts" $ do+        let missing = resolve defaultResolveOptions [] (required portSetting)+        (code, output, _) <- consumer NoDiagnostic supported (pure missing) poison+        code @?= 4+        output @?= ""+    ]+  where+    supported = Just (deploymentContract emptyContractInputs (required portSetting))+    poison = fail "runtime effect invoked"+    poisonValue = error "unused static input forced"+    safe output = assertBool "secret leaked" (not (any (`Text.isInfixOf` output) [validationSentinel, "SETTEI_VALIDATION_SECRET_29"]))

@@ -0,0 +1,7 @@+module OldResolutionDispatch (oldDispatch) where++import Settei+import Settei.Optparse++oldDispatch :: ResolveResult a -> DiagnosticDecision a+oldDispatch = resolutionDiagnostic DeploymentContractJson

@@ -0,0 +1,7 @@+module OldValidatedDispatch (oldDispatch) where++import Settei+import Settei.Optparse++oldDispatch :: ValidatedResult a -> DiagnosticDecision a+oldDispatch = validatedDiagnostic DescribeConfigJson

@@ -0,0 +1,19 @@+module CheckedDispatch (dispatch) where++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Settei+import Settei.Optparse++-- The caller owns stream routing, exit policy, and warning reporting.+dispatch :: DiagnosticMode -> Schema -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> IO (ResolveResult a) -> (a -> IO ()) -> IO (Either Text Text)+dispatch mode schema contract acquire startup =+  case prepareDiagnostic mode schema contract of+    DiagnosticRejected problems -> pure (Left problems)+    DiagnosticRendered output -> pure (Right output)+    DiagnosticNeedsRuntime runtimeMode -> do+      result <- acquire+      case resolutionDiagnostic runtimeMode result of+        DiagnosticFailure problems -> pure (Left problems)+        DiagnosticOutput output -> pure (Right output)+        DiagnosticContinue config -> startup config >> pure (Right mempty)