packages feed

figment (empty) → 0.2.0.0

raw patch · 84 files changed

+7979/−0 lines, 84 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, bytestring, conduit, containers, criterion, deepseq, directory, figment, filepath, libyaml, scientific, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, temporary, text, time, toml-parser, vector

Files

+ ADRs/001-defaultDepth-64.md view
@@ -0,0 +1,41 @@+# ADR 001 — defaultDepth = 64++> **Amended by ADR 017 (0.2.0.0): the depth budget is now one of two `Limits`, enforced inside every parser; the root dictionary counts as depth 1.**+++**Status:** Accepted (provisional; see Gate 2(e))+**Date:** 2026-10-21+**Standard rule under review:** §5.9 (deviations recorded)++## Context++`Figment.Value.defaultDepth` is the recursion budget every built-in+provider gets when the caller does not override it. The feasibility study+(§1.3, §11 item 3, §12 Gate 2(e)) records this value as "a judgment call,+not a proof".++## Decision++Use `64`.++## Rationale++- Any hand-authored configuration schema deeper than 64 levels is already+  a schema smell; 64 comfortably exceeds real configs while bounding+  worst-case stack use to a small constant (Standard §4.10).+- Callers whose schema legitimately needs more can pass an explicit+  `Depth` to `tagProvider`; the default is not a hard ceiling.++## What this ADR does *not* claim++- That 64 is empirically correct. It is provisional. Gate 2(e) (Standard+  §5.6 benchmark on a realistic config, feasibility study §12) is the+  evidence-gathering step, and if it shows a different number is right,+  this ADR is superseded rather than edited.++## Consequences++- `Figment.Value.defaultDepth` stays a single named constant.+- Any change to `64` is a breaking change only if it lowers the value+  (would turn currently-accepted inputs into `DepthExceeded`); raising it+  is non-breaking.
+ ADRs/002-cpp-for-foldl-import.md view
@@ -0,0 +1,25 @@+# ADR 002 — CPP guard for the foldl' import in Figment.Layer++> **Superseded by ADR 016 (0.2.0.0): base >= 4.20 only, so `foldl'` comes from the Prelude and the codebase has no CPP.**++Status: Accepted | Date: 2026-10-21 | Rule: §1.8, §0.7++## Context+`foldl'` is in Data.List/Data.Foldable on base < 4.20 (GHC < 9.10);+it is re-exported by Prelude on base >= 4.20 (GHC >= 9.10). An+unconditional import fails -Wunused-imports under -Werror on GHC >= 9.10;+omitting it fails scope on GHC < 9.10.++## Decision+CPP-guarded import with CPP in default-extensions:++    #if !MIN_VERSION_base(4,20,0)+    import Data.Foldable (foldl')+    #endif++## Rationale+Dropping GHC < 9.10 rejected (matrix requirement). Reimplementing foldl'+violates §4.7. CPP is the standard zero-cost mechanism for this case.++## Consequences+This is the only CPP in the codebase and should remain so.
+ ADRs/003-nfdata-instances.md view
@@ -0,0 +1,22 @@+# ADR 003 — Manual NFData instances on the value domain++> **Superseded by ADR 016 (0.2.0.0): NFData instances are derived (`deriving anyclass NFData`) on GHC 9.10 and 9.12. The 9.14 failure this ADR cited was never reproduced on a supported compiler.**++Status: Accepted | Date: 2026-10-21 | Rule: §5.6++## Context+criterion's `nf` requires NFData on the benchmarked output type.+`mkTagged` returns `Either ConfigError Tagged`; `mergeAlg` returns `Tagged`.++## Decision+Hand-written NFData instances on Key, SourceId, Path, Profile,+ProfileName, Depth, Value, Metadata, Tagged, ConfigError.++## Rationale+Deriving NFData via Generic failed on GHC 9.14. Manual instances work+identically on GHC 9.4.7 through 9.14 with no version-specific code.+`nf` on a projection (`nf (const () …)`) would benchmark allocation,+not the result (§2.8).++## Consequences+`deepseq` added to library build-depends. No runtime semantics change.
+ ADRs/004-freeze-deferral.md view
@@ -0,0 +1,17 @@+# ADR 004 — cabal.project.freeze deferred to Phase 2+Status: Accepted (provisional) | Date: 2026-10-21 | Rule: §2.12++## Context+§2.12 requires a lockfile. cabal.project.freeze is per-GHC; a single+freeze file does not work across a five-version CI matrix.++## Decision+Phase 1 pins Hackage index date via index-state (in cabal.project).+The full per-GHC freeze matrix is deferred to Phase 2 via haskell-ci.++## Rationale+index-state is a necessary first step. Per-GHC freeze files are the+correct long-term answer and are produced/maintained by haskell-ci.++## Consequences+Known deviation until Phase 2. Not silent (§5.9).
+ ADRs/005-quickcheck-bound.md view
@@ -0,0 +1,21 @@+# ADR 005 — QuickCheck upper bound relaxed to < 2.20++> **Amended (0.2.0.0): the test suite now needs QuickCheck >= 2.14 && < 2.17 and no longer depends on hedgehog.**++Status: Accepted | Date: 2026-10-21 | Rule: §2.11++## Context+aeson-2.3.2.0 (pulled in by criterion) depends on QuickCheck >= 2.19.+The original bound `QuickCheck < 2.16` prevented the solver from+finding a plan that includes both test and bench components.++## Decision+Relax the bound to `QuickCheck >= 2.14.3 && < 2.20`.++## Rationale+The properties use only the stable QuickCheck API (forAll, ===,+counterexample, chooseInt, elements, frequency, vectorOf, once). Nothing+in the suite depends on behaviour that changed between 2.14 and 2.19.++## Consequences+Test-suite and benchmark components can now be solved together.
+ ADRs/006-runExtract-design.md view
@@ -0,0 +1,57 @@+# ADR 006 — runExtract design: two-pass decode with provenance reattachment++> **Superseded by ADR 012, which is in turn superseded by ADR 018.**+++Status: Superseded by ADR 012 | Date: 2026-10-21 | Rule: §2.1, §2.8, §11++## Context+`runExtract :: FromJSON a => Tagged -> Either ConfigError a` is the+boundary from the merged tree back to a caller's record type. The+feasibility study §11 calls this Risk #1 and states that no bridge+is designed.++The load-bearing question (Gate 2(b)): does leaf-level provenance+(specifically `path`) survive the round-trip through aeson's FromJSON?++## Options considered++(a) Two-pass decode:+    1. Convert Tagged -> aeson Value, dropping metadata.+    2. Decode Value -> a with aeson's standard FromJSON.+    3. On DecodeError, re-walk the original Tagged tree to locate the+       failing path for the error message.+    Provenance is NOT threaded through decode; it is only available to+    error reporting, not to the decoded result.++(b) Custom FromJSON Tagged:+    Write a `FromJSON Tagged` instance that carries metadata through+    every Parser step. This preserves per-field provenance in the+    decoded result, but requires `a` to be built from Tagged, not from+    aeson Value — a new class, not FromJSON.++(c) Field-path reattachment post-decode:+    Decode to `a` via (a), then re-walk Tagged and `a` in parallel to+    reattach provenance to each leaf of `a`. Requires `a` to be+    reflectable via `Generic`, and requires a parallel data type that+    mirrors `a` with per-leaf Tagged values.++## Decision (proposed)+Option (a) for Phase 3. Rationale:+- Matches §2.1 (one canonical IR: Tagged is the IR, aeson Value is a+  wire form used only at the provider/decode edge).+- Option (b) is a new typeclass the study does not name; it is a much+  larger design than an ADR can commit to.+- Option (c) is Gate 2(b) work, not Phase 3 work — provenance+  reattachment requires Generic walkers of `a` that we do not have.+- Option (a) satisfies the §8.1 DecodeError contract: on failure, the+  error carries the failing Path, even if the successful result does+  not carry provenance per-leaf.++## Consequences+- Gate 2(b) is NOT satisfied by Phase 3. If provenance must survive+  decode, a future ADR chooses between (b) and (c).+- `DecodeError Path Text` gets its Path by a Tagged-tree walk on the+  failing field, not from aeson's internal parser state.+- `Figment.hs` exports `composeChecked` / `composeUnchecked` as+  specified in §8.2, both delegating to `runLayers` + `runExtract`.
+ ADRs/007-no-redundant-constraints-in-figment-facade.md view
@@ -0,0 +1,28 @@+# ADR 007 — Disable -Wredundant-constraints in Figment.hs++> **Superseded by ADR 021 (0.2.0.0): `composeChecked` was removed, so the warning suppression went with it.**++Status: Accepted | Date: 2026-10-21 | Rule: §5.1++## Context+`composeChecked`'s `RequireGenericProvider r ps` constraint is a+type-level-only compile-time gate. GHC sees no path where it is used+inside the body and reports it as redundant under+`-Wredundant-constraints`, which §5.1 makes an error.++## Decision+Add `{-# OPTIONS_GHC -Wno-redundant-constraints #-}` at the top of+`Figment.hs` only.++## Rationale+The constraint is not redundant — it is exactly what makes §6.2's+TypeError fire at call sites. GHC's redundancy analysis cannot see+type-level-only constraints as "used" because they discharge no+runtime evidence. Replacing the constraint with a class-with-method+would add a runtime witness no caller needs.++## Consequences+Scope: one module only. The rest of the library keeps the §5.1+warning. `composeChecked`'s call sites still get the §6.2 TypeError+when no generic provider is present (verified by+test/CompileFail/NoProvider.hs).
+ ADRs/008-env-prefix-rule.md view
@@ -0,0 +1,33 @@+# ADR 008 — Env-var key decomposition rule++> **Superseded by ADR 019 (0.2.0.0): Rust-compatible environment-variable rule.**++Status: Accepted | Date: 2026-10-21 | Rule: §2.8, §5.7 (RT-03)++## Context+The feasibility study §10 names RT-03 (env-var prefix collision) as a+regression class that must be pre-empted with a named test before the+Env provider is implemented.++## Decision+Given a prefix P and an env var name N:+1. If N does not start with P, ignore it.+2. Strip P.+3. Lowercase the remainder.+4. Split on '_'.+5. Drop empty components.+6. If the result is empty (N == P), ignore it.+7. Otherwise the resulting list is the env var's path.++Collisions at the same path (two vars mapping to the same path after+case folding) are resolved by last-wins in Map insertion order.++## Rationale+Underscore is the only portable separator across POSIX and Windows+environments. Case folding is required because some shells (Windows+notably) are case-insensitive; folding to lower-case is deterministic+and testable.++## Consequences+- Test/Figment/EnvProvider.hs pins each rule with a named case.+- Any future change to the rule requires superseding this ADR (§5.9).
+ ADRs/009-orphan-provider-instances.md view
@@ -0,0 +1,33 @@+# ADR 009 — Provider instances are orphans in their adapter modules++> **Superseded (0.2.0.0): each provider type is now defined in the same module as its `Provider` instance, so there are no orphan instances.**++Status: Accepted | Date: 2026-10-21 | Rule: §1.7, §2.6++## Context+The feasibility study §9 places each provider type in Figment.Provider+and its instance in Figment.Provider.<Format>. That creates an orphan+instance under GHC's rules: neither the class (Provider) nor the type+(EnvPrefixed) is defined in the module containing the instance.++## Decision+Keep the layout from §9 and silence -Worphans in each adapter module+that declares a Provider instance, with a one-line comment pointing+here.++## Rationale+Alternative (a) — put EnvPrefixed and its instance both in Env.hs —+    inverts the dependency direction: Figment.Check would have to import+    from an adapter to reach the type, violating §2.6.+Alternative (b) — put the instance in Figment.Provider — forces+    Figment.Provider to import System.Environment, violating §1.6+    (IO confined to adapters).+Alternative (c) — newtype-wrap in each adapter — adds a layer of+    boilerplate per provider for no semantic gain.++The Standard's §1.7 orphan ban is about *unrelated* modules; here the+"orphan" module is literally the adapter for that provider.++## Consequences+Each Provider/<Format>.hs opens with -Wno-orphans and this ADR is+referenced. Scope: adapter modules only.
+ ADRs/010-cli-arg-rule.md view
@@ -0,0 +1,15 @@+# ADR 010 — CLI argument decomposition rule++> **Superseded by ADR 020 (0.2.0.0): revised CLI rule (flags, `--no-flag`, `--`, malformed options are errors).**++Status: Accepted | Date: 2026-10-21 | Rule: §2.8++## Decision+A CLI argument is consumed as @--key=value@. The key is lowercased and+split on '.' into path components. Arguments not starting with '--' or+with no '=' are ignored.++## Consequences+- Test/Figment/CliProvider.hs pins each case.+- Space-separated form @--key value@ is NOT supported at this layer;+  argument-pairing is the caller's job before passing to 'CliArgs'.
+ ADRs/011-benchmark-ci-thresholds.md view
@@ -0,0 +1,28 @@+# ADR 011 — Benchmark CI: baseline artifact, no auto-fail thresholds yet++> **Amended (0.2.0.0): CI builds the benchmarks and does a smoke run (`--time-limit 0.2`) on every build. Threshold-based failing is still deferred; the "future ADR 012" mentioned below was never written (that number went to provenance).**++Status: Accepted (provisional) | Date: 2026-10-21 | Rule: §5.6++## Context+§5.6 requires benchmarks checked into CI with regression thresholds.+Thresholds must be calibrated against real variance; without a baseline+sample, a threshold is a guess.++## Decision+- Run the benchmark suite on every PR (quick mode, in the `build` job).+- Run the full benchmark on `main` only, upload the JSON result as an+  artifact, and promote it to `bench-baseline` on every successful main+  build.+- Do NOT auto-fail a PR on benchmark regression until at least 10+  baseline samples exist and variance is measured.++## Rationale+An auto-fail threshold set without variance data would be either+toothless (too high) or flaky (too low). The baseline artifact provides+the data needed for a future ADR that sets real thresholds.++## Consequences+- Benchmark results are visible in CI artifacts on every main build.+- A future ADR 012 will introduce threshold-based failing.+- Until then, PR authors are expected to inspect the artifact manually.
+ ADRs/012-runExtract-provenance-preservation.md view
@@ -0,0 +1,43 @@+# ADR 012 — runExtract provenance-preserving decode (supersedes ADR 006)++> **Superseded by ADR 018 (0.2.0.0): the native decoder carries provenance into every error and into `Tagged` fields, so a separate `ProvMap` is unnecessary. (The `Provenanced` class described below was never implemented.)**++Status: Accepted | Date: 2026-10-21 | Rule: §2.1, §2.8, §11++## Context+ADR 006 chose two-pass decode: `Tagged → aeson Value → a` with+provenance only available for error reporting, not on the decoded+result. That left Gate 2(b) of the feasibility study unsatisfied:+"does leaf-level provenance survive the round-trip through+aeson's FromJSON?"++## Decision+Provide an *additional* decoder alongside `runExtract`:++    runExtractProv+      :: forall a. (Generic a, Provenanced a)+      => Tagged -> Either ConfigError (a, ProvMap)++where `ProvMap = Map Path Metadata` collects the metadata of every+leaf in the source tree, keyed by path. `a` is decoded exactly as in+`runExtract` — provenance is *not* threaded through aeson; it is+collected in a second walk of the same tree and returned alongside.++Callers who need per-field provenance look up `Path` in the map. The+`Provenanced a` class supplies the path-aware field walk for `a`.+A default blanket instance covers every `Generic a` by walking `Rep a`.++## Rationale+Options (b) and (c) of ADR 006 both require threading metadata through+the parse. Both are invasive: (b) is a new class replacing FromJSON for+every field type; (c) needs parallel mirror types. The ProvMap approach+gives the same consumer-visible guarantee (leaf → provenance, reachable+by path) without changing how `a` is decoded, so it stays compatible+with every existing FromJSON instance.++## Consequences+- `runExtract` retains its existing behaviour and signature.+- `runExtractProv` is new; no existing call site changes.+- Gate 2(b) is satisfied at the `Path → Metadata` map level. Consumers+  that need provenance attached per-structure-field build a lookup on+  top; the primitive guarantee is the map.
+ ADRs/013-field-coverage-constraint.md view
@@ -0,0 +1,50 @@+# ADR 013 — Field-level coverage is a runtime default-value concern, not compile-time++> **Superseded by ADR 021 (0.2.0.0): higher-kinded partial configurations provide a field-level guarantee after all, by construction rather than by inspecting providers.**++Status: Accepted (supersedes earlier draft) | Date: 2026-10-21 | Rule: §2.8, §6.1, §8.4++## Context+§6.1 of the feasibility study says the reachability check is over the+provider list, not individual fields, and Gate 2(d) asks whether a+per-field check is worth adding.++The Rust `figment` crate — the study's closest prior art — does not do+a field-level coverage check at all. It lets the configuration struct+declare defaults via `#[serde(default)]`. Missing required fields+surface at extraction time; missing optional/defaulted fields fall back+to their declared default. Serde is the single source of truth.++## Decision+Do NOT add a field-level type-level coverage constraint. Keep+`RequireGenericProvider` as the only compile-time reachability check.+Field coverage is a responsibility of the `FromJSON a` instance+together with whatever default mechanism the caller chooses — `Maybe`+fields, `Default` + aeson's `allowOmittedFields`/`omittedField`+(aeson ≥ 2.2), or explicit defaulting logic.++Ensure `runExtract` returns a structured `MissingKey Path` when a+required field has no supplied value (already true at the type level;+field-level path reporting is a separate aeson-interop concern).++## Rationale+- A file provider reads user input; the compiler cannot know which+  keys it will contain. Any type-level check is either equivalent to+  the existing `RequireGenericProvider` (worthless) or requires the+  caller to declare per-field coverage (heavyweight, surprising, and+  unlike any comparable library).+- The default-value mechanism is already idiomatic in Haskell via+  aeson. Reimplementing it as a compile-time reachability check+  duplicates the responsibility in a less capable place.+- Aligning with Rust `figment` matters for interoperability and for+  users bringing mental models from that ecosystem.++## Consequences+- `FieldsOf` / `OptionalFields` (§8.4) remain exposed as building+  blocks for future use, but are not used by any constraint in this+  release.+- `composeChecked` gains no new constraints.+- README documents the required/defaulted-field discipline (see+  README section "Required and optional fields").+- test/CompileFail/ keeps `NoProvider` and `OkProvider`; drops the+  `RequiredAndMaybe` case (no longer meaningful).
+ ADRs/014-safe-haskell.md view
@@ -0,0 +1,40 @@+# ADR 014 — Safe Haskell boundary: Safe core, Trustworthy adapters++> **Superseded by ADR 022 (0.2.0.0): Safe Haskell annotations removed.**++Status: Accepted | Date: 2026-10-21 | Rule: §2.8, §1.7++## Context+Figment reads untrusted config input. Safe Haskell offers a+machine-checkable guarantee that a module contains no unsafePerformIO+and cannot violate type safety or referential transparency. The+question is which modules to mark, and with which of the three flags+(Safe, Trustworthy, Unsafe).++## Decision+- Pure core: `Figment.Prim`, `Figment.Value`, `Figment.Merge`,+  `Figment.Layer`, `Figment.Error`, `Figment.Extract`, `Figment.Prov`+  carry `{-# LANGUAGE Safe #-}`.+- IO adapters and façade: `Figment.Provider.*`, `Figment`,+  `Figment.Provider` carry `{-# LANGUAGE Trustworthy #-}`.+- A new test module `test/Figment/SafeBoundary.hs` opens with+  `{-# LANGUAGE Safe #-}` and imports only the pure-core modules,+  proving the machine-checked claim at test time.++## Rationale+- All-Safe is rejected: the provider adapters import aeson, tomly-parser,+  yaml, and env libraries whose Safe Haskell status is not under our+  control and varies by GHC version. A Safe module with one untrusted+  import fails to compile [GHC User's Guide §6.18].+- All-Trustworthy is rejected: it discards the machine-checked+  guarantee on the merge algebra and the depth-bound tagger, which are+  exactly the parts the feasibility study proved.+- Safe core + Trustworthy edge is the standard Haskell library pattern+  for "pure logic with a thin IO shell".++## Consequences+- Every pure-core module gains one pragma.+- If a pure-core module's imports become unsafe in a future GHC/package+  version, the build fails loudly at that import, not silently.+- `test/Figment/SafeBoundary.hs` is the mechanical check (Standard §2.8).+- The README trust-boundary section cites this ADR.
+ ADRs/015-ghc-914-deferred.md view
@@ -0,0 +1,26 @@+# ADR 015 — GHC 9.14.1 support deferred++> **Amended (0.2.0.0): tested-with is GHC 9.10.3 and 9.12.4 (the earlier 9.4.7 to 9.12.1 range was never actually tested). The stale `cabal.project.freeze.ghc-9.14.1` was removed. 9.14 remains untested.**++Status: Accepted | Date: 2026-10-22 | Rule: §2.11, §5.9++## Context+The library builds and passes all 57 tests on GHC 9.12.1. On GHC 9.14.1,+the solver cannot satisfy `hashable-1.5.0.0`, which requires `base <+4.22`; GHC 9.14.1 ships `base-4.22.0.0`. This is a Hackage upper bound,+not a bug in this codebase.++`allow-newer: hashable:base` would let 9.14.1 build, but would lie+about compatibility to downstream users.++## Decision+Ship with `tested-with: GHC 9.4.7 - 9.12.1`. Defer 9.14.1 until a+`hashable` release supports `base-4.22`.++## Consequences+- CI matrix stays at 9.4.7 - 9.12.1.+- 9.14.1 becomes a one-line `tested-with` change plus a freeze refresh+  when `hashable` publishes.+- Users on 9.14.1 install a library that does not officially support+  their compiler — the standard behaviour for any package whose+  transitive deps have not caught up.
+ ADRs/016-toolchain-and-language.md view
@@ -0,0 +1,19 @@+# ADR 016 — Toolchain, language edition, dependencies+Status: Accepted | Date: 2026-10-22 | Supersedes: 002, 003++## Decision+- `default-language: GHC2021` plus `DerivingStrategies`, `DeriveAnyClass`,+  `LambdaCase`, `OverloadedStrings`. Every `deriving` clause names its+  strategy, so `DeriveAnyClass` can never be picked silently.+- `base >= 4.20 && < 4.22` (GHC 9.10, 9.12): the bounds claim exactly the+  compilers CI tests. No CPP anywhere.+- Instances are derived where possible (`NFData` via `Generic`).+- Dependencies: aeson (token stream, bridge), toml-parser (TOML with+  positions), libyaml + conduit (the YAML event stream), time (dates),+  directory/filepath/temporary (files, jail), containers, vector,+  scientific, text, bytestring, deepseq. `yaml` is no longer used, because+  its aeson-based decoder hides positions, duplicates and alias expansion.++## Consequences+Users on GHC < 9.10 must stay on 0.1. Widening the bounds is only a+`tested-with` change once CI covers the extra compilers.
+ ADRs/017-limits-inside-parsers.md view
@@ -0,0 +1,27 @@+# ADR 017 — Resource limits are enforced inside the parsers+Status: Accepted | Date: 2026-10-22 | Amends: 001++## Context+0.1 checked depth in `mkTagged`, after aeson, yaml or toml-parser had+already built the whole tree, so the guard ran after the cost had been+paid. Its stress test built a lazy tree the guard never forced, so it+proved nothing about real input.++## Decision+`Limits { maxDepth = 64, maxNodes = 1_000_000 }` (smart constructor+`mkLimits`; defaults per ADR 001) are threaded into every parser and+checked while the tree is built:+- JSON: aeson's lazy token stream, so tokens past the limit are never+  produced;+- YAML: the libyaml event stream; an alias is charged its *expanded*+  size and height (this defeats "billion laughs");+- TOML: the converter from toml-parser's tree (toml-parser's LR parser+  keeps its stack on the heap, which grows only with the input);+- env/CLI structured values: the value parser.++## Verification+`test/Figment/Test/Adversarial.hs`: 1M-deep JSON text, 100k-deep YAML,+10k-deep TOML and env values are rejected with `DepthExceeded 64`; an+exact boundary test (64 accepted, 65 rejected); a billion-laughs document+is rejected with `TooManyNodes`; arbitrary bytes and truncated documents+never raise an exception (results are forced with `evaluate . force`).
+ ADRs/018-native-decoder.md view
@@ -0,0 +1,27 @@+# ADR 018 — A native, accumulating decoder (supersedes 006 and 012)+Status: Accepted | Date: 2026-10-22++## Context+0.1 converted the merged tree to an aeson `Value` (dropping provenance),+used `fromJSON` (dropping aeson's error path), then reported the+alphabetically first leaf as the error location. The error pointed at+the wrong key.++## Decision+`FromConfig` decodes figment's own `Value` tree in a `DecodeContext`+(path, profile, lossy flag, consulted sources). `Decoder` is an+**accumulating applicative**; it deliberately has no `Monad` instance,+because a monad has to short-circuit. `andThen` provides explicit+sequencing. Generic deriving covers records, enums, externally tagged+sums, newtypes and positional products, with `Options`+(`fieldLabelModifier`, `constructorTagModifier`,+`rejectUnknownFields` with edit-distance suggestions). Strict by default;+`extractLossy` opts in to string-to-number/bool coercion. Values parsed+from untyped text keep their original text (`tagRaw`), so `Text` fields+receive `007` verbatim. `ViaAeson` bridges existing `FromJSON` instances+and translates aeson's `JSONPath` into figment paths.++## Consequences+Every error carries the exact path, source, profile, line/column and+the provider-native name. Users with only `FromJSON` instances use+`deriving FromConfig via ViaAeson T`.
+ ADRs/019-env-rule.md view
@@ -0,0 +1,21 @@+# ADR 019 — Environment variables follow Rust figment (supersedes 008)+Status: Accepted | Date: 2026-10-22++## Decision+- The prefix is matched case-insensitively and stripped. Key+  transformations (`split`, `only`, `ignore`, `filterKeys`, `mapKeys`)+  apply in the order they were added. Keys are lower-cased by default.+  As in Rust, a `.` in the final key nests, and a key with an empty+  segment is ignored.+- **No splitting by default**: `APP_MAX_CONNECTIONS` is+  `max_connections`. `split "__"` makes `APP_DB__HOST` `db.host`. (0.1+  always split on `_`, which made underscored field names unreachable.)+- Values are parsed (TOML-like: booleans, exact numbers, quoted strings,+  arrays, inline dictionaries; anything else is the string itself) and+  keep their original text.+- Variables are processed in sorted order. Two variables that cannot+  both hold (a value and a dictionary at the same key, or two names that+  are equal after lower-casing) are **errors** naming both variables;+  0.1 silently dropped one (and, through a bug, dropped every value).+- `Env.fromList` injects variables, so tests need no process-global+  state.
+ ADRs/020-cli-rule.md view
@@ -0,0 +1,13 @@+# ADR 020 — Command-line rule, revised (supersedes 010)+Status: Accepted | Date: 2026-10-22++## Decision+`--key=value` (value parsed as for env vars), `--flag` (true),+`--no-flag` (false); dots nest, dashes become underscores, case is+kept; `--` ends options; everything else is positional and returned by+`parseArgs`. A repeated key: the last occurrence wins (the CLI+convention). Malformed options and structural conflicts are errors.+`--key value` is not supported: without a schema it is ambiguous with a+flag followed by a positional argument. Rich CLIs should parse with+optparse-applicative and pass the result through `defaults`, which is+what Rust figment recommends with clap.
+ ADRs/021-hkd-partial-configs.md view
@@ -0,0 +1,23 @@+# ADR 021 — Higher-kinded partial configurations replace composeChecked+Status: Accepted | Date: 2026-10-22 | Supersedes: 007, 013++## Context+`composeChecked @R @ps` took a type-level provider list that was not+connected to the layers actually passed (its own `OkProvider` fixture+compiled with an empty list). Its premise was also weak: an env provider+being present says nothing about whether a field is supplied.++## Decision+Remove `composeChecked`/`composeUnchecked`. Offer `Field f a` (where+`Field Identity a = a`) and the `Partial` class, all of whose methods+are generic defaults:+- `extractPartial defaults` decodes whatever is present (all type+  errors), overlays it on partial defaults, and reports **every**+  missing field with the env var, flag or key that would set it;+- `extractTotal` takes total defaults (`c Identity`), so a missing-field+  error is impossible by the type.+This is a guarantee Rust's figment cannot express.++## Verification+`test/Figment/Test/Partial.hs`; `test/compile-fail/PartialSum.hs`+shows that sum types are rejected with a named type error.
+ ADRs/022-safe-haskell-dropped.md view
@@ -0,0 +1,16 @@+# ADR 022 — Safe Haskell annotations removed (supersedes 014)+Status: Accepted | Date: 2026-10-22++## Context+In 0.1 the `Safe`/`Trustworthy` assignments contradicted ADR 014, and+`Trustworthy` was used to get past aeson's inferred status rather than+as the result of an audit. That is a promise nobody had checked.+Trustworthy guarantees also mean nothing unless downstream users enable+`-fpackage-trust`, which almost no one does. Every adapter now depends+on aeson, libyaml or toml-parser, none of which is Safe.++## Decision+No Safe Haskell pragmas. Purity is visible in the types: only `provide`,+`load` and the jail live in `IO`. The single `unsafePerformIO` (the+jail's process-wide lock, the standard top-level `MVar` idiom) is+documented where it appears.
+ ADRs/023-figment-as-description.md view
@@ -0,0 +1,19 @@+# ADR 023 — A Figment is a pure description; load collects everything+Status: Accepted | Date: 2026-10-22++## Decision+- `Figment` is a sequence of steps (order, metadata, provider action)+  plus the last `select` and `withLimits`. It is a lawful `Monoid` (the+  free monoid on steps), which is the lawful structure the value-level+  merge cannot provide. The laws are property-tested observationally.+- Builders (`merge`, `join`, `adjoin`, `admerge`, `combine`) take+  `HasCallStack` and record where each provider was added.+- `load` runs providers in order and **does not stop at the first+  failure**: all provider errors are returned together. Any synchronous+  exception that escapes a provider becomes an `IoError` with that+  provider's metadata; asynchronous exceptions are re-thrown.+- `Figment` is itself a `Provider`. Inner values keep their tags,+  because retagging only fills in missing provenance.+- Profiles: `Default`, then the selected profile, then `Global`. An+  explicit `select` beats profile hints from providers, which combine by+  the step's order.
+ ADRs/024-yaml-event-stream.md view
@@ -0,0 +1,10 @@+# ADR 024 — YAML from libyaml events, YAML 1.2 core schema+Status: Accepted | Date: 2026-10-22++## Decision+Parse the libyaml event stream directly instead of going through+`Data.Yaml`. This gives positions for every value, duplicate-key errors,+alias expansion charged to the node limit, merge keys (`<<`, where+explicit keys win), and an explicit rejection of multi-document files.+Plain scalars resolve under the YAML 1.2 core schema, so `no`, `on` and+`yes` remain strings. Explicit tags (`!!str`, `!!int`, ...) are honoured.
+ ADRs/025-error-rendering.md view
@@ -0,0 +1,11 @@+# ADR 025 — Error values and their rendering+Status: Accepted | Date: 2026-10-22++## Decision+`ConfigError { kind, path, profile, metadata, pos, hints }` with a+closed `ErrorKind`, every constructor of which is produced somewhere.+`ConfigErrors` is non-empty, a `Semigroup`, and an `Exception` whose+`displayException` is `renderErrors`. The rendered form is part of the+public interface and is pinned by golden tests in `test/golden/`.+(0.1 pinned derived `Show` output, which leaked the internal+`UnsafeDepth` constructor.)
+ CHANGELOG.md view
@@ -0,0 +1,55 @@+# Changelog++## 0.2.0.0 — 2026-10-22++A breaking redesign, following a forensic audit of 0.1+(`docs/audit-remediation.md` maps every finding to its fix and test).++### Fixed+- Environment and CLI providers dropped every value (`APP_HOST=x` became+  `{host: {}}`).+- Decode errors reported the alphabetically first key instead of the+  failing one.+- The compile-time "provider check" was disconnected from the layers it+  claimed to check.+- Missing JSON/YAML files threw `IOException`; TOML caught asynchronous+  exceptions.+- TOML dates became `null`, `inf`/`nan` became garbage numbers, invalid+  UTF-8 was silently replaced; duplicate YAML keys and env conflicts+  were resolved silently.+- The depth limit ran after parsing, so it never protected the parsers.+- The README example did not compile.++### Added+- `Figment.Tutorial`: a sixteen-section guided tour whose snippets are+  compiled and run by the test suite.+- Profiles (`Default`, `Global`, custom; `select`; nested files; profile+  hints) with Rust figment's semantics.+- A native, accumulating decoder (`FromConfig`, generic deriving with+  options, combinators): every error is reported at once with path,+  source, line/column, profile and the provider-native key name.+- Higher-kinded partial configurations (`Field`, `Partial`,+  `extractPartial`, `extractTotal`).+- `Tagged`, `RelativePath`, `ViaAeson`; `extractLossy`, `extractAt`,+  `findValue`, `contains`, `findMetadata`, `focus`, `reselect`.+- Providers: `fromText`, `file` (optional, searched upward), `fileExact`,+  `required`, `nested`; Rust-compatible `Env` with options; revised+  `Cli`; `Serialized` (`defaults`, `globals`, `keyed`); figments as+  providers.+- Metadata: structured source, the call site where each provider was+  added, and a key-name interpolater.+- Parser limits (`Limits`: depth and node count) enforced inside every+  parser; YAML alias-bomb protection.+- `Figment.Jail` for configuration tests.+- `Exception` instance and a human-readable renderer for `ConfigErrors`.++### Removed+- `composeChecked`, `composeUnchecked`, `Figment.Check`, `RawJSON`,+  `mkTagged`, `ProvMap`/`runExtractProv` (superseded), `SourceId`,+  `Depth` (now `Limits`), Safe Haskell pragmas, the `yaml` dependency.++### Changed+- `base >= 4.20` (GHC 9.10 and 9.12, as tested).++## 0.1.0.0+Initial pre-release.
+ ENGINEERING_STANDARD.md view
@@ -0,0 +1,856 @@+# The Haskell Engineering Standard++**Status: binding.** This document is the constitution for any Haskell+codebase it governs — read and applied *before* the first module is+written, not retrofitted afterward. It applies equally to AI-authored and+human-authored code, and to AI or human review of either. Where a request+conflicts with this document, follow this document and say so explicitly.++**Precedence when principles conflict**, highest first:+1. Correctness / totality — a fast or elegant function that can go wrong+   silently loses to a slower one that can't go wrong at all.+2. Safety of representation — illegal states must stay unrepresentable+   even at the cost of a more verbose type.+3. Architectural clarity — a boundary that makes the system easier to+   reason about beats a shortcut that makes today's diff smaller.+4. Performance — addressed deliberately, with evidence, never guessed at+   the expense of 1–3.+5. Brevity — the last thing optimized for, never the first.++---++## Part 0 — Foundational Design Principles, in Haskell Terms++Classic software-design principles are usually stated in OOP vocabulary.+They still hold; they just cash out differently without classes and+inheritance. State them this way so there's no ambiguity about what they+mean here.++### 0.1 Single Responsibility Principle+One module, one reason to change. A module that both parses a format and+knows how to render one has two responsibilities wearing one name; split+it. The test: describe the module's job in one sentence with no "and."++### 0.2 Open/Closed Principle+A system should be open to extension without modifying proven code. In+Haskell this is a genuine design choice with two valid, opposite-shaped+answers — pick the right one deliberately, per extension axis:+- **Closed sum + exhaustive pattern match**, when the set of cases is+  owned and finite (e.g. the source formats *this* project supports).+  Adding a case is a compile error at every site that needs updating —+  extension is "open" in the sense that the compiler *guides* the change,+  even though the type itself is closed.+- **Typeclass or record-of-functions ("Handle") boundary**, when the set+  of cases is genuinely open to third parties (e.g. a plugin renderer a+  downstream consumer supplies). Extension happens with zero edits to+  existing code.++Never blend the two on the same axis of variation — decide, per+extension point, which discipline governs it, and document the choice.++### 0.3 Liskov Substitution — restated as typeclass law-abidance+Any two instances of the same typeclass must satisfy the same laws.+A `Monoid` instance whose `mappend` isn't associative, an `Eq` instance+that isn't reflexive, an `Ord` instance inconsistent with its `Eq` — these+are the Haskell equivalent of a subtype that violates its supertype's+contract. State each instance's laws in a comment and, wherever practical,+test them with a law-checking library (`hspec-hedgehog`, `checkers`).++### 0.4 Interface Segregation+Typeclasses (and Handle records) should be as small as the caller actually+needs. A function should be constrained by the narrowest capability it+uses — `(Monad m) => ...` rather than `(MonadIO m, MonadState S m,+MonadReader R m) => ...` when only `Monad` is actually exercised. A fat+typeclass or a fat Handle forces every implementation to satisfy+capabilities most call sites never touch.++### 0.5 Dependency Inversion — the Handle pattern+Haskell has no interfaces in the OOP sense; the idiomatic equivalent of+"depend on abstractions, not concretions" is passing a small record of+functions (a **Handle**) into pure or effect-polymorphic code, rather than+having that code import a concrete `IO`-performing module directly.++```haskell+-- | The core logic depends on this shape, not on any concrete backend.+data StorageHandle m = StorageHandle+  { loadDocument :: DocId -> m (Either MirrorError Document)+  , saveDocument :: DocId -> Document -> m (Either MirrorError ())+  }++-- | Pure with respect to *how* storage happens — swap the Handle for+-- tests (an in-memory Map) without touching this function.+republish :: Monad m => StorageHandle m -> DocId -> m (Either MirrorError ())+```+This is what makes core logic testable without spinning up real I/O, and+it is preferred over a typeclass when only one concrete instance is ever+needed per call site (a Handle is simpler; a typeclass is for genuine+ad hoc polymorphism across many types).++### 0.6 DRY — with its correct limit stated explicitly+Duplication of *knowledge* (the same invariant, checked two different+ways in two places) must be eliminated — that's what the shared+"raw → validated" translation layer and the shared smart constructors in+Part 2 exist to prevent. Duplication of *code that happens to look+similar but encodes unrelated decisions* should **not** be merged. Two+functions that currently have the same three lines but answer different+questions are not a DRY violation — collapsing them creates a false+coupling that will need to be un-collapsed the moment the two decisions+diverge. When in doubt: ask whether the two call sites would ever need to+change independently. If yes, don't merge them.++### 0.7 KISS and YAGNI+Implement the mechanism the current, real requirement needs — not the one+a hypothetical future requirement might need. An error constructor,+typeclass, or extension point is added in the same change that makes it+reachable, never speculatively (this is also stated in Part 1 as a+closed-vocabulary rule, because it's load-bearing there too). Prefer the+simplest technique in Part 3's toolkit that fully closes the problem;+reach for a more powerful technique (GADT, existential, type family) only+once the simpler one is demonstrably insufficient, and say why in a+comment when you do.++### 0.8 Law of Demeter+A function should not reach through more than one level of a nested+record/structure to get what it needs. If `renderPage` needs+`documentMeta.author.displayName`, that's a sign `documentMeta` should+expose `authorDisplayName` directly, or the caller should be handed the+narrower value it actually needs rather than the whole tree. This keeps+refactors local: changing how `author` is represented shouldn't ripple+into every renderer that happens to reach through it.++### 0.9 Composition over inheritance — the Haskell default+There is no inheritance to avoid reaching for; the discipline instead is+to build behavior by composing small, independent pieces (function+composition, typeclass constraints, monad transformers, or simple value+composition) rather than by building one large record or one large+typeclass that tries to be everything. If a type is accumulating+unrelated fields "because it's convenient to have them all in one place,"+that's the inheritance instinct resurfacing in record form — split it.++### 0.10 Principle of Least Power+Give every function the least expressive type that still lets it do its+job. A function that doesn't need `IO` shouldn't have it in its+signature. A function that only reads state shouldn't be typed to allow+writes. A typeclass constraint should name the weakest class in the+hierarchy that suffices (`Foldable` instead of a concrete `[]`, when only+folding is needed). Least power at the type level is what makes a+signature trustworthy on sight — the type is a promise about what the+function *cannot* do, not just what it does.++### 0.11 Compatibility is a promise about the boundary, not the internals+Preserve backward compatibility for a module's public API where+practical — don't churn an external signature for cosmetic reasons; see+2.13 for how this is enforced through versioning. That promise applies+only to the boundary. Internally, continuously review and simplify type+and module design: refactor implementations freely, delete dead+abstractions, and collapse a type that turned out more general than+needed, as long as the public shape either stays put or moves behind a+deliberate version bump. Stability and simplification aren't in tension+once it's clear which side of the export list each applies to.++---++## Part 1 — Language Principles (never violated)++### 1.1 Every function is total, or its type says it isn't+No partial functions. Never use: `head`, `tail`, `last`, `init`,+`fromJust`, `(!!)`, non-exhaustive pattern matches, `error`, `undefined`,+or incomplete `case`/`if` chains on a closed type. If a function can fail,+its type says so — `Maybe a` for one reason, `Either e a` when the reason+needs to be named. `-Wall -Werror -Wincomplete-uni-patterns+-Wincomplete-record-updates -Wpartial-fields` are mandatory, not optional.++### 1.2 Illegal states are unrepresentable, not merely rejected+Prefer a type that cannot hold invalid data over a type that can, plus a+validator. This is the single most important habit in this document and+recurs throughout Part 3's toolkit — see especially 3.1–3.4.++### 1.3 Cross-field invariants are enforced once, at construction+If correctness depends on a relationship between two or more fields (e.g.+"every row has the same width"), the constructor is not exported; the+only way to obtain a value is a smart constructor returning+`Either err a`. Once constructed, the value is trusted everywhere+downstream — never re-checked. (Full treatment in 3.3.)++### 1.4 Closed domains are closed types, not strings+Any finite, known set of alternatives is a sum type — never a+`Text`/`String` compared against literals. A value outside the closed set+is a compile-time impossibility, not a runtime "unrecognised value"+string.++### 1.5 Errors are a closed, structured vocabulary+One sum type per failure category, each constructor documented with *why+it exists* and *what can produce it*. No stringly-typed errors, no+catch-all `OtherError Text`. A constructor is added only in the same+change that makes it reachable.++### 1.6 Purity is pushed to the edges+Business logic is pure. `IO` is confined to a thin shell at the+boundary — reading input, writing output, catching foreign-library+exceptions and converting them into the structured error type+immediately. A function is never `IO`-typed merely because a library it+calls can throw; catch and convert at that call site.++### 1.7 No implicit escape hatches+No `unsafePerformIO`, no `Debug.Trace` in committed code, no `Show`-based+serialization used as data interchange, no orphan instances (an instance+lives next to the type or next to the class, never floating in an+unrelated module).++### 1.8 Explicit over implicit, always+No global mutable state (`IORef`s reached for reflexively instead of+threading state explicitly), no reliance on typeclass resolution doing+something surprising (`OverlappingInstances`, `IncoherentInstances` are+red flags requiring explicit justification), no reflection-like tricks to+avoid writing an explicit case. If a reader has to run the code mentally+to know what will happen, it's too implicit.++### 1.9 Immutability is the default, not an aspiration+Data is immutable unless a specific, profiled reason calls for a mutable+cell (`IORef`, `STRef`, `MVar`, a mutable vector). Local transformations+use record-update syntax and pure recursion, not accumulation into a+mutable variable "for convenience." This is distinct from 1.8's ban on+*global* mutable state — 1.9 is the default even for a value that never+leaves a single function.++### 1.10 Referential transparency is the target, not just a byproduct of purity+An expression's value must not depend on when, how many times, or in+what order it's evaluated — this is what makes equational reasoning+possible: a sub-expression can be replaced by its value, memoized, or+lifted out and shared, without changing the program's meaning.+`unsafePerformIO` and any hidden mutable state breaks this, which is why+1.7 bans the former outright rather than merely discouraging it.++### 1.11 Zero dead code, zero empty stubs — strictly enforced+Nothing unreachable is committed: no unused top-level bindings, no+commented-out blocks "kept just in case," no functions exported but+never called anywhere in the codebase or its public API surface.+`-Wunused-top-binds -Wunused-local-binds -Wunused-matches` are treated+as errors, and a dead-code detector (`weeder`) runs in CI alongside+`hlint`. Equally strict in the other direction: a function is either+fully implemented or does not exist in the merged code — no+`someFunction = undefined`, no `error "TODO"`, no placeholder that+type-checks but panics if called. If a capability isn't ready, its+call site isn't merged either; half-built scaffolding is worse than an+honest absence, because it compiles clean and looks finished.++---++## Part 2 — Software Architecture (never violated)++### 2.1 One canonical intermediate representation+When a problem involves multiple input or output formats converging on+shared logic, there is exactly **one** internal representation every+input funnels into and every output funnels out of. Format-specific logic+lives only in the thin translation layer at each edge; core logic is+written once, against the IR.++### 2.2 Validation is staged, not scattered+Recovering *shape* is kept separate from checking *content validity*. Use+a shared "raw → validated" translation layer if multiple producers reach+the same validation step — write the validation once, share it.++### 2.3 Errors are layered to match pipeline stages+The top-level error type is a closed sum of closed sums, one case per+pipeline stage. A function's return type tells you unambiguously which+stage produced a failure without inspecting a string.++### 2.4 Recursive structures carry an explicit resource bound+Any recursive data type that hostile or careless input could nest+arbitrarily deep gets an explicit, threaded depth/size limit at every+point of recursive descent, applied **uniformly** across every stage+capable of producing that nesting — not just the one someone happened to+think of first.++### 2.5 Module boundaries are drawn by responsibility, enforced by exports+Each module has one reason to change (0.1). Constructors and functions+that could violate an invariant if exported freely are **not** exported.+`-Wmissing-export-lists` is mandatory. A module's export list is its+contract.++### 2.6 Dependency direction is acyclic and points at the core+Format-specific / adapter modules depend on the core IR module; the core+never imports outward. This is hexagonal architecture stated in Haskell+terms: a pure core, with parsers/renderers/storage/network as adapters at+the boundary, wired in either via closed dispatch (0.2) or a Handle/+typeclass (0.5) — never via the core reaching outward to call them+directly.++### 2.7 Extensibility mechanism is chosen deliberately, per axis, and documented+See 0.2. State, in the relevant module's Haddock, whether a given+extension point is closed-by-design (compiler-enforced exhaustiveness) or+open-by-design (Handle/typeclass) — and don't let a "just this once"+exception blur the line without updating the documentation to match.++### 2.8 Every architectural claim has a mechanical check behind it+"This module is total" is checked by `-Wincomplete-patterns -Werror`.+"This invariant holds for every value of this type" is checked by a+property test. A claim without an enforcement mechanism is a wish, not a+property of the code, and must not be described as though it were+guaranteed.++### 2.9 Testing is part of the architecture, not an afterthought+Property-based tests are a *design tool*, not just a QA step — writing+the property before/alongside the implementation ("for any input, output+satisfies X") is often what reveals whether the type actually needs a+smart constructor. Regression tests are named after the specific defect+they guard, not "test5." Unit tests exercise the pure core directly,+never through an `IO` shell, because the core is pure and testable in+isolation by construction (1.6, 0.5) — if a test needs `IO` to exercise+core logic, that's a signal the architecture leaked an effect it didn't+need to.++### 2.10 Organise modules by domain, not by technical utility+Group modules by what they mean in the problem (`Document`,+`Pipeline`, `Rendering.Html`), not by what kind of thing they technically+are (`Utils`, `Helpers`, `Common`, `Types`). A grab-bag `Utils.hs` is a+confession that some piece of logic was never given a real owner — it+belongs in whichever domain module actually needs it, even at the cost+of a small amount of near-duplicate code across two domains (0.6).++### 2.11 Depend on the fewest, best-maintained libraries the problem needs+Prefer an established, actively maintained library over a hand-rolled+equivalent — including for 4.2's named algorithms: if a well-maintained+library already implements the algorithm correctly, depend on it rather+than re-proving it in-house (4.7), unless the dependency itself becomes+the risk (parsing untrusted input, licensing, supply-chain exposure).+Every dependency joins the trusted computing base; add one deliberately,+not by default, and prefer one well-chosen library over three overlapping+ones that each cover part of the same need.++### 2.12 Builds are deterministic and reproducible+Pin dependency versions (`cabal.project.freeze` or an equivalent+lockfile, a fixed Stackage resolver) so the same commit produces the same+build, today and a year from now. A build that silently picks up a newer+transitive dependency on every fresh checkout undermines every other+guarantee in this document — a passing property test says little if next+week's build compiles different code underneath it.++### 2.13 Package and module versioning follows the PVP, deliberately+Follow the Haskell Package Versioning Policy: a breaking change to any+exported signature bumps the major version; anything else does not.+Combined with 0.11 — a public signature changes only behind a deliberate+version bump, never as the silent side effect of an unrelated refactor.++### 2.14 Code is portable by default+Avoid unnecessary dependence on a specific OS, filesystem layout, or+compiler version beyond what the problem genuinely requires. Use+portable path/file libraries (`filepath`, `directory`) instead of+hardcoded separators or absolute paths; note any genuine, unavoidable+platform dependency explicitly in the module that has it, rather than+letting it surface later as a mysterious build failure somewhere else.++### 2.15 Errors live in a dedicated module, and every message is descriptive+The closed error vocabulary (1.5, 2.3) is defined in its own module,+separate from the domain logic that raises it — one place a reviewer or+a new contributor goes to see the entire universe of ways the system can+fail. Every constructor's rendered message names the specific thing that+went wrong and, wherever the information is available, the specific+input or location that caused it (a file path, a line number, a field+name) — never a bare "invalid input" or "something went wrong." A vague+error message is a silent failure wearing an error type; it satisfies+1.5's letter while missing its point.++---++## Part 3 — The Haskell Type-System Toolkit: What to Reach For, and When++Use the least powerful tool in this list that fully solves the problem+(0.7, 0.10). Escalate only when the simpler tool genuinely can't express+the invariant, and say so in a comment when you escalate.++### 3.1 Algebraic data types — the default, reach for first+Sum types for closed alternatives, product types (records) for "all of+these together." This is the baseline for making illegal states+unrepresentable: a value that can only be one of N well-defined shapes,+never a partially-filled record with a `Maybe` flag simulating a variant.++```haskell+-- Bad: simulates a sum type with a flag and nullable fields.+data Shape = Shape { isCircle :: Bool, radius :: Maybe Double+                    , width :: Maybe Double, height :: Maybe Double }++-- Good: the type itself rules out "circle with a width."+data Shape = Circle Double | Rectangle Double Double+```++### 3.2 Newtypes — eliminate primitive obsession at zero runtime cost+Any domain concept represented as a bare `Text`, `Int`, or `Double` that+could be confused with another value of the same primitive type gets a+`newtype`. `UserId`, `DocId`, and `SessionId` should not all be `Text`+that the compiler will happily let you swap by accident.++```haskell+newtype UserId = UserId Text deriving (Eq, Ord, Show)+newtype DocId  = DocId  Text deriving (Eq, Ord, Show)+-- lookupDoc :: UserId -> DocId -> ...   -- now a compile error to swap them+```++### 3.3 Smart constructors + opaque exports — the standard invariant-enforcement mechanism+Whenever a value's validity depends on content, not just shape (a+rectangular table, a syntactically valid URL, non-empty-after-trimming+text), the type's constructor is unexported and the *only* way to build+one is a function returning `Either err a`. This is not optional+whenever 1.2/1.3 apply — it is the mechanism those principles are+implemented with.++```haskell+module M (Percentage, mkPercentage, unPercentage) where++newtype Percentage = UnsafePercentage Double deriving (Eq, Ord, Show)++mkPercentage :: Double -> Either ValidationError Percentage+mkPercentage x+  | x >= 0 && x <= 100 = Right (UnsafePercentage x)+  | otherwise          = Left (OutOfRange x)++unPercentage :: Percentage -> Double+unPercentage (UnsafePercentage x) = x+```++### 3.4 Phantom types — compile-time-only tags with zero runtime cost+Use a type parameter that never appears on the right-hand side of any+constructor to carry a *static* fact about a value — "this text has been+escaped," "this ID belongs to a draft, not a published document" — that+the compiler checks but that costs nothing at runtime.++```haskell+data Status = Draft | Published++newtype DocRef (s :: Status) = DocRef Text++publish :: DocRef 'Draft -> IO (DocRef 'Published)+-- A published-only operation now cannot even type-check against a draft.+notifySubscribers :: DocRef 'Published -> IO ()+```++### 3.5 GADTs — when different constructors need different result types+Reach for a GADT when a plain ADT would force every constructor to share+one result type even though they logically produce different types, and+you'd otherwise be compensating with an unsafe cast or a partial+extraction function. Typed embedded languages/ASTs, and safety-indexed+wrappers (a value's constructors *are* its safety guarantee) are the+canonical use case.++```haskell+data Expr a where+  IntLit  :: Int -> Expr Int+  BoolLit :: Bool -> Expr Bool+  Add     :: Expr Int -> Expr Int -> Expr Int+  If      :: Expr Bool -> Expr a -> Expr a -> Expr a++eval :: Expr a -> a          -- total: GADT rules out ill-typed terms+eval (IntLit n)  = n+eval (BoolLit b) = b+eval (Add x y)   = eval x + eval y+eval (If c t e)  = if eval c then eval t else eval e+```+Without the GADT, `eval :: Expr -> SomeValue` would need a runtime type+check and a partial extraction (`asInt`, `asBool`) — exactly the+partiality Part 1 prohibits. The GADT moves that check to compile time.++### 3.6 Existential types — last resort, justify explicitly+Use `forall`/existentials only when you genuinely need a heterogeneous+collection of values that share a common interface but whose concrete+type doesn't matter (e.g. a list of "anything renderable"). Existentials+throw away the very type information Part 1–3 spend so much effort+preserving, so treat reaching for one as a flag: state in a comment+*why* the concrete type must be forgotten here and why a closed sum+(3.1) or typeclass-constrained polymorphic function isn't sufficient+instead.++### 3.7 Typeclasses — principled overloading with laws, not ad hoc dispatch+A typeclass is appropriate when multiple types share genuinely the same+abstract operation *and* that operation obeys stated laws (0.3). It is+not a substitute for a Handle (0.5) when there's only ever one+implementation live at a call site, and it is not a way to fake+function overloading for otherwise-unrelated operations. Every+non-trivial typeclass ships with its laws stated in a Haddock comment,+and law-checking tests where a library exists for the class in question.++### 3.8 DataKinds / kind signatures — promote a value to the type level only when the compiler needs it there+Use `DataKinds` when a value genuinely needs to participate in a+type-level distinction (as in 3.4's `Status` kind). Don't promote a value+to the type level "for elegance" if a plain runtime value moving through+an `Either`/smart-constructor already closes the same hole — that's+reaching for 3.4–3.5's power where 3.1/3.3 would fully suffice (0.7).++### 3.9 mtl-style constraints / effect boundaries — dependency inversion at the type level+When a function needs several capabilities (state, config, failure)+without being locked to one concrete monad stack, constrain it+polymorphically (`(MonadReader Config m, MonadError MirrorError m) => ...`)+rather than hardcoding `ReaderT Config (ExceptT MirrorError IO) a`. This+is 0.5's dependency inversion applied to effects: the function states+what it needs, not which stack provides it, and can be run over a pure+test stack and a real `IO` stack without being rewritten. Reach for a+full effect system (`polysemy`/`effectful`/`fused-effects`) only once+the mtl-style constraint set is unwieldy in practice — not by default.++### 3.10 Free monads / tagless-final — advanced, use only when interpreter-swapping is a real requirement+These let business logic be written once and interpreted multiple ways+(a real backend, an in-memory test double, a dry-run/audit log). They are+powerful and legitimately useful, but they add real conceptual and+compile-time cost. Reach for them only when the Handle pattern (0.5)+genuinely can't express the needed flexibility — e.g. when the *sequence+of operations itself* needs to be inspected or optimized before+execution, not just when-swapped. Justify the choice in the module's+Haddock when used.++### 3.11 Refinement types (Liquid Haskell) — optional, for the highest-stakes invariants only+When a smart constructor's `Either`-returning runtime check would be+better as a statically checked refinement (e.g. "this index is always+in bounds," "this list is always sorted"), Liquid Haskell annotations+can move the proof obligation to compile time, checked by an SMT solver.+This is an opt-in escalation for the small number of invariants where+the cost of getting it wrong is high enough to justify the tooling+overhead — not a default for every smart constructor in the codebase.++### 3.12 Type aliases document; they don't protect — don't mistake one for the other+`type CustomerId = Text` buys readability and nothing else: the compiler+still lets a bare `Text` meant as an email address flow anywhere a+`CustomerId` is expected. Reach for `type` only as genuine shorthand for+a long, repeated type expression. The moment two values sharing an+underlying representation must not be interchangeable, that's `newtype`+territory (3.2), not `type`.++### 3.13 Use the standard abstractions idiomatically; prefer the weakest one that suffices+Write code against `Functor`, `Applicative`, `Monad`, `Foldable`, and+`Traversable` using their standard combinators (`fmap`, `traverse`,+`sequence`, `for_`) rather than reimplementing their effect by hand —+4.1's combinator discipline applied to the handful of classes that recur+constantly. Prefer `Applicative` over `Monad` whenever the computation's+structure doesn't actually depend on a previous result: an `Applicative`+signature is a stronger, more honest claim ("these effects are+independent of each other") than a `Monad` signature over the same code,+and it composes and parallelizes better as a direct consequence.++### 3.14 Parametric polymorphism internally; concrete types at the boundary+Prefer a polymorphic type (`Foldable t => t a -> ...`) inside a module+where it genuinely generalizes the logic without adding constraint-+solving noise (0.10). At a module's public boundary — the functions in+its export list — prefer concrete, specific types over polymorphism for+its own sake: `Document -> Either MirrorError Html` is easier to consume,+produces clearer type errors at the call site, and is easier to reason+about than a signature generalized over a typeclass nobody outside the+module will ever instantiate differently.++### 3.15 Linear types — when a resource's usage discipline is itself the invariant+Where correctness depends not just on a value's shape but on *how many+times and in what order* it is used — a file handle that must be closed+exactly once, a protocol token that must not be duplicated or silently+dropped — `LinearTypes` let the compiler enforce that usage discipline+the same way GADTs (3.5) enforce shape. Treat this as a specialized,+last-resort-among-first-resorts tool: reach for it only when the+resource-usage invariant can't be adequately captured by a Handle (0.5)+plus ordinary discipline, since linear types add real signature-level+complexity everywhere the resource is touched.++---++## Part 4 — Code Style: Algorithmic, Not Improvised++Every non-trivial piece of control flow is either a **named combinator**+or a **named, published algorithm** — so a reader verifies it by+recognition, not by re-deriving it line by line. This is not a request+for brevity or point-free cleverness; point-free style is permitted only+where it reveals structure (4.4), and is otherwise prohibited.++### 4.1 Name the recursion scheme before writing the recursion+| Shape | Combinator |+|---|---|+| Consume a structure, build one value | `foldr` / `foldl'` |+| Produce a stream from a seed until done | `unfoldr` |+| Structure-preserving traversal with effects | `traverse` / `mapM` |+| Map while threading accumulator state | `mapAccumL` / `mapAccumR` |+| Repeated application until a fixed point | `until` / `iterate` + `takeWhile` |+| Group / partition by a predicate | `span`, `break`, `groupBy`, `partition` |++Hand-written recursion is reserved for logic with no existing combinator+shape — and even then, the Haddock states which scheme it approximates+and why no combinator fits.++### 4.2 If a published algorithm solves the exact problem, implement that algorithm, by name+Don't reinvent a heuristic that happens to converge on a known+algorithm's answer — implement the known algorithm and cite it (Kahn's+algorithm for topological order, Pratt parsing for precedence-based+expression parsing, Myers' algorithm for sequence diffing, and so on).+Naming it lets a reviewer check the implementation against a reference+instead of re-establishing correctness from first principles.++### 4.3 Match complexity to access pattern+`Map`/`Set` for lookup-heavy code, not a linearly scanned `[a]`; `Seq`+for append/index-heavy code, not a repeatedly reversed list. Do not,+conversely, reach for a more sophisticated algorithm than the problem+needs (0.7) — correct complexity for the real access pattern, not+maximal sophistication for its own sake.++### 4.4 Point-free style only when it reveals structure+`f = g . h` is preferred over an explicit lambda only when the+composition itself is the insight worth stating. If it requires the+reader to mentally re-expand it to check what's happening, write it+pointfully. Never chain more than two or three compositions without a+named intermediate.++### 4.5 Every exported function is one lemma+If a function's body doesn't fit in roughly 15–20 lines, it's not one+claim, it's several — split it and name each part. A long `case` across+a closed type is fine (it's exhaustiveness, not sprawl); a long sequence+of unrelated steps is not.++### 4.6 The type signature is the theorem; the Haddock states the invariant, not the procedure+**Bad:** `-- loops through the list and picks out the valid rows`+**Good:** `-- | The only way to obtain a 'Table': every row, header+included, is checked against the first row's width. On success, the+result's rectangularity is guaranteed for every later consumer.`++### 4.7 Reuse a proven library's implementation of a named algorithm before writing your own+4.2 says to implement a named, published algorithm rather than an ad hoc+heuristic. The stronger version: if a well-maintained library already+provides that exact algorithm correctly, depend on it (2.11) instead of+re-implementing it. Reserve a from-scratch implementation for the case+where no adequate library exists, or where this codebase's handling of+untrusted input specifically requires an implementation whose safety+properties can be independently audited (Part 5).++### 4.8 Consistent naming conventions, applied without exception+One convention per category: types and constructors in `UpperCamelCase`,+functions and fields in `lowerCamelCase`, module names mirror their file+path. Smart constructors are named `mkX` (3.3); unsafe or internal-only+constructors are prefixed `Unsafe` or kept unexported entirely. A reader+should be able to predict a name's category from its case alone, without+opening the module that defines it.++### 4.9 Laziness is exploited on purpose; strictness is added on evidence+Rely on laziness deliberately for what it's actually good at — infinite+or self-referential structures, short-circuiting, decoupling production+from consumption — and treat an unexplained space leak as a bug to+diagnose, not a tax to accept. Add strictness annotations (`!` on+fields, `seq`, `foldl'` over `foldl`, `BangPatterns`) only where+profiling, not intuition, has shown a real leak or a real cost.+Premature strictness is the same unjustified complexity 0.7 already+prohibits, just approached from the performance direction instead of the+abstraction direction.++### 4.10 Recursion over unbounded input is stack-safe — strictly enforced+Beyond 2.4's bound on adversarial nesting, any function that folds or+recurses over a structure whose size is driven by ordinary, legitimate+input (a large file, a long list) must not blow the stack. Use+`foldl'`/`foldMap'`-style strict folds instead of `foldr`/lazy `foldl`+for large accumulations, prefer combinators with known stack behavior+(4.1's table) over bespoke recursion, and make any genuinely necessary+hand-written recursive function tail-recursive with a strict+accumulator. A function that works in tests on small fixtures but is+never checked against a realistically large input is not verified to be+stack-safe — add a large-input case specifically to catch this (5.4).++### 4.11 Known space-leak patterns are avoided by construction+The recurring, well-documented sources of Haskell space leaks are treated+as defects, not idiosyncrasies to tolerate: unbounded thunk buildup from+lazy accumulation (`foldl` on a large list, a lazy `State`/`Writer`+accumulator never forced), quadratic-blowup string/list concatenation+(repeated `(++)` instead of a builder or `Data.Text.Builder`/`Seq`),+holding onto the head of a list or a whole lazy `ByteString`/`Text` far+longer than needed because one small part of it is still referenced, and+unbounded lazy I/O. Each is a specific, nameable pattern (not a vague+"Haskell can leak" caveat), and each has a specific, standard fix — apply+the fix at the point the pattern is introduced, not after a production+memory graph shows it.++---++## Part 5 — Verification and Enforcement++### 5.1 Mandatory compiler flags+```+-Wall -Wcompat -Werror+-Wincomplete-uni-patterns -Wincomplete-record-updates+-Wmissing-export-lists -Wunused-imports -Wunused-top-binds+-Wunused-local-binds -Wunused-matches+-Wredundant-constraints -Wpartial-fields -Widentities+```++### 5.2 Banned outright (lint-enforced)+`head`, `tail`, `fromJust`, `(!!)`, `error`, `undefined`,+`unsafePerformIO`, `Debug.Trace.*` in committed code, partial record+field accessors, `OverlappingInstances`/`IncoherentInstances` without+explicit written justification, and any unreachable code flagged by+`weeder` (1.11).++### 5.3 Formatting is enforced, not a matter of taste+`ormolu` or `fourmolu` runs as a CI check alongside `hlint`, so a diff is+never mixed style-only noise and substantive change, and no two+contributors — human or AI — drift into different house styles over+time.++### 5.4 Tests are exhaustive, including outliers — strictly enforced+A test suite that only exercises the happy path is incomplete by+definition, not merely light. For every function with a bounded or+partially-bounded domain, tests cover: the empty/zero/minimum case, the+single-element case, the maximum or a realistically large case (4.10),+known adjacent-to-boundary values (off-by-one candidates), malformed or+adversarial input for anything crossing a trust boundary (2.4), and, via+property-based testing, a generator wide enough that these outliers are+sampled rather than hand-picked and potentially forgotten. "It passes on+the examples I thought of" is not exhaustive; "the generator's shrinker+was pointed at this class of input and found nothing" is closer to what+this rule requires.++### 5.5 Every stated invariant needs a property test in the same change that introduces it+A Haddock claim ("output is always escaped," "result is always+rectangular," "instance obeys the Monoid laws") ships with a+QuickCheck/Hedgehog property checking exactly that claim, in the same+diff — not as an afterthought.++### 5.6 Benchmarking is part of the test suite, not a side activity+Every module on a path that matters for real-world input size (parsers,+renderers, anything called per-request) has a `criterion` (or+equivalent) benchmark checked in alongside its tests, run in CI with+regression thresholds, not just on demand before a release. This is the+evidence 4.9 requires before adding a strictness annotation, and the+mechanism that makes "performance is addressed deliberately, with+evidence" (the precedence rule at the top of this document) an actual+practice rather than a stated intention. A change that regresses a+benchmark beyond its threshold is treated the same as a failing test.++### 5.7 Known bugs from comparable prior art are pre-empted, not rediscovered+Before implementing a component that has established prior art (a DOCX+parser, a Markdown renderer, an HTML escaper, a diff algorithm), the+issue tracker and changelog of at least one or two comparable existing+projects are reviewed for the specific bug classes they've hit historically+— parser desync on a particular malformed input, an escaping bypass, a+resource-exhaustion vector, an off-by-one in a boundary case. Each+applicable bug class gets a named regression test *written before or+alongside the first implementation*, not added reactively after the same+bug is independently rediscovered in this codebase. This research is+recorded (a short note or linked issue) so the next contributor can see+which known failure modes were already checked, rather than re-doing the+same archaeology or, worse, assuming it was never done.++### 5.8 Two-pass self-audit for AI-authored code+After writing a function, re-read its own Haddock claim and check, line+by line, whether the implementation actually establishes it. Do not+trust a comment written in the same pass that wrote the code. State+explicitly if a claimed invariant is *not* fully established, rather+than leaving an inaccurate guarantee in place.++### 5.9 Deviations are recorded, not silent+If a rule in this document is knowingly not followed for a specific,+justified reason (performance-critical hot path, a library's API forces+an escape hatch), record it as a short Architecture Decision Record next+to the code — what rule was relaxed, why, and what was tried first — so+it reads as a deliberate, reviewed exception, not an oversight.+++---++## Part 6 — Before the Project Starts: Setup Checklist++Put this in place *before* the first feature module is written.++- [ ] `cabal`/`hpack` project skeleton with the Part 5 GHC flags set as a+      shared `common warnings` stanza, applied to every component+      (library, executable, tests) — not opt-in per module.+- [ ] `hlint` configured with the Part 5 ban-list as errors, not+      suggestions, wired into CI.+- [ ] Module skeleton drawn along the hexagonal boundary of 2.6 up+      front: a `Core`/`Domain` area (pure, IR-centered) and an+      `Adapters` area (parsers, renderers, storage, network) — so the+      dependency direction is structural from commit one, not something+      to "clean up later."+- [ ] A single canonical IR module identified and agreed before any+      format-specific or adapter-specific module is started (2.1).+- [ ] The closed-vocabulary error type (2.3) scaffolded before the first+      failure case is needed, with the reachability discipline (1.5)+      stated in its own Haddock.+- [ ] Test framework wired for both example-based (hspec) and+      property-based (QuickCheck/Hedgehog) tests from the first+      commit, with the rule from 2.9 (tests exercise the pure core+      directly) established as the default shape, and an explicit+      outlier/boundary-case checklist template for new test modules (5.4).+- [ ] Benchmark harness (`criterion` or equivalent) wired into CI with+      regression thresholds before the first performance-relevant module+      is merged, not added retroactively once something feels slow (5.6).+- [ ] For each planned component with established prior art, the known+      bug classes from at least one or two comparable projects' issue+      trackers reviewed and logged before implementation begins, with a+      named regression test planned for each applicable one (5.7).+- [ ] This document itself checked into the repository (e.g.+      `ENGINEERING_STANDARD.md`) and referenced from the project's+      `README` and from any AI-agent configuration file (`CLAUDE.md`,+      `.cursorrules`, or equivalent), so it is loaded as context+      automatically rather than depended on being remembered.++---++## Pre-submission Checklist++Before presenting any Haskell code written or edited under this+standard, confirm each of the following, explicitly:++- [ ] Single responsibility per module; no "and" needed to describe it (0.1)+- [ ] Extension axis for this change identified as closed-sum or+      Handle/typeclass, and consistent with existing choice (0.2, 2.7)+- [ ] Any new typeclass instance obeys its class's laws (0.3)+- [ ] Typeclass/Handle constraints are the narrowest that suffice (0.4, 0.10)+- [ ] New effectful dependency passed as a Handle or mtl-style+      constraint, not imported and called directly (0.5, 3.9)+- [ ] No duplicated *invariant logic*; deliberate, justified duplication+      of unrelated-but-similar code left alone (0.6)+- [ ] No speculative generality — the mechanism added matches a real,+      current requirement (0.7)+- [ ] No structure reached through more than one level deep (0.8)+- [ ] No partial functions; every failure path is typed (1.1)+- [ ] Illegal states are unrepresentable, not just checked (1.2, 3.1)+- [ ] Cross-field invariants enforced once, at construction, via an+      unexported constructor (1.3, 3.3)+- [ ] Closed domains are sum types, not strings (1.4)+- [ ] Errors are structured and layered by pipeline stage (1.5, 2.3)+- [ ] `IO` confined to the edges; core logic pure and independently+      testable (1.6, 2.9)+- [ ] Considered whether a newtype, phantom type, or GADT would close a+      hole more cheaply than a runtime check (3.2, 3.4, 3.5) — and, if+      an existential was used, justified why a closed sum couldn't (3.6)+- [ ] Single canonical IR respected if multiple formats are involved (2.1)+- [ ] Recursive structures have an explicit depth/size bound, applied+      uniformly across every stage capable of producing the nesting (2.4)+- [ ] Module exports only what's safe to export (2.5)+- [ ] No hand-rolled recursion where a named combinator applies (4.1)+- [ ] Known algorithms implemented and cited by name, not reinvented (4.2)+- [ ] Every function is one lemma, ~15–20 lines or fewer (4.5)+- [ ] Every non-trivial comment states an invariant, not a procedure (4.6)+- [ ] A named algorithm's proven library implementation used in+      preference to a from-scratch one, where a good one exists (4.7)+- [ ] Naming follows the standard convention for its category (4.8)+- [ ] Any new strictness annotation is backed by profiling evidence, not+      intuition (4.9)+- [ ] No new mutable local state where pure recursion/record-update would+      do (1.9)+- [ ] New module placed by domain, not dropped into a `Utils`/`Common`+      catch-all (2.10)+- [ ] Any new dependency is deliberate, well-maintained, and not+      duplicating an existing one (2.11)+- [ ] `type` alias not used where a `newtype` boundary was actually+      needed (3.12)+- [ ] `Applicative` used instead of `Monad` where the effects are+      genuinely independent (3.13)+- [ ] Public boundary functions use concrete types; polymorphism kept+      internal to where it earns its constraints (3.14)+- [ ] No dead code, no `undefined`/stub placeholders merged (1.11, 5.2)+- [ ] Error messages name the specific thing and location that failed;+      errors live in their own dedicated module (2.15)+- [ ] Any function over unbounded legitimate input is checked+      tail-recursive/strict-accumulator and tested on a large input (4.10)+- [ ] Checked against the named space-leak patterns — no `foldl` on a+      large structure, no repeated `(++)`, nothing holding a large+      structure alive longer than needed (4.11)+- [ ] New tests cover the boundary/empty/maximum/adversarial cases, not+      only the happy path (5.4)+- [ ] A benchmark exists and is checked in for any change on a+      performance-relevant path (5.6)+- [ ] For new prior-art-backed components, comparable projects' known+      bug classes were checked and pre-empted with a named test (5.7)+- [ ] Every claimed invariant has a matching property test (5.5)+- [ ] Self-audited: implementation re-checked against its own stated+      claim, in a separate pass (5.8)+- [ ] Any knowing deviation from this document recorded as a short ADR,+      not left silent (5.9)
+ LICENSE view
@@ -0,0 +1,30 @@+BSD 3-Clause License++Copyright (c) 2026, Sabrinathan Nair+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,249 @@+# figment++Layered configuration for Haskell, after Rust's+[`figment`](https://docs.rs/figment): combine files (JSON, TOML, YAML),+environment variables, command-line arguments and Haskell values; select+profiles; decode into your own types. Every value remembers where it came+from, so when something is wrong you get **every** problem at once, each+pointing at the key, the name you would actually type (`APP_PORT`,+`--port`), the file, and the line and column:++```text+4 configuration errors:++error: missing field `name`+  --> key `name`+  = hint: no source sets it; it can be set as `name` in TOML source string, or `APP_NAME` in environment variables (prefix APP_)++error: unknown field `hots`+  --> key `db.hots` in TOML source string at line 4, column 8+  = hint: did you mean `host`?++error: invalid value: found integer 70000, expected an integer in the range 0..65535+  --> key `db.port` in TOML source string at line 3, column 8++error: unknown variant `verbose`, expected one of `Debug`, `Info`+  --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_)+```++(That exact output is pinned by a golden test.)++## Quick start++```haskell+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings, TypeApplications #-}++import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Function ((&))+import Data.Text (Text)+import GHC.Generics (Generic)++import qualified Figment as F++data Config = Config+  { name :: Text+  , port :: Int+  , debug :: Bool+  }+  deriving stock (Show, Generic)+  deriving anyclass (F.FromConfig)++figment :: F.Figment+figment =+  F.new+    & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False]))+    & F.merge (F.file F.toml "App.toml")      -- optional; searched for upwards+    & F.merge (F.prefixed "APP_")              -- APP_PORT=9000, APP_DEBUG=true++main :: IO ()+main = F.loadExtractOrThrow @Config figment >>= print+```++Import `Figment` qualified: it exports `merge`, `join` and `from`. The+README examples are compiled and run by the test suite.++**New to figment?** Start with the tutorial,+[`Figment.Tutorial`](https://hackage.haskell.org/package/figment/docs/Figment-Tutorial.html):+sixteen short sections covering layering, environment variables, the+command line, profiles, errors, decoding, provenance, partial+configurations, library patterns, custom providers and testing. It also+has a cheat sheet for Rust figment users and a guide for upgrading from+0.1.++## Concepts++**Providers** produce configuration, one dictionary per **profile**. A+**`Figment`** is a pure description: an ordered list of providers, each+combined with one of four strategies (the same as Rust figment):++| strategy  | on a conflicting key | arrays      |+|-----------|----------------------|-------------|+| `merge`   | incoming value wins  | replaced    |+| `join`    | existing value wins  | kept        |+| `admerge` | incoming value wins  | concatenated|+| `adjoin`  | existing value wins  | concatenated|++Dictionaries always merge key by key. Building a figment does no IO.+`load` runs every provider, collects **every** failure (an unreadable+file and a syntax error elsewhere are reported together), and combines+the results. `Figment` is a lawful `Monoid`, so a library can publish its+defaults as a `Figment` and an application can append overrides with+`<>`. (The value-level merge is *not* associative, so values have no+`Semigroup`; the laws are property-tested.)++**Profiles.** On extraction, the `Default` profile is merged with the+selected profile, and the `Global` profile is merged over both. Select+with `F.select "prod"`, or read the choice from the environment with+`F.profileFromEnv "APP_PROFILE" F.Default`. With `F.nested`, a file's+top-level keys are profiles:++```toml+[default]+workers = 4+[prod]+workers = 32+```++## Providers++| provider | notes |+|---|---|+| `F.file fmt path` | optional; a relative path is searched for in the working directory and its parents. `F.fileExact` does not search; `F.required` makes absence an error; `F.nested` maps top-level keys to profiles |+| `F.fromText fmt text` | configuration held in memory |+| formats `F.json`, `F.toml`, `F.yaml` | each parser enforces depth and size limits *while parsing*, rejects duplicate keys, and (TOML, YAML) records line and column for every value |+| `F.prefixed "APP_"` | environment variables, Rust semantics: no splitting unless `Env.split "__"`; values are typed (`8080`, `true`, `[1, 2]`, `{a = 1}`) while keeping the original text (so a `Text` field gets `007`, not `7`); conflicts are errors; see `Figment.Provider.Env` for `only`, `ignore`, `mapKeys`, `global`, ... |+| `F.cli args` | `--key=value`, `--flag`, `--no-flag`, `--db.port=1`, `--` ends options; see `Figment.Provider.Cli` |+| `F.defaults x`, `F.globals x`, `F.keyed "db.port" x` | any `ToJSON` value; errors point at the Haskell source line |+| a `Figment` | figments nest, keeping the provenance of every inner value |+| your own | implement the three-method `Provider` class |++Format details: TOML dates and times arrive as ISO 8601 strings and+decode straight into `Day`, `LocalTime`, `ZonedTime`, `UTCTime`; `inf`+and `nan` are kept as non-finite numbers. YAML uses the 1.2 core schema+(`no` and `on` stay strings, so there is no "Norway problem"), supports+anchors, aliases and merge keys (`<<`), and charges alias expansion to+the node limit, which defeats "billion laughs". Invalid UTF-8 is an+error, never silently replaced.++## Decoding++`FromConfig` is figment's own decoding class. It reads the value tree+directly, which is how errors know their source and position. Derive it+with `Generic`:++* records are dictionaries; `Maybe` fields are optional;+* enums are strings, matched case-insensitively; unknown variants list+  the valid ones;+* other sum types are externally tagged (`{ Circle = { radius = 1 } }`);+* newtypes unwrap and positional constructors are arrays.++`genericDecoder defaultOptions { fieldLabelModifier = snakeCase,+rejectUnknownFields = True }` changes the key names and reports unknown+keys with suggestions. Hand-written decoders use an **accumulating**+applicative (`field`, `optionalField`, `fieldOr`, `validate`, ...). It+deliberately has no `Monad` instance, so independent errors are never+hidden; `andThen` gives you sequencing when you need it.++Strict by default: a string is not a number. `F.extractLossy` accepts+`"8080"` for numbers and `"yes"` for booleans (Rust's `extract_lossy`).++Magic types: `Tagged a` carries the value's provider, profile, position+and path. `RelativePath` resolves a path written in a file against+*that file's* directory. `ViaAeson a` reuses an existing `FromJSON`+instance, and aeson's error path is translated so it still points at+the right key and line.++Queries on a loaded configuration: `findValue`, `contains`,+`findMetadata`, `extractAt` (Rust: `extract_inner`), `focus`,+`reselect`.++## Partial configurations: no missing field, by construction++Write the record once, parameterised by a functor:++```haskell+data ServerF f = Server+  { host :: F.Field f Text+  , listen :: F.Field f Int+  , workers :: F.Field f Int+  }+  deriving stock (Generic)++instance F.Partial ServerF++type Server = ServerF F.Identity   -- ordinary fields: host :: Text++serverDefaults :: ServerF Maybe+serverDefaults = (F.emptyPartial @ServerF) {listen = Just 8080, workers = Just 4}++-- given a loaded configuration `loaded :: F.Loaded`, every missing field+-- is reported at once, each with the env var, CLI flag, or file key+-- that would have set it:+--+--   F.extractPartial serverDefaults loaded :: Either F.ConfigErrors Server+```++`F.extractTotal` takes *total* defaults (`ServerF Identity`). Its type+guarantees that a missing-field error cannot happen; only type errors in+the values that are present remain. Nested partial records are+supported, and `overlay`, `complete` and `total` are available for your+own layering.++## Safety++* **Limits** (`F.defaultLimits`: depth 64, one million values; override+  with `F.withLimits`) are enforced inside every parser, so a hostile+  `[[[[...` megabyte is rejected at depth 65 without being built.+* No exception escapes `load`: I/O and parse failures are errors, and a+  synchronous exception thrown by a third-party provider becomes an+  `IoError` (asynchronous exceptions are re-thrown, as they must be).+* `ConfigErrors` is an `Exception` whose `displayException` is the+  rendered report.++## Testing your configuration++`Figment.Jail.withJail` runs a test in a fresh temporary working+directory with a snapshot of the environment, restores both afterwards,+and serialises jails process-wide, so jailed tests are safe under a+parallel runner. `Env.fromList` gives an environment provider fixed+variables, with no global state at all.++## Compared with Rust figment++Feature parity: providers, the four strategies, profiles (default,+global, nested, selection), metadata with interpolated key names and the+code location where each provider was added, `Tagged`, `RelativePath`,+lossy extraction, `extract_inner`/`focus`/`find_value`/`contains`, a+test jail, and figments as providers.++Beyond it:++* all errors are reported at once, not one per run;+* TOML and YAML errors and values carry line and column;+* missing-field hints list the exact env var, flag and key to set;+* unknown fields come with "did you mean" suggestions;+* `extractTotal` guarantees, through its type, that no field is missing;+* resource limits are enforced inside the parsers, YAML alias bombs are+  defeated, and the YAML 1.2 core schema avoids the Norway problem;+* conflicting env vars or flags are errors, never silently resolved;+* the builder is a lawful monoid with property-tested laws.++## Building++```bash+cabal build all+cabal test+bash scripts/check-compile-fail.sh   # the compile-time guarantees+cabal bench+```++Supported compilers: GHC 9.10 and 9.12.++Version 0.2.0.0 is a breaking redesign of 0.1; see the changelog. The+source distribution also contains the design record: `ADRs/` (decisions+016 onwards apply to 0.2) and `docs/audit-remediation.md` (each problem+found in 0.1, how it was fixed, and the test that pins it).++License: BSD-3-Clause.
+ bench/Bench.hs view
@@ -0,0 +1,68 @@+-- | Benchmarks for the per-load path: parsing each format, combining+-- layers, and decoding (ADR 011).+module Main (main) where++import Control.DeepSeq (NFData, rnf)+import Criterion.Main+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import Data.Text (Text)+import GHC.Generics (Generic)++import qualified Figment as F++data Service = Service {name :: Text, port :: Int, replicas :: Int, tags :: [Text]}+  deriving stock (Generic)+  deriving anyclass (F.FromConfig)++instance NFData Service where+  -- fields are strict enough for a benchmark; force them explicitly+  rnf (Service n p r ts) = rnf n `seq` rnf p `seq` rnf r `seq` rnf ts++-- | A config with @n@ services, in each format.+jsonDoc, tomlDoc, yamlDoc :: Int -> Text+jsonDoc n = "{" <> Text.intercalate "," [svc i | i <- [1 .. n]] <> "}"+  where+    svc i = "\"s" <> t i <> "\":{\"name\":\"svc" <> t i <> "\",\"port\":" <> t (8000 + i)+      <> ",\"replicas\":3,\"tags\":[\"a\",\"b\",\"c\"]}"+tomlDoc n = Text.concat [svc i | i <- [1 .. n]]+  where+    svc i = "[s" <> t i <> "]\nname = \"svc" <> t i <> "\"\nport = " <> t (8000 + i)+      <> "\nreplicas = 3\ntags = [\"a\", \"b\", \"c\"]\n"+yamlDoc n = Text.concat [svc i | i <- [1 .. n]]+  where+    svc i = "s" <> t i <> ":\n  name: svc" <> t i <> "\n  port: " <> t (8000 + i)+      <> "\n  replicas: 3\n  tags: [a, b, c]\n"++t :: Int -> Text+t = Text.pack . show++-- | Load and decode everything, forcing the result.+loadDecode :: F.Figment -> IO Int+loadDecode fig = do+  r <- F.loadExtract fig :: IO (Either F.ConfigErrors (Map.Map Text Service))+  case r of+    Left es -> fail (Text.unpack (F.renderErrors es))+    Right m -> pure $! (rnf m `seq` Map.size m)++main :: IO ()+main =+  defaultMain+    [ bgroup "load+decode 200 services"+        [ bench "json" $ nfIO (decodeFrom (F.fromText F.json (jsonDoc 200)))+        , bench "toml" $ nfIO (decodeFrom (F.fromText F.toml (tomlDoc 200)))+        , bench "yaml" $ nfIO (decodeFrom (F.fromText F.yaml (yamlDoc 200)))+        ]+    , bgroup "layers"+        [ bench "3 layers x 200 services" $ nfIO $ decodeLayers+            ( F.new+                & F.merge (F.fromText F.json (jsonDoc 200))+                & F.join (F.fromText F.toml (tomlDoc 200))+                & F.admerge (F.fromText F.yaml (yamlDoc 200))+            )+        ]+    ]+  where+    decodeFrom d = loadDecode (F.from d)+    decodeLayers = loadDecode
+ docs/audit-remediation.md view
@@ -0,0 +1,66 @@+# Audit remediation (0.1.0.0 → 0.2.0.0)++Each finding from the forensic audit, what changed, and the test that+pins it. Test names are tasty patterns (`cabal test --test-options='-p "..."'`).++## Critical++| # | Finding | Resolution | Pinned by |+|---|---|---|---|+| C1 | `EnvPrefixed`/`CliArgs` stored `{}` for every value | Shared, tested `Internal.Nest`; values parsed and kept | `REGRESSION C1/H1` (env), `REGRESSION C1` (cli) |+| C2 | `composeChecked`'s type list was not tied to the layers | Removed. Replaced by HKD partial configs with a real guarantee (ADR 021) | `partial (HKD)`; `test/compile-fail/*` |+| C3 | Decode errors reported the first leaf's path | Native decoder; exact paths; all errors accumulate (ADR 018) | `REGRESSION C3`, `all errors are reported at once` |+| C4 | Profiles were dead code | Default → selected → global; `select`; nested files; hints (ADR 023) | `default profile, then selected, then global`, `nested files` |+| C5 | `readFile` threw; TOML caught async exceptions | `IOException` handled per provider; safety net in `load` re-throws async exceptions | `a missing required file`, `an exception escaping a provider becomes an error`, fuzz properties |+| C6 | Silent data loss: TOML dates→null, inf/nan garbage, UTF-8 replaced, duplicate keys | Dates are ISO strings decoding to `Data.Time`; non-finite numbers kept; strict UTF-8; duplicates are errors in JSON, YAML and TOML; env/CLI conflicts are errors | `dates and times`, `inf and nan`, `invalid UTF-8`, `duplicate keys`, `conflicts are reported` |++## High++| # | Finding | Resolution | Pinned by |+|---|---|---|---|+| H1 | Env/CLI values were all strings | TOML-like value parsing, original text kept in `tagRaw` (`007` stays `007` for `Text`) | `REGRESSION C1/H1`, `structured values` |+| H2 | Always split on `_`; underscored fields unreachable | No split by default; opt-in `split "__"` (ADR 019) | `REGRESSION H2` |+| H3 | README example did not compile | README examples are compiled and run by the test suite | `README` group |+| H4 | "No Semigroup" argument misplaced | `Figment` is a lawful `Monoid` (free monoid on steps); `Value` has none (non-associativity demonstrated) | `Figment is a monoid`, `not associative in general`, `test/compile-fail/NoValueSemigroup.hs` |+| H5 | Container tags lost; concat corrupted stored paths | Tags follow Rust (join keeps left, merge keeps right); paths are positional, never stored, so they cannot go stale | `container tags follow Rust`, `duality` |+| H6 | Depth guard ran after the parsers | `Limits` enforced inside every parser; alias expansion is charged (ADR 017) | `adversarial` group |+| H7 | `UnsafeDepth` exported through an exposed module | `Limits` has a hidden constructor; internals are `other-modules` | `custom limits are validated` |+| H8 | One error at a time; no `Exception`; golden tests pinned `show`; dead constructors | `ConfigErrors` (non-empty, `Semigroup`, `Exception`), renderer pinned by goldens, every `ErrorKind` constructor produced (ADR 025) | `errors (golden)` |+| H9 | Safe Haskell claims did not match the code | Pragmas removed (ADR 022) | — |++## Medium++| # | Finding | Resolution |+|---|---|---|+| M1 | `Path` was a list of text keys (index/key confusion, O(n²) snoc) | `Seq Segment` with `Key`/`Index`; `renderPath`/`parsePath` round-trip |+| M2 | Arrays as lists | `Vector` |+| M3 | Key order and number kinds | Keys are sorted (Rust's default ordering); numbers are exact `Scientific`, plus explicit non-finite values; integral decoders accept integral values (`1.0` included), never truncate, and never wrap |+| M4 | Lazy fields | All value, tag and error fields strict |+| M5 | Top level not required to be a dictionary | Enforced with a precise error |+| M6 | Null semantics implicit | Documented in `Figment.Merge` (Rust semantics: `null` is a value) |+| M7 | Copy-pasted `buildRaw` | One `Internal.Nest` |+| M8 | Lazy IO, stringly `SourceId`, no call site | Strict reads; structured `Source`; `HasCallStack` site per provider; interpolater |+| M9 | CLI doc/behaviour mismatch, no flags | Revised rule (ADR 020) |+| M10 | Dead type-level code | Removed with `Figment.Check` |+| M11 | Global CPP/DeriveAnyClass, heavy tool dep, dishonest bounds, stale freeze | GHC2021 with explicit strategies; no CPP; no `build-tool-depends`; bounds equal tested compilers; freeze removed (ADR 016) |+| M12 | CI skipped compile-fail and benchmarks; junk files | Both are CI steps; `failure` removed; study file renamed |++## Documentation drift++Every ADR that 0.2 changes now carries a status note at the top, and+ADRs 016–025 record the new decisions. The README describes only+behaviour that the tests exercise.++## Not done (and why)++- **hlint / formatter in CI.** No hlint binary exists for the platform+  this release was prepared on, so a lint gate could not be run locally+  before adding it. Recommended next step: add a `haskell-actions/hlint-run`+  job and fourmolu once the code has been formatted once.+- **GHC 9.12.4.** Declared in `tested-with` and run by CI; the release+  was verified locally on 9.10.3 only.+- **Positions for JSON.** aeson's token stream does not expose offsets.+  JSON errors carry path and source, but no line or column.+- **Insertion-ordered dictionaries.** Keys are sorted, as in Rust+  figment's default. A `preserve_order` equivalent can be added later+  without breaking the API.
+ figment.cabal view
@@ -0,0 +1,156 @@+cabal-version:      3.0+name:               figment+version:            0.2.0.0+synopsis:           Layered configuration with provenance, profiles and complete error reports+description:+  A Haskell take on Rust's figment. Combine configuration from files+  (JSON, TOML, YAML), environment variables, command-line arguments and+  Haskell values; select profiles; and decode into your own types.+  .+  Every value remembers where it came from, so all problems are reported+  together, each with the key, the name you would type to fix it+  (@APP_PORT@, @--port@), the file, and the line and column. Higher-kinded+  partial configurations give a compile-time guarantee that no field is+  missing. Parsers enforce resource limits while parsing.+  .+  Start with "Figment.Tutorial"; the API is in "Figment".+license:            BSD-3-Clause+license-file:       LICENSE+author:             Sabrinathan Nair+maintainer:         bombay.boyz@hotmail.com+copyright:          (c) 2026 Bombay-Boyz+homepage:           https://github.com/Bombay-Boyz/Figment+bug-reports:        https://github.com/Bombay-Boyz/Figment/issues+category:           Configuration+build-type:         Simple+tested-with:        GHC == 9.10.3 || == 9.12.4+extra-doc-files:+  README.md+  CHANGELOG.md+  ENGINEERING_STANDARD.md+  ADRs/*.md+  docs/*.md+extra-source-files:+  test/golden/*.txt+  test/compile-fail/*.hs+  scripts/check-compile-fail.sh++source-repository head+  type:     git+  location: https://github.com/Bombay-Boyz/Figment++flag dev+  description: Enable -Werror for local development+  default:     False+  manual:      True++common shared+  default-language: GHC2021+  default-extensions:+    DerivingStrategies+    DeriveAnyClass+    LambdaCase+    OverloadedStrings+  ghc-options:+    -Wall -Wcompat+    -Wincomplete-uni-patterns -Wincomplete-record-updates+    -Wmissing-export-lists -Wpartial-fields -Wredundant-constraints+    -Widentities -Wunused-packages+  if flag(dev)+    ghc-options: -Werror++library+  import:           shared+  hs-source-dirs:   src+  exposed-modules:+    Figment+    Figment.Aeson+    Figment.Core+    Figment.Decode+    Figment.Error+    Figment.Extract+    Figment.Jail+    Figment.Limits+    Figment.Merge+    Figment.Metadata+    Figment.Partial+    Figment.Path+    Figment.Profile+    Figment.Provider.Cli+    Figment.Provider.Env+    Figment.Provider.Format+    Figment.Provider.Json+    Figment.Provider.Toml+    Figment.Provider.Yaml+    Figment.Tutorial+    Figment.Value+  other-modules:+    Figment.Internal.Budget+    Figment.Internal.Nest+    Figment.Internal.ValueParser+  build-depends:+      base        >= 4.20   && < 4.22+    , aeson       >= 2.2    && < 2.3+    , bytestring  >= 0.11   && < 0.13+    , conduit     >= 1.3    && < 1.4+    , containers  >= 0.6.7  && < 0.8+    , deepseq     >= 1.4.8  && < 1.6+    , directory   >= 1.3    && < 1.4+    , filepath    >= 1.4    && < 1.6+    , libyaml     >= 0.1.2  && < 0.2+    , scientific  >= 0.3.7  && < 0.4+    , temporary   >= 1.3    && < 1.4+    , text        >= 2.0.2  && < 2.2+    , time        >= 1.9    && < 1.15+    , toml-parser >= 2.0    && < 2.1+    , vector      >= 0.13   && < 0.14++test-suite figment-test+  import:           shared+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs+  other-modules:+    Figment.Test.Arbitrary+    Figment.Test.MergeLaws+    Figment.Test.Figment+    Figment.Test.Decode+    Figment.Test.Partial+    Figment.Test.Providers+    Figment.Test.Env+    Figment.Test.Cli+    Figment.Test.Errors+    Figment.Test.Adversarial+    Figment.Test.Readme+    Figment.Test.Tutorial+  build-depends:+      base+    , figment+    , aeson+    , bytestring+    , containers+    , deepseq+    , filepath+    , tasty        >= 1.4  && < 1.6+    , tasty-golden >= 2.3  && < 2.4+    , tasty-hunit  >= 0.10 && < 0.11+    , tasty-quickcheck >= 0.10 && < 0.12+    , QuickCheck   >= 2.14 && < 2.17+    , text+    , time+    , vector+  ghc-options:      -threaded -rtsopts "-with-rtsopts=-N"++benchmark figment-bench+  import:           shared+  type:             exitcode-stdio-1.0+  hs-source-dirs:   bench+  main-is:          Bench.hs+  build-depends:+      base+    , figment+    , containers+    , criterion  >= 1.6 && < 1.7+    , deepseq+    , text+  ghc-options:      -threaded -rtsopts
+ scripts/check-compile-fail.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+# Compile-time guarantees, checked mechanically (run from the package+# root after `cabal build`). CABAL may be overridden (CI passes its own).+set -euo pipefail+CABAL=${CABAL:-cabal}++typecheck() {+  $CABAL exec -v0 -- ghc -fno-code -package figment -package text "$1" 2>&1+}++expect_failure() {+  local fixture="$1" expected="$2" out+  if out=$(typecheck "$fixture"); then+    echo "FAIL: $fixture compiled, but must not"; exit 1+  fi+  if ! grep -q -- "$expected" <<<"$out"; then+    echo "FAIL: $fixture failed without the expected message '$expected':"; echo "$out"; exit 1+  fi+  echo "ok: $fixture is rejected ($expected)"+}++expect_success() {+  local fixture="$1" out+  if ! out=$(typecheck "$fixture"); then+    echo "FAIL: $fixture must compile:"; echo "$out"; exit 1+  fi+  echo "ok: $fixture compiles"+}++expect_success test/compile-fail/Ok.hs+expect_failure test/compile-fail/EmptyType.hs "cannot derive FromConfig for an empty data type"+expect_failure test/compile-fail/PartialSum.hs "a Partial configuration must be a record with a single constructor"+expect_failure test/compile-fail/NoValueSemigroup.hs "No instance for .Semigroup Value"
+ src/Figment.hs view
@@ -0,0 +1,187 @@+-- | Layered configuration with provenance: a Haskell take on Rust's+-- figment. New here? Read "Figment.Tutorial" first.+--+-- > import Data.Function ((&))+-- > import qualified Figment as F+-- > import qualified Figment.Provider.Env as Env+-- >+-- > data Config = Config {name :: Text, port :: Int, debug :: Bool}+-- >   deriving stock (Show, Generic)+-- >   deriving anyclass (F.FromConfig)+-- >+-- > main :: IO ()+-- > main = do+-- >   cfg <- F.loadExtractOrThrow @Config $+-- >     F.new+-- >       & F.merge (F.file F.toml "App.toml")+-- >       & F.merge (F.prefixed "APP_" & Env.split "__")+-- >       & F.merge (F.cli ["--port=9000"])+-- >   print cfg+--+-- Every value remembers its source, and failures are reported all at+-- once, each with its key path, the provider-native name (@APP_PORT@,+-- @--port@), the file, and the line and column.+--+-- This module re-exports the whole API. Import it qualified, because it+-- exports 'join', 'merge' and 'from'. Options for individual providers+-- live in "Figment.Provider.Env", "Figment.Provider.Cli" and+-- "Figment.Provider.Format". Test helpers are in "Figment.Jail".+module Figment+  ( -- * Building a figment+    Figment+  , new+  , from+  , merge+  , join+  , adjoin+  , admerge+  , combine+  , Order (..)+  , select+  , withLimits+  , figmentSources+  , Provider (..)+    -- * Loading+  , Loaded+  , load+  , loadedProfile+  , loadedSources+  , profiles+  , selected+  , reselect+  , findValue+  , contains+  , findMetadata+  , focus+    -- * Extracting+  , extract+  , extractLossy+  , extractAt+  , extractWith+  , loadExtract+  , loadExtractOrThrow+    -- * Partial (higher-kinded) configurations+  , Field+  , Partial (..)+  , extractPartial+  , extractPartialWith+  , extractTotal+  , extractTotalWith+  , Identity (..)+    -- * Decoding+  , FromConfig (..)+  , FromConfigKey (..)+  , Decoder+  , Result (..)+  , DecodeContext (..)+  , runDecoder+  , decodeWith+  , mkDecoder+  , andThen+  , withValue+  , currentPath+  , failWith+  , validate+  , field+  , fieldWith+  , optionalField+  , fieldOr+  , arrayOf+  , dictOf+  , textual+  , boundedIntegral+  , Options (..)+  , defaultOptions+  , snakeCase+  , kebabCase+  , genericDecoder+  , Tagged (..)+  , taggedMetadata+  , RelativePath (..)+  , relative+  , ViaAeson (..)+  , aesonDecoder+    -- * Providers+    -- ** Files and strings+  , Format+  , Data+  , json+  , toml+  , yaml+  , file+  , fileExact+  , fromText+  , nested+  , required+    -- ** Environment variables (see "Figment.Provider.Env" for options)+  , Env+  , prefixed+    -- ** Command-line arguments (see "Figment.Provider.Cli")+  , Cli+  , cli+  , cliFromProcess+    -- ** Haskell values+  , Serialized+  , defaults+  , globals+  , keyed+    -- * Values+  , Value (..)+  , Node (..)+  , Number (..)+  , Dict+  , Tag (..)+    -- * Paths+  , Path+  , Segment (..)+  , root+  , keyPath+  , parsePath+  , renderPath+  , (/.)+  , (/#)+    -- * Profiles+  , Profile (Default, Global)+  , profile+  , profileName+  , profileFromEnv+    -- * Metadata+  , Metadata (..)+  , Source (..)+  , Pos (..)+  , named+    -- * Errors+  , ConfigError (..)+  , ConfigErrors+  , ErrorKind (..)+  , errorList+  , renderError+  , renderErrors+    -- * Limits+  , Limits+  , mkLimits+  , defaultLimits+  , maxDepth+  , maxNodes+  ) where++import Data.Functor.Identity (Identity (..))++import Figment.Aeson+import Figment.Core+import Figment.Decode+import Figment.Error+import Figment.Extract+import Figment.Limits+import Figment.Merge+import Figment.Metadata+import Figment.Partial+import Figment.Path+import Figment.Profile+import Figment.Provider.Cli+import Figment.Provider.Env (Env, prefixed)+import Figment.Provider.Format+import Figment.Provider.Json+import Figment.Provider.Toml+import Figment.Provider.Yaml+import Figment.Value
+ src/Figment/Aeson.hs view
@@ -0,0 +1,159 @@+-- | Interoperability with aeson: reuse existing 'Data.Aeson.FromJSON' / 'Data.Aeson.ToJSON'+-- instances, and serialise Haskell values as a provider.+module Figment.Aeson+  ( -- * Decoding via FromJSON+    ViaAeson (..)+  , aesonDecoder+    -- * Conversion+  , toAeson+  , fromAeson+    -- * The Serialized provider+  , Serialized+  , defaults+  , globals+  , keyed+  , serializedIn+  , serializedNamed+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Types as AT+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import GHC.Stack (CallStack, HasCallStack, SrcLoc, callStack, getCallStack)++import Figment.Core+import Figment.Decode+import Figment.Error+import Figment.Internal.Budget+import Figment.Limits+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++-- | Decode with an existing 'Data.Aeson.FromJSON' instance:+--+-- > newtype Port = Port Int deriving newtype FromJSON+-- >   deriving FromConfig via ViaAeson Port+--+-- aeson's error path is translated into a figment t'Path', so the error+-- still points at the right key, file, line and column.+newtype ViaAeson a = ViaAeson {unViaAeson :: a}++instance Aeson.FromJSON a => FromConfig (ViaAeson a) where+  fromConfig = ViaAeson <$> aesonDecoder+  missingValue = ViaAeson <$> Aeson.omittedField++-- | A decoder from a 'Aeson.FromJSON' instance.+aesonDecoder :: Aeson.FromJSON a => Decoder a+aesonDecoder = mkDecoder $ \c v -> case AT.iparse Aeson.parseJSON (toAeson v) of+  AT.ISuccess a -> Success a+  AT.IError jpath msg ->+    let rel = fromSegments (map seg jpath)+        target = fromMaybe v (lookupPath rel v)+        t = valueTag target+    in Failure $ single+         ConfigError+           { errorKind = Message (Text.pack msg)+           , errorPath = ctxPath c <> rel+           , errorProfile = Just (fromMaybe (ctxProfile c) (tagProfile t))+           , errorMetadata = tagMeta t+           , errorPos = tagPos t+           , errorHints = []+           }+  where+    seg (AT.Key k) = Figment.Path.Key (Key.toText k)+    seg (AT.Index i) = Figment.Path.Index i++-- | Forget provenance and produce an aeson value. Non-finite numbers+-- (which JSON cannot represent) become strings.+toAeson :: Value -> Aeson.Value+toAeson (Value _ n) = case n of+  Null -> Aeson.Null+  Bool b -> Aeson.Bool b+  Num (Finite s) -> Aeson.Number s+  Num PosInfinity -> Aeson.String "inf"+  Num NegInfinity -> Aeson.String "-inf"+  Num NaN -> Aeson.String "nan"+  String t -> Aeson.String t+  Array xs -> Aeson.Array (fmap toAeson xs)+  Dict d -> Aeson.Object (KeyMap.fromList [(Key.fromText k, toAeson x) | (k, x) <- Map.toList d])++-- | Convert an aeson value, enforcing limits.+fromAeson :: Limits -> Aeson.Value -> Either ConfigError Value+fromAeson lim = runBudget lim . go 1 root+  where+    go :: Int -> Path -> Aeson.Value -> Budget Value+    go d p v = do+      spend 1 p Nothing+      case v of+        Aeson.Null -> pure (mkValue Null)+        Aeson.Bool b -> pure (mkValue (Bool b))+        Aeson.Number s -> pure (mkValue (Num (Finite s)))+        Aeson.String t -> pure (mkValue (String t))+        Aeson.Array xs -> do+          enterContainer d p Nothing+          ys <- traverse (\(i, x) -> go (d + 1) (p /# i) x) (Vector.indexed xs)+          pure (mkValue (Array ys))+        Aeson.Object o -> do+          enterContainer d p Nothing+          kvs <- traverse (\(k, x) -> let kt = Key.toText k in (,) kt <$> go (d + 1) (p /. kt) x) (KeyMap.toList o)+          pure (mkValue (Dict (Map.fromList kvs)))++-- | A provider serialising a Haskell value with its 'Aeson.ToJSON'+-- instance (Rust: @Serialized@).+data Serialized = Serialized+  { serValue :: Aeson.Value+  , serProfile :: Profile+  , serKey :: Maybe Path+  , serName :: Text+  , serLoc :: Maybe SrcLoc+  }++-- | Values for the 'Default' profile.+defaults :: (HasCallStack, Aeson.ToJSON a) => a -> Serialized+defaults a = Serialized (Aeson.toJSON a) Default Nothing "serialized defaults" (here callStack)++-- | Values for the 'Global' profile (override every profile).+globals :: (HasCallStack, Aeson.ToJSON a) => a -> Serialized+globals a = Serialized (Aeson.toJSON a) Global Nothing "serialized globals" (here callStack)++-- | A single value at a dotted key path, e.g. @keyed "db.port" 5432@.+keyed :: (HasCallStack, Aeson.ToJSON a) => Text -> a -> Serialized+keyed k a = Serialized (Aeson.toJSON a) Default (Just (keyPath k)) ("serialized value for `" <> k <> "`") (here callStack)++-- | Put the values in another profile.+serializedIn :: Profile -> Serialized -> Serialized+serializedIn p s = s {serProfile = p}++-- | Rename the provider (shown in error messages).+serializedNamed :: Text -> Serialized -> Serialized+serializedNamed n s = s {serName = n}++here :: CallStack -> Maybe SrcLoc+here cs = case getCallStack cs of+  ((_, l) : _) -> Just l+  [] -> Nothing++instance Provider Serialized where+  metadata s = (named (serName s)) {metaSource = CodeSource <$> serLoc s}+  provide lim s = pure $ case fromAeson lim (serValue s) of+    Left e -> Left (single e)+    Right v -> case serKey s of+      Just p -> Right (Map.singleton (serProfile s) (wrap (segments p) v))+      Nothing -> case valueNode v of+        Dict d -> Right (Map.singleton (serProfile s) d)+        n -> Left (single (configError (InvalidType (describe n) "a dictionary (serialize a record or a map, or use `keyed`)")))+    where+      wrap [] v = case valueNode v of+        Dict d -> d+        _ -> Map.empty+      wrap [Figment.Path.Key k] v = Map.singleton k v+      wrap (Figment.Path.Key k : rest) v = Map.singleton k (mkValue (Dict (wrap rest v)))+      wrap (Figment.Path.Index _ : rest) v = wrap rest v
+ src/Figment/Core.hs view
@@ -0,0 +1,255 @@+-- | Providers, figments, and loading.+--+-- A t'Figment' is a pure /description/: an ordered sequence of providers,+-- each with a combination 'Order'. Building one performs no IO; 'load'+-- runs every provider, collects every failure, and combines the results.+--+-- Unlike the value-level merge, sequencing figments is a lawful+-- 'Monoid' (it is the free monoid on steps), so library defaults and+-- application overrides compose with '<>'.+module Figment.Core+  ( -- * Providers+    Provider (..)+    -- * Figments+  , Figment+  , new+  , from+  , merge+  , join+  , adjoin+  , admerge+  , combine+  , select+  , withLimits+  , figmentLimits+  , figmentSources+    -- * Loading+  , Loaded+  , load+  , loadedProfile+  , loadedData+  , loadedSources+  , loadedLimits+  , selected+  , reselect+  , profiles+  , findValue+  , contains+  , findMetadata+  , focus+  ) where++import Control.Exception (SomeAsyncException, SomeException (..), displayException, fromException, throwIO, try)+import Data.Foldable (toList)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (Last (..))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack)++import Figment.Error+import Figment.Limits+import Figment.Merge+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++-- | A source of configuration.+--+-- Implementations return one dictionary per profile. Values may be left+-- untagged: 'load' fills in this provider's 'metadata' and the profile+-- for every value that has none. A provider that learns better metadata+-- while reading (e.g. the resolved path of a searched-for file) may tag+-- values itself; existing tags are never overwritten.+--+-- 'provide' must enforce the given 'Limits' on any untrusted input and+-- should report failures as 'Left'. As a safety net, 'load' converts any+-- synchronous exception that escapes into an 'IoError'.+class Provider p where+  metadata :: p -> Metadata+  provide :: Limits -> p -> IO (Either ConfigErrors (Map Profile Dict))+  -- | A profile this provider asks to be selected, if any.+  providerProfile :: p -> Maybe Profile+  providerProfile _ = Nothing++data Step = Step+  { stepOrder :: !Order+  , stepMeta :: !Metadata+  , stepProfile :: !(Maybe Profile)+  , stepRun :: Limits -> IO (Either ConfigErrors (Map Profile Dict))+  }++-- | A configuration description.+data Figment = Figment+  { figSteps :: !(Seq Step)+  , figSelect :: !(Last Profile)+  , figLimitsOpt :: !(Last Limits)+  }++-- | Steps concatenate; for 'select' and 'withLimits' the right-most+-- setting wins. Associative with identity 'new' by construction.+instance Semigroup Figment where+  Figment a s l <> Figment b s' l' = Figment (a <> b) (s <> s') (l <> l')++instance Monoid Figment where+  mempty = new++-- | The empty figment.+new :: Figment+new = Figment Seq.empty (Last Nothing) (Last Nothing)++-- | A figment with a single provider.+from :: (HasCallStack, Provider p) => p -> Figment+from p = addStep Merge p new++-- | Add a provider whose values override existing ones.+merge :: (HasCallStack, Provider p) => p -> Figment -> Figment+merge = addStep Merge++-- | Add a provider whose values only fill gaps.+join :: (HasCallStack, Provider p) => p -> Figment -> Figment+join = addStep Join++-- | Like 'join', but arrays are concatenated.+adjoin :: (HasCallStack, Provider p) => p -> Figment -> Figment+adjoin = addStep Adjoin++-- | Like 'merge', but arrays are concatenated.+admerge :: (HasCallStack, Provider p) => p -> Figment -> Figment+admerge = addStep Admerge++-- | Add a provider with an explicit order.+combine :: (HasCallStack, Provider p) => Order -> p -> Figment -> Figment+combine = addStep++addStep :: (HasCallStack, Provider p) => Order -> p -> Figment -> Figment+addStep o p fig = fig {figSteps = figSteps fig Seq.|> step}+  where+    meta0 = metadata p+    meta = case (metaAddedAt meta0, callerLoc) of+      (Nothing, Just l) -> withAddedAt l meta0+      _ -> meta0+    step = Step o meta (providerProfile p) (\lim -> provide lim p)++-- | The outermost call site outside this module (the user's @merge@).+callerLoc :: HasCallStack => Maybe SrcLoc+callerLoc = case reverse (getCallStack callStack) of+  ((_, l) : _) -> Just l+  [] -> Nothing++-- | Select the profile to extract. An explicit selection always wins+-- over profile hints from providers.+select :: Profile -> Figment -> Figment+select p fig = fig {figSelect = Last (Just p)}++-- | Override the parser limits for every provider in this figment.+withLimits :: Limits -> Figment -> Figment+withLimits l fig = fig {figLimitsOpt = Last (Just l)}++-- | The parser limits in effect ('defaultLimits' unless overridden).+figmentLimits :: Figment -> Limits+figmentLimits = fromMaybe defaultLimits . getLast . figLimitsOpt++-- | Metadata of every provider, in order.+figmentSources :: Figment -> [Metadata]+figmentSources = map stepMeta . toList . figSteps++-- | A loaded configuration: every provider has been read and combined.+data Loaded = Loaded+  { loadedProfile :: !Profile+    -- ^ the selected profile+  , loadedData :: !(Map Profile Dict)+    -- ^ the combined data of every profile+  , loadedSources :: ![Metadata]+    -- ^ every provider, in order+  , loadedLimits :: !Limits+    -- ^ the limits the sources were read with+  }++-- | Run every provider, in order. Failures do not stop the load: all of+-- them are collected and reported together.+load :: Figment -> IO (Either ConfigErrors Loaded)+load fig = do+  let lim = figmentLimits fig+      steps = toList (figSteps fig)+  results <- traverse (runStep lim) steps+  let errs = [e | Left e <- results]+      oks = [(s, d) | (s, Right d) <- zip steps results]+      combined = foldl' (\acc (s, d) -> coalesceData (stepOrder s) acc (retagData (stepMeta s) d)) Map.empty oks+      hinted = foldl' (\acc s -> maybe acc (coalesceProfile (stepOrder s) acc) (stepProfile s)) Default steps+      chosen = fromMaybe hinted (getLast (figSelect fig))+  pure $ case errs of+    (e : es) -> Left (foldl' (<>) e es)+    [] -> Right (Loaded chosen combined (map stepMeta steps) lim)++runStep :: Limits -> Step -> IO (Either ConfigErrors (Map Profile Dict))+runStep lim s = do+  r <- try (stepRun s lim)+  case r of+    Right (Left es) -> pure (Left (fmap' es))+    Right ok -> pure ok+    Left (ex :: SomeException)+      | isJust (fromException ex :: Maybe SomeAsyncException) -> throwIO ex+      | otherwise ->+          pure (Left (single (withMetadata (Just (stepMeta s)) (configError (IoError (Text.pack (bare ex)))))))+  where+    -- attach this step's metadata to errors that have none+    fmap' es = case fromErrorList [maybe (e {errorMetadata = Just (stepMeta s)}) (const e) (errorMetadata e) | e <- errorList es] of+      Just es' -> es'+      Nothing -> es++-- | The exception's message without the backtrace GHC >= 9.10 appends.+bare :: SomeException -> String+bare (SomeException e) = displayException e++retagData :: Metadata -> Map Profile Dict -> Map Profile Dict+retagData m = Map.mapWithKey (\p d -> fmap (retag m p) d)++instance Provider Figment where+  metadata _ = named "Figment"+  provide _ fig = fmap loadedData <$> load fig+  providerProfile = getLast . figSelect++-- | The configuration of the selected profile: 'Default', then the+-- selected profile, then 'Global', each merged over the previous.+selected :: Loaded -> Value+selected l =+  let get p = Map.findWithDefault Map.empty p (loadedData l)+      prof = loadedProfile l+      base = get Default+      withSel = if prof == Default || prof == Global then base else coalesceDict Merge base (get prof)+      final = coalesceDict Merge withSel (get Global)+  in Value untagged {tagProfile = Just prof} (Dict final)++-- | Choose another profile without re-reading any source.+reselect :: Profile -> Loaded -> Loaded+reselect p l = l {loadedProfile = p}++-- | Every profile with data.+profiles :: Loaded -> [Profile]+profiles = Map.keys . loadedData++-- | The value at a path in the selected profile.+findValue :: Path -> Loaded -> Maybe Value+findValue p = lookupPath p . selected++-- | Is there a value at this path in the selected profile?+contains :: Path -> Loaded -> Bool+contains p = isJust . findValue p++-- | The provider that supplied the value at a path.+findMetadata :: Path -> Loaded -> Maybe Metadata+findMetadata p l = findValue p l >>= tagMeta . valueTag++-- | Re-root every profile at the given key path (Rust: @focus@).+-- Profiles in which the path is absent or not a dictionary become empty.+focus :: Path -> Loaded -> Loaded+focus p l = l {loadedData = Map.mapMaybe sub (loadedData l)}+  where+    sub d = case lookupPath p (mkValue (Dict d)) of+      Just (Value _ (Dict d')) -> Just d'+      _ -> Nothing
+ src/Figment/Decode.hs view
@@ -0,0 +1,722 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Decoding configuration values into Haskell types.+--+-- t'Decoder' is an /accumulating/ applicative: independent failures (two+-- bad fields, a missing field and an out-of-range number, ...) are all+-- reported, each with its exact path, source, line and column. There is+-- deliberately no 'Monad' instance, because a monad must short-circuit;+-- use 'andThen' when a step genuinely depends on an earlier result.+module Figment.Decode+  ( -- * Decoders+    Decoder+  , Result (..)+  , DecodeContext (..)+  , rootContext+  , runDecoder+  , decodeWith+  , mkDecoder+  , resultToEither+    -- * The class+  , FromConfig (..)+  , FromConfigKey (..)+    -- * Combinators+  , andThen+  , withValue+  , currentPath+  , failWith+  , validate+  , field+  , fieldWith+  , optionalField+  , fieldOr+  , arrayOf+  , dictOf+  , textual+  , boundedIntegral+    -- * Generic deriving+  , Options (..)+  , defaultOptions+  , snakeCase+  , kebabCase+  , genericDecoder+  , GDecode+    -- * Magic types+  , Tagged (..)+  , taggedMetadata+  , RelativePath (..)+  , relative+    -- * Internals shared with "Figment.Partial"+  , missingFieldError+  , suggest+  ) where++import Data.Char (isUpper, toLower)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import qualified Data.Map.Lazy as LMap+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Proxy (Proxy (..))+import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime, zonedTimeToUTC)+import Data.Time.Format.ISO8601 (ISO8601, iso8601ParseM)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Numeric.Natural (Natural)+import System.FilePath (isAbsolute, takeDirectory, (</>))++import Figment.Error+import Figment.Internal.ValueParser (parseNumber)+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++------------------------------------------------------------------------+-- Results and decoders++-- | Success, or every failure found.+data Result a+  = Failure !ConfigErrors+  | Success a+  deriving stock (Show, Functor)++instance Applicative Result where+  pure = Success+  Failure a <*> Failure b = Failure (a <> b)+  Failure a <*> Success _ = Failure a+  Success _ <*> Failure b = Failure b+  Success f <*> Success x = Success (f x)++-- | Convert a 'Result'.+resultToEither :: Result a -> Either ConfigErrors a+resultToEither (Failure e) = Left e+resultToEither (Success a) = Right a++-- | What a decoder knows about where it is.+data DecodeContext = DecodeContext+  { ctxPath :: !Path+  , ctxProfile :: !Profile+  , ctxLossy :: !Bool+    -- ^ accept strings for numbers and booleans, and scalars for strings+  , ctxSources :: ![Metadata]+    -- ^ every provider consulted, for missing-field hints+  }++-- | A context at the root, for the given profile and sources.+rootContext :: Profile -> [Metadata] -> DecodeContext+rootContext p ms = DecodeContext root p False ms++-- | Decodes a t'Value' in a t'DecodeContext'. Accumulates errors (see the module header).+newtype Decoder a = Decoder {unDecoder :: DecodeContext -> Value -> Result a}+  deriving stock (Functor)++instance Applicative Decoder where+  pure a = Decoder $ \_ _ -> Success a+  Decoder f <*> Decoder g = Decoder $ \c v -> f c v <*> g c v++-- | Run a decoder.+runDecoder :: Decoder a -> DecodeContext -> Value -> Either ConfigErrors a+runDecoder d c v = resultToEither (unDecoder d c v)++-- | Run a decoder, keeping the accumulating 'Result'.+decodeWith :: Decoder a -> DecodeContext -> Value -> Result a+decodeWith = unDecoder++-- | Build a decoder from a function (for custom instances that need the+-- context, e.g. to report errors at a precise location).+mkDecoder :: (DecodeContext -> Value -> Result a) -> Decoder a+mkDecoder = Decoder++-- | Sequential composition. Short-circuits: errors from the second step+-- are only seen if the first succeeds.+andThen :: Decoder a -> (a -> Decoder b) -> Decoder b+andThen (Decoder f) k = Decoder $ \c v -> case f c v of+  Failure e -> Failure e+  Success a -> unDecoder (k a) c v++-- | Inspect the raw value before choosing a decoder.+withValue :: (Value -> Decoder a) -> Decoder a+withValue k = Decoder $ \c v -> unDecoder (k v) c v++-- | The key path of the value being decoded.+currentPath :: Decoder Path+currentPath = Decoder $ \c _ -> Success (ctxPath c)++errorAt :: DecodeContext -> Value -> ErrorKind -> ConfigErrors+errorAt c v k =+  let t = valueTag v+  in single+       ConfigError+         { errorKind = k+         , errorPath = ctxPath c+         , errorProfile = Just (fromMaybe (ctxProfile c) (tagProfile t))+         , errorMetadata = tagMeta t+         , errorPos = tagPos t+         , errorHints = []+         }++-- | Fail at the current value.+failWith :: ErrorKind -> Decoder a+failWith k = Decoder $ \c v -> Failure (errorAt c v k)++-- | Post-process a decoded value; a 'Left' becomes a 'Message' error+-- located at this value (its source, line and column).+validate :: (a -> Either Text b) -> Decoder a -> Decoder b+validate f (Decoder g) = Decoder $ \c v -> case g c v of+  Failure e -> Failure e+  Success a -> case f a of+    Left msg -> Failure (errorAt c v (Message msg))+    Right b -> Success b++typeError :: DecodeContext -> Value -> Text -> Result a+typeError c v expected = Failure (errorAt c v (InvalidType (describe (valueNode v)) expected))++valueError :: DecodeContext -> Value -> Text -> Result a+valueError c v expected = Failure (errorAt c v (InvalidValue (describe (valueNode v)) expected))++------------------------------------------------------------------------+-- The class++-- | Types that can be decoded from configuration. Derive it generically (@deriving anyclass FromConfig@ with a 'Generic' instance) or write 'fromConfig' with the combinators below.+class FromConfig a where+  fromConfig :: Decoder a+  default fromConfig :: (Generic a, GDecode (Rep a)) => Decoder a+  fromConfig = genericDecoder defaultOptions++  -- | The value to use when a record field of this type is absent.+  -- 'Nothing' (the default) makes the field required; 'Maybe' fields+  -- answer @Just Nothing@.+  missingValue :: Maybe a+  missingValue = Nothing++  -- | How to decode a list of this type. Exists so that t'String'+  -- decodes from a string rather than an array of characters.+  listDecoder :: Decoder [a]+  listDecoder = Vector.toList <$> arrayOf fromConfig++------------------------------------------------------------------------+-- Field access++-- | A required field of the current dictionary (or its+-- 'missingValue', for types that have one).+field :: forall a. FromConfig a => Text -> Decoder a+field name = fieldWith name fromConfig (missingValue @a)++-- | A field with an explicit decoder and an optional fallback.+fieldWith :: Text -> Decoder a -> Maybe a -> Decoder a+fieldWith name d missing = Decoder $ \c v -> case valueNode v of+  Dict m -> case Map.lookup name m of+    Just sub -> unDecoder d c {ctxPath = ctxPath c /. name} sub+    Nothing -> maybe (Failure (single (missingFieldError c name))) Success missing+  _ -> typeError c v "a dictionary"++-- | An optional field: 'Nothing' when absent or null.+optionalField :: FromConfig a => Text -> Decoder (Maybe a)+optionalField name = fieldWith name fromConfig (Just Nothing)++-- | A field with a default used when it is absent.+fieldOr :: FromConfig a => Text -> a -> Decoder a+fieldOr name def = fieldWith name fromConfig (Just def)++-- | The error for an absent required field, with a hint naming every+-- way it could have been supplied.+missingFieldError :: DecodeContext -> Text -> ConfigError+missingFieldError c name =+  let p = ctxPath c /. name+      prof = ctxProfile c+      ways = [ "`" <> interpolate m prof p <> "` in " <> metaName m <> maybe "" ((" " <>) . renderSource) (metaSource m)+             | m <- ctxSources c ]+      hint = case ways of+        [] -> []+        [w] -> ["no source sets it; it can be set as " <> w]+        _ -> ["no source sets it; it can be set as " <> Text.intercalate ", " (init ways) <> ", or " <> last ways]+  in ConfigError (MissingField name) p (Just prof) Nothing Nothing hint++------------------------------------------------------------------------+-- Containers++-- | Decode every element of an array (errors in different elements accumulate).+arrayOf :: Decoder a -> Decoder (Vector a)+arrayOf (Decoder d) = Decoder $ \c v -> case valueNode v of+  Array xs -> traverse (\(i, x) -> d c {ctxPath = ctxPath c /# i} x) (Vector.indexed xs)+  _ -> typeError c v "an array"++-- | Decode every value of a dictionary.+dictOf :: Decoder a -> Decoder (Map Text a)+dictOf (Decoder d) = Decoder $ \c v -> case valueNode v of+  Dict m -> Map.traverseWithKey (\k x -> d c {ctxPath = ctxPath c /. k} x) m+  _ -> typeError c v "a dictionary"++-- | Keys of decoded maps.+class FromConfigKey k where+  fromConfigKey :: Text -> Either Text k++instance FromConfigKey Text where fromConfigKey = Right+instance FromConfigKey [Char] where fromConfigKey = Right . Text.unpack++------------------------------------------------------------------------+-- Scalars++-- | Text: a string; or the original text of a value parsed from an+-- untyped source; or (lossy mode) any scalar rendered as text.+textual :: Decoder Text+textual = Decoder $ \c v -> case valueNode v of+  String t -> Success t+  n+    | Just r <- tagRaw (valueTag v) -> Success r+    | ctxLossy c, Just t <- scalarText n -> Success t+    | otherwise -> typeError c v "a string"++scalarText :: Node -> Maybe Text+scalarText = \case+  Bool b -> Just (if b then "true" else "false")+  Num (Finite s)+    | Sci.isInteger s, abs (Sci.base10Exponent s) < 64 -> Just (Text.pack (Sci.formatScientific Sci.Fixed (Just 0) s))+    | otherwise -> Just (Text.pack (show s))+  Num PosInfinity -> Just "inf"+  Num NegInfinity -> Just "-inf"+  Num NaN -> Just "nan"+  _ -> Nothing++-- | A number, accepting strings in lossy mode.+numberD :: Text -> Decoder Number+numberD expected = Decoder $ \c v -> case valueNode v of+  Num n -> Success n+  String t | ctxLossy c, Just n <- parseNumber (Text.strip t) -> Success n+  _ -> typeError c v expected++-- | Integral types with bounds, rejecting non-integers and+-- out-of-range values (never wrapping, never allocating huge integers).+boundedIntegral :: forall a. (Integral a, Bounded a, Show a) => Decoder a+boundedIntegral = decodeIntegral $ \s ->+  case Sci.toBoundedInteger s of+    Just x -> Right x+    Nothing -> Left ("an integer in the range " <> tshow (minBound :: a) <> ".." <> tshow (maxBound :: a))++decodeIntegral :: (Scientific -> Either Text a) -> Decoder a+decodeIntegral conv = Decoder $ \c v -> case unDecoder (numberD "an integer") c v of+  Failure e -> Failure e+  Success (Finite s)+    | not (Sci.isInteger s) -> valueError c v "an integer"+    | otherwise -> either (valueError c v) Success (conv s)+  Success _ -> valueError c v "a finite integer"++unboundedInteger :: Decoder Integer+unboundedInteger = decodeIntegral $ \s ->+  if Sci.base10Exponent s > 4096+    then Left "an integer with at most ~4096 digits"+    else Right (truncate s)++realFloatD :: RealFloat a => Decoder a+realFloatD = Decoder $ \c v -> case unDecoder (numberD "a number") c v of+  Failure e -> Failure e+  Success (Finite s) -> Success (Sci.toRealFloat s)+  Success PosInfinity -> Success (1 / 0)+  Success NegInfinity -> Success (-1 / 0)+  Success NaN -> Success (0 / 0)++instance FromConfig Value where fromConfig = Decoder $ \_ v -> Success v++instance FromConfig Text where fromConfig = textual++instance FromConfig Char where+  fromConfig = Decoder $ \c v -> case unDecoder textual c v of+    Success t | Text.length t == 1 -> Success (Text.head t)+    Success _ -> valueError c v "a single character"+    Failure e -> Failure e+  listDecoder = Text.unpack <$> textual++instance FromConfig Bool where+  fromConfig = Decoder $ \c v -> case valueNode v of+    Bool b -> Success b+    String t | ctxLossy c, Just b <- lossyBool t -> Success b+    Num (Finite s) | ctxLossy c, s == 0 -> Success False+                   | ctxLossy c, s == 1 -> Success True+    _ -> typeError c v "a boolean"+    where+      lossyBool t = case Text.toLower (Text.strip t) of+        x | x `elem` ["true", "yes", "on", "1"] -> Just True+          | x `elem` ["false", "no", "off", "0"] -> Just False+          | otherwise -> Nothing++instance FromConfig Int where fromConfig = boundedIntegral+instance FromConfig Int8 where fromConfig = boundedIntegral+instance FromConfig Int16 where fromConfig = boundedIntegral+instance FromConfig Int32 where fromConfig = boundedIntegral+instance FromConfig Int64 where fromConfig = boundedIntegral+instance FromConfig Word where fromConfig = boundedIntegral+instance FromConfig Word8 where fromConfig = boundedIntegral+instance FromConfig Word16 where fromConfig = boundedIntegral+instance FromConfig Word32 where fromConfig = boundedIntegral+instance FromConfig Word64 where fromConfig = boundedIntegral+instance FromConfig Integer where fromConfig = unboundedInteger++instance FromConfig Natural where+  fromConfig = Decoder $ \c v -> case unDecoder unboundedInteger c v of+    Success n | n >= 0 -> Success (fromInteger n)+              | otherwise -> valueError c v "a non-negative integer"+    Failure e -> Failure e++instance FromConfig Double where fromConfig = realFloatD+instance FromConfig Float where fromConfig = realFloatD++instance FromConfig Scientific where+  fromConfig = Decoder $ \c v -> case unDecoder (numberD "a number") c v of+    Success (Finite s) -> Success s+    Success _ -> valueError c v "a finite number"+    Failure e -> Failure e++instance FromConfig () where+  fromConfig = Decoder $ \c v -> case valueNode v of+    Null -> Success ()+    Dict m | Map.null m -> Success ()+    Array xs | Vector.null xs -> Success ()+    _ -> typeError c v "null"++instance FromConfig a => FromConfig (Maybe a) where+  fromConfig = Decoder $ \c v -> case valueNode v of+    Null -> Success Nothing+    _ -> Just <$> unDecoder fromConfig c v+  missingValue = Just Nothing++instance FromConfig a => FromConfig [a] where+  fromConfig = listDecoder++instance FromConfig a => FromConfig (NonEmpty a) where+  fromConfig = Decoder $ \c v -> case unDecoder (listDecoder @a) c v of+    Success (x : xs) -> Success (x :| xs)+    Success [] -> Failure (errorAt c v (InvalidLength 0 "a non-empty array"))+    Failure e -> Failure e++instance FromConfig a => FromConfig (Vector a) where fromConfig = arrayOf fromConfig++instance FromConfig a => FromConfig (Seq a) where+  fromConfig = Seq.fromList . Vector.toList <$> arrayOf fromConfig++instance (Ord a, FromConfig a) => FromConfig (Set a) where+  fromConfig = Set.fromList . Vector.toList <$> arrayOf fromConfig++instance (Ord k, FromConfigKey k, FromConfig a) => FromConfig (Map k a) where+  fromConfig = Decoder $ \c v -> case unDecoder (dictOf fromConfig) c v of+    Failure e -> Failure e+    Success m ->+      let conv (k, x) = case fromConfigKey k of+            Right k' -> Success (k', x)+            Left msg -> Failure (errorAt c {ctxPath = ctxPath c /. k} v (InvalidValue ("key `" <> k <> "`") msg))+      in Map.fromList <$> traverse conv (Map.toList m)++instance (FromConfig a, FromConfig b) => FromConfig (a, b) where+  fromConfig = tupleD 2 $ \c xs -> (,) <$> at c xs 0 <*> at c xs 1++instance (FromConfig a, FromConfig b, FromConfig c) => FromConfig (a, b, c) where+  fromConfig = tupleD 3 $ \c xs -> (,,) <$> at c xs 0 <*> at c xs 1 <*> at c xs 2++tupleD :: Int -> (DecodeContext -> Vector Value -> Result a) -> Decoder a+tupleD n k = Decoder $ \c v -> case valueNode v of+  Array xs+    | Vector.length xs == n -> k c xs+    | otherwise -> Failure (errorAt c v (InvalidLength (Vector.length xs) ("an array of length " <> tshow n)))+  _ -> typeError c v ("an array of length " <> tshow n)++at :: FromConfig a => DecodeContext -> Vector Value -> Int -> Result a+at c xs i = case xs Vector.!? i of+  Just x -> unDecoder fromConfig c {ctxPath = ctxPath c /# i} x+  Nothing -> Failure (single (atPath (ctxPath c /# i) (configError (InvalidLength i "more elements"))))++-- Time: ISO 8601 text (TOML date/time values arrive as such text).+isoD :: ISO8601 t => Text -> Decoder t+isoD what = Decoder $ \c v -> case unDecoder textual c v of+  Failure e -> Failure e+  Success t -> case iso8601ParseM (Text.unpack (Text.strip t)) of+    Just x -> Success x+    Nothing -> valueError c v ("an ISO 8601 " <> what)++instance FromConfig Day where fromConfig = isoD "date"+instance FromConfig TimeOfDay where fromConfig = isoD "time of day"+instance FromConfig LocalTime where fromConfig = isoD "local date-time"+instance FromConfig ZonedTime where fromConfig = isoD "date-time with offset"+instance FromConfig UTCTime where+  fromConfig = Decoder $ \c v -> case unDecoder textual c v of+    Failure e -> Failure e+    Success t ->+      let s = Text.unpack (Text.strip t)+      in case (iso8601ParseM s, iso8601ParseM s) of+           (Just z, _) -> Success (zonedTimeToUTC z)+           (_, Just u) -> Success u+           _ -> valueError c v "an ISO 8601 date-time with offset"++------------------------------------------------------------------------+-- Magic types++-- | A value together with its provenance: which provider, which+-- profile, which line and column, and its key path. The Haskell+-- counterpart of Rust figment's @Tagged\<T\>@.+data Tagged a = Tagged+  { taggedValue :: a+  , taggedTag :: Tag+  , taggedPath :: Path+  }+  deriving stock (Eq, Show, Functor)++-- | The provider the value came from.+taggedMetadata :: Tagged a -> Maybe Metadata+taggedMetadata = tagMeta . taggedTag++instance FromConfig a => FromConfig (Tagged a) where+  fromConfig = Decoder $ \c v -> (\a -> Tagged a (valueTag v) (ctxPath c)) <$> unDecoder fromConfig c v+  missingValue = (\a -> Tagged a untagged root) <$> missingValue++-- | A path written in a configuration file, remembered together with+-- the directory of that file, so that relative paths can be resolved+-- against the file that declared them rather than the working+-- directory (Rust figment's @RelativePathBuf@).+data RelativePath = RelativePath+  { relativeOriginal :: FilePath+  , relativeBase :: Maybe FilePath+    -- ^ directory of the declaring file, if it came from a file+  }+  deriving stock (Eq, Show)++-- | Resolve: absolute paths and paths not from a file are returned+-- as written; others are joined to the declaring file's directory.+relative :: RelativePath -> FilePath+relative (RelativePath p base)+  | isAbsolute p = p+  | otherwise = maybe p (</> p) base++instance FromConfig RelativePath where+  fromConfig = Decoder $ \c v -> case unDecoder textual c v of+    Failure e -> Failure e+    Success t ->+      let base = case tagMeta (valueTag v) >>= metaSource of+            Just (FileSource f) -> Just (takeDirectory f)+            _ -> Nothing+      in Success (RelativePath (Text.unpack t) base)++------------------------------------------------------------------------+-- Generic deriving++-- | Options for 'genericDecoder'.+data Options = Options+  { fieldLabelModifier :: String -> String+    -- ^ field name to configuration key+  , constructorTagModifier :: String -> String+    -- ^ constructor name to enum tag+  , rejectUnknownFields :: Bool+    -- ^ report keys the record does not expect (with suggestions)+  }++-- | Field and constructor names used as written; unknown keys allowed.+defaultOptions :: Options+defaultOptions = Options id id False++-- | @maxConnections@ to @max_connections@.+snakeCase :: String -> String+snakeCase = separate '_'++-- | @maxConnections@ to @max-connections@.+kebabCase :: String -> String+kebabCase = separate '-'++separate :: Char -> String -> String+separate sep = go True+  where+    go _ [] = []+    go start (c : cs)+      | isUpper c = (if start then [] else [sep]) ++ toLower c : go False cs+      | otherwise = c : go False cs++-- | Derive a decoder from a 'Generic' instance: records are dictionaries, enums are strings (matched case-insensitively), other sums are externally tagged (@{ Variant = payload }@), newtypes unwrap, positional constructors are arrays.+genericDecoder :: (Generic a, GDecode (Rep a)) => Options -> Decoder a+genericDecoder o = to <$> gdecode o++-- | Proxy for generic metadata, so that names are read without+-- conjuring values.+data P (m :: Meta) (f :: Type -> Type) a = P++-- | Generic machinery behind 'genericDecoder'.+class GDecode (f :: Type -> Type) where+  gdecode :: Options -> Decoder (f x)++data Ctor a = Ctor+  { ctorTag :: Text+  , ctorNullary :: Bool+  , ctorPayload :: Decoder a+  }+  deriving stock (Functor)++instance GCtors f => GDecode (D1 d f) where+  gdecode o = M1 <$> decodeCtors (gctors o)++class GCtors (f :: Type -> Type) where+  gctors :: Options -> [Ctor (f x)]++instance (GCtors f, GCtors g) => GCtors (f :+: g) where+  gctors o = map (fmap L1) (gctors o) ++ map (fmap R1) (gctors o)++instance (Constructor c, GFields f, GPositional f) => GCtors (C1 c f) where+  gctors o =+    [ Ctor+        { ctorTag = Text.pack (constructorTagModifier o (conName (P :: P c f ())))+        , ctorNullary = arity == 0+        , ctorPayload = M1 <$> payload+        }+    ]+    where+      arity = garity (Proxy :: Proxy f)+      payload+        | arity == 0 = Decoder $ \_ _ -> gposition o emptyCtx 0 Vector.empty+        | conIsRecord (P :: P c f ()) = recordD o (gfieldNames o (Proxy :: Proxy f)) (gfields o)+        | arity == 1 = case gunwrapped o of+            Just d -> d+            Nothing -> tupleD 1 (\c xs -> gposition o c 0 xs)+        | otherwise = tupleD arity (\c xs -> gposition o c 0 xs)+      emptyCtx = DecodeContext root Default False []++instance+  TypeError ('Text "figment: cannot derive FromConfig for an empty data type")+  => GCtors V1+  where+  gctors _ = []++decodeCtors :: [Ctor a] -> Decoder a+decodeCtors [c] | not (ctorNullary c) = ctorPayload c+decodeCtors [c] = Decoder $ \ctx v -> case valueNode v of+  -- a unit-like type accepts null, an empty container, or its own name+  Null -> unDecoder (ctorPayload c) ctx v+  Dict m | Map.null m -> unDecoder (ctorPayload c) ctx v+  _ -> unDecoder (decodeCtors' [c]) ctx v+decodeCtors cs = decodeCtors' cs++decodeCtors' :: [Ctor a] -> Decoder a+decodeCtors' cs = Decoder $ \c v ->+  let tags = map ctorTag cs+      byTag t = case filter ((== t) . ctorTag) cs of+        (x : _) -> Just x+        [] -> case filter ((== Text.toCaseFold t) . Text.toCaseFold . ctorTag) cs of+          [x] -> Just x+          _ -> Nothing+      unknown t = Failure (errorAt c v (UnknownVariant t tags))+  in case valueNode v of+       Dict m -> case Map.toList m of+         [(k, payload)] -> case byTag k of+           Just ctor -> unDecoder (ctorPayload ctor) c {ctxPath = ctxPath c /. k} payload+           Nothing -> Failure (errorAt c {ctxPath = ctxPath c /. k} payload (UnknownVariant k tags))+         _ -> valueError c v "a variant name, or a dictionary with exactly one key naming a variant"+       _ -> case unDecoder textual c v of+         Success t -> case byTag (Text.strip t) of+           Just ctor+             | ctorNullary ctor -> unDecoder (ctorPayload ctor) c v+             | otherwise -> valueError c v ("a dictionary `{ " <> ctorTag ctor <> " = ... }` (variant has fields)")+           Nothing -> unknown t+         Failure _ -> typeError c v ("one of " <> Text.intercalate ", " (map (\t -> "`" <> t <> "`") tags))++recordD :: Options -> [Text] -> (DecodeContext -> Dict -> Result a) -> Decoder a+recordD o known fields = Decoder $ \c v -> case valueNode v of+  Dict m ->+    let unknownErrs =+          [ errorAt c {ctxPath = ctxPath c /. k} x (UnknownField k (suggest k known))+          | rejectUnknownFields o+          , (k, x) <- Map.toList m+          , k `notElem` known+          ]+        unknownR = case unknownErrs of+          [] -> Success ()+          (e : es) -> Failure (foldl (<>) e es)+    in unknownR *> fields c m+  _ -> typeError c v "a dictionary"++-- | Candidates within a small edit distance, best first.+suggest :: Text -> [Text] -> [Text]+suggest k known =+  let scored = mapMaybe (\cand -> let d = editDistance (Text.unpack k) (Text.unpack cand)+                                  in if d <= max 1 (Text.length cand `div` 3) then Just (d, cand) else Nothing) known+  in map snd (take 3 (sortOn' fst scored))+  where+    sortOn' f = foldr ins []+      where ins x [] = [x]+            ins x (y : ys) | f x <= f y = x : y : ys+                           | otherwise = y : ins x ys++-- | Optimal string alignment distance (Levenshtein plus adjacent+-- transpositions, so @hots@ is one edit from @host@).+editDistance :: String -> String -> Int+editDistance a b = table LMap.! (la, lb)+  where+    la = length a+    lb = length b+    av = Vector.fromList a+    bv = Vector.fromList b+    table = LMap.fromList [((i, j), cell i j) | i <- [0 .. la], j <- [0 .. lb]]+    get i j = table LMap.! (i, j)+    cell i 0 = i+    cell 0 j = j+    cell i j =+      let ca = av Vector.! (i - 1)+          cb = bv Vector.! (j - 1)+          cost = if ca == cb then 0 else 1+          base = minimum [get (i - 1) j + 1, get i (j - 1) + 1, get (i - 1) (j - 1) + cost]+      in if i > 1 && j > 1 && ca == bv Vector.! (j - 2) && av Vector.! (i - 2) == cb+           then min base (get (i - 2) (j - 2) + 1)+           else base++class GFields (f :: Type -> Type) where+  gfields :: Options -> DecodeContext -> Dict -> Result (f x)+  gfieldNames :: Options -> Proxy f -> [Text]++instance (GFields f, GFields g) => GFields (f :*: g) where+  gfields o c m = (:*:) <$> gfields o c m <*> gfields o c m+  gfieldNames o _ = gfieldNames o (Proxy :: Proxy f) ++ gfieldNames o (Proxy :: Proxy g)++instance GFields U1 where+  gfields _ _ _ = Success U1+  gfieldNames _ _ = []++instance (Selector s, FromConfig a) => GFields (S1 s (Rec0 a)) where+  gfields o c m =+    let name = Text.pack (fieldLabelModifier o (selName (P :: P s (Rec0 a) ())))+    in case Map.lookup name m of+         Just v -> M1 . K1 <$> unDecoder fromConfig c {ctxPath = ctxPath c /. name} v+         Nothing -> case missingValue @a of+           Just d -> Success (M1 (K1 d))+           Nothing -> Failure (single (missingFieldError c name))+  gfieldNames o _ = [Text.pack (fieldLabelModifier o (selName (P :: P s (Rec0 a) ())))]++class GPositional (f :: Type -> Type) where+  garity :: Proxy f -> Int+  gposition :: Options -> DecodeContext -> Int -> Vector Value -> Result (f x)+  gunwrapped :: Options -> Maybe (Decoder (f x))+  gunwrapped _ = Nothing++instance (GPositional f, GPositional g) => GPositional (f :*: g) where+  garity _ = garity (Proxy :: Proxy f) + garity (Proxy :: Proxy g)+  gposition o c i xs = (:*:) <$> gposition o c i xs <*> gposition o c (i + garity (Proxy :: Proxy f)) xs++instance GPositional U1 where+  garity _ = 0+  gposition _ _ _ _ = Success U1++instance FromConfig a => GPositional (S1 s (Rec0 a)) where+  garity _ = 1+  gposition _ c i xs = M1 . K1 <$> at c xs i+  gunwrapped _ = Just (M1 . K1 <$> fromConfig)++tshow :: Show a => a -> Text+tshow = Text.pack . show
+ src/Figment/Error.hs view
@@ -0,0 +1,206 @@+-- | The error vocabulary. Every failure anywhere in figment is a+-- t'ConfigError'; operations that can fail in more than one place return+-- t'ConfigErrors', a non-empty collection, so users see /every/ problem+-- in one run instead of fixing them one at a time.+module Figment.Error+  ( ErrorKind (..)+  , ConfigError (..)+  , ConfigErrors+  , configError+  , single+  , errorList+  , fromErrorList+  , atPath+  , withMetadata+  , withPos+  , withProfile+  , addHints+  , describeKind+  , renderError+  , renderErrors+  ) where++import Control.DeepSeq (NFData)+import Control.Exception (Exception (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)++import Figment.Metadata+import Figment.Path+import Figment.Profile++-- | What went wrong. Closed: every constructor is produced somewhere in+-- the library.+data ErrorKind+  = IoError !Text+    -- ^ a source could not be read+  | SyntaxError !Text+    -- ^ a source could not be parsed+  | DepthExceeded !Int+    -- ^ nesting deeper than the configured limit (the limit is carried)+  | TooManyNodes !Int+    -- ^ more values than the configured limit (the limit is carried)+  | DuplicateKey !Text+    -- ^ the same key appears twice in one dictionary of one source+  | KeyConflict !Text !Text+    -- ^ two flat keys (env vars, CLI flags) that cannot both hold: one+    -- sets a value where the other needs a dictionary+  | InvalidType !Text !Text+    -- ^ @InvalidType actual expected@+  | InvalidValue !Text !Text+    -- ^ right type, unacceptable value: @InvalidValue actual expected@+  | InvalidLength !Int !Text+    -- ^ @InvalidLength actualLength expected@+  | MissingField !Text+    -- ^ a required field has no value in any source+  | UnknownField !Text ![Text]+    -- ^ field not expected by the target type; carries suggestions+  | UnknownVariant !Text ![Text]+    -- ^ enum tag not recognised; carries the valid tags+  | Message !Text+    -- ^ a custom failure, e.g. from a validation step+  | InvalidArgument !Text+    -- ^ the library API was called with an invalid argument+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | One error, with everything known about where it happened.+data ConfigError = ConfigError+  { errorKind :: !ErrorKind+  , errorPath :: !Path+    -- ^ key path within the selected profile+  , errorProfile :: !(Maybe Profile)+    -- ^ the profile the offending value came from+  , errorMetadata :: !(Maybe Metadata)+    -- ^ the provider the offending value came from+  , errorPos :: !(Maybe Pos)+    -- ^ line/column in that provider's source text, when known+  , errorHints :: ![Text]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | One or more errors. A 'Semigroup', so independent failures combine.+newtype ConfigErrors = ConfigErrors (NonEmpty ConfigError)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)+  deriving newtype (Semigroup)++instance Exception ConfigErrors where+  displayException = Text.unpack . renderErrors++-- | An error of the given kind at the root, with no provenance yet.+configError :: ErrorKind -> ConfigError+configError k = ConfigError k root Nothing Nothing Nothing []++-- | One error.+single :: ConfigError -> ConfigErrors+single e = ConfigErrors (e :| [])++-- | All errors, in order.+errorList :: ConfigErrors -> [ConfigError]+errorList (ConfigErrors es) = NE.toList es++-- | Collect errors, if there are any.+fromErrorList :: [ConfigError] -> Maybe ConfigErrors+fromErrorList = fmap ConfigErrors . NE.nonEmpty++-- | Set the path.+atPath :: Path -> ConfigError -> ConfigError+atPath p e = e {errorPath = p}++-- | Set the provider metadata.+withMetadata :: Maybe Metadata -> ConfigError -> ConfigError+withMetadata m e = e {errorMetadata = m}++-- | Set the source position.+withPos :: Maybe Pos -> ConfigError -> ConfigError+withPos p e = e {errorPos = p}++-- | Set the profile.+withProfile :: Maybe Profile -> ConfigError -> ConfigError+withProfile p e = e {errorProfile = p}++-- | Append hints.+addHints :: [Text] -> ConfigError -> ConfigError+addHints hs e = e {errorHints = errorHints e ++ hs}++-- | The one-line description of an error kind.+describeKind :: ErrorKind -> Text+describeKind = \case+  IoError t -> "could not read source: " <> t+  SyntaxError t -> "syntax error: " <> t+  DepthExceeded n -> "nesting exceeds the depth limit of " <> tshow n+  TooManyNodes n -> "source contains more than the limit of " <> tshow n <> " values"+  DuplicateKey k -> "duplicate key " <> tick k+  KeyConflict a b -> tick a <> " conflicts with " <> tick b+    <> ": one sets a value where the other needs a dictionary"+  InvalidType actual expected -> "invalid type: found " <> actual <> ", expected " <> expected+  InvalidValue actual expected -> "invalid value: found " <> actual <> ", expected " <> expected+  InvalidLength n expected -> "invalid length " <> tshow n <> ", expected " <> expected+  MissingField f -> "missing field " <> tick f+  UnknownField f _ -> "unknown field " <> tick f+  UnknownVariant v valid -> "unknown variant " <> tick v <> ", expected one of "+    <> Text.intercalate ", " (map tick valid)+  Message t -> t+  InvalidArgument t -> "invalid argument: " <> t++-- | A multi-line, human-oriented rendering:+--+-- > error: invalid type: found string "abc", expected an integer+-- >   --> key `port` (`APP_PORT`) in environment variables+-- >   = hint: ...+renderError :: ConfigError -> Text+renderError e =+  Text.intercalate "\n" $+    ("error: " <> describeKind (errorKind e))+      : location+      ++ map ("  = hint: " <>) (suggestions ++ errorHints e)+  where+    suggestions = case errorKind e of+      UnknownField _ (s : ss) -> ["did you mean " <> Text.intercalate " or " (map tick (s : ss)) <> "?"]+      _ -> []+    prof = maybe Default id (errorProfile e)+    path = errorPath e+    keyPart+      | isRoot path = "top level"+      | otherwise = "key " <> tick (renderPath path)+    native = case errorMetadata e of+      Just m | not (isRoot path) ->+        let n = interpolate m prof path+        in if n == renderPath path then "" else " (" <> tick n <> ")"+      _ -> ""+    sourcePart = case errorMetadata e of+      Nothing -> ""+      Just m -> " in " <> metaName m <> case metaSource m of+        Just s -> " " <> renderSource s <> posSuffix+        Nothing -> posWords+    posSuffix = case errorPos e of+      Just (Pos l c) -> ":" <> tshow l <> ":" <> tshow c+      Nothing -> ""+    posWords = case errorPos e of+      Just (Pos l c) -> " at line " <> tshow l <> ", column " <> tshow c+      Nothing -> ""+    profPart = case errorProfile e of+      Just p | p /= Default -> " [profile " <> tick (profileName p) <> "]"+      _ -> ""+    location =+      let line = keyPart <> native <> sourcePart <> profPart+      in ["  --> " <> line]++-- | Render every error, separated by blank lines, with a count header+-- when there is more than one.+renderErrors :: ConfigErrors -> Text+renderErrors (ConfigErrors (e :| [])) = renderError e+renderErrors (ConfigErrors es) =+  tshow (length es) <> " configuration errors:\n\n"+    <> Text.intercalate "\n\n" (map renderError (NE.toList es))++tick :: Text -> Text+tick t = "`" <> t <> "`"++tshow :: Show a => a -> Text+tshow = Text.pack . show
+ src/Figment/Extract.hs view
@@ -0,0 +1,89 @@+-- | Turning a loaded configuration into typed values.+module Figment.Extract+  ( extract+  , extractLossy+  , extractAt+  , extractWith+  , extractPartial+  , extractPartialWith+  , extractTotal+  , extractTotalWith+  , loadExtract+  , loadExtractOrThrow+  , decodeContext+  ) where++import Control.Exception (throwIO)+import Data.Functor.Identity (Identity)+import Data.Semigroup (sconcat)++import Figment.Core+import Figment.Decode+import Figment.Error+import Figment.Partial+import Figment.Path+import Figment.Value++-- | The context decoders run in for a loaded configuration.+decodeContext :: Loaded -> DecodeContext+decodeContext l = rootContext (loadedProfile l) (loadedSources l)++-- | Decode the selected profile.+extract :: FromConfig a => Loaded -> Either ConfigErrors a+extract = extractWith fromConfig++-- | Like 'extract', but accept @"8080"@ for numbers, @"yes"@ for+-- booleans, and scalars for strings (Rust: @extract_lossy@).+extractLossy :: FromConfig a => Loaded -> Either ConfigErrors a+extractLossy l = runDecoder fromConfig (decodeContext l) {ctxLossy = True} (selected l)++-- | Decode the selected profile with an explicit decoder.+extractWith :: Decoder a -> Loaded -> Either ConfigErrors a+extractWith d l = runDecoder d (decodeContext l) (selected l)++-- | Decode the value at a key path (Rust: @extract_inner@).+extractAt :: forall a. FromConfig a => Path -> Loaded -> Either ConfigErrors a+extractAt p l = case lookupPath p (selected l) of+  Just v -> runDecoder fromConfig (decodeContext l) {ctxPath = p} v+  Nothing -> case missingValue @a of+    Just d -> Right d+    Nothing -> Left (single (missingAt (decodeContext l) p))++-- | Decode a 'Partial' configuration, filling gaps from partial+-- defaults (provider values win). Reports every type error, or else+-- every missing required field.+extractPartial :: Partial c => c Maybe -> Loaded -> Either ConfigErrors (c Identity)+extractPartial = extractPartialWith defaultOptions++-- | 'extractPartial' with explicit generic t'Options' (e.g. 'snakeCase' field names).+extractPartialWith :: Partial c => Options -> c Maybe -> Loaded -> Either ConfigErrors (c Identity)+extractPartialWith o defs l = do+  found <- runDecoder (partialDecoder o) (decodeContext l) (selected l)+  case complete o (overlay defs found) of+    Right r -> Right r+    Left ps ->+      let errs = fmap (missingAt (decodeContext l)) ps+      in Left (sconcat (fmap single errs))++-- | With /total/ defaults a missing-field error is impossible by+-- construction: the type guarantees every field has a value.+extractTotal :: Partial c => c Identity -> Loaded -> Either ConfigErrors (c Identity)+extractTotal = extractTotalWith defaultOptions++-- | 'extractTotal' with explicit generic t'Options'.+extractTotalWith :: Partial c => Options -> c Identity -> Loaded -> Either ConfigErrors (c Identity)+extractTotalWith o d = extractPartialWith o (total d)++missingAt :: DecodeContext -> Path -> ConfigError+missingAt c p = case reverse (segments p) of+  (Key name : parentRev) -> missingFieldError c {ctxPath = fromSegments (reverse parentRev)} name+  _ -> atPath p (configError (MissingField (renderPath p)))++-- | 'load' then 'extract'.+loadExtract :: FromConfig a => Figment -> IO (Either ConfigErrors a)+loadExtract fig = (>>= extract) <$> load fig++-- | 'loadExtract', throwing t'ConfigErrors' (whose 'Control.Exception.displayException' is+-- the rendered report).+loadExtractOrThrow :: FromConfig a => Figment -> IO a+loadExtractOrThrow fig = loadExtract fig >>= either throwIO pure
+ src/Figment/Internal/Budget.hs view
@@ -0,0 +1,62 @@+-- | A tiny state/error monad shared by every parser that builds a+-- t'Figment.Value.Value' from untrusted input: it enforces 'Limits' while the tree is+-- being built, so a hostile source is rejected before it is+-- materialised.+module Figment.Internal.Budget+  ( Budget+  , runBudget+  , spend+  , enterContainer+  , throwB+  , askLimits+  ) where++import Figment.Error+import Figment.Limits+import Figment.Metadata (Pos)+import Figment.Path (Path)++newtype Budget a = Budget {unBudget :: Limits -> Int -> Either ConfigError (a, Int)}++instance Functor Budget where+  fmap f (Budget g) = Budget $ \l n -> case g l n of+    Left e -> Left e+    Right (a, n') -> Right (f a, n')++instance Applicative Budget where+  pure a = Budget $ \_ n -> Right (a, n)+  Budget f <*> Budget g = Budget $ \l n -> case f l n of+    Left e -> Left e+    Right (h, n') -> case g l n' of+      Left e -> Left e+      Right (a, n'') -> Right (h a, n'')++instance Monad Budget where+  Budget g >>= k = Budget $ \l n -> case g l n of+    Left e -> Left e+    Right (a, n') -> unBudget (k a) l n'++runBudget :: Limits -> Budget a -> Either ConfigError a+runBudget l (Budget g) = fst <$> g l (maxNodes l)++askLimits :: Budget Limits+askLimits = Budget $ \l n -> Right (l, n)++throwB :: ConfigError -> Budget a+throwB e = Budget $ \_ _ -> Left e++-- | Account for @k@ values at the given location.+spend :: Int -> Path -> Maybe Pos -> Budget ()+spend k p pos = Budget $ \l n ->+  let n' = n - k+  in if n' < 0+       then Left (withPos pos (atPath p (configError (TooManyNodes (maxNodes l)))))+       else Right ((), n')++-- | Check that a container at nesting level @depth@ (root = 1) is+-- allowed.+enterContainer :: Int -> Path -> Maybe Pos -> Budget ()+enterContainer depth p pos = Budget $ \l n ->+  if depth > maxDepth l+    then Left (withPos pos (atPath p (configError (DepthExceeded (maxDepth l)))))+    else Right ((), n)
+ src/Figment/Internal/Nest.hs view
@@ -0,0 +1,60 @@+-- | Turning flat @(key path, value)@ pairs (environment variables, CLI+-- arguments, keyed defaults) into a nested dictionary, reporting every+-- conflict instead of silently dropping data.+module Figment.Internal.Nest+  ( Duplicates (..)+  , nest+  ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)++import Figment.Error+import Figment.Path+import Figment.Value++-- | What to do when two entries set exactly the same key.+data Duplicates+  = LastWins   -- ^ later entries override earlier ones (CLI convention)+  | RejectDuplicates -- ^ report 'DuplicateKey'++data Entry+  = Leaf !Text !Value+  | Branch !Text !(Map Text Entry)++-- | @nest policy entries@, where each entry is+-- @(original name, key segments, value)@. The original name (e.g.+-- @APP_DB\__HOST@) is used in conflict messages.+nest :: Duplicates -> [(Text, [Text], Value)] -> Either ConfigErrors Dict+nest policy entries =+  let (tree, errs) = foldl' step (Map.empty, []) entries+  in case fromErrorList (reverse errs) of+       Just es -> Left es+       Nothing -> Right (fmap toValue tree)+  where+    step (tree, errs) (name, ks, v) = case insert root name ks v tree of+      Left e -> (tree, e : errs)+      Right tree' -> (tree', errs)++    insert _ _ [] _ tree = Right tree+    insert path name [k] v tree = case Map.lookup k tree of+      Nothing -> Right (Map.insert k (Leaf name v) tree)+      Just (Leaf other _) -> case policy of+        LastWins -> Right (Map.insert k (Leaf name v) tree)+        RejectDuplicates ->+          Left (atPath (path /. k) (configError (DuplicateKey (other <> " and " <> name))))+      Just (Branch other _) ->+        Left (atPath (path /. k) (configError (KeyConflict name other)))+    insert path name (k : ks) v tree = case Map.lookup k tree of+      Nothing -> do+        sub <- insert (path /. k) name ks v Map.empty+        Right (Map.insert k (Branch name sub) tree)+      Just (Branch first sub) -> do+        sub' <- insert (path /. k) name ks v sub+        Right (Map.insert k (Branch first sub') tree)+      Just (Leaf other _) ->+        Left (atPath (path /. k) (configError (KeyConflict other name)))++    toValue (Leaf _ v) = v+    toValue (Branch _ m) = mkValue (Dict (fmap toValue m))
+ src/Figment/Internal/ValueParser.hs view
@@ -0,0 +1,195 @@+-- | Parsing untyped text (environment variables, CLI arguments) into+-- structured values, with syntax resembling TOML (as Rust figment's+-- @Env@ does):+--+-- * @true@ / @false@ are booleans+-- * integers and decimals (@-12@, @3.5@, @1e3@) are exact numbers;+--   @inf@, @-inf@, @nan@ are the non-finite numbers+-- * @\"double\"@ and @'single'@ quoted text is a string (quotes removed)+-- * @[a, b, c]@ is an array and @{k = v, k2 = v2}@ a dictionary; their+--   elements follow the same rules, and bare words inside them are+--   strings+-- * anything else, including malformed structured text, is the string+--   itself, verbatim+--+-- The top-level result always records the original text in 'tagRaw',+-- so a 'Text' field still receives @007@ rather than @7@.+module Figment.Internal.ValueParser+  ( parseValue+  , parseNumber+  ) where++import Data.Char (isDigit, isSpace)+import qualified Data.Map.Strict as Map+import Data.Scientific (scientific)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector++import Figment.Error+import Figment.Limits+import Figment.Value++-- | Parse one untyped text value. Fails only when structured text is+-- nested beyond the depth limit; any syntax problem falls back to the+-- string.+parseValue :: Limits -> Text -> Either ConfigError Value+parseValue lim raw = case top of+  Left (Limit e) -> Left e+  Left NoParse -> Right (rawTagged (String raw))+  Right n -> Right (rawTagged n)+  where+    trimmed = Text.strip raw+    rawTagged n = Value untagged {tagRaw = Just raw} n+    top+      | Text.null trimmed = Right (String raw)+      | otherwise = case Text.head trimmed of+          c | c == '[' || c == '{' || c == '"' || c == '\'' ->+                case structured lim 1 trimmed of+                  Right (v, rest) | Text.null (Text.strip rest) -> Right (valueNode v)+                  Right _ -> Left NoParse+                  Left e -> Left e+          _ -> Right (scalarNode raw trimmed)++data Failure = NoParse | Limit ConfigError++-- | A bare scalar: boolean, number, or the text itself.+scalarNode :: Text -> Text -> Node+scalarNode original t+  | t == "true" = Bool True+  | t == "false" = Bool False+  | Just n <- parseNumber t = Num n+  | otherwise = String original++type P a = Either Failure (a, Text)++structured :: Limits -> Int -> Text -> P Value+structured lim depth t0 = case Text.uncons t of+  Just ('[', rest) -> do+    guardDepth+    (xs, rest') <- elements rest+    pure (mkValue (Array (Vector.fromList xs)), rest')+  Just ('{', rest) -> do+    guardDepth+    (kvs, rest') <- pairs rest+    pure (mkValue (Dict (Map.fromList kvs)), rest')+  Just ('"', rest) -> first' string (quotedDouble "" rest)+  Just ('\'', rest) -> first' string (quotedSingle rest)+  Just _ ->+    let (tok, rest) = Text.break (`elem` (",]}" :: String)) t+        tok' = Text.strip tok+    in if Text.null tok'+         then Left NoParse+         else Right (mkValue (scalarNode tok' tok'), rest)+  Nothing -> Left NoParse+  where+    t = Text.stripStart t0+    guardDepth+      | depth > maxDepth lim = Left (Limit (configError (DepthExceeded (maxDepth lim))))+      | otherwise = Right ()++    elements s0 =+      let s = Text.stripStart s0+      in case Text.uncons s of+           Just (']', rest) -> Right ([], rest)+           _ -> go [] s+      where+        go acc s = do+          (v, rest) <- structured lim (depth + 1) s+          let rest' = Text.stripStart rest+          case Text.uncons rest' of+            Just (',', more) ->+              let more' = Text.stripStart more+              in case Text.uncons more' of+                   Just (']', fin) -> Right (reverse (v : acc), fin)+                   _ -> go (v : acc) more'+            Just (']', fin) -> Right (reverse (v : acc), fin)+            _ -> Left NoParse++    pairs s0 =+      let s = Text.stripStart s0+      in case Text.uncons s of+           Just ('}', rest) -> Right ([], rest)+           _ -> go [] s+      where+        go acc s = do+          (k, rest) <- key s+          rest1 <- case Text.uncons (Text.stripStart rest) of+            Just (c, r) | c == '=' || c == ':' -> Right r+            _ -> Left NoParse+          (v, rest2) <- structured lim (depth + 1) rest1+          let rest3 = Text.stripStart rest2+          case Text.uncons rest3 of+            Just (',', more) ->+              let more' = Text.stripStart more+              in case Text.uncons more' of+                   Just ('}', fin) -> Right (reverse ((k, v) : acc), fin)+                   _ -> go ((k, v) : acc) more'+            Just ('}', fin) -> Right (reverse ((k, v) : acc), fin)+            _ -> Left NoParse++    key s = case Text.uncons (Text.stripStart s) of+      Just ('"', rest) -> quotedDouble "" rest+      Just ('\'', rest) -> quotedSingle rest+      _ ->+        let (k, rest) = Text.span (\c -> not (isSpace c) && c `notElem` ("=:,{}[]" :: String)) (Text.stripStart s)+        in if Text.null k then Left NoParse else Right (k, rest)++    first' f r = fmap (\(a, rest) -> (f a, rest)) r++quotedDouble :: Text -> Text -> P Text+quotedDouble acc s = case Text.uncons s of+  Nothing -> Left NoParse+  Just ('"', rest) -> Right (acc, rest)+  Just ('\\', rest) -> case Text.uncons rest of+    Just (c, rest') -> case c of+      'n' -> quotedDouble (Text.snoc acc '\n') rest'+      't' -> quotedDouble (Text.snoc acc '\t') rest'+      'r' -> quotedDouble (Text.snoc acc '\r') rest'+      _ -> quotedDouble (Text.snoc acc c) rest'+    Nothing -> Left NoParse+  Just (c, rest) -> quotedDouble (Text.snoc acc c) rest++quotedSingle :: Text -> P Text+quotedSingle s =+  let (body, rest) = Text.break (== '\'') s+  in case Text.uncons rest of+       Just ('\'', rest') -> Right (body, rest')+       _ -> Left NoParse++-- | Exact number syntax: @[+-]?digits(.digits)?([eE][+-]?digits)?@, or+-- @inf@ / @+inf@ / @-inf@ / @nan@.+parseNumber :: Text -> Maybe Number+parseNumber t = case t of+  "inf" -> Just PosInfinity+  "+inf" -> Just PosInfinity+  "-inf" -> Just NegInfinity+  "nan" -> Just NaN+  "+nan" -> Just NaN+  "-nan" -> Just NaN+  _ -> do+    let (neg, body) = case Text.uncons t of+          Just ('-', r) -> (True, r)+          Just ('+', r) -> (False, r)+          _ -> (False, t)+        (intPart, r1) = Text.span isDigit body+    if Text.null intPart then Nothing else pure ()+    (fracPart, r2) <- case Text.uncons r1 of+      Just ('.', r) ->+        let (f, r') = Text.span isDigit r+        in if Text.null f then Nothing else Just (f, r')+      _ -> Just ("", r1)+    expo <- case Text.uncons r2 of+      Nothing -> Just 0+      Just (e, r) | e == 'e' || e == 'E' ->+        let (sgn, ds) = case Text.uncons r of+              Just ('-', d) -> (-1, d)+              Just ('+', d) -> (1, d)+              _ -> (1, r)+        in if Text.null ds || not (Text.all isDigit ds) || Text.length ds > 9+             then Nothing+             else Just (sgn * read (Text.unpack ds) :: Int)+      _ -> Nothing+    let coeff = read (Text.unpack (intPart <> fracPart)) :: Integer+        signed = if neg then negate coeff else coeff+    pure (Finite (scientific signed (expo - Text.length fracPart)))
+ src/Figment/Jail.hs view
@@ -0,0 +1,95 @@+-- | A sandbox for configuration tests (Rust: @figment::Jail@).+--+-- 'withJail' runs an action in a fresh temporary working directory with+-- a snapshot of the environment, and restores both afterwards, even on+-- exceptions. Jails are serialised process-wide (the working directory+-- and the environment are process-global), so jailed tests are safe+-- under a parallel test runner. Tests that do not use a jail should not+-- touch the working directory or the environment.+module Figment.Jail+  ( Jail+  , withJail+  , jailDirectory+  , createFile+  , createBinaryFile+  , createDirectory+  , inDirectory+  , setEnv+  , unsetEnv+  , clearEnv+  ) where++import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Control.Exception (bracket, bracket_)+import qualified Data.ByteString as BS+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import System.Directory (createDirectoryIfMissing, getCurrentDirectory, setCurrentDirectory)+import qualified System.Environment as Env+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.IO.Unsafe (unsafePerformIO)++-- | A handle on the running jail.+newtype Jail = Jail+  { jailDirectory :: FilePath+    -- ^ the temporary directory (also the working directory)+  }++-- The one piece of global state: a lock serialising jails. Standard+-- top-level-MVar idiom; NOINLINE guarantees a single MVar.+jailLock :: MVar ()+jailLock = unsafePerformIO (newMVar ())+{-# NOINLINE jailLock #-}++-- | Run an action in a fresh jail; see the module header.+withJail :: (Jail -> IO a) -> IO a+withJail act = withMVar jailLock $ \() ->+  withSystemTempDirectory "figment-jail" $ \dir ->+    bracket Env.getEnvironment restoreEnv $ \_ ->+      bracket getCurrentDirectory setCurrentDirectory $ \_ ->+        bracket_ (setCurrentDirectory dir) (pure ()) (act (Jail dir))+  where+    restoreEnv saved = do+      now <- Env.getEnvironment+      mapM_ (Env.unsetEnv . fst) [kv | kv@(k, _) <- now, k `notElem` map fst saved]+      mapM_ (uncurry Env.setEnv) [kv | kv <- saved, lookup (fst kv) now /= Just (snd kv)]++-- | Write a UTF-8 file, relative to the jail directory.+createFile :: Jail -> FilePath -> Text -> IO FilePath+createFile (Jail dir) rel contents = do+  let path = dir </> rel+  createDirectoryIfMissing True (takeDirectory path)+  BS.writeFile path (TE.encodeUtf8 contents)+  pure path++-- | Write raw bytes (e.g. deliberately invalid UTF-8).+createBinaryFile :: Jail -> FilePath -> BS.ByteString -> IO FilePath+createBinaryFile (Jail dir) rel contents = do+  let path = dir </> rel+  createDirectoryIfMissing True (takeDirectory path)+  BS.writeFile path contents+  pure path++-- | Run an action with another working directory (restored afterwards).+inDirectory :: Jail -> FilePath -> IO a -> IO a+inDirectory _ d act = bracket getCurrentDirectory setCurrentDirectory (\_ -> setCurrentDirectory d >> act)++-- | Create a directory (and parents) inside the jail.+createDirectory :: Jail -> FilePath -> IO FilePath+createDirectory (Jail dir) rel = do+  let path = dir </> rel+  createDirectoryIfMissing True path+  pure path++-- | Set an environment variable for the duration of the jail. (As with "System.Environment", setting the empty string unsets it.)+setEnv :: Jail -> String -> String -> IO ()+setEnv _ = Env.setEnv++-- | Unset an environment variable for the duration of the jail.+unsetEnv :: Jail -> String -> IO ()+unsetEnv _ = Env.unsetEnv++-- | Remove every environment variable (restored when the jail ends).+clearEnv :: Jail -> IO ()+clearEnv _ = Env.getEnvironment >>= mapM_ (Env.unsetEnv . fst)
+ src/Figment/Limits.hs view
@@ -0,0 +1,40 @@+-- | Resource limits applied while reading untrusted sources.+module Figment.Limits+  ( Limits+  , mkLimits+  , defaultLimits+  , maxDepth+  , maxNodes+  ) where++import Control.DeepSeq (NFData)+import qualified Data.Text as Text+import GHC.Generics (Generic)++import Figment.Error++-- | Bounds enforced /inside/ every parser figment ships (not after the+-- fact), so a hostile source is rejected before it can exhaust memory.+-- The constructor is hidden: obtain values via 'mkLimits'.+data Limits = Limits+  { maxDepth :: !Int+    -- ^ maximum container nesting (the root dictionary is depth 1)+  , maxNodes :: !Int+    -- ^ maximum number of values per source, counting YAML alias+    -- expansions (defeats \"billion laughs\")+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Both limits must be positive.+mkLimits :: Int -> Int -> Either ConfigError Limits+mkLimits d n+  | d <= 0 = Left (bad "maxDepth" d)+  | n <= 0 = Left (bad "maxNodes" n)+  | otherwise = Right (Limits d n)+  where+    bad name v = configError (InvalidArgument (name <> " must be positive, got " <> Text.pack (show v)))++-- | Depth 64, one million values (ADR 001, ADR 017).+defaultLimits :: Limits+defaultLimits = Limits 64 1000000
+ src/Figment/Merge.hs view
@@ -0,0 +1,68 @@+-- | Combining values: the four strategies of Rust figment, with the+-- same semantics (see @coalesce.rs@ upstream).+--+-- * 'Merge'   — on conflict the incoming value wins+-- * 'Join'    — on conflict the existing value wins+-- * 'Adjoin'  — like 'Join', but arrays are concatenated+-- * 'Admerge' — like 'Merge', but arrays are concatenated+--+-- Dictionaries are always merged key by key, recursively. A @null@ is a+-- value like any other: merging @null@ over a key replaces it.+--+-- Laws (property-tested in @test/Figment/MergeLaws.hs@):+--+-- * @coalesce Join a b == coalesce Merge b a@ (duality, tags included)+-- * @coalesce o v v@ has the same data as @v@ for 'Merge' and 'Join'+-- * the empty dictionary is a two-sided identity on dictionaries+-- * for a fixed order, 'coalesce' is associative on trees of identical+--   shape. It is /not/ associative in general (a scalar between two+--   dictionaries), which is why t'Value' has no 'Semigroup' instance; the+--   lawful monoid lives one level up, on 'Figment.Figment'.+module Figment.Merge+  ( Order (..)+  , coalesce+  , coalesceDict+  , coalesceData+  , coalesceProfile+  ) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import Figment.Profile+import Figment.Value++-- | How a provider's values combine with the values already present.+data Order = Merge | Join | Adjoin | Admerge+  deriving stock (Eq, Ord, Show, Enum, Bounded)++leftWins :: Order -> Bool+leftWins Join = True+leftWins Adjoin = True+leftWins _ = False++concatenates :: Order -> Bool+concatenates Adjoin = True+concatenates Admerge = True+concatenates _ = False++-- | Combine an existing value (left) with an incoming one (right).+coalesce :: Order -> Value -> Value -> Value+coalesce o a@(Value ta na) b@(Value tb nb) = case (na, nb) of+  (Dict da, Dict db) ->+    Value (if leftWins o then ta else tb) (Dict (coalesceDict o da db))+  (Array xa, Array xb)+    | concatenates o -> Value ta (Array (xa <> xb))+  _ -> if leftWins o then a else b++-- | Combine two dictionaries key by key.+coalesceDict :: Order -> Dict -> Dict -> Dict+coalesceDict o = Map.unionWith (coalesce o)++-- | Combine per-profile data.+coalesceData :: Order -> Map Profile Dict -> Map Profile Dict -> Map Profile Dict+coalesceData o = Map.unionWith (coalesceDict o)++-- | Combine selected-profile hints.+coalesceProfile :: Order -> Profile -> Profile -> Profile+coalesceProfile o a b = if leftWins o then a else b
+ src/Figment/Metadata.hs view
@@ -0,0 +1,113 @@+-- | Where configuration values come from.+module Figment.Metadata+  ( Metadata (..)+  , Source (..)+  , Pos (..)+  , named+  , fileMetadata+  , withSource+  , withInterpolater+  , withAddedAt+  , interpolate+  , renderSource+  , renderSrcLoc+  ) where++import Control.DeepSeq (NFData (..), rwhnf)+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import GHC.Stack (SrcLoc (..))++import Figment.Path (Path, renderPath)+import Figment.Profile (Profile)++-- | A one-based line and column in a source text.+data Pos = Pos+  { posLine :: !Int+  , posColumn :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | The origin of a provider's data.+data Source+  = FileSource !FilePath   -- ^ a file on disk (resolved path)+  | CodeSource !SrcLoc     -- ^ values written in Haskell code+  | CustomSource !Text     -- ^ anything else (\"environment\", a URL, ...)+  deriving stock (Eq, Show, Generic)++instance NFData Source where+  rnf (FileSource p) = rnf p+  rnf (CodeSource l) = l `seq` ()+  rnf (CustomSource t) = rnf t++-- | Everything known about a provider.+--+-- 'metaInterpolate' turns a key path back into the provider's own+-- vocabulary, e.g. @db.port@ into @APP_DB\__PORT@ for environment+-- variables or @--db.port@ for CLI arguments; error messages and+-- missing-field hints use it so users are told what to /type/.+data Metadata = Metadata+  { metaName :: !Text+  , metaSource :: !(Maybe Source)+  , metaAddedAt :: !(Maybe SrcLoc)+  , metaInterpolate :: Profile -> Path -> Text+  }+  deriving stock (Generic)++-- | Equality ignores the interpolation function (functions have no+-- equality); two metadata are equal when they name the same source+-- added at the same place.+instance Eq Metadata where+  a == b =+    metaName a == metaName b+      && metaSource a == metaSource b+      && metaAddedAt a == metaAddedAt b++instance Show Metadata where+  showsPrec d m = showParen (d > 10) $+    showString "Metadata {metaName = " . shows (metaName m)+      . showString ", metaSource = " . shows (metaSource m)+      . showString ", metaAddedAt = " . shows (metaAddedAt m)+      . showString "}"++instance NFData Metadata where+  rnf (Metadata n s a i) = rnf n `seq` rnf s `seq` maybe () (`seq` ()) a `seq` rwhnf i++-- | Metadata with a name and the default interpolater (the rendered+-- key path).+named :: Text -> Metadata+named n = Metadata n Nothing Nothing (const renderPath)++-- | Metadata for a file-backed source.+fileMetadata :: Text -> FilePath -> Metadata+fileMetadata n p = withSource (FileSource p) (named n)++-- | Set the source.+withSource :: Source -> Metadata -> Metadata+withSource s m = m {metaSource = Just s}++-- | Replace the key-name renderer.+withInterpolater :: (Profile -> Path -> Text) -> Metadata -> Metadata+withInterpolater f m = m {metaInterpolate = f}++-- | Record where the provider was added.+withAddedAt :: SrcLoc -> Metadata -> Metadata+withAddedAt l m = m {metaAddedAt = Just l}++-- | The provider-native name of a key.+interpolate :: Metadata -> Profile -> Path -> Text+interpolate = metaInterpolate++-- | A short rendering of a source.+renderSource :: Source -> Text+renderSource (FileSource p) = Text.pack p+renderSource (CodeSource l) = renderSrcLoc l+renderSource (CustomSource t) = t++-- | @file:line:column@.+renderSrcLoc :: SrcLoc -> Text+renderSrcLoc l =+  Text.pack (srcLocFile l) <> ":" <> Text.pack (show (srcLocStartLine l))+    <> ":" <> Text.pack (show (srcLocStartCol l))
+ src/Figment/Partial.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Higher-kinded partial configurations.+--+-- Write a configuration record once, parameterised by a functor:+--+-- > data AppF f = App+-- >   { host :: Field f Text+-- >   , port :: Field f Int+-- >   , db   :: DbF f            -- nested partial record+-- >   } deriving stock Generic+-- > instance Partial AppF+-- > type App = AppF Identity      -- fields are plain: host :: Text+--+-- @AppF Maybe@ is the /partial/ form: every field optional. Defaults+-- are written as a partial value, merged under whatever the providers+-- supplied, and 'complete' turns the result into the total @AppF+-- Identity@, reporting /every/ missing field (with the env var, CLI+-- flag, or file key that would have set it) rather than the first.+--+-- The compile-time guarantee: 'Figment.extractTotal' takes a total+-- @AppF Identity@ as its defaults, so a missing-field error is+-- impossible by construction; only type errors remain.+module Figment.Partial+  ( Field+  , Partial (..)+  , GPartial+  ) where++import Control.Applicative ((<|>))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)++import Figment.Decode+import Figment.Error+import Figment.Path+import Figment.Value++-- | @Field Identity a = a@, so the total record has ordinary fields;+-- @Field Maybe a = Maybe a@ for the partial record.+type family Field (f :: Type -> Type) (a :: Type) :: Type where+  Field Identity a = a+  Field f a = f a++-- | Records whose fields are 'Field's or nested 'Partial' records.+-- Every method has a generic default: @instance Partial AppF@ suffices.+class Partial (c :: (Type -> Type) -> Type) where+  -- | Decode whatever is present; absent fields are 'Nothing'. Type+  -- errors in present fields are reported (all of them).+  partialDecoder :: Options -> Decoder (c Maybe)+  default partialDecoder+    :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity)))+    => Options -> Decoder (c Maybe)+  partialDecoder o = to <$> mkDecoder (\c v -> case valueNode v of+    Dict m -> recordCheck o (gpnames @(Rep (c Maybe)) @(Rep (c Identity)) o) c m+                (gpfields @(Rep (c Maybe)) @(Rep (c Identity)) o c m)+    n -> Failure (single (atValue c v (InvalidType (describe n) "a dictionary"))))++  -- | Right-biased combination: fields set on the right win.+  overlay :: c Maybe -> c Maybe -> c Maybe+  default overlay+    :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity)))+    => c Maybe -> c Maybe -> c Maybe+  overlay a b = to (goverlay @(Rep (c Maybe)) @(Rep (c Identity)) (from a) (from b))++  -- | The partial value with nothing set.+  emptyPartial :: c Maybe+  default emptyPartial+    :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity)))+    => c Maybe+  emptyPartial = to (gempty @(Rep (c Maybe)) @(Rep (c Identity)))++  -- | The total value, or the (relative) paths of every required field+  -- that is still missing. Fields whose type has a 'missingValue'+  -- (e.g. 'Maybe') are never missing.+  complete :: Options -> c Maybe -> Either (NonEmpty Path) (c Identity)+  default complete+    :: (Generic (c Maybe), Generic (c Identity), GPartial (Rep (c Maybe)) (Rep (c Identity)))+    => Options -> c Maybe -> Either (NonEmpty Path) (c Identity)+  complete o p = case gcomplete @(Rep (c Maybe)) @(Rep (c Identity)) o root (from p) of+    Left (x : xs) -> Left (x :| xs)+    Left [] -> Left (root :| [])+    Right r -> Right (to r)++  -- | Embed a total value (every field set).+  total :: c Identity -> c Maybe+  default total+    :: (Generic (c Maybe), Generic (c Identity), GPartial (Rep (c Maybe)) (Rep (c Identity)))+    => c Identity -> c Maybe+  total = to . gtotal @(Rep (c Maybe)) @(Rep (c Identity)) . from++-- | Accumulating completion.+type Completion a = Either [Path] a++both :: Completion (a -> b) -> Completion a -> Completion b+both (Left a) (Left b) = Left (a ++ b)+both (Left a) (Right _) = Left a+both (Right _) (Left b) = Left b+both (Right f) (Right x) = Right (f x)++-- | Generic machinery behind 'Partial's defaults.+class GPartial (pm :: Type -> Type) (pi :: Type -> Type) where+  gpfields :: Options -> DecodeContext -> Dict -> Result (pm x)+  gpnames :: Options -> [Text]+  goverlay :: pm x -> pm x -> pm x+  gempty :: pm x+  gcomplete :: Options -> Path -> pm x -> Completion (pi x)+  gtotal :: pi x -> pm x++instance GPartial pm pi => GPartial (D1 d pm) (D1 d pi) where+  gpfields o c m = M1 <$> gpfields @pm @pi o c m+  gpnames o = gpnames @pm @pi o+  goverlay (M1 a) (M1 b) = M1 (goverlay @pm @pi a b)+  gempty = M1 (gempty @pm @pi)+  gcomplete o p (M1 a) = M1 <$> gcomplete @pm @pi o p a+  gtotal (M1 a) = M1 (gtotal @pm @pi a)++instance GPartial pm pi => GPartial (C1 c pm) (C1 c pi) where+  gpfields o c m = M1 <$> gpfields @pm @pi o c m+  gpnames o = gpnames @pm @pi o+  goverlay (M1 a) (M1 b) = M1 (goverlay @pm @pi a b)+  gempty = M1 (gempty @pm @pi)+  gcomplete o p (M1 a) = M1 <$> gcomplete @pm @pi o p a+  gtotal (M1 a) = M1 (gtotal @pm @pi a)++instance (GPartial am ai, GPartial bm bi) => GPartial (am :*: bm) (ai :*: bi) where+  gpfields o c m = (:*:) <$> gpfields @am @ai o c m <*> gpfields @bm @bi o c m+  gpnames o = gpnames @am @ai o ++ gpnames @bm @bi o+  goverlay (a :*: b) (a' :*: b') = goverlay @am @ai a a' :*: goverlay @bm @bi b b'+  gempty = gempty @am @ai :*: gempty @bm @bi+  gcomplete o p (a :*: b) = fmap (:*:) (gcomplete @am @ai o p a) `both` gcomplete @bm @bi o p b+  gtotal (a :*: b) = gtotal @am @ai a :*: gtotal @bm @bi b++instance GPartial U1 U1 where+  gpfields _ _ _ = Success U1+  gpnames _ = []+  goverlay _ _ = U1+  gempty = U1+  gcomplete _ _ _ = Right U1+  gtotal _ = U1++-- | A leaf field: @Field f a@.+instance (Selector s, FromConfig a) => GPartial (S1 s (Rec0 (Maybe a))) (S1 s (Rec0 a)) where+  gpfields o c m =+    let name = selKey @s o+    in case Map.lookup name m of+         Just v -> M1 . K1 . Just <$> runIn c {ctxPath = ctxPath c /. name} v+         Nothing -> Success (M1 (K1 Nothing))+  gpnames o = [selKey @s o]+  goverlay (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (b <|> a))+  gempty = M1 (K1 Nothing)+  gcomplete o p (M1 (K1 m)) = case m <|> missingValue @a of+    Just a -> Right (M1 (K1 a))+    Nothing -> Left [p /. selKey @s o]+  gtotal (M1 (K1 a)) = M1 (K1 (Just a))++-- | A nested partial record.+instance (Selector s, Partial b) => GPartial (S1 s (Rec0 (b Maybe))) (S1 s (Rec0 (b Identity))) where+  gpfields o c m =+    let name = Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ())))+    in case Map.lookup name m of+         Just v -> M1 . K1 <$> runDecoderIn (partialDecoder @b o) c {ctxPath = ctxPath c /. name} v+         Nothing -> Success (M1 (K1 (emptyPartial @b)))+  gpnames o = [Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ())))]+  goverlay (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (overlay @b a b))+  gempty = M1 (K1 (emptyPartial @b))+  gcomplete o p (M1 (K1 m)) =+    let here = p /. Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ())))+    in case complete @b o m of+         Right r -> Right (M1 (K1 r))+         Left ps -> Left (map (here <>) (NE.toList ps))+  gtotal (M1 (K1 a)) = M1 (K1 (total @b a))++instance+  TypeError ('Text "figment: a Partial configuration must be a record with a single constructor")+  => GPartial (f :+: g) (f' :+: g')+  where+  gpfields _ _ _ = Failure (single (configError (Message "unreachable")))+  gpnames _ = []+  goverlay a _ = a+  gempty = gempty @(f :+: g) @(f' :+: g')+  gcomplete _ _ _ = Left []+  gtotal _ = gempty @(f :+: g) @(f' :+: g')++-- helpers ----------------------------------------------------------------++data SP (s :: Meta) (f :: Type -> Type) a = SP++selKey :: forall (s :: Meta). Selector s => Options -> Text+selKey o = Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ())))++-- | Run 'fromConfig' at an explicit context.+runIn :: FromConfig a => DecodeContext -> Value -> Result a+runIn = decodeWith fromConfig++runDecoderIn :: Decoder a -> DecodeContext -> Value -> Result a+runDecoderIn = decodeWith++-- | Unknown-field check, accumulated together with the field results.+recordCheck :: Options -> [Text] -> DecodeContext -> Dict -> Result a -> Result a+recordCheck o known c m fields =+  let unknown =+        [ single (atValue c {ctxPath = ctxPath c /. key} x (UnknownField key (suggest key known)))+        | rejectUnknownFields o, (key, x) <- Map.toList m, key `notElem` known ]+  in case unknown of+       [] -> fields+       (e : es) -> Failure (foldl (<>) e es) <* fields++atValue :: DecodeContext -> Value -> ErrorKind -> ConfigError+atValue c x kind =+  let t = valueTag x+  in ConfigError kind (ctxPath c) (tagProfile t) (tagMeta t) (tagPos t) []
+ src/Figment/Path.hs view
@@ -0,0 +1,162 @@+-- | Key paths into a configuration tree.+--+-- A t'Path' is a sequence of 'Segment's: either a dictionary 'Key' or an+-- array 'Index'. Keeping the two apart (rather than encoding indices as+-- text) means key @"0"@ and index @0@ can never be confused, and error+-- messages can render @servers[2].port@ faithfully.+module Figment.Path+  ( Segment (..)+  , Path+  , root+  , isRoot+  , segments+  , fromSegments+  , (/.)+  , (/#)+  , keyPath+  , parsePath+  , renderPath+  , renderSegment+  ) where++import Control.DeepSeq (NFData)+import Data.Char (isAlphaNum, isDigit)+import Data.Foldable (toList)+import Data.Sequence (Seq, (|>))+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)++-- | One step into a configuration tree.+data Segment+  = Key !Text   -- ^ a dictionary key+  | Index !Int  -- ^ a zero-based array index+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A location in a configuration tree, from the root. Appending is+-- O(1) ('Seq' snoc), so building paths while descending is linear.+newtype Path = Path (Seq Segment)+  deriving stock (Eq, Ord, Generic)+  deriving anyclass (NFData)++instance Show Path where+  showsPrec d p = showParen (d > 10) $+    showString "keyPath " . shows (renderPath p)++instance Semigroup Path where+  Path a <> Path b = Path (a <> b)++instance Monoid Path where+  mempty = root++-- | The empty path: the top of the tree.+root :: Path+root = Path Seq.empty++-- | Is this the root path?+isRoot :: Path -> Bool+isRoot (Path s) = Seq.null s++-- | The segments of a path, from the root.+segments :: Path -> [Segment]+segments (Path s) = toList s++-- | Build a path from segments.+fromSegments :: [Segment] -> Path+fromSegments = Path . Seq.fromList++-- | Extend a path with a key.+(/.) :: Path -> Text -> Path+Path s /. k = Path (s |> Key k)+infixl 5 /.++-- | Extend a path with an index.+(/#) :: Path -> Int -> Path+Path s /# i = Path (s |> Index i)+infixl 5 /#++-- | A dotted key path, as used by Rust figment: @"db.host"@ is+-- @[Key "db", Key "host"]@. Total: empty segments are kept as empty keys+-- (so @keyPath ""@ is the single empty key, never an error). Use+-- 'parsePath' to read the full rendered syntax including indices and+-- quoted keys.+keyPath :: Text -> Path+keyPath t = fromSegments (map Key (Text.splitOn "." t))++-- | Render a path: keys joined with @.@, indices as @[n]@, and keys that+-- are not plain identifiers double-quoted. The root renders as the empty+-- text. @parsePath . renderPath == Right@.+renderPath :: Path -> Text+renderPath (Path s) = go True (toList s)+  where+    go _ [] = Text.empty+    go first (seg : rest) = piece first seg <> go False rest+    piece _ (Index i) = "[" <> Text.pack (show i) <> "]"+    piece first (Key k) = (if first then "" else ".") <> renderKey k++-- | Render a single segment on its own.+renderSegment :: Segment -> Text+renderSegment (Index i) = "[" <> Text.pack (show i) <> "]"+renderSegment (Key k) = renderKey k++renderKey :: Text -> Text+renderKey k+  | not (Text.null k) && Text.all plain k = k+  | otherwise = "\"" <> Text.concatMap esc k <> "\""+  where+    plain c = isAlphaNum c || c == '_' || c == '-'+    esc '"' = "\\\""+    esc '\\' = "\\\\"+    esc c = Text.singleton c++-- | Parse the syntax produced by 'renderPath'.+parsePath :: Text -> Either Text Path+parsePath t0+  | Text.null t0 = Right root+  | otherwise = fromSegments . reverse <$> start [] t0+  where+    start acc t = do+      (seg, rest) <- keySeg t+      more (seg : acc) rest++    more acc t = case Text.uncons t of+      Nothing -> Right acc+      Just ('.', rest) -> do+        (seg, rest') <- keySeg rest+        more (seg : acc) rest'+      Just ('[', rest) -> do+        let (ds, rest') = Text.span isDigit rest+        case Text.uncons rest' of+          Just (']', rest'') | not (Text.null ds) ->+            more (Index (read (Text.unpack ds)) : acc) rest''+          _ -> Left ("malformed index in path " <> quoted t0)+      Just (c, _) -> Left ("unexpected " <> Text.pack (show c) <> " in path " <> quoted t0)++    keySeg t = case Text.uncons t of+      Just ('[', _) -> idxFirst t+      Just ('"', rest) -> quotedKey "" rest+      _ ->+        let (k, rest) = Text.span (\c -> c /= '.' && c /= '[') t+        in if Text.null k+             then Left ("empty key in path " <> quoted t0)+             else Right (Key k, rest)++    idxFirst t = case Text.uncons t of+      Just ('[', rest) ->+        let (ds, rest') = Text.span isDigit rest+        in case Text.uncons rest' of+             Just (']', rest'') | not (Text.null ds) -> Right (Index (read (Text.unpack ds)), rest'')+             _ -> Left ("malformed index in path " <> quoted t0)+      _ -> Left ("malformed path " <> quoted t0)++    quotedKey acc t = case Text.uncons t of+      Nothing -> Left ("unterminated quoted key in path " <> quoted t0)+      Just ('"', rest) -> Right (Key acc, rest)+      Just ('\\', rest) -> case Text.uncons rest of+        Just (c, rest') -> quotedKey (Text.snoc acc c) rest'+        Nothing -> Left ("dangling escape in path " <> quoted t0)+      Just (c, rest) -> quotedKey (Text.snoc acc c) rest++    quoted x = "`" <> x <> "`"
+ src/Figment/Profile.hs view
@@ -0,0 +1,69 @@+-- | Profiles: named slices of configuration ("semi-hierarchical"+-- configuration, as in Rust figment).+--+-- Every provider yields one dictionary per profile. On extraction, the+-- 'Default' profile is merged with the selected profile, and the+-- 'Global' profile is merged over both.+module Figment.Profile+  ( Profile (Default, Global)+  , profile+  , profileName+  , isCustom+  , profileFromEnv+  ) where++import Control.DeepSeq (NFData)+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import System.Environment (lookupEnv)++-- | A configuration profile. Custom profile names are case-insensitive+-- (stored lower-cased), matching Rust figment. The 'Named' constructor+-- is not exported: use 'profile', which maps @"default"@ and+-- @"global"@ to the built-in profiles so there is exactly one+-- representation of each.+data Profile+  = Default+  | Global+  | Named !Text+  deriving stock (Eq, Ord, Generic)+  deriving anyclass (NFData)++instance Show Profile where+  showsPrec _ Default = showString "Default"+  showsPrec _ Global = showString "Global"+  showsPrec d (Named t) = showParen (d > 10) $ showString "profile " . shows t++instance IsString Profile where+  fromString = profile . Text.pack++-- | Smart constructor. Case-insensitive; surrounding whitespace is+-- ignored; the empty name is 'Default'.+profile :: Text -> Profile+profile raw = case Text.toLower (Text.strip raw) of+  "" -> Default+  "default" -> Default+  "global" -> Global+  t -> Named t++-- | The canonical (lower-case) name of a profile.+profileName :: Profile -> Text+profileName Default = "default"+profileName Global = "global"+profileName (Named t) = t++-- | Is this a user-defined profile (neither 'Default' nor 'Global')?+isCustom :: Profile -> Bool+isCustom (Named _) = True+isCustom _ = False++-- | Read a profile from an environment variable, falling back to the+-- given profile when it is unset or empty (Rust: @Profile::from_env_or@).+profileFromEnv :: String -> Profile -> IO Profile+profileFromEnv var fallback = do+  v <- lookupEnv var+  pure $ case v of+    Just s | not (null s) -> fromString s+    _ -> fallback
+ src/Figment/Provider/Cli.hs view
@@ -0,0 +1,128 @@+-- | Command-line arguments as a provider.+--+-- Rules (ADR 010, revised):+--+-- * @--key=value@ sets @key@; the value is parsed like an environment+--   variable (numbers, booleans, arrays, ...; original text kept).+-- * @--flag@ sets @flag = true@; @--no-flag@ sets @flag = false@.+-- * Dots nest (@--db.port=5432@) and dashes become underscores+--   (@--max-connections@ is @max_connections@); keys are not+--   lower-cased.+-- * @--@ ends option parsing. Anything else (including @-x@ short+--   options) is positional and returned by 'parseArgs'; the provider+--   ignores it.+-- * @--key value@ is /not/ supported: without a schema it is ambiguous+--   with a flag followed by a positional argument. For rich CLIs, parse+--   with optparse-applicative and feed the result in via+--   'Figment.Aeson.defaults'.+-- * Repeating a key: the last occurrence wins. A malformed option+--   (@--=x@, @--a..b=1@) is an error, not silently ignored.+module Figment.Provider.Cli+  ( Cli+  , cli+  , cliFromProcess+  , keyMap+  , unparsedCli+  , cliInProfile+  , parseArgs+  , Arg (..)+  ) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import System.Environment (getArgs)++import Figment.Core+import Figment.Error+import Figment.Internal.Nest+import Figment.Internal.ValueParser (parseValue)+import Figment.Limits+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++-- | Command-line arguments as a configuration source (see the module header for the rules).+data Cli = Cli+  { cliArgs :: [Text]+  , cliKeyMap :: Text -> Text+  , cliParsed :: Bool+  , cliProfile :: Profile+  }++-- | A CLI provider over the given arguments.+cli :: [Text] -> Cli+cli args = Cli args (Text.replace "-" "_") True Default++-- | The arguments of the running process.+cliFromProcess :: IO Cli+cliFromProcess = cli . map Text.pack <$> getArgs++-- | How each key segment is mapped (default: dashes to underscores).+keyMap :: (Text -> Text) -> Cli -> Cli+keyMap f c = c {cliKeyMap = f}++-- | Do not parse values: every value is a string.+unparsedCli :: Cli -> Cli+unparsedCli c = c {cliParsed = False}++-- | Put the values in a profile other than 'Default'.+cliInProfile :: Profile -> Cli -> Cli+cliInProfile p c = c {cliProfile = p}++-- | One classified argument.+data Arg+  = Option !Text ![Text] !(Maybe Text)+    -- ^ original argument, key segments, value (@Nothing@: a flag)+  | NegatedFlag !Text ![Text]+  | Positional !Text+  | Malformed !Text+  deriving stock (Eq, Show)++-- | Classify every argument.+parseArgs :: Cli -> [Arg]+parseArgs c = go (cliArgs c)+  where+    go [] = []+    go ("--" : rest) = map Positional rest+    go (a : rest) = classify a : go rest+    classify a = case Text.stripPrefix "--" a of+      Nothing -> Positional a+      Just body ->+        let (k, eqv) = Text.breakOn "=" body+            v = if Text.null eqv then Nothing else Just (Text.drop 1 eqv)+        in case keySegs k of+             Nothing -> Malformed a+             Just segs -> case (v, Text.stripPrefix "no-" k) of+               (Nothing, Just positive) | Just segs' <- keySegs positive -> NegatedFlag a segs'+               _ -> Option a segs v+    keySegs k+      | Text.null k = Nothing+      | otherwise =+          let segs = map (cliKeyMap c) (Text.splitOn "." k)+          in if any Text.null segs then Nothing else Just segs++instance Provider Cli where+  metadata _ =+    withInterpolater (\_ p -> "--" <> Text.intercalate "." [Text.replace "_" "-" k | Key k <- segments p]) $+      named "command-line arguments"+  provide lim c = pure $+    let args = parseArgs c+        malformed = [ atPath root (configError (SyntaxError ("malformed option `" <> a <> "`"))) | Malformed a <- args ]+        entries = concatMap (entry lim c) args+        failures = malformed ++ [e | Left e <- entries]+    in case fromErrorList failures of+         Just es -> Left es+         Nothing -> Map.singleton (cliProfile c) <$> nest LastWins [x | Right x <- entries]++entry :: Limits -> Cli -> Arg -> [Either ConfigError (Text, [Text], Value)]+entry lim c = \case+  Option a segs (Just v)+    | cliParsed c -> [(a, segs, ) <$> parseValue lim v]+    | otherwise -> [Right (a, segs, Value untagged {tagRaw = Just v} (String v))]+  Option a segs Nothing -> [Right (a, segs, flag True)]+  NegatedFlag a segs -> [Right (a, segs, flag False)]+  _ -> []+  where+    flag b = Value untagged {tagRaw = Just (if b then "true" else "false")} (Bool b)
+ src/Figment/Provider/Env.hs view
@@ -0,0 +1,164 @@+-- | Environment variables, with Rust figment's semantics.+--+-- > import qualified Figment.Provider.Env as Env+-- > Env.prefixed "APP_"                     -- APP_MAX_CONNECTIONS -> max_connections+-- > Env.prefixed "APP_" & Env.split "__"    -- APP_DB__HOST -> db.host+--+-- * The prefix is matched case-insensitively and stripped.+-- * Keys are lower-cased (see 'lowercase').+-- * There is no splitting unless 'split' is used, so fields whose names+--   contain underscores remain reachable. As in Rust figment, a @.@ in a+--   key (after any 'split') nests, and variables with an empty key+--   segment are ignored.+-- * Values are parsed: @8080@ is a number, @true@ a boolean, @[1, 2]@+--   an array, @{a = 1}@ a dictionary; anything else is a string. The+--   original text is kept, so 'Text' fields still receive @007@+--   verbatim. Use 'unparsed' to keep every value a string.+-- * Two variables that cannot both hold (@APP_DB=x@ and @APP_DB.HOST=y@,+--   or two names that are equal after lower-casing) are reported as+--   errors rather than one silently winning.+module Figment.Provider.Env+  ( Env+  , prefixed+  , raw+  , split+  , lowercase+  , ignoreEmpty+  , only+  , ignore+  , filterKeys+  , mapKeys+  , inProfile+  , global+  , unparsed+  , fromList+  , envVariableName+  ) where++import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import System.Environment (getEnvironment)++import Figment.Core+import Figment.Error+import Figment.Internal.Nest+import Figment.Internal.ValueParser (parseValue)+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++-- | Environment variables as a configuration source; build with 'prefixed' or 'raw'.+data Env = Env+  { envPrefix :: !Text+  , envChain :: [Text -> Maybe Text]+    -- ^ key transformations, applied in the order they were added+  , envSplit :: !(Maybe Text)+  , envLower :: !Bool+  , envIgnoreEmpty :: !Bool+  , envProfile :: !Profile+  , envParsed :: !Bool+  , envSnapshot :: !(Maybe [(Text, Text)])+  }++-- | Variables starting with the prefix (case-insensitive), prefix+-- removed.+prefixed :: Text -> Env+prefixed p = Env p [] Nothing True False Default True Nothing++-- | Every environment variable.+raw :: Env+raw = prefixed ""++-- | Nest on a separator: with @split \"\__\"@, @APP_DB\__HOST@ is @db.host@.+split :: Text -> Env -> Env+split sep e+  | Text.null sep = e+  | otherwise = e {envSplit = Just sep, envChain = envChain e ++ [Just . Text.replace sep "."]}++-- | Lower-case keys (default 'True').+lowercase :: Bool -> Env -> Env+lowercase b e = e {envLower = b}++-- | Skip variables whose value is empty (default 'False').+ignoreEmpty :: Bool -> Env -> Env+ignoreEmpty b e = e {envIgnoreEmpty = b}++-- | Keep only these keys (compared case-insensitively, after the prefix+-- and any earlier transformations).+only :: [Text] -> Env -> Env+only ks = filterKeys (\k -> Text.toCaseFold k `elem` map Text.toCaseFold ks)++-- | Drop these keys (compared case-insensitively).+ignore :: [Text] -> Env -> Env+ignore ks = filterKeys (\k -> Text.toCaseFold k `notElem` map Text.toCaseFold ks)++-- | Keep only keys satisfying a predicate (applied in order with other key transformations).+filterKeys :: (Text -> Bool) -> Env -> Env+filterKeys f e = e {envChain = envChain e ++ [\k -> if f k then Just k else Nothing]}++-- | Transform keys (applied in order with other key transformations).+mapKeys :: (Text -> Text) -> Env -> Env+mapKeys f e = e {envChain = envChain e ++ [Just . f]}++-- | Put the values in a profile (default 'Default').+inProfile :: Profile -> Env -> Env+inProfile p e = e {envProfile = p}++-- | Put the values in the 'Global' profile, overriding every profile.+global :: Env -> Env+global = inProfile Global++-- | Do not parse values: every value is a string.+unparsed :: Env -> Env+unparsed e = e {envParsed = False}++-- | Read from the given variables instead of the process environment+-- (deterministic tests, or environments assembled by hand).+fromList :: [(Text, Text)] -> Env -> Env+fromList vs e = e {envSnapshot = Just vs}++-- | The variable name that sets a key path, assuming no custom+-- 'mapKeys' (used in error messages and missing-field hints).+envVariableName :: Env -> Path -> Text+envVariableName e p =+  envPrefix e <> Text.intercalate (fromMaybe "." (envSplit e)) [Text.toUpper k | Key k <- segments p]++keyOf :: Env -> Text -> Maybe [Text]+keyOf e name = do+  rest <- stripPrefixCI (envPrefix e) name+  k <- foldl (\acc f -> acc >>= f) (Just rest) (envChain e)+  let k' = if envLower e then Text.toLower k else k+      segs = Text.splitOn "." k'+  if Text.null k' || any Text.null segs then Nothing else Just segs++stripPrefixCI :: Text -> Text -> Maybe Text+stripPrefixCI p t+  | Text.toCaseFold (Text.take (Text.length p) t) == Text.toCaseFold p = Just (Text.drop (Text.length p) t)+  | otherwise = Nothing++instance Provider Env where+  metadata e =+    withInterpolater (\_ p -> envVariableName e p) $+      named (if Text.null (envPrefix e) then "environment variables" else "environment variables (prefix " <> envPrefix e <> ")")+  provide lim e = do+    vars <- case envSnapshot e of+      Just vs -> pure vs+      Nothing -> map (\(k, v) -> (Text.pack k, Text.pack v)) <$> getEnvironment+    let relevant =+          [ (name, ks, val)+          | (name, val) <- sortOn fst vars+          , not (envIgnoreEmpty e && Text.null val)+          , Just ks <- [keyOf e name]+          ]+        parsed = [ (name, ks, ) <$> parse val | (name, ks, val) <- relevant ]+        parse val+          | envParsed e = parseValue lim val+          | otherwise = Right (Value untagged {tagRaw = Just val} (String val))+        failures = [ err | Left err <- parsed ]+    pure $ case fromErrorList failures of+      Just es -> Left es+      Nothing -> Map.singleton (envProfile e) <$> nest RejectDuplicates [x | Right x <- parsed]
+ src/Figment/Provider/Format.hs view
@@ -0,0 +1,154 @@+-- | File- and string-backed providers for any data format (Rust:+-- @Format@ / @Data\<F\>@).+--+-- > F.merge (file toml "App.toml")              -- optional, searched upward+-- > F.merge (required (fileExact json "/etc/app.json"))+-- > F.merge (nested (file yaml "profiles.yaml")) -- top-level keys are profiles+module Figment.Provider.Format+  ( Format (..)+  , Data+  , file+  , fileExact+  , fromText+  , nested+  , required+  , inProfile+  ) where++import Control.Exception (IOException, try)+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import System.Directory (doesFileExist, getCurrentDirectory, makeAbsolute)+import System.FilePath (isRelative, takeDirectory, (</>))++import Figment.Core+import Figment.Error+import Figment.Limits+import Figment.Metadata+import Figment.Path+import Figment.Profile+import Figment.Value++-- | A data format: a name and a parser. The parser must enforce the+-- 'Limits' and should record 'tagPos' on values when it can.+data Format = Format+  { formatName :: Text+  , formatParse :: Limits -> ByteString -> IO (Either ConfigError Value)+  }++data Origin+  = FromFile !FilePath !Bool -- ^ path, search parent directories?+  | FromText !Text++-- | A file or string in some t'Format'; build with 'file', 'fileExact' or 'fromText'.+data Data = Data+  { dataFormat :: Format+  , dataOrigin :: Origin+  , dataNested :: Bool+  , dataRequired :: Bool+  , dataProfile :: Profile+  }++-- | An optional file. A relative path is looked for in the working+-- directory and then each parent directory (as Rust figment does); a+-- missing file contributes nothing. Combine with 'required' to make+-- absence an error.+file :: Format -> FilePath -> Data+file f p = Data f (FromFile p True) False False Default++-- | Like 'file', but only the exact path is tried.+fileExact :: Format -> FilePath -> Data+fileExact f p = Data f (FromFile p False) False False Default++-- | Configuration text held in memory (Rust: @Format::string@).+fromText :: Format -> Text -> Data+fromText f t = Data f (FromText t) False False Default++-- | Treat top-level keys as profile names.+nested :: Data -> Data+nested d = d {dataNested = True}++-- | Fail if the file cannot be found.+required :: Data -> Data+required d = d {dataRequired = True}++-- | Put the data in a profile other than 'Default' (ignored when+-- 'nested').+inProfile :: Profile -> Data -> Data+inProfile p d = d {dataProfile = p}++baseMetadata :: Data -> Maybe FilePath -> Metadata+baseMetadata d resolved =+  let fmt = formatName (dataFormat d)+      m = case (dataOrigin d, resolved) of+        (_, Just p) -> fileMetadata (fmt <> " file") p+        (FromFile p _, Nothing) -> fileMetadata (fmt <> " file") p+        (FromText _, Nothing) -> named (fmt <> " source string")+      interp+        | dataNested d = \prof path -> profileName prof <> (if isRoot path then "" else "." <> renderPath path)+        | otherwise = const renderPath+  in withInterpolater interp m++instance Provider Data where+  metadata d = baseMetadata d Nothing+  provide lim d = case dataOrigin d of+    FromText t -> parseWith (baseMetadata d Nothing) (TE.encodeUtf8 t)+    FromFile p search -> do+      found <- locate search p+      case found of+        Nothing+          | dataRequired d ->+              pure (Left (single (withMetadata (Just (baseMetadata d Nothing))+                (configError (IoError ("file not found: " <> Text.pack p+                  <> (if search && isRelative p then " (searched the working directory and its parents)" else "")))))))+          | otherwise -> pure (Right Map.empty)+        Just resolved -> do+          let meta = baseMetadata d (Just resolved)+          r <- try (BS.readFile resolved)+          case r of+            Left (e :: IOException) ->+              pure (Left (single (withMetadata (Just meta) (configError (IoError (Text.pack (show e)))))))+            Right bytes -> parseWith meta bytes+    where+      parseWith meta bytes = do+        parsed <- formatParse (dataFormat d) lim bytes+        pure $ case parsed of+          Left e -> Left (single (withMetadata (Just meta) e))+          Right v -> case valueNode v of+            Dict top+              | dataNested d -> splitProfiles meta top+              | otherwise -> Right (Map.singleton (dataProfile d) (fmap (retag meta (dataProfile d)) top))+            n -> Left (single (withMetadata (Just meta) (withPos (tagPos (valueTag v))+                   (configError (InvalidType (describe n) "a dictionary at the top level")))))++      splitProfiles meta top =+        let one (k, v) = case valueNode v of+              Dict d' -> let p = profile k in Right (p, fmap (retag meta p) d')+              n -> Left (withMetadata (Just meta) (withPos (tagPos (valueTag v))+                     (atPath (root /. k) (configError (InvalidType (describe n) "a dictionary (nested files map profile names to dictionaries)")))))+            results = map one (Map.toList top)+        in case fromErrorList [e | Left e <- results] of+             Just es -> Left es+             Nothing -> Right (Map.fromListWith (\later earlier -> Map.union earlier later) [x | Right x <- results])++-- | Find a file, optionally searching parent directories. Returns an+-- absolute path.+locate :: Bool -> FilePath -> IO (Maybe FilePath)+locate search p+  | search && isRelative p = getCurrentDirectory >>= go+  | otherwise = do+      ok <- doesFileExist p+      if ok then Just <$> makeAbsolute p else pure Nothing+  where+    go dir = do+      let candidate = dir </> p+      ok <- doesFileExist candidate+      if ok+        then pure (Just candidate)+        else+          let parent = takeDirectory dir+          in if parent == dir then pure Nothing else go parent
+ src/Figment/Provider/Json.hs view
@@ -0,0 +1,76 @@+-- | JSON. Parsed from aeson's lazy token stream, so the depth and size+-- limits are enforced while parsing (a megabyte of @[[[[...@ is+-- rejected at depth 65 without being materialised) and duplicate keys+-- are reported instead of silently keeping the last.+module Figment.Provider.Json+  ( json+  , parseJson+  ) where++import qualified Data.Aeson.Decoding.ByteString as Tok+import Data.Aeson.Decoding.Tokens+import qualified Data.Aeson.Key as Key+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Vector as Vector++import Figment.Error+import Figment.Internal.Budget+import Figment.Limits+import Figment.Path+import Figment.Provider.Format (Format (..))+import Figment.Value++-- | The JSON format.+json :: Format+json = Format "JSON" (\lim bs -> pure (parseJson lim bs))++-- | Parse a JSON document, enforcing the limits.+parseJson :: Limits -> ByteString -> Either ConfigError Value+parseJson lim bs = runBudget lim $ do+  (v, rest) <- value 1 root (Tok.bsToTokens bs)+  if BC.all (`elem` (" \t\r\n" :: String)) rest+    then pure v+    else throwB (configError (SyntaxError "unexpected characters after the JSON value"))++syntax :: Path -> String -> Budget a+syntax p e = throwB (atPath p (configError (SyntaxError (Text.pack e))))++value :: forall k. Int -> Path -> Tokens k String -> Budget (Value, k)+value d p tok = do+  spend 1 p Nothing+  case tok of+    TkLit LitNull k -> pure (mkValue Null, k)+    TkLit LitTrue k -> pure (mkValue (Bool True), k)+    TkLit LitFalse k -> pure (mkValue (Bool False), k)+    TkText t k -> pure (mkValue (String t), k)+    TkNumber n k -> pure (mkValue (Num (Finite (num n))), k)+    TkArrayOpen arr -> enterContainer d p Nothing >> items 0 [] arr+    TkRecordOpen rec -> enterContainer d p Nothing >> pairs Map.empty rec+    TkErr e -> syntax p e+  where+    num (NumInteger i) = fromInteger i+    num (NumDecimal s) = s+    num (NumScientific s) = s++    items :: Int -> [Value] -> TkArray k String -> Budget (Value, k)+    items i acc = \case+      TkItem toks -> do+        (v, rest) <- value (d + 1) (p /# i) toks+        items (i + 1) (v : acc) rest+      TkArrayEnd k -> pure (mkValue (Array (Vector.fromList (reverse acc))), k)+      TkArrayErr e -> syntax p e++    pairs :: Map.Map Text.Text Value -> TkRecord k String -> Budget (Value, k)+    pairs acc = \case+      TkPair key toks -> do+        let kt = Key.toText key+        if Map.member kt acc+          then throwB (atPath (p /. kt) (configError (DuplicateKey kt)))+          else do+            (v, rest) <- value (d + 1) (p /. kt) toks+            pairs (Map.insert kt v acc) rest+      TkRecordEnd k -> pure (mkValue (Dict acc), k)+      TkRecordErr e -> syntax p e
+ src/Figment/Provider/Toml.hs view
@@ -0,0 +1,86 @@+-- | TOML (v1.0, via toml-parser). Strict UTF-8; every value carries+-- its line and column; dates and times become ISO 8601 strings (decode+-- them into "Data.Time" types directly); @inf@ and @nan@ are kept as+-- non-finite numbers rather than corrupted.+module Figment.Provider.Toml+  ( toml+  , parseToml+  ) where++import Data.ByteString (ByteString)+import qualified Data.Map.Strict as Map+import qualified Data.Scientific as Sci+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as Vector+import Data.Time.Format.ISO8601 (iso8601Show)+import qualified Toml.Semantics as T+import qualified Toml.Syntax as T++import Figment.Error+import Figment.Internal.Budget+import Figment.Limits+import Figment.Metadata (Pos (..))+import Figment.Path+import Figment.Provider.Format (Format (..))+import Figment.Value++-- | The TOML format.+toml :: Format+toml = Format "TOML" (\lim bs -> pure (parseToml lim bs))++-- | Parse a TOML document, enforcing the limits.+parseToml :: Limits -> ByteString -> Either ConfigError Value+parseToml lim bs = do+  txt <- case TE.decodeUtf8' bs of+    Left e -> Left (configError (SyntaxError ("invalid UTF-8: " <> Text.pack (show e))))+    Right t -> Right t+  exprs <- case T.parseRawToml txt of+    Left (T.Located p msg) -> Left (withPos (Just (pos p)) (configError (SyntaxError (Text.pack msg))))+    Right es -> Right es+  tab <- case T.semantics exprs of+    Left (T.SemanticError ann key kind) ->+      Left (withPos (Just (pos ann)) (configError (semantic key kind)))+    Right t -> Right t+  runBudget lim (table 1 root Nothing tab)+  where+    semantic key = \case+      T.AlreadyAssigned -> DuplicateKey key+      T.ClosedTable -> SyntaxError ("table `" <> key <> "` was already closed")+      T.ImplicitlyTable -> SyntaxError ("`" <> key <> "` was implicitly defined as a table")++pos :: T.Position -> Pos+pos p = Pos (T.posLine p) (T.posColumn p)++table :: Int -> Path -> Maybe Pos -> T.Table' T.Position -> Budget Value+table d p at (T.MkTable m) = do+  spend 1 p at+  enterContainer d p at+  kvs <- Map.traverseWithKey (\k (_, v) -> value (d + 1) (p /. k) v) m+  pure (Value untagged {tagPos = at} (Dict kvs))++value :: Int -> Path -> T.Value' T.Position -> Budget Value+value d p v = case v of+  T.Table' a t -> table d p (Just (pos a)) t+  T.List' a xs -> do+    spend 1 p (Just (pos a))+    enterContainer d p (Just (pos a))+    ys <- traverse (\(i, x) -> value (d + 1) (p /# i) x) (zip [0 ..] xs)+    pure (Value (at a) (Array (Vector.fromList ys)))+  T.Integer' a n -> leaf a (Num (Finite (fromInteger n)))+  T.Double' a x -> leaf a (Num (double x))+  T.Bool' a b -> leaf a (Bool b)+  T.Text' a t -> leaf a (String t)+  T.TimeOfDay' a t -> leaf a (String (Text.pack (iso8601Show t)))+  T.ZonedTime' a t -> leaf a (String (Text.pack (iso8601Show t)))+  T.LocalTime' a t -> leaf a (String (Text.pack (iso8601Show t)))+  T.Day' a t -> leaf a (String (Text.pack (iso8601Show t)))+  where+    at a = untagged {tagPos = Just (pos a)}+    leaf a n = do+      spend 1 p (Just (pos a))+      pure (Value (at a) n)+    double x+      | isNaN x = NaN+      | isInfinite x = if x > 0 then PosInfinity else NegInfinity+      | otherwise = Finite (Sci.fromFloatDigits x)
+ src/Figment/Provider/Yaml.hs view
@@ -0,0 +1,286 @@+-- | YAML, read directly from libyaml's event stream.+--+-- * YAML 1.2 core schema: only @true@/@false@ are booleans, so @no@,+--   @on@ and @NO@ (the \"Norway problem\") stay strings.+-- * Every value carries its line and column.+-- * Anchors and aliases are supported, and alias expansion is charged+--   against the node limit, which defeats \"billion laughs\".+-- * Merge keys (@<<: *base@) are supported; explicit keys win.+-- * Duplicate keys are errors; multiple documents are rejected.+module Figment.Provider.Yaml+  ( yaml+  , parseYaml+  ) where++import Control.Applicative ((<|>))+import Control.Exception (try)+import Data.ByteString (ByteString)+import Data.Char (isDigit, isHexDigit, isOctDigit)+import Data.Conduit (runConduitRes, (.|))+import qualified Data.Conduit.List as CL+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as Vector+import Numeric (readHex, readOct)+import qualified Text.Libyaml as Y++import Figment.Error+import Figment.Internal.ValueParser (parseNumber)+import Figment.Limits+import Figment.Metadata (Pos (..))+import Figment.Path+import Figment.Provider.Format (Format (..))+import Figment.Value hiding (null)++-- | The YAML format.+yaml :: Format+yaml = Format "YAML" parseYaml++-- | Parse a YAML document, enforcing the limits.+parseYaml :: Limits -> ByteString -> IO (Either ConfigError Value)+parseYaml lim bs = do+  r <- try (runConduitRes (Y.decodeMarked bs .| CL.consume))+  pure $ case r of+    Left (Y.YamlException msg) -> Left (configError (SyntaxError (Text.pack msg)))+    Left (Y.YamlParseException problem ctx mark) ->+      Left (withPos (Just (markPos mark))+        (configError (SyntaxError (Text.pack (problem ++ (if null ctx then "" else " " ++ ctx))))))+    Right [] -> Right emptyDict+    Right events -> fst <$> runY document (YState events Map.empty (maxNodes lim)) lim++markPos :: Y.YamlMark -> Pos+markPos m = Pos (Y.yamlLine m + 1) (Y.yamlColumn m + 1)++------------------------------------------------------------------------+-- A small state/error monad over the event list++data YState = YState+  { ysEvents :: [Y.MarkedEvent]+  , ysAnchors :: Map String Anchored+  , ysBudget :: !Int+  }++-- | An anchored subtree, with its expanded size and container height.+data Anchored = Anchored Value !Int !Int++newtype YP a = YP {runY :: YState -> Limits -> Either ConfigError (a, YState)}++instance Functor YP where+  fmap f (YP g) = YP $ \s l -> fmap (\(a, s') -> (f a, s')) (g s l)++instance Applicative YP where+  pure a = YP $ \s _ -> Right (a, s)+  YP f <*> YP g = YP $ \s l -> case f s l of+    Left e -> Left e+    Right (h, s') -> fmap (\(a, s'') -> (h a, s'')) (g s' l)++instance Monad YP where+  YP g >>= k = YP $ \s l -> case g s l of+    Left e -> Left e+    Right (a, s') -> runY (k a) s' l++failY :: ConfigError -> YP a+failY e = YP $ \_ _ -> Left e++next :: YP (Maybe Y.MarkedEvent)+next = YP $ \s _ -> case ysEvents s of+  [] -> Right (Nothing, s)+  (e : es) -> Right (Just e, s {ysEvents = es})++peek :: YP (Maybe Y.Event)+peek = YP $ \s _ -> Right (Y.yamlEvent <$> safeHead (ysEvents s), s)+  where+    safeHead (x : _) = Just x+    safeHead [] = Nothing++spendY :: Int -> Path -> Pos -> YP ()+spendY k p at = YP $ \s l ->+  let b = ysBudget s - k+  in if b < 0+       then Left (withPos (Just at) (atPath p (configError (TooManyNodes (maxNodes l)))))+       else Right ((), s {ysBudget = b})++depthCheck :: Int -> Path -> Pos -> YP ()+depthCheck d p at = YP $ \s l ->+  if d > maxDepth l+    then Left (withPos (Just at) (atPath p (configError (DepthExceeded (maxDepth l)))))+    else Right ((), s)++remember :: Y.Anchor -> Anchored -> YP ()+remember Nothing _ = pure ()+remember (Just name) a = YP $ \s _ -> Right ((), s {ysAnchors = Map.insert name a (ysAnchors s)})++recall :: String -> YP (Maybe Anchored)+recall name = YP $ \s _ -> Right (Map.lookup name (ysAnchors s), s)++syntaxAt :: Path -> Pos -> Text -> YP a+syntaxAt p at msg = failY (withPos (Just at) (atPath p (configError (SyntaxError msg))))++------------------------------------------------------------------------+-- Grammar++document :: YP Value+document = do+  _ <- expectStart+  ev <- peek+  case ev of+    Just Y.EventStreamEnd -> pure emptyDict+    Just Y.EventDocumentStart -> do+      _ <- next+      Anchored v _ _ <- node 1 root+      end <- next+      case Y.yamlEvent <$> end of+        Just Y.EventDocumentEnd -> pure ()+        _ -> failY (configError (SyntaxError "malformed YAML document"))+      rest <- peek+      case rest of+        Just Y.EventDocumentStart ->+          failY (configError (SyntaxError "multiple YAML documents are not supported in a configuration file"))+        _ -> pure v+    _ -> failY (configError (SyntaxError "malformed YAML stream"))+  where+    expectStart = next++-- | Parse one node at nesting level @d@ (root = 1). Returns the value+-- with its expanded size and container height.+node :: Int -> Path -> YP Anchored+node d p = do+  me <- next+  case me of+    Nothing -> failY (atPath p (configError (SyntaxError "unexpected end of YAML input")))+    Just (Y.MarkedEvent ev start _) -> do+      let at = markPos start+      case ev of+        Y.EventScalar bytes tag style anchor -> do+          spendY 1 p at+          n <- scalar p at bytes tag style+          let a = Anchored (Value untagged {tagPos = Just at} n) 1 0+          remember anchor a+          pure a+        Y.EventSequenceStart _ _ anchor -> do+          spendY 1 p at+          depthCheck d p at+          (items, size, height) <- sequenceItems 0 [] 1 0+          let a = Anchored (Value untagged {tagPos = Just at} (Array (Vector.fromList items))) size (height + 1)+          remember anchor a+          pure a+        Y.EventMappingStart _ _ anchor -> do+          spendY 1 p at+          depthCheck d p at+          (m, size, height) <- mappingPairs Map.empty [] 1 0+          let a = Anchored (Value untagged {tagPos = Just at} (Dict m)) size (height + 1)+          remember anchor a+          pure a+        Y.EventAlias name -> do+          found <- recall name+          case found of+            Nothing -> syntaxAt p at ("unknown alias `*" <> Text.pack name <> "`")+            Just a@(Anchored _ size height) -> do+              spendY size p at+              if height > 0 then depthCheck (d + height - 1) p at else pure ()+              pure a+        _ -> syntaxAt p at "unexpected YAML event"+  where+    sequenceItems :: Int -> [Value] -> Int -> Int -> YP ([Value], Int, Int)+    sequenceItems i acc size height = do+      ev <- peek+      case ev of+        Just Y.EventSequenceEnd -> next >> pure (reverse acc, size, height)+        _ -> do+          Anchored v s h <- node (d + 1) (p /# i)+          sequenceItems (i + 1) (v : acc) (size + s) (max height h)++    -- explicit pairs, then merge-key sources (applied underneath)+    mappingPairs :: Dict -> [Dict] -> Int -> Int -> YP (Dict, Int, Int)+    mappingPairs acc merges size height = do+      me <- next+      case me of+        Just (Y.MarkedEvent Y.EventMappingEnd _ _) ->+          pure (Map.union acc (Map.unions merges), size, height)+        Just (Y.MarkedEvent (Y.EventScalar bytes _ style _) kstart _) -> do+          let kat = markPos kstart+          key <- decodeText p kat bytes+          if key == "<<" && style `elem` [Y.Plain, Y.PlainNoTag, Y.Any]+            then do+              Anchored v s h <- node (d + 1) (p /. key)+              srcs <- mergeSources kat v+              mappingPairs acc (merges ++ srcs) (size + s) (max height (h - 1))+            else+              if Map.member key acc+                then failY (withPos (Just kat) (atPath (p /. key) (configError (DuplicateKey key))))+                else do+                  Anchored v s h <- node (d + 1) (p /. key)+                  mappingPairs (Map.insert key v acc) merges (size + s) (max height h)+        Just (Y.MarkedEvent _ kstart _) ->+          syntaxAt p (markPos kstart) "only scalar mapping keys are supported"+        Nothing -> failY (atPath p (configError (SyntaxError "unexpected end of YAML input")))++    mergeSources kat v = case valueNode v of+      Dict m -> pure [m]+      Array xs | all isDict (Vector.toList xs) -> pure [m | Value _ (Dict m) <- Vector.toList xs]+      _ -> syntaxAt (p /. "<<") kat "a merge key (`<<`) needs a mapping or a list of mappings"+    isDict (Value _ (Dict _)) = True+    isDict _ = False++decodeText :: Path -> Pos -> ByteString -> YP Text+decodeText p at bytes = case TE.decodeUtf8' bytes of+  Right t -> pure t+  Left _ -> syntaxAt p at "invalid UTF-8 in YAML scalar"++-- | Resolve a scalar under the YAML 1.2 core schema.+scalar :: Path -> Pos -> ByteString -> Y.Tag -> Y.Style -> YP Node+scalar p at bytes tag style = do+  t <- decodeText p at bytes+  let quoted = style `elem` [Y.SingleQuoted, Y.DoubleQuoted, Y.Literal, Y.Folded]+      bad what = syntaxAt p at ("`" <> t <> "` is not a valid " <> what)+  case tag of+    Y.StrTag -> pure (String t)+    Y.NullTag -> pure Null+    Y.BoolTag -> maybe (bad "boolean") (pure . Bool) (coreBool t)+    Y.IntTag -> maybe (bad "integer") (pure . Num) (coreInt t)+    Y.FloatTag -> maybe (bad "float") (pure . Num) (coreFloat t <|> coreInt t)+    _ | quoted -> pure (String t)+      | otherwise -> pure (resolve t)+  where+    resolve t+      | t `elem` ["", "~", "null", "Null", "NULL"] = Null+      | Just b <- coreBool t = Bool b+      | Just n <- coreInt t = Num n+      | Just n <- coreFloat t = Num n+      | otherwise = String t++coreBool :: Text -> Maybe Bool+coreBool t+  | t `elem` ["true", "True", "TRUE"] = Just True+  | t `elem` ["false", "False", "FALSE"] = Just False+  | otherwise = Nothing++coreInt :: Text -> Maybe Number+coreInt t+  | Just r <- Text.stripPrefix "0x" t, not (Text.null r), Text.all isHexDigit r =+      Just (Finite (fromInteger (fst (head' (readHex (Text.unpack r))))))+  | Just r <- Text.stripPrefix "0o" t, not (Text.null r), Text.all isOctDigit r =+      Just (Finite (fromInteger (fst (head' (readOct (Text.unpack r))))))+  | otherwise =+      let body = maybe t id (Text.stripPrefix "-" t <> Text.stripPrefix "+" t)+      in if not (Text.null body) && Text.all isDigit body then parseNumber t else Nothing+  where+    head' (x : _) = x+    head' [] = (0, "")++coreFloat :: Text -> Maybe Number+coreFloat t+  | t `elem` [".inf", ".Inf", ".INF", "+.inf", "+.Inf", "+.INF"] = Just PosInfinity+  | t `elem` ["-.inf", "-.Inf", "-.INF"] = Just NegInfinity+  | t `elem` [".nan", ".NaN", ".NAN"] = Just NaN+  | Text.any isDigit t, Text.all (`elem` ("0123456789+-.eE" :: String)) t =+      parseNumber (fixLeadingDot t)+  | otherwise = Nothing+  where+    fixLeadingDot x = case Text.uncons x of+      Just ('.', _) -> "0" <> x+      Just (s, r) | s `elem` ("+-" :: String), Just ('.', _) <- Text.uncons r -> Text.singleton s <> "0" <> r+      _ -> x
+ src/Figment/Tutorial.hs view
@@ -0,0 +1,539 @@+-- | A guided tour of figment, from a first configuration file to+-- writing your own provider. Every snippet here is compiled and run by+-- the package's test suite (@test\/Figment\/Test\/Tutorial.hs@).+--+-- The examples assume these imports and extensions:+--+-- > {-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-}+-- > {-# LANGUAGE OverloadedStrings, TypeApplications, TypeFamilies #-}+-- >+-- > import Data.Aeson ((.=))+-- > import qualified Data.Aeson as Aeson+-- > import Data.Function ((&))+-- > import qualified Data.Map.Strict as Map+-- > import Data.Text (Text)+-- > import GHC.Generics (Generic)+-- >+-- > import qualified Figment as F+-- > import qualified Figment.Jail as Jail+-- > import qualified Figment.Provider.Env as Env+--+-- "Figment" is meant to be imported qualified: it exports names such as+-- 'Figment.merge', 'Figment.join' and 'Figment.from'.+module Figment.Tutorial+  ( -- * 1. The idea+    -- $idea++    -- * 2. Your first configuration+    -- $first++    -- * 3. Layering sources+    -- $layering++    -- * 4. Environment variables+    -- $env++    -- * 5. Command-line arguments+    -- $cli++    -- * 6. Profiles+    -- $profiles++    -- * 7. Reading errors+    -- $errors++    -- * 8. Decoding in depth+    -- $decoding++    -- * 9. Provenance in your own types+    -- $provenance++    -- * 10. Partial configurations+    -- $partial++    -- * 11. For library authors+    -- $libraries++    -- * 12. Writing a provider+    -- $providers++    -- * 13. Testing+    -- $testing++    -- * 14. Untrusted input+    -- $limits++    -- * 15. Coming from Rust figment+    -- $rust++    -- * 16. Upgrading from figment 0.1+    -- $upgrade+  ) where++-- $idea+--+-- Configuration usually comes from several places at once: defaults in+-- code, a file, environment variables, a few command-line flags. figment+-- lets you list those sources in order of precedence, combines them+-- into one tree, and decodes the tree into your own types.+--+-- Two ideas make it pleasant:+--+-- * Every value remembers where it came from: which source, which+--   profile, which line and column, and the name the user would type to+--   set it (@APP_PORT@, @--port@).+--+-- * Problems are collected, not thrown one at a time. A misspelt key, a+--   port out of range and a missing field are reported together, each+--   pointing at its source.+--+-- The moving parts are /providers/ (sources of configuration), the+-- t'Figment.Figment' (an ordered list of providers), 'Figment.load'+-- (reads every provider), and 'Figment.FromConfig' (decodes into your+-- types).++-- $first+--+-- Describe the configuration as a record and derive+-- 'Figment.FromConfig' through "GHC.Generics":+--+-- > data Config = Config+-- >   { name :: Text+-- >   , port :: Int+-- >   , debug :: Bool+-- >   }+-- >   deriving stock (Show, Eq, Generic)+-- >   deriving anyclass (F.FromConfig)+--+-- Read it from a TOML file:+--+-- > firstFigment :: F.Figment+-- > firstFigment = F.from (F.file F.toml "App.toml")+-- >+-- > main :: IO ()+-- > main = do+-- >   cfg <- F.loadExtractOrThrow @Config firstFigment+-- >   print cfg+--+-- with an @App.toml@ such as+--+-- > name = "demo"+-- > port = 8080+-- > debug = false+--+-- 'Figment.file' looks for a relative path in the working directory and+-- then in each parent directory, and a missing file simply contributes+-- nothing. Use 'Figment.fileExact' to disable the search and+-- 'Figment.required' to make a missing file an error. 'Figment.json' and+-- 'Figment.yaml' work the same way, and 'Figment.fromText' reads+-- configuration held in memory.+--+-- 'Figment.loadExtractOrThrow' throws t'Figment.ConfigErrors', whose+-- 'Control.Exception.displayException' is the full report. Use+-- 'Figment.loadExtract' to get an 'Either' instead.++-- $layering+--+-- Most programs combine several sources. Later sources win:+--+-- > layered :: [Text] -> F.Figment+-- > layered args =+-- >   F.new+-- >     & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False]))+-- >     & F.merge (F.file F.toml "App.toml")+-- >     & F.merge (F.prefixed "APP_")+-- >     & F.merge (F.cli args)+--+-- Here a built-in default is overridden by the file, the file by+-- environment variables such as @APP_PORT=9000@, and those by flags+-- such as @--port=9100@. 'Figment.defaults' accepts any value with a+-- 'Data.Aeson.ToJSON' instance, including your own record.+--+-- Four strategies decide what happens when two sources set the same key+-- (they are those of Rust figment):+--+-- * 'Figment.merge': the incoming value wins;+--+-- * 'Figment.join': the existing value wins, so the incoming source only+--   fills gaps;+--+-- * 'Figment.admerge' and 'Figment.adjoin': the same, except that arrays+--   are concatenated instead of replaced.+--+-- Dictionaries are always combined key by key, recursively. A @null@ is+-- an ordinary value: merging @null@ over a key replaces it.+--+-- A t'Figment.Figment' is only a description; building one performs no+-- IO. 'Figment.load' reads every source in order and reports every+-- failure (an unreadable file /and/ a syntax error elsewhere), then+-- 'Figment.extract' decodes. 'Figment.loadExtract' does both.++-- $env+--+-- @F.prefixed \"APP_\"@ ('Figment.prefixed') reads every variable whose name starts+-- with @APP_@ (in any case), removes the prefix and lower-cases the+-- rest: @APP_MAX_CONNECTIONS@ sets @max_connections@. There is no+-- nesting unless you ask for it:+--+-- > data Db = Db {host :: Text, port :: Int}+-- >   deriving stock (Show, Eq, Generic)+-- >   deriving anyclass (F.FromConfig)+-- >+-- > newtype WithDb = WithDb {db :: Db}+-- >   deriving stock (Show, Eq, Generic)+-- >   deriving anyclass (F.FromConfig)+-- >+-- > dbFromEnv :: F.Figment+-- > dbFromEnv = F.from (F.prefixed "APP_" & Env.split "__")+--+-- With @APP_DB\__HOST=db.internal@ and @APP_DB\__PORT=5432@ this decodes+-- to @WithDb (Db \"db.internal\" 5432)@.+--+-- Values are typed: @5432@ is a number, @true@ a boolean, @[1, 2]@ an+-- array and @{a = 1}@ a dictionary; anything else is a string. The+-- original text is kept too, so a 'Data.Text.Text' field set to @007@+-- receives @\"007\"@, not @7@. Two variables that cannot both hold (for+-- example @APP_DB=x@ next to @APP_DB\__HOST=y@) are reported as an+-- error naming both.+--+-- "Figment.Provider.Env" has the remaining options:+-- 'Figment.Provider.Env.only', 'Figment.Provider.Env.ignore',+-- 'Figment.Provider.Env.mapKeys', 'Figment.Provider.Env.filterKeys',+-- 'Figment.Provider.Env.lowercase', 'Figment.Provider.Env.ignoreEmpty',+-- 'Figment.Provider.Env.unparsed', 'Figment.Provider.Env.inProfile' and+-- 'Figment.Provider.Env.global'.++-- $cli+--+-- @F.cli args@ ('Figment.cli'), or 'Figment.cliFromProcess', understands+--+-- * @--key=value@ (the value is typed as for environment variables);+--+-- * @--flag@ (true) and @--no-flag@ (false);+--+-- * @--db.port=5432@ (dots nest) and @--max-connections=5@ (dashes+--   become underscores);+--+-- * @--@, which ends option parsing.+--+-- Everything else is positional; 'Figment.Provider.Cli.parseArgs'+-- returns it. @--key value@ (with a space) is deliberately not+-- supported: without knowing which options take values it cannot be told+-- apart from a flag followed by a positional argument. For a full+-- command-line interface, parse with optparse-applicative and pass the+-- result in with 'Figment.defaults', as Rust figment recommends with+-- clap.++-- $profiles+--+-- A profile is a named slice of configuration. With 'Figment.nested',+-- the top-level tables of a file are profiles:+--+-- > [default]+-- > name = "app"+-- > port = 8080+-- > debug = true+-- >+-- > [production]+-- > port = 80+-- > debug = false+--+-- > profiled :: F.Profile -> F.Figment+-- > profiled p =+-- >   F.new+-- >     & F.merge (F.nested (F.file F.toml "App.toml"))+-- >     & F.select p+--+-- @profiled F.Default@ decodes to @Config \"app\" 8080 True@, and+-- @profiled \"production\"@ to @Config \"app\" 80 False@.+--+-- On extraction, the 'Figment.Default' profile is merged with the+-- selected profile, and the 'Figment.Global' profile is merged over+-- both. Profile names are case-insensitive. To choose the profile at+-- run time, use 'Figment.profileFromEnv', for example+-- @F.profileFromEnv \"APP_PROFILE\" F.Default@.+-- 'Figment.reselect' switches the profile of an already loaded+-- configuration without reading anything again.++-- $errors+--+-- A report looks like this:+--+-- > 4 configuration errors:+-- >+-- > error: missing field `name`+-- >   --> key `name`+-- >   = hint: no source sets it; it can be set as `name` in TOML file /srv/app/App.toml, or `APP_NAME` in environment variables (prefix APP_)+-- >+-- > error: unknown field `hots`+-- >   --> key `db.hots` in TOML file /srv/app/App.toml:4:8+-- >   = hint: did you mean `host`?+-- >+-- > error: invalid value: found integer 70000, expected an integer in the range 0..65535+-- >   --> key `db.port` in TOML file /srv/app/App.toml:3:8+-- >+-- > error: unknown variant `verbose`, expected one of `Debug`, `Info`+-- >   --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_)+--+-- Errors are also plain values. 'Figment.errorList' gives each+-- t'Figment.ConfigError', with its 'Figment.errorKind',+-- 'Figment.errorPath', 'Figment.errorMetadata' (the source),+-- 'Figment.errorPos' (line and column) and 'Figment.errorHints'. For+-- example, decoding @name = 1@ into @Config@ gives+--+-- > [ InvalidType "integer 1" "a string"+-- > , MissingField "port"+-- > , MissingField "debug" ]+--+-- 'Figment.renderErrors' produces the report shown above.++-- $decoding+--+-- Generic decoding maps records to dictionaries. Optional fields have+-- type 'Maybe'. Enumerations are strings, matched case-insensitively.+-- Other sum types are externally tagged (@{ Circle = { radius = 1 } }@).+-- Newtypes unwrap, and constructors with unnamed fields are arrays.+--+-- 'Figment.genericDecoder' takes t'Figment.Options':+--+-- > data Level = Debug | Info | Warning+-- >   deriving stock (Show, Eq, Generic)+-- >   deriving anyclass (F.FromConfig)+-- >+-- > data Server = Server+-- >   { listenAddress :: Text+-- >   , maxConnections :: Int+-- >   , logLevel :: Level+-- >   }+-- >   deriving stock (Show, Eq, Generic)+-- >+-- > instance F.FromConfig Server where+-- >   fromConfig =+-- >     F.genericDecoder+-- >       F.defaultOptions+-- >         { F.fieldLabelModifier = F.snakeCase+-- >         , F.rejectUnknownFields = True+-- >         }+--+-- This reads @listen_address@, @max_connections@ and @log_level: info@,+-- and reports any other key as an unknown field, with a suggestion when+-- the key looks like a typo.+--+-- Hand-written decoders use an applicative that /accumulates/ errors.+-- Validation keeps the location of the value:+--+-- > newtype Port = Port Int+-- >+-- > instance F.FromConfig Port where+-- >   fromConfig = F.validate check F.fromConfig+-- >     where+-- >       check n+-- >         | n > 0 && n < 65536 = Right (Port n)+-- >         | otherwise = Left "a port must be between 1 and 65535"+-- >+-- > data Endpoint = Endpoint {url :: Text, timeout :: Int, retries :: Int}+-- >+-- > instance F.FromConfig Endpoint where+-- >   fromConfig =+-- >     Endpoint+-- >       <$> F.field "url"+-- >       <*> F.fieldOr "timeout" 30+-- >       <*> F.fieldOr "retries" 3+--+-- t'Figment.Decoder' deliberately has no 'Monad' instance, because a+-- monad has to stop at the first error. When one step really depends on+-- another, use 'Figment.andThen'.+--+-- Decoding is strict: the string @\"8080\"@ is not an 'Int'.+-- 'Figment.extractLossy' accepts strings for numbers and booleans. Use+-- 'Figment.extractAt' to decode a single key path, for example+-- @F.extractAt (F.keyPath \"api\") loaded@. Types with an existing+-- 'Data.Aeson.FromJSON' instance can be reused with+-- @deriving F.FromConfig via F.ViaAeson T@.++-- $provenance+--+-- Two types carry provenance into your configuration:+--+-- > data Paths = Paths+-- >   { dataDir :: F.RelativePath+-- >   , token :: F.Tagged Text+-- >   }+-- >   deriving stock (Show, Eq, Generic)+-- >+-- > instance F.FromConfig Paths where+-- >   fromConfig = F.genericDecoder F.defaultOptions {F.fieldLabelModifier = F.snakeCase}+--+-- If @conf\/app.toml@ says @data_dir = \"data\"@, then+-- @F.relative (dataDir paths)@ is @conf\/data@: the path is resolved+-- against the file that wrote it, not the working directory.+-- t'Figment.Tagged' holds the value together with its source, profile,+-- position and path, so that later validation can report precisely+-- where a value came from. On a loaded configuration,+-- 'Figment.findMetadata', 'Figment.findValue' and 'Figment.contains'+-- answer the same questions for any key path.++-- $partial+--+-- Declare the configuration once, parameterised by a functor, and get+-- both a total and a partial version of it:+--+-- > data AppF f = App+-- >   { appName :: F.Field f Text+-- >   , workers :: F.Field f Int+-- >   , motd :: F.Field f (Maybe Text)+-- >   }+-- >   deriving stock (Generic)+-- >+-- > instance F.Partial AppF+-- >+-- > type App = AppF F.Identity          -- appName :: Text, workers :: Int, ...+-- >+-- > appDefaults :: AppF Maybe+-- > appDefaults = (F.emptyPartial @AppF) {workers = Just 4}+--+-- @F.extractPartial appDefaults loaded@ decodes whatever the sources+-- provide, fills the gaps from the defaults, and reports /every/ field+-- that is still missing, together with the variable, flag or key that+-- would set it. 'Maybe' fields are never missing.+--+-- 'Figment.extractTotal' takes complete defaults (an @AppF Identity@),+-- and its type guarantees that a missing-field error cannot happen.+-- Partial records can be nested (a field of type @DbF f@), and+-- 'Figment.overlay', 'Figment.complete' and 'Figment.total' let you+-- layer partial values yourself.++-- $libraries+--+-- A library can publish its configuration as a t'Figment.Figment'.+-- Applications append their own sources with '<>':+--+-- > libraryFigment :: F.Figment+-- > libraryFigment =+-- >   F.new+-- >     & F.merge (F.defaults (Aeson.object ["workers" .= (4 :: Int)]))+-- >     & F.merge (F.prefixed "MYLIB_")+-- >+-- > applicationFigment :: F.Figment+-- > applicationFigment = libraryFigment <> F.from (F.file F.toml "MyApp.toml")+--+-- t'Figment.Figment' is a lawful 'Monoid', so this grouping is safe.+-- A t'Figment.Figment' is also a provider: @F.merge libraryFigment@+-- nests it, and every inner value keeps its original source.++-- $providers+--+-- A provider has a name, and an action that returns one dictionary per+-- profile:+--+-- > newtype Secrets = Secrets (Map.Map Text Text)+-- >+-- > instance F.Provider Secrets where+-- >   metadata _ = F.named "secrets service"+-- >   provide _limits (Secrets m) =+-- >     pure (Right (Map.singleton F.Default (fmap (F.Value untaggedTag . F.String) m)))+-- >+-- > untaggedTag :: F.Tag+-- > untaggedTag = F.Tag Nothing Nothing Nothing Nothing+--+-- 'Figment.load' fills in the provider's metadata and profile for every+-- value, so error messages name the secrets service. A provider that+-- parses untrusted text should respect the t'Figment.Limits' it is+-- given. Any synchronous exception that escapes 'Figment.provide' is+-- turned into an 'Figment.IoError' for that provider. For a new file+-- format, write a t'Figment.Format' instead (a name and a parser); see+-- "Figment.Provider.Format".++-- $testing+--+-- 'Figment.Jail.withJail' runs a test in a fresh temporary directory,+-- with a snapshot of the environment, and restores both afterwards:+--+-- > Jail.withJail $ \j -> do+-- >   _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 9000\n"+-- >   Jail.setEnv j "APP_DEBUG" "true"+-- >   cfg <- F.loadExtractOrThrow (layered ["--port=9100"])+-- >   cfg @?= Config "demo" 9100 True+--+-- Jails are serialised across the whole process, so they are safe under+-- a parallel test runner. To avoid global state altogether, give the+-- environment provider fixed variables:+--+-- > F.from (Env.fromList [("APP_PORT", "1")] (F.prefixed "APP_"))++-- $limits+--+-- Every bundled parser enforces t'Figment.Limits' /while/ parsing:+-- nesting depth (64 by default) and the number of values (one million).+-- A megabyte of @[[[[@ is rejected at depth 65 without being built.+-- YAML aliases count at their expanded size, which defeats \"billion+-- laughs\" documents. Change the limits with 'Figment.withLimits' and+-- 'Figment.mkLimits'. Duplicate keys are errors, invalid UTF-8 is+-- rejected rather than replaced, and YAML uses the 1.2 core schema, so+-- @no@ stays a string.++-- $rust+--+-- The same concepts, side by side (Rust first):+--+-- * @Figment::new().merge(p)@ is @F.new & F.merge p@; @join@, @adjoin@+--   and @admerge@ keep their names.+--+-- * @Toml::file(p)@ is @F.file F.toml p@; @.nested()@ is+--   'Figment.nested'; @Toml::string(s)@ is @F.fromText F.toml s@.+--+-- * @Env::prefixed(\"APP_\").split(\"\__\")@ is+--   @F.prefixed \"APP_\" & Env.split \"\__\"@.+--+-- * @Serialized::defaults(x)@ is @F.defaults x@.+--+-- * @.select(\"prod\")@ is @F.select \"prod\"@.+--+-- * @.extract::\<T\>()@ is @F.loadExtract \@T fig@;+--   @.extract_inner(\"a.b\")@ is @F.extractAt (F.keyPath \"a.b\")@;+--   @.extract_lossy()@ is 'Figment.extractLossy'.+--+-- * @focus@, @find_value@ and @contains@ are 'Figment.focus',+--   'Figment.findValue' and 'Figment.contains'.+--+-- * @Tagged\<T\>@ and @RelativePathBuf@ are t'Figment.Tagged' and+--   t'Figment.RelativePath'.+--+-- * @Jail::expect_with@ is 'Figment.Jail.withJail'.+--+-- * @#[derive(Deserialize)]@ is @deriving anyclass F.FromConfig@.+--+-- What is different: all errors are reported at once, not just the+-- first; TOML and YAML values carry line and column; missing fields come+-- with hints; partial configurations give a type-level guarantee+-- ('Figment.extractTotal'); environment variable conflicts are errors;+-- and @--key value@ CLI pairs are not parsed (use optparse-applicative).++-- $upgrade+--+-- Version 0.2 is a redesign. The main replacements:+--+-- * @runLayers [Merge t, ...]@ and @composeChecked@: build a+--   t'Figment.Figment' with 'Figment.merge' and friends, then+--   'Figment.loadExtract'. The compile-time guarantee now comes from+--   'Figment.extractTotal'.+--+-- * @tagProviderDefault (TomlFile p)@: @F.file F.toml p@ (or+--   'Figment.fileExact' with 'Figment.required' to keep 0.1's \"must+--   exist\" behaviour).+--+-- * @EnvPrefixed \"APP_\"@: @F.prefixed \"APP_\" & Env.split \"_\"@+--   reproduces 0.1's splitting; plain @F.prefixed \"APP_\"@ is+--   recommended.+--+-- * @CliArgs args@: @F.cli args@.+--+-- * @Defaults r@: @F.defaults r@.+--+-- * @FromJSON@-only types: add @deriving F.FromConfig via F.ViaAeson T@,+--   or derive 'Figment.FromConfig' directly.+--+-- * @runExtractProv@: use 'Figment.findMetadata', or t'Figment.Tagged'+--   fields.+--+-- * @Depth@ and @mkDepth@: t'Figment.Limits' and 'Figment.mkLimits'.
+ src/Figment/Value.hs view
@@ -0,0 +1,207 @@+-- | The configuration value tree. Every node carries a t'Tag' recording+-- which provider and profile it came from, where in the source text it+-- was written, and (for values parsed from untyped text such as+-- environment variables) the original text.+module Figment.Value+  ( -- * Values+    Value (..)+  , Node (..)+  , Number (..)+  , Dict+    -- * Tags+  , Tag (..)+  , untagged+  , retag+  , setTagMeta+    -- * Construction+  , mkValue+  , string+  , bool+  , number+  , null+  , array+  , dict+  , emptyDict+    -- * Inspection+  , lookupPath+  , describe+  , kindOf+  , stripTags+  , numberFromScientific+  ) where++import Prelude hiding (null)++import Control.DeepSeq (NFData)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import GHC.Generics (Generic)++import Figment.Metadata+import Figment.Path+import Figment.Profile++-- | Numbers. Finite values are exact ('Scientific'), so a 30-digit+-- decimal in a JSON file survives intact; TOML and YAML also allow+-- infinities and NaN, which are represented explicitly rather than+-- being smuggled through as nonsense 'Scientific's.+data Number+  = Finite !Scientific+  | PosInfinity+  | NegInfinity+  | NaN+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Provenance attached to a value.+data Tag = Tag+  { tagMeta :: !(Maybe Metadata)+  , tagProfile :: !(Maybe Profile)+  , tagPos :: !(Maybe Pos)+  , tagRaw :: !(Maybe Text)+    -- ^ the original text, for values parsed out of untyped text+    -- (environment variables, CLI arguments). Lets a 'Text' field+    -- receive @007@ verbatim even though it also parses as a number.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A tag with no provenance.+untagged :: Tag+untagged = Tag Nothing Nothing Nothing Nothing++-- | A dictionary. Keys are kept sorted (Rust figment's default ordering).+type Dict = Map Text Value++-- | The shape of a value.+data Node+  = Null+  | Bool !Bool+  | Num !Number+  | String !Text+  | Array !(Vector Value)+  | Dict !Dict+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A tagged configuration value.+data Value = Value+  { valueTag :: !Tag+  , valueNode :: !Node+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | An untagged value.+mkValue :: Node -> Value+mkValue = Value untagged++-- | An untagged string.+string :: Text -> Value+string = mkValue . String++-- | An untagged boolean.+bool :: Bool -> Value+bool = mkValue . Bool++-- | An untagged finite number.+number :: Scientific -> Value+number = mkValue . Num . Finite++-- | The untagged null.+null :: Value+null = mkValue Null++-- | An untagged array.+array :: [Value] -> Value+array = mkValue . Array . Vector.fromList++-- | An untagged dictionary.+dict :: [(Text, Value)] -> Value+dict = mkValue . Dict . Map.fromList++-- | The empty dictionary.+emptyDict :: Value+emptyDict = mkValue (Dict Map.empty)++-- | A finite number.+numberFromScientific :: Scientific -> Number+numberFromScientific = Finite++-- | Fill in missing provenance (never overwrite: values coming from a+-- nested t'Figment.Core.Figment' keep their original source).+retag :: Metadata -> Profile -> Value -> Value+retag m p = go+  where+    go (Value t n) = Value (fill t) (goNode n)+    fill t = t+      { tagMeta = maybe (Just m) Just (tagMeta t)+      , tagProfile = maybe (Just p) Just (tagProfile t)+      }+    goNode (Array xs) = Array (fmap go xs)+    goNode (Dict d) = Dict (fmap go d)+    goNode n = n++-- | Overwrite the metadata of every node (used by providers that learn+-- their final metadata, e.g. a resolved file path, only when reading).+setTagMeta :: Metadata -> Value -> Value+setTagMeta m = go+  where+    go (Value t n) = Value t {tagMeta = Just m} (goNode n)+    goNode (Array xs) = Array (fmap go xs)+    goNode (Dict d) = Dict (fmap go d)+    goNode n = n++-- | Follow a path.+lookupPath :: Path -> Value -> Maybe Value+lookupPath p v0 = foldl step (Just v0) (segments p)+  where+    step Nothing _ = Nothing+    step (Just (Value _ (Dict d))) (Key k) = Map.lookup k d+    step (Just (Value _ (Array xs))) (Index i) = xs Vector.!? i+    step _ _ = Nothing++-- | A short description of a node's kind, for error messages.+kindOf :: Node -> Text+kindOf = \case+  Null -> "null"+  Bool _ -> "a boolean"+  Num (Finite s) | Sci.isInteger s -> "an integer"+  Num _ -> "a number"+  String _ -> "a string"+  Array _ -> "an array"+  Dict _ -> "a dictionary"++-- | Kind plus a preview of the value, e.g. @string "abc"@.+describe :: Node -> Text+describe = \case+  Null -> "null"+  Bool b -> "boolean " <> (if b then "true" else "false")+  Num n -> case n of+    Finite s+      | Sci.isInteger s, abs (Sci.base10Exponent s) < 64 ->+          "integer " <> Text.pack (Sci.formatScientific Sci.Fixed (Just 0) s)+      | otherwise -> "number " <> Text.pack (show s)+    PosInfinity -> "number inf"+    NegInfinity -> "number -inf"+    NaN -> "number nan"+  String t -> "string " <> Text.pack (show (preview t))+  Array xs -> "an array of length " <> Text.pack (show (Vector.length xs))+  Dict _ -> "a dictionary"+  where+    preview t+      | Text.length t > 40 = Text.take 40 t <> "..."+      | otherwise = t++-- | Remove all provenance (for comparing data only).+stripTags :: Value -> Value+stripTags (Value _ n) = Value untagged $ case n of+  Array xs -> Array (fmap stripTags xs)+  Dict d -> Dict (fmap stripTags d)+  other -> other
+ test/Figment/Test/Adversarial.hs view
@@ -0,0 +1,89 @@+-- | Hostile input: limits are enforced inside the parsers, nothing+-- escapes as an exception.+module Figment.Test.Adversarial (tests) where++import Control.DeepSeq (force)+import Control.Exception (SomeException, evaluate, try)+import qualified Data.ByteString as BS+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Data.Word (Word8)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Figment+import qualified Figment.Provider.Env as Env++kinds :: Figment -> IO [ErrorKind]+kinds f = either (map errorKind . errorList) (const []) <$> load f++deepArrays :: Int -> Text+deepArrays n = Text.replicate n "[" <> Text.replicate n "]"++limits :: Int -> Int -> Limits+limits d n = either (const defaultLimits) id (mkLimits d n)++tests :: TestTree+tests =+  testGroup+    "adversarial"+    [ testCase "1M-deep JSON is rejected at the depth limit, quickly" $ do+        k <- kinds (from (fromText json ("{\"a\":" <> deepArrays 1000000 <> "}")))+        k @?= [DepthExceeded 64]+    , testCase "1M-deep YAML flow sequence is rejected" $ do+        k <- kinds (from (fromText yaml ("a: " <> deepArrays 100000 <> "\n")))+        k @?= [DepthExceeded 64]+    , testCase "deep TOML inline arrays are rejected" $ do+        k <- kinds (from (fromText toml ("a = " <> deepArrays 10000 <> "\n")))+        k @?= [DepthExceeded 64]+    , testCase "deep structured env values are rejected" $ do+        k <- kinds (from (Env.fromList [("APP_X", deepArrays 10000)] (prefixed "APP_")))+        k @?= [DepthExceeded 64]+    , testCase "depth limit is exact: 64 accepted, 65 rejected" $ do+        let nestedJson n = Text.replicate n "{\"a\":" <> "1" <> Text.replicate n "}"+        ok <- kinds (from (fromText json (nestedJson 64)))+        ok @?= []+        bad <- kinds (from (fromText json (nestedJson 65)))+        bad @?= [DepthExceeded 64]+    , testCase "billion laughs: alias expansion is charged to the node limit" $ do+        let lol = Text.unlines $+              "a: &a [x, x, x, x, x, x, x, x, x, x]"+                : [ Text.pack (c : ": &" ++ [c] ++ " [" ++ concat (replicate 10 ('*' : [p] ++ ", ")) ++ "*" ++ [p] ++ "]")+                  | (c, p) <- zip "bcdefgh" "abcdefg" ]+        k <- kinds (withLimits (limits 64 100000) (from (fromText yaml lol)))+        k @?= [TooManyNodes 100000]+    , testCase "huge exponents do not allocate huge integers" $ do+        l <- load (from (fromText json "{\"n\":1e1000000000}")) >>= either (assertFailure . show) pure+        case extractAt (keyPath "n") l :: Either ConfigErrors Integer of+          Left es -> map errorKind (errorList es) @?= [InvalidValue "number 1.0e1000000000" "an integer with at most ~4096 digits"]+          Right _ -> assertFailure "accepted"+        case extractAt (keyPath "n") l :: Either ConfigErrors Int of+          Left _ -> pure ()+          Right v -> assertFailure (show v)+    , testCase "custom limits are validated" $+        case mkLimits 0 1 of+          Left e -> errorKind e @?= InvalidArgument "maxDepth must be positive, got 0"+          Right _ -> assertFailure "accepted"+    , testProperty "no format throws on arbitrary bytes" $ \(bytes :: [Word8]) ->+        ioProperty $ do+          let bs = BS.pack bytes+              txt = TE.decodeUtf8Lenient bs+          rs <- mapM (\fmt -> try (load (from (fromText fmt txt)) >>= evaluate . force . either (Left . renderErrors) (Right . show . selected)))+                     [json, toml, yaml]+          pure $ conjoin [counterexample (show e) False | Left (e :: SomeException) <- rs]+    , testProperty "no format throws on near-miss documents" $+        forAll (elements seeds) $ \seed -> forAll (chooseInt (0, Text.length seed)) $ \cut ->+          ioProperty $ do+            rs <- mapM (\fmt -> try (load (from (fromText fmt (Text.take cut seed))) >>= evaluate . force . either (Left . renderErrors) (Right . show . selected)))+                       [json, toml, yaml]+            pure $ conjoin [counterexample (show e) False | Left (e :: SomeException) <- rs]+    ]+  where+    seeds =+      [ "{\"a\": [1, 2, {\"b\": \"c\\u00e9\"}], \"d\": null}"+      , "[t]\na = 1\nb = [1, 2]\nc = { d = \"e\" }\n[[u]]\nx = 2021-01-01\n"+      , "a: &x [1, 2]\nb: *x\nc:\n  <<: {k: v}\n  d: 'q'\n"+      ]+
+ test/Figment/Test/Arbitrary.hs view
@@ -0,0 +1,80 @@+-- | Generators for configuration trees.+module Figment.Test.Arbitrary+  ( genValue+  , genDict+  , genSameShape+  , Shape (..)+  , genShape+  , fill+  ) where++import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import Test.QuickCheck++import Figment++genKey :: Gen Text.Text+genKey = elements ["a", "b", "c", "d"]++genScalar :: Gen Node+genScalar =+  oneof+    [ pure Null+    , Bool <$> arbitrary+    , Num . Finite . fromIntegral <$> chooseInt (-3, 3)+    , String . Text.pack <$> elements ["x", "y", ""]+    ]++-- | Arbitrary values, with arbitrary (distinguishable) tags.+genValue :: Int -> Gen Value+genValue d = do+  tag <- genTag+  n <-+    if d <= 0+      then genScalar+      else+        frequency+          [ (2, genScalar)+          , (2, Array . Vector.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k (genValue (d - 1))))+          , (3, Dict . Map.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k ((,) <$> genKey <*> genValue (d - 1))))+          ]+  pure (Value tag n)++genTag :: Gen Tag+genTag = do+  i <- chooseInt (0, 5)+  pure (Tag Nothing Nothing (Just (Pos i i)) Nothing)++genDict :: Int -> Gen Value+genDict d = do+  tag <- genTag+  kvs <- chooseInt (0, 4) >>= \k -> vectorOf k ((,) <$> genKey <*> genValue (d - 1))+  pure (Value tag (Dict (Map.fromList kvs)))++data Shape = SScalar | SArr [Shape] | SDict [(Text.Text, Shape)]+  deriving stock (Show)++genShape :: Int -> Gen Shape+genShape 0 = pure SScalar+genShape d =+  frequency+    [ (2, pure SScalar)+    , (1, SArr <$> (chooseInt (0, 2) >>= \k -> vectorOf k (genShape (d - 1))))+    , (3, SDict . Map.toList . Map.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k ((,) <$> genKey <*> genShape (d - 1))))+    ]++-- | A value of the given shape with arbitrary leaves and tags.+fill :: Shape -> Gen Value+fill sh = do+  tag <- genTag+  case sh of+    SScalar -> Value tag <$> genScalar+    SArr xs -> Value tag . Array . Vector.fromList <$> traverse fill xs+    SDict kvs -> Value tag . Dict . Map.fromList <$> traverse (\(k, s) -> (,) k <$> fill s) kvs++genSameShape :: Gen (Value, Value, Value)+genSameShape = do+  sh <- genShape 3+  (,,) <$> fill sh <*> fill sh <*> fill sh
+ test/Figment/Test/Cli.hs view
@@ -0,0 +1,55 @@+-- | Command-line arguments.+module Figment.Test.Cli (tests) where++import qualified Data.Text as Text+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import Figment.Provider.Cli (Arg (..), parseArgs)+import qualified Figment.Value as V+import Figment.Value (stripTags)++loadCli :: [Text.Text] -> IO (Either ConfigErrors Loaded)+loadCli = load . from . cli++ok :: [Text.Text] -> IO Loaded+ok args = loadCli args >>= either (assertFailure . Text.unpack . renderErrors) pure++at :: Text.Text -> Loaded -> Maybe Value+at k l = stripTags <$> findValue (keyPath k) l++tests :: TestTree+tests =+  testGroup+    "cli"+    [ testCase "REGRESSION C1: values are kept and typed" $ do+        l <- ok ["--host=x", "--port=80"]+        at "host" l @?= Just (V.string "x")+        at "port" l @?= Just (V.number 80)+    , testCase "flags, negated flags, dots and dashes" $ do+        l <- ok ["--verbose", "--no-color", "--db.max-connections=5"]+        at "verbose" l @?= Just (V.bool True)+        at "color" l @?= Just (V.bool False)+        at "db.max_connections" l @?= Just (V.number 5)+    , testCase "last occurrence wins; -- ends options" $ do+        l <- ok ["--a=1", "--a=2", "--", "--b=3"]+        at "a" l @?= Just (V.number 2)+        at "b" l @?= Nothing+    , testCase "positional arguments are classified, not lost" $+        parseArgs (cli ["run", "-x", "--k=v", "--", "--z"])+          @?= [Positional "run", Positional "-x", Option "--k=v" ["k"] (Just "v"), Positional "--z"]+    , testCase "malformed options are errors" $ do+        r <- loadCli ["--=x", "--a..b=1"]+        case r of+          Left es -> length (errorList es) @?= 2+          Right _ -> assertFailure "expected errors"+    , testCase "structural conflicts are errors" $ do+        r <- loadCli ["--db=x", "--db.host=y"]+        case r of+          Left es -> map errorKind (errorList es) @?= [KeyConflict "--db=x" "--db.host=y"]+          Right _ -> assertFailure "expected a conflict"+    , testCase "keys are not lower-cased" $ do+        l <- ok ["--Name=x"]+        at "Name" l @?= Just (V.string "x")+    ]
+ test/Figment/Test/Decode.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DerivingVia #-}+-- Sum types with record payloads are under test here, deliberately.+{-# OPTIONS_GHC -Wno-partial-fields #-}++-- | The native decoder.+module Figment.Test.Decode (tests) where++import qualified Data.Aeson as Aeson+import Data.Function ((&))+import Data.Int (Int8)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (Day, fromGregorian)+import Data.Word (Word16)+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import qualified Figment.Jail as Jail+import qualified Figment.Provider.Env as Env++data Server = Server {host :: Text, port :: Word16, tags :: [Text]}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++data Level = Debug | Info | Warn+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++data Shape = Circle {radius :: Double} | Square {side :: Double} | Dot+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++newtype Port = Port Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++data Pair = Pair Int Text+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++data Strict = Strict {maxConnections :: Int, timeoutSecs :: Int}+  deriving stock (Eq, Show, Generic)++instance FromConfig Strict where+  fromConfig = genericDecoder defaultOptions {fieldLabelModifier = snakeCase, rejectUnknownFields = True}++data Opt = Opt {required' :: Int, optional' :: Maybe Int, withDefault :: Int}+  deriving stock (Eq, Show, Generic)++instance FromConfig Opt where+  fromConfig = Opt <$> field "required" <*> optionalField "optional" <*> fieldOr "with_default" 42++newtype Legacy = Legacy (Map.Map Text Int)+  deriving stock (Eq, Show)+  deriving newtype (Aeson.FromJSON)+  deriving (FromConfig) via (ViaAeson Legacy)++data WithTagged = WithTagged {secret :: Tagged Text, dir :: RelativePath}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++loadText :: Data -> IO Loaded+loadText d = load (from d) >>= either (assertFailure . Text.unpack . renderErrors) pure++decodeJ :: FromConfig a => Text -> IO (Either ConfigErrors a)+decodeJ t = extract <$> loadText (fromText json t)++paths :: ConfigErrors -> [Text]+paths = map (renderPath . errorPath) . errorList++tests :: TestTree+tests =+  testGroup+    "decode"+    [ testCase "records, lists, bounded ints" $ do+        r <- decodeJ "{\"host\":\"h\",\"port\":8080,\"tags\":[\"a\",\"b\"]}"+        r @?= Right (Server "h" 8080 ["a", "b"])+    , testCase "REGRESSION C3: the error points at the failing field, not the first key" $ do+        r <- decodeJ "{\"host\":\"h\",\"port\":\"bad\",\"tags\":[]}" :: IO (Either ConfigErrors Server)+        either paths (const []) r @?= ["port"]+    , testCase "all errors are reported at once, each with its path" $ do+        r <- decodeJ "{\"port\":70000,\"tags\":[\"ok\", 5]}" :: IO (Either ConfigErrors Server)+        case r of+          Left es -> do+            paths es @?= ["host", "port", "tags[1]"]+            map errorKind (errorList es)+              @?= [ MissingField "host"+                  , InvalidValue "integer 70000" "an integer in the range 0..65535"+                  , InvalidType "integer 5" "a string"+                  ]+          Right v -> assertFailure (show v)+    , testCase "errors carry the source, line and column" $ do+        l <- loadText (fromText toml "host = \"h\"\nport = \"x\"\ntags = []\n")+        case extract l :: Either ConfigErrors Server of+          Left es -> case errorList es of+            [e] -> do+              errorPos e @?= Just (Pos 2 8)+              fmap metaName (errorMetadata e) @?= Just "TOML source string"+            other -> assertFailure (show other)+          Right v -> assertFailure (show v)+    , testCase "out of range never wraps" $ do+        r <- decodeJ "{\"n\":300}" :: IO (Either ConfigErrors (Map.Map Text Int8))+        either (map errorKind . errorList) (const []) r @?= [InvalidValue "integer 300" "an integer in the range -128..127"]+    , testCase "non-integers are not truncated" $ do+        r <- decodeJ "{\"n\":1.5}" :: IO (Either ConfigErrors (Map.Map Text Int))+        either (map errorKind . errorList) (const []) r @?= [InvalidValue "number 1.5" "an integer"]+    , testCase "enums, case-insensitively; unknown variants list the options" $ do+        r <- decodeJ "{\"a\":\"Debug\",\"b\":\"warn\"}"+        r @?= Right (Map.fromList [("a" :: Text, Debug), ("b", Warn)])+        bad <- decodeJ "{\"a\":\"verbose\"}" :: IO (Either ConfigErrors (Map.Map Text Level))+        either (map errorKind . errorList) (const []) bad @?= [UnknownVariant "verbose" ["Debug", "Info", "Warn"]]+    , testCase "sum types are externally tagged" $ do+        r <- decodeJ "{\"xs\":[{\"Circle\":{\"radius\":1}}, {\"Square\":{\"side\":2}}, \"Dot\"]}"+        r @?= Right (Map.fromList [("xs" :: Text, [Circle 1, Square 2, Dot])])+    , testCase "newtypes unwrap, positional constructors are arrays" $ do+        p <- decodeJ "{\"p\":80}"+        p @?= Right (Map.fromList [("p" :: Text, Port 80)])+        q <- decodeJ "{\"q\":[1,\"x\"]}"+        q @?= Right (Map.fromList [("q" :: Text, Pair 1 "x")])+    , testCase "snake_case options and unknown-field suggestions" $ do+        ok <- decodeJ "{\"max_connections\":1,\"timeout_secs\":2}"+        ok @?= Right (Strict 1 2)+        bad <- decodeJ "{\"max_conections\":1,\"timeout_secs\":2}" :: IO (Either ConfigErrors Strict)+        case bad of+          Left es -> map errorKind (errorList es) @?= [UnknownField "max_conections" ["max_connections"], MissingField "max_connections"]+          Right v -> assertFailure (show v)+    , testCase "hand-written decoders: optional and defaulted fields" $ do+        r <- decodeJ "{\"required\":1}"+        r @?= Right (Opt 1 Nothing 42)+    , testCase "missing-field hints name every way to set it" $ do+        l <- load (new & merge (fromText json "{}") & merge (Env.fromList [] (prefixed "APP_") & Env.split "__") & merge (cli []))+               >>= either (assertFailure . show) pure+        case extract l :: Either ConfigErrors Server of+          Left es -> case filter ((== MissingField "port") . errorKind) (errorList es) of+            [e] -> do+              let h = Text.unlines (errorHints e)+              assertBool (Text.unpack h) ("`APP_PORT`" `Text.isInfixOf` h && "`--port`" `Text.isInfixOf` h)+            other -> assertFailure (show other)+          Right v -> assertFailure (show v)+    , testCase "lossy extraction" $ do+        l <- loadText (fromText json "{\"host\":5,\"port\":\"8080\",\"tags\":[]}")+        case extract l :: Either ConfigErrors Server of+          Left es -> length (errorList es) @?= 2+          Right v -> assertFailure (show v)+        extractLossy l @?= Right (Server "5" 8080 [])+    , testCase "Tagged and RelativePath know their source" $ withTmpToml $ \path -> do+        l <- load (from (fileExact toml path)) >>= either (assertFailure . show) pure+        case extract l of+          Right (WithTagged s d) -> do+            taggedValue s @?= "x"+            taggedPath s @?= keyPath "secret"+            fmap metaSource (taggedMetadata s) @?= Just (Just (FileSource path))+            relative d @?= dirOf path <> "/data"+          Left e -> assertFailure (Text.unpack (renderErrors e))+    , testCase "ISO dates, NonEmpty, tuples" $ do+        r <- decodeJ "{\"d\":\"2024-02-29\"}"+        r @?= Right (Map.fromList [("d" :: Text, fromGregorian 2024 2 29 :: Day)])+        ne <- decodeJ "{\"xs\":[]}" :: IO (Either ConfigErrors (Map.Map Text (NonEmpty Int)))+        either (map errorKind . errorList) (const []) ne @?= [InvalidLength 0 "a non-empty array"]+        t <- decodeJ "{\"t\":[1,\"a\"]}"+        t @?= Right (Map.fromList [("t" :: Text, (1 :: Int, "a" :: Text))])+    , testCase "ViaAeson bridge keeps the path of aeson's error" $ do+        ok <- decodeJ "{\"legacy\":{\"a\":1}}"+        ok @?= Right (Map.fromList [("legacy" :: Text, Legacy (Map.fromList [("a", 1)]))])+        bad <- decodeJ "{\"legacy\":{\"a\":\"x\"}}" :: IO (Either ConfigErrors (Map.Map Text Legacy))+        either paths (const []) bad @?= ["legacy.a"]+    , testCase "validate attaches the location of the value" $ do+        l <- loadText (fromText toml "port = 0\n")+        let positive p = if (p :: Int) > 0 then Right p else Left "port must be positive"+            d = fieldWith "port" (validate positive fromConfig) Nothing+        case extractWith d l of+          Left es -> map (\e -> (errorKind e, errorPos e)) (errorList es) @?= [(Message "port must be positive", Just (Pos 1 8))]+          Right v -> assertFailure (show v)+    ]+  where+    dirOf = reverse . drop 1 . dropWhile (/= '/') . reverse++withTmpToml :: (FilePath -> IO a) -> IO a+withTmpToml k = Jail.withJail $ \j ->+  Jail.createFile j "conf/app.toml" "secret = \"x\"\ndir = \"data\"\n" >>= k
+ test/Figment/Test/Env.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | Environment variables.+module Figment.Test.Env (tests) where++import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import qualified Figment.Jail as Jail+import qualified Figment.Provider.Env as Env+import Figment.Value (stripTags)+import qualified Figment.Value as V++data Cfg = Cfg {host :: Text, port :: Int, max_connections :: Int, zip_code :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++data Db = Db {host :: Text, port :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++newtype Outer = Outer {db :: Db}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++env :: [(Text, Text)] -> Env -> IO (Either ConfigErrors Loaded)+env vars e = load (from (Env.fromList vars e))++ok :: [(Text, Text)] -> Env -> IO Loaded+ok vars e = env vars e >>= either (assertFailure . Text.unpack . renderErrors) pure++node :: Text -> Loaded -> Maybe Node+node k l = valueNode <$> findValue (keyPath k) l++tests :: TestTree+tests =+  testGroup+    "env"+    [ testCase "REGRESSION C1/H1: values are kept and typed" $ do+        l <- ok [("APP_HOST", "x"), ("APP_PORT", "9000"), ("APP_MAX_CONNECTIONS", "5"), ("APP_ZIP_CODE", "01234"), ("OTHER", "1")] (prefixed "APP_")+        extract l @?= Right (Cfg "x" 9000 5 "01234")+    , testCase "REGRESSION H2: underscores stay in keys unless split is asked for" $ do+        l <- ok [("APP_MAX_CONNECTIONS", "5")] (prefixed "APP_")+        node "max_connections" l @?= Just (Num (Finite 5))+        l2 <- ok [("APP_DB__HOST", "h"), ("APP_DB__PORT", "5432")] (prefixed "APP_" & Env.split "__")+        extract l2 @?= Right (Outer (Db "h" 5432))+    , testCase "prefix is case-insensitive, keys are lower-cased" $ do+        l <- ok [("app_Host", "x")] (prefixed "APP_")+        node "host" l @?= Just (String "x")+        l2 <- ok [("APP_Host", "x")] (prefixed "APP_" & Env.lowercase False)+        node "Host" l2 @?= Just (String "x")+    , testCase "structured values" $ do+        l <- ok [("APP_LIST", "[1, two, \"three\"]"), ("APP_MAP", "{a = 1, b = true}"), ("APP_Q", "\"quoted\"")] (prefixed "APP_")+        fmap stripTags (findValue (keyPath "list") l) @?= Just (V.array [V.number 1, V.string "two", V.string "three"])+        fmap stripTags (findValue (keyPath "map") l) @?= Just (V.dict [("a", V.number 1), ("b", V.bool True)])+        node "q" l @?= Just (String "quoted")+    , testCase "malformed structured text is just a string" $ do+        l <- ok [("APP_X", "[1, 2")] (prefixed "APP_")+        node "x" l @?= Just (String "[1, 2")+    , testCase "conflicts are reported, not silently resolved" $ do+        r <- env [("APP_DB", "x"), ("APP_DB__HOST", "y")] (prefixed "APP_" & Env.split "__")+        case r of+          Left es -> map errorKind (errorList es) @?= [KeyConflict "APP_DB" "APP_DB__HOST"]+          Right _ -> assertFailure "expected a conflict"+        r2 <- env [("APP_HOST", "a"), ("APP_host", "b")] (prefixed "APP_")+        case r2 of+          Left es -> map errorKind (errorList es) @?= [DuplicateKey "APP_HOST and APP_host"]+          Right _ -> assertFailure "expected a duplicate"+    , testCase "only / ignore / map / filter / ignoreEmpty" $ do+        let vars = [("APP_A", "1"), ("APP_B", "2"), ("APP_C", ""), ("APP_D", "4")]+        l <- ok vars (prefixed "APP_" & Env.only ["a", "C"])+        Map.keys <$> (extract l :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["a", "c"]+        l2 <- ok vars (prefixed "APP_" & Env.ignore ["a"] & Env.ignoreEmpty True)+        Map.keys <$> (extract l2 :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["b", "d"]+        l3 <- ok vars (prefixed "APP_" & Env.mapKeys (<> "_x") & Env.filterKeys (/= "D_x"))+        Map.keys <$> (extract l3 :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["a_x", "b_x", "c_x"]+    , testCase "unparsed keeps strings" $ do+        l <- ok [("APP_N", "5")] (prefixed "APP_" & Env.unparsed)+        node "n" l @?= Just (String "5")+    , testCase "empty key segments are ignored" $ do+        l <- ok [("APP_", "1"), ("APP_A____B", "2"), ("APP_OK", "3")] (prefixed "APP_" & Env.split "__")+        Map.keys <$> (extract l :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["ok"]+    , testCase "profiles and global" $ do+        l <- ok [("APP_PORT", "1")] (prefixed "APP_" & Env.inProfile "prod")+        profiles l @?= ["prod"]+        l2 <- ok [("APP_PORT", "1")] (prefixed "APP_" & Env.global)+        profiles l2 @?= [Global]+    , testCase "error messages name the variable" $ do+        l <- ok [("APP_DB__PORT", "abc"), ("APP_DB__HOST", "h")] (prefixed "APP_" & Env.split "__")+        case extract l :: Either ConfigErrors Outer of+          Left es -> assertBool (Text.unpack (renderErrors es)) ("`APP_DB__PORT`" `Text.isInfixOf` renderErrors es)+          Right v -> assertFailure (show v)+    , testCase "reads the real process environment" $ Jail.withJail $ \j -> do+        Jail.clearEnv j+        Jail.setEnv j "JAILED_HOST" "real"+        l <- load (from (prefixed "JAILED_")) >>= either (assertFailure . show) pure+        node "host" l @?= Just (String "real")+    ]
+ test/Figment/Test/Errors.hs view
@@ -0,0 +1,67 @@+-- | Golden tests for rendered error reports. The rendering is part of+-- the public interface (users read it); changing it is a visible change.+module Figment.Test.Errors (tests) where++import qualified Data.ByteString.Lazy as BL+import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import GHC.Generics (Generic)+import Data.Word (Word16)+import Test.Tasty+import Test.Tasty.Golden (goldenVsString)++import Figment+import qualified Figment.Provider.Env as Env++data Db = Db {host :: Text, port :: Word16}+  deriving stock (Show, Generic)++instance FromConfig Db where+  fromConfig = genericDecoder defaultOptions {rejectUnknownFields = True}++data Cfg = Cfg {name :: Text, db :: Db, level :: Level}+  deriving stock (Show, Generic)+  deriving anyclass (FromConfig)++data Level = Debug | Info+  deriving stock (Show, Generic)+  deriving anyclass (FromConfig)++report :: Figment -> IO Text+report f = do+  r <- load f+  pure $ case r of+    Left es -> renderErrors es+    Right l -> case extract l :: Either ConfigErrors Cfg of+      Left es -> renderErrors es+      Right v -> Text.pack ("unexpected success: " ++ show v)++golden :: String -> IO Text -> TestTree+golden n act = goldenVsString n ("test/golden/" ++ n ++ ".txt") (BL.fromStrict . TE.encodeUtf8 . (<> "\n") <$> act)++tests :: TestTree+tests =+  testGroup+    "errors (golden)"+    [ golden "decode-many" $+        report $+          new+            & merge (fromText toml "[db]\nhost = \"h\"\nport = 70000\nhots = 1\n")+            & merge (Env.fromList [("APP_LEVEL", "verbose")] (prefixed "APP_"))+    , golden "missing" $+        report $+          new+            & merge (fromText json "{\"db\":{\"host\":\"h\",\"port\":1},\"level\":\"Info\"}")+            & merge (Env.fromList [] (prefixed "APP_") & Env.split "__")+            & merge (cli [])+    , golden "load-failures" $+        report $+          new+            & merge (fromText yaml "a: 1\na: 2\n")+            & merge (fromText toml "x = \n")+            & merge (Env.fromList [("APP_DB", "1"), ("APP_DB__HOST", "2")] (prefixed "APP_" & Env.split "__"))+    , golden "single" $+        report (new & merge (fromText json "{\"name\":\"n\",\"db\":{\"host\":\"h\",\"port\":\"x\"},\"level\":\"Debug\"}"))+    ]
+ test/Figment/Test/Figment.hs view
@@ -0,0 +1,112 @@+-- | Loading, profiles, queries, composition.+module Figment.Test.Figment (tests) where++import Control.Exception (ErrorCall (..), throwIO)+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import GHC.Stack (SrcLoc (..))+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import qualified Figment.Provider.Env as Env++data Cfg = Cfg {name :: Text, port :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++tomlProfiles :: Text+tomlProfiles =+  "[default]\nname = \"base\"\nport = 1\n\n[debug]\nname = \"dbg\"\n\n[global]\nport = 9\n"++loadOk :: Figment -> IO Loaded+loadOk f = load f >>= either (assertFailure . Text.unpack . renderErrors) pure++tests :: TestTree+tests =+  testGroup+    "figment"+    [ testCase "default profile, then selected, then global" $ do+        let base = new & merge (nested (fromText toml tomlProfiles))+        l <- loadOk base+        extract l @?= Right (Cfg "base" 9)+        l' <- loadOk (base & select "debug")+        extract l' @?= Right (Cfg "dbg" 9)+        extract (reselect "DEBUG" l) @?= Right (Cfg "dbg" 9)+        extract (reselect "missing" l) @?= Right (Cfg "base" 9)+    , testCase "later providers win, even over globals of earlier ones" $ do+        l <- loadOk $+          new+            & merge (nested (fromText toml tomlProfiles))+            & merge (fromText toml "port = 7")+        -- the second source writes to Default; Global of the first still wins+        extract l @?= Right (Cfg "base" 9)+        l2 <- loadOk $+          new+            & merge (nested (fromText toml tomlProfiles))+            & merge (Env.global (Env.fromList [("APP_PORT", "7")] (prefixed "APP_")))+        extract l2 @?= Right (Cfg "base" 7)+    , testCase "join only fills gaps" $ do+        l <- loadOk $+          new+            & merge (fromText json "{\"name\":\"a\"}")+            & join (fromText json "{\"name\":\"b\",\"port\":2}")+        extract l @?= Right (Cfg "a" 2)+    , testCase "every failing provider is reported, not just the first" $ do+        r <- load $+          new+            & merge (required (fileExact toml "/nonexistent/a.toml"))+            & merge (fromText json "{ not json")+            & merge (fromText yaml "a: [1, 2")+        case r of+          Left es -> length (errorList es) @?= 3+          Right _ -> assertFailure "expected errors"+    , testCase "an exception escaping a provider becomes an error" $ do+        r <- load (from Boom)+        case r of+          Left es -> case errorList es of+            [e] -> do+              errorKind e @?= IoError "boom"+              fmap metaName (errorMetadata e) @?= Just "boom provider"+            other -> assertFailure (show other)+          Right _ -> assertFailure "expected an error"+    , testCase "metadata records where the provider was added" $ do+        l <- loadOk (from (fromText json "{\"name\":\"x\",\"port\":1}"))+        case loadedSources l of+          [m] -> fmap srcLocFile (metaAddedAt m) @?= Just "test/Figment/Test/Figment.hs"+          other -> assertFailure (show other)+    , testCase "findValue / contains / findMetadata / extractAt / focus" $ do+        l <- loadOk (from (fromText json "{\"db\":{\"host\":\"h\",\"port\":5}}"))+        contains (keyPath "db.host") l @?= True+        contains (keyPath "db.nope") l @?= False+        fmap metaName (findMetadata (keyPath "db.port") l) @?= Just "JSON source string"+        extractAt (keyPath "db.port") l @?= Right (5 :: Int)+        extractLossy (focus (keyPath "db") l) @?= Right (Map.fromList [("host" :: Text, "h" :: Text), ("port", "5")])+    , testCase "a Figment is itself a provider, and keeps inner provenance" $ do+        let inner = from (fromText yaml "name: inner\nport: 3\n")+        l <- loadOk (new & merge inner & merge (fromText json "{\"port\":4}"))+        extract l @?= Right (Cfg "inner" 4)+        fmap metaName (findMetadata (keyPath "name") l) @?= Just "YAML source string"+    , testCase "a provider's profile hint is honoured, explicit select wins" $ do+        let hinted = new & merge (Hint "debug") & merge (nested (fromText toml tomlProfiles))+        l <- loadOk hinted+        loadedProfile l @?= "debug"+        l' <- loadOk (hinted & select Default)+        loadedProfile l' @?= Default+    ]++data Boom = Boom++instance Provider Boom where+  metadata _ = named "boom provider"+  provide _ _ = throwIO (ErrorCall "boom")++newtype Hint = Hint Profile++instance Provider Hint where+  metadata _ = named "hint"+  provide _ _ = pure (Right Map.empty)+  providerProfile (Hint p) = Just p
+ test/Figment/Test/MergeLaws.hs view
@@ -0,0 +1,83 @@+-- | The algebra of 'coalesce' and of 'Figment' sequencing.+module Figment.Test.MergeLaws (tests) where++import qualified Data.Map.Strict as Map+import qualified Data.Vector as Vector+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Figment+import Figment.Merge (coalesce)+import Figment.Test.Arbitrary+import Figment.Value (stripTags)++tests :: TestTree+tests =+  testGroup+    "merge laws"+    [ testProperty "duality: Join a b == Merge b a (including tags)" $+        forAll (genValue 3) $ \a -> forAll (genValue 3) $ \b ->+          coalesce Join a b === coalesce Merge b a+    , testProperty "idempotence of Merge and Join (data)" $+        forAll (genValue 3) $ \v ->+          stripTags (coalesce Merge v v) === stripTags v+            .&&. stripTags (coalesce Join v v) === stripTags v+    , testProperty "empty dictionary is a left and right identity on dictionaries" $+        forAll (genDict 3) $ \v -> conjoin+          [ stripTags (coalesce o (mkEmpty) v) === stripTags v .&&. stripTags (coalesce o v mkEmpty) === stripTags v+          | o <- [minBound .. maxBound] ]+    , testProperty "associative on same-shape trees, every order" $+        forAll genSameShape $ \(a, b, c) -> conjoin+          [ coalesce o (coalesce o a b) c === coalesce o a (coalesce o b c) | o <- [minBound .. maxBound] ]+    , testCase "not associative in general (why Value has no Semigroup)" $ do+        let a = dictV [("x", num 1)]+            b = num 5+            c = dictV [("y", num 2)]+        assertBool "counterexample" $+          stripTags (coalesce Merge (coalesce Merge a b) c) /= stripTags (coalesce Merge a (coalesce Merge b c))+    , testCase "adjoin/admerge concatenate arrays; merge/join replace" $ do+        let a = arr [num 1]+            b = arr [num 2]+        stripTags (coalesce Adjoin a b) @?= arr [num 1, num 2]+        stripTags (coalesce Admerge a b) @?= arr [num 1, num 2]+        stripTags (coalesce Merge a b) @?= arr [num 2]+        stripTags (coalesce Join a b) @?= arr [num 1]+    , testCase "container tags follow Rust: join keeps left, merge keeps right" $ do+        let tl = Tag Nothing Nothing (Just (Pos 1 1)) Nothing+            tr = Tag Nothing Nothing (Just (Pos 2 2)) Nothing+            l = Value tl (Dict Map.empty)+            r = Value tr (Dict Map.empty)+        valueTag (coalesce Join l r) @?= tl+        valueTag (coalesce Merge l r) @?= tr+    , testProperty "Figment is a monoid (observationally: same loaded data)" $+        forAll (genDict 2) $ \a -> forAll (genDict 2) $ \b -> forAll (genDict 2) $ \c ->+          ioProperty $ do+            let fa = from (Const a)+                fb = merge (Const b) new+                fc = join (Const c) new+            l1 <- loadedPlain ((fa <> fb) <> fc)+            l2 <- loadedPlain (fa <> (fb <> fc))+            l3 <- loadedPlain (new <> fa)+            l4 <- loadedPlain (fa <> new)+            l5 <- loadedPlain fa+            pure (l1 === l2 .&&. l3 === l5 .&&. l4 === l5)+    ]+  where+    mkEmpty = Value (Tag Nothing Nothing Nothing Nothing) (Dict Map.empty)+    num :: Int -> Value+    num = Value (Tag Nothing Nothing Nothing Nothing) . Num . Finite . fromIntegral+    arr = Value (Tag Nothing Nothing Nothing Nothing) . Array . Vector.fromList+    dictV = Value (Tag Nothing Nothing Nothing Nothing) . Dict . Map.fromList++-- | A provider returning a fixed dictionary.+newtype Const = Const Value++instance Provider Const where+  metadata _ = named "const"+  provide _ (Const v) = pure $ case valueNode v of+    Dict d -> Right (Map.singleton Default d)+    _ -> Right Map.empty++loadedPlain :: Figment -> IO (Maybe Value)+loadedPlain f = either (const Nothing) (Just . stripTags . selected) <$> load f
+ test/Figment/Test/Partial.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TypeFamilies #-}++-- | Higher-kinded partial configurations.+module Figment.Test.Partial (tests) where++import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import qualified Figment.Provider.Env as Env++data DbF f = Db+  { url :: Field f Text+  , pool :: Field f Int+  }+  deriving stock (Generic)++instance Partial DbF++data AppF f = App+  { host :: Field f Text+  , port :: Field f Int+  , motd :: Field f (Maybe Text)+  , db :: DbF f+  }+  deriving stock (Generic)++instance Partial AppF++deriving stock instance Eq (DbF Identity)+deriving stock instance Show (DbF Identity)+deriving stock instance Eq (AppF Identity)+deriving stock instance Show (AppF Identity)++type App = AppF Identity++partialDefaults :: AppF Maybe+partialDefaults = (emptyPartial @AppF) {port = Just 8080, db = (emptyPartial @DbF) {pool = Just 4}}++totalDefaults :: App+totalDefaults = App "localhost" 8080 Nothing (Db "sqlite::memory:" 4)++loaded :: [(Text, Text)] -> Text -> IO Loaded+loaded vars body =+  load (new & merge (fromText toml body) & merge (Env.fromList vars (prefixed "APP_") & Env.split "__"))+    >>= either (assertFailure . Text.unpack . renderErrors) pure++tests :: TestTree+tests =+  testGroup+    "partial (HKD)"+    [ testCase "defaults fill gaps; providers win; nested records" $ do+        l <- loaded [("APP_DB__URL", "postgres://x")] "host = \"h\"\n"+        extractPartial partialDefaults l @?= Right (App "h" 8080 Nothing (Db "postgres://x" 4))+    , testCase "every missing field is reported, with how to set it" $ do+        l <- loaded [] "port = 1\n"+        case extractPartial partialDefaults l of+          Left es -> do+            map errorKind (errorList es) @?= [MissingField "host", MissingField "url"]+            map (renderPath . errorPath) (errorList es) @?= ["host", "db.url"]+            let hints = Text.unlines (concatMap errorHints (errorList es))+            assertBool (Text.unpack hints) ("`APP_DB__URL`" `Text.isInfixOf` hints)+          Right v -> assertFailure (show v)+    , testCase "type errors in present fields are all reported" $ do+        l <- loaded [] "port = \"x\"\n[db]\npool = \"y\"\n"+        case extractPartial partialDefaults l of+          Left es -> map (renderPath . errorPath) (errorList es) @?= ["port", "db.pool"]+          Right v -> assertFailure (show v)+    , testCase "total defaults: missing fields are impossible" $ do+        l <- loaded [] ""+        extractTotal totalDefaults l @?= Right totalDefaults+        l2 <- loaded [("APP_PORT", "9")] "motd = \"hi\"\n"+        extractTotal totalDefaults l2 @?= Right totalDefaults {port = 9, motd = Just "hi"}+    , testCase "overlay is right-biased; total/complete round-trip" $ do+        let a = (emptyPartial @AppF) {host = Just "a", port = Just 1}+            b = (emptyPartial @AppF) {port = Just 2}+        fmap port (complete defaultOptions (overlay (total totalDefaults) (overlay a b))) @?= Right 2+        complete defaultOptions (total totalDefaults) @?= Right totalDefaults+    ]
+ test/Figment/Test/Providers.hs view
@@ -0,0 +1,181 @@+-- | File formats end to end.+module Figment.Test.Providers (tests) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (Day, LocalTime, ZonedTime, zonedTimeToUTC, UTCTime)+import GHC.Generics (Generic)+import System.FilePath ((</>))+import Test.Tasty+import Test.Tasty.HUnit++import Figment+import qualified Figment.Jail as Jail++data Cfg = Cfg {host :: Text, port :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromConfig)++expectOk :: Figment -> IO Loaded+expectOk f = load f >>= either (assertFailure . Text.unpack . renderErrors) pure++expectErr :: Figment -> IO [ConfigError]+expectErr f = load f >>= either (pure . errorList) (const (assertFailure "expected a load error"))++kinds :: [ConfigError] -> [ErrorKind]+kinds = map errorKind++tests :: TestTree+tests =+  testGroup+    "providers"+    [ testGroup "files" fileTests+    , testGroup "json" jsonTests+    , testGroup "toml" tomlTests+    , testGroup "yaml" yamlTests+    , testGroup "serialized" serializedTests+    ]++fileTests :: [TestTree]+fileTests =+  [ testCase "round trip in every format" $ Jail.withJail $ \j -> do+      _ <- Jail.createFile j "a.json" "{\"host\":\"j\",\"port\":1}"+      _ <- Jail.createFile j "a.toml" "host = \"t\"\nport = 2\n"+      _ <- Jail.createFile j "a.yaml" "host: y\nport: 3\n"+      mapM_+        (\(f, expected) -> expectOk (from f) >>= \l -> extract l @?= Right expected)+        [ (file json "a.json", Cfg "j" 1)+        , (file toml "a.toml", Cfg "t" 2)+        , (file yaml "a.yaml", Cfg "y" 3)+        ]+  , testCase "a missing optional file contributes nothing" $ Jail.withJail $ \_ -> do+      l <- expectOk (from (file toml "absent.toml"))+      extract l @?= (Right Map.empty :: Either ConfigErrors (Map.Map Text Int))+  , testCase "a missing required file is an IoError naming the file" $ Jail.withJail $ \_ -> do+      es <- expectErr (from (required (file toml "absent.toml")))+      case kinds es of+        [IoError msg] -> assertBool (Text.unpack msg) ("absent.toml" `Text.isInfixOf` msg)+        other -> assertFailure (show other)+  , testCase "relative files are searched for in parent directories" $ Jail.withJail $ \j -> do+      _ <- Jail.createFile j "App.toml" "host = \"up\"\nport = 1\n"+      sub <- Jail.createDirectory j "a/b/c"+      Jail.inDirectory j sub $ do+        l <- expectOk (from (file toml "App.toml"))+        extract l @?= Right (Cfg "up" 1)+        fmap metaSource (findMetadata (keyPath "host") l) @?= Just (Just (FileSource (Jail.jailDirectory j </> "App.toml")))+        l2 <- expectOk (from (fileExact toml "App.toml"))+        (extract l2 :: Either ConfigErrors (Map.Map Text Text)) @?= Right Map.empty+  , testCase "top level must be a dictionary" $ do+      es <- expectErr (from (fromText json "[1,2]"))+      kinds es @?= [InvalidType "an array of length 2" "a dictionary at the top level"]+  , testCase "nested files: top-level keys are profiles" $ do+      l <- expectOk (from (nested (fromText yaml "default:\n  host: d\n  port: 1\nprod:\n  host: p\n")))+      extract (reselect "prod" l) @?= Right (Cfg "p" 1)+      es <- expectErr (from (nested (fromText yaml "default: 5\n")))+      kinds es @?= [InvalidType "integer 5" "a dictionary (nested files map profile names to dictionaries)"]+  ]++jsonTests :: [TestTree]+jsonTests =+  [ testCase "duplicate keys are errors" $ do+      es <- expectErr (from (fromText json "{\"a\":1,\"a\":2}"))+      kinds es @?= [DuplicateKey "a"]+      map (renderPath . errorPath) es @?= ["a"]+  , testCase "syntax errors and trailing garbage" $ do+      es <- expectErr (from (fromText json "{\"a\":1} x"))+      case kinds es of+        [SyntaxError _] -> pure ()+        other -> assertFailure (show other)+  , testCase "big and precise numbers survive exactly" $ do+      l <- expectOk (from (fromText json "{\"n\":123456789012345678901234567890.123456789}"))+      fmap (valueNode) (findValue (keyPath "n") l) @?= Just (Num (Finite 123456789012345678901234567890.123456789))+  ]++tomlTests :: [TestTree]+tomlTests =+  [ testCase "dates and times decode into Data.Time types" $ do+      l <- expectOk (from (fromText toml "d = 2024-01-02\nlt = 2024-01-02T03:04:05\nzt = 2024-01-02T03:04:05+05:30\n"))+      extractAt (keyPath "d") l @?= Right (read "2024-01-02" :: Day)+      extractAt (keyPath "lt") l @?= Right (read "2024-01-02 03:04:05" :: LocalTime)+      fmap zonedTimeToUTC (extractAt (keyPath "zt") l :: Either ConfigErrors ZonedTime)+        @?= Right (read "2024-01-01 21:34:05 UTC" :: UTCTime)+      extractAt (keyPath "zt") l @?= Right (read "2024-01-01 21:34:05 UTC" :: UTCTime)+  , testCase "inf and nan are kept, not corrupted" $ do+      l <- expectOk (from (fromText toml "a = inf\nb = -inf\nc = nan\n"))+      fmap valueNode (findValue (keyPath "a") l) @?= Just (Num PosInfinity)+      fmap valueNode (findValue (keyPath "b") l) @?= Just (Num NegInfinity)+      fmap valueNode (findValue (keyPath "c") l) @?= Just (Num NaN)+      (extractAt (keyPath "a") l :: Either ConfigErrors Double) @?= Right (1 / 0)+      case extractAt (keyPath "a") l :: Either ConfigErrors Int of+        Left _ -> pure ()+        Right v -> assertFailure (show v)+  , testCase "invalid UTF-8 is rejected (not replaced)" $ Jail.withJail $ \j -> do+      p <- Jail.createBinaryFile j "bad.toml" "name = \"\xff\xfe\"\n"+      es <- expectErr (from (fileExact toml p))+      case kinds es of+        [SyntaxError msg] -> assertBool (Text.unpack msg) ("UTF-8" `Text.isInfixOf` msg)+        other -> assertFailure (show other)+  , testCase "syntax errors carry a position" $ do+      es <- expectErr (from (fromText toml "a = 1\nb = = 2\n"))+      map errorPos es @?= [Just (Pos 2 5)]+  , testCase "redefinition is a duplicate key" $ do+      es <- expectErr (from (fromText toml "a = 1\na = 2\n"))+      kinds es @?= [DuplicateKey "a"]+  ]++yamlTests :: [TestTree]+yamlTests =+  [ testCase "YAML 1.2 core schema: no Norway problem" $ do+      l <- expectOk (from (fromText yaml "country: NO\nflag: on\nyes_: yes\nt: true\nn: ~\ni: 0x1F\nf: 1.5e3\nq: '42'\n"))+      let node k = fmap valueNode (findValue (keyPath k) l)+      node "country" @?= Just (String "NO")+      node "flag" @?= Just (String "on")+      node "yes_" @?= Just (String "yes")+      node "t" @?= Just (Bool True)+      node "n" @?= Just Null+      node "i" @?= Just (Num (Finite 31))+      node "f" @?= Just (Num (Finite 1500))+      node "q" @?= Just (String "42")+  , testCase "anchors, aliases and merge keys" $ do+      l <- expectOk (from (fromText yaml "base: &b\n  host: h\n  port: 1\nsite:\n  <<: *b\n  port: 2\ncopy: *b\n"))+      extractAt (keyPath "site") l @?= Right (Cfg "h" 2)+      extractAt (keyPath "copy") l @?= Right (Cfg "h" 1)+  , testCase "positions are one-based line and column" $ do+      l <- expectOk (from (fromText yaml "a: 1\nb:\n  c: x\n"))+      fmap (tagPos . valueTag) (findValue (keyPath "b.c") l) @?= Just (Just (Pos 3 6))+  , testCase "duplicate keys and multiple documents are errors" $ do+      es <- expectErr (from (fromText yaml "a: 1\na: 2\n"))+      kinds es @?= [DuplicateKey "a"]+      es2 <- expectErr (from (fromText yaml "a: 1\n---\nb: 2\n"))+      case kinds es2 of+        [SyntaxError m] -> assertBool (Text.unpack m) ("multiple" `Text.isInfixOf` m)+        other -> assertFailure (show other)+  , testCase "an empty file is an empty configuration" $ do+      l <- expectOk (from (fromText yaml ""))+      (extract l :: Either ConfigErrors (Map.Map Text Int)) @?= Right Map.empty+  ]++serializedTests :: [TestTree]+serializedTests =+  [ testCase "defaults, keyed values and globals" $ do+      l <- expectOk $+        new+          `andThenMerge` defaults (Map.fromList [("host" :: Text, "d" :: Text)])+          `andThenMerge` keyed "port" (5 :: Int)+      extract l @?= Right (Cfg "d" 5)+      l2 <- expectOk (from (defaults (Map.fromList [("port" :: Text, 1 :: Int)])) <> from (globals (Map.fromList [("port" :: Text, 2 :: Int)])))+      extractAt (keyPath "port") (reselect "any" l2) @?= Right (2 :: Int)+  , testCase "serialized values point at the Haskell source line" $ do+      l <- expectOk (from (defaults (Map.fromList [("host" :: Text, "d" :: Text)])))+      case findMetadata (keyPath "host") l >>= metaSource of+        Just (CodeSource _) -> pure ()+        other -> assertFailure (show other)+  , testCase "a non-dictionary needs keyed" $ do+      es <- expectErr (from (defaults (5 :: Int)))+      case kinds es of+        [InvalidType _ _] -> pure ()+        other -> assertFailure (show other)+  ]+  where+    andThenMerge f p = merge p f
+ test/Figment/Test/Readme.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeFamilies #-}++-- | The examples from README.md, compiled and run, so the README cannot+-- rot (it did in 0.1: its headline example did not compile).+module Figment.Test.Readme (tests) where++import Data.Function ((&))+import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Figment as F+import qualified Figment.Jail as Jail+import qualified Figment.Provider.Env as Env++-- README: quick start ---------------------------------------------------++data Config = Config+  { name :: Text+  , port :: Int+  , debug :: Bool+  }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (F.FromConfig)++figment :: F.Figment+figment =+  F.new+    & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False]))+    & F.merge (F.file F.toml "App.toml")+    & F.merge (F.prefixed "APP_")++-- README: partial configurations ------------------------------------------++data ServerF f = Server+  { host :: F.Field f Text+  , listen :: F.Field f Int+  , workers :: F.Field f Int+  }+  deriving stock (Generic)++instance F.Partial ServerF++deriving stock instance Show (ServerF F.Identity)+deriving stock instance Eq (ServerF F.Identity)++serverDefaults :: ServerF Maybe+serverDefaults = (F.emptyPartial @ServerF) {listen = Just 8080, workers = Just 4}++tests :: TestTree+tests =+  testGroup+    "README"+    [ testCase "quick start" $ Jail.withJail $ \j -> do+        _ <- Jail.createFile j "App.toml" "name = \"demo\"\n"+        Jail.setEnv j "APP_DEBUG" "true"+        cfg <- F.loadExtractOrThrow figment+        cfg @?= Config "demo" 8080 True+    , testCase "partial configurations" $ do+        l <- F.load (F.from (Env.fromList [("SRV_HOST", "0.0.0.0")] (F.prefixed "SRV_")))+               >>= either (assertFailure . Text.unpack . F.renderErrors) pure+        F.extractPartial serverDefaults l @?= Right (Server "0.0.0.0" 8080 4)+    ]
+ test/Figment/Test/Tutorial.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeFamilies #-}++-- | Every code snippet in "Figment.Tutorial", compiled and run. If you+-- change one, change the other.+module Figment.Test.Tutorial (tests) where++import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit++import qualified Figment as F+import qualified Figment.Jail as Jail+import qualified Figment.Provider.Env as Env++-- §2 Your first configuration ---------------------------------------------++data Config = Config+  { name :: Text+  , port :: Int+  , debug :: Bool+  }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (F.FromConfig)++firstFigment :: F.Figment+firstFigment = F.from (F.file F.toml "App.toml")++-- §3 Layering sources --------------------------------------------------------++layered :: [Text] -> F.Figment+layered args =+  F.new+    & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False]))+    & F.merge (F.file F.toml "App.toml")+    & F.merge (F.prefixed "APP_")+    & F.merge (F.cli args)++-- §4 Environment variables ---------------------------------------------------++data Db = Db {host :: Text, port :: Int}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (F.FromConfig)++newtype WithDb = WithDb {db :: Db}+  deriving stock (Show, Eq, Generic)+  deriving anyclass (F.FromConfig)++dbFromEnv :: F.Figment+dbFromEnv = F.from (F.prefixed "APP_" & Env.split "__")++-- §6 Profiles ----------------------------------------------------------------++profiled :: F.Profile -> F.Figment+profiled p =+  F.new+    & F.merge (F.nested (F.file F.toml "App.toml"))+    & F.select p++-- §8 Decoding in depth -------------------------------------------------------++data Level = Debug | Info | Warning+  deriving stock (Show, Eq, Generic)+  deriving anyclass (F.FromConfig)++data Server = Server+  { listenAddress :: Text+  , maxConnections :: Int+  , logLevel :: Level+  }+  deriving stock (Show, Eq, Generic)++instance F.FromConfig Server where+  fromConfig =+    F.genericDecoder+      F.defaultOptions+        { F.fieldLabelModifier = F.snakeCase+        , F.rejectUnknownFields = True+        }++newtype Port = Port Int+  deriving stock (Show, Eq)++instance F.FromConfig Port where+  fromConfig = F.validate check F.fromConfig+    where+      check n+        | n > 0 && n < 65536 = Right (Port n)+        | otherwise = Left "a port must be between 1 and 65535"++data Endpoint = Endpoint {url :: Text, timeout :: Int, retries :: Int}+  deriving stock (Show, Eq)++instance F.FromConfig Endpoint where+  fromConfig =+    Endpoint+      <$> F.field "url"+      <*> F.fieldOr "timeout" 30+      <*> F.fieldOr "retries" 3++-- §9 Provenance --------------------------------------------------------------++data Paths = Paths+  { dataDir :: F.RelativePath+  , token :: F.Tagged Text+  }+  deriving stock (Show, Eq, Generic)++instance F.FromConfig Paths where+  fromConfig = F.genericDecoder F.defaultOptions {F.fieldLabelModifier = F.snakeCase}++-- §10 Partial configurations -------------------------------------------------++data AppF f = App+  { appName :: F.Field f Text+  , workers :: F.Field f Int+  , motd :: F.Field f (Maybe Text)+  }+  deriving stock (Generic)++instance F.Partial AppF++deriving stock instance Show (AppF F.Identity)+deriving stock instance Eq (AppF F.Identity)++type App = AppF F.Identity++appDefaults :: AppF Maybe+appDefaults = (F.emptyPartial @AppF) {workers = Just 4}++-- §11 For library authors -----------------------------------------------------++libraryFigment :: F.Figment+libraryFigment =+  F.new+    & F.merge (F.defaults (Aeson.object ["workers" .= (4 :: Int)]))+    & F.merge (F.prefixed "MYLIB_")++applicationFigment :: F.Figment+applicationFigment = libraryFigment <> F.from (F.file F.toml "MyApp.toml")++-- §12 Writing a provider ------------------------------------------------------++-- | Configuration held in a Haskell map, e.g. fetched from a secrets+-- service at startup.+newtype Secrets = Secrets (Map.Map Text Text)++instance F.Provider Secrets where+  metadata _ = F.named "secrets service"+  provide _limits (Secrets m) =+    pure (Right (Map.singleton F.Default (fmap (F.Value untaggedTag . F.String) m)))++untaggedTag :: F.Tag+untaggedTag = F.Tag Nothing Nothing Nothing Nothing++-- tests --------------------------------------------------------------------++ok :: F.Figment -> IO F.Loaded+ok f = F.load f >>= either (assertFailure . Text.unpack . F.renderErrors) pure++tests :: TestTree+tests =+  testGroup+    "tutorial"+    [ testCase "§2 first configuration" $ Jail.withJail $ \j -> do+        _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 8080\ndebug = false\n"+        cfg <- F.loadExtractOrThrow firstFigment+        cfg @?= Config "demo" 8080 False+    , testCase "§3 layering" $ Jail.withJail $ \j -> do+        _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 9000\n"+        Jail.setEnv j "APP_DEBUG" "true"+        cfg <- F.loadExtractOrThrow (layered ["--port=9100"])+        cfg @?= Config "demo" 9100 True+    , testCase "§4 env" $ Jail.withJail $ \j -> do+        Jail.setEnv j "APP_DB__HOST" "db.internal"+        Jail.setEnv j "APP_DB__PORT" "5432"+        cfg <- F.loadExtractOrThrow dbFromEnv+        cfg @?= WithDb (Db "db.internal" 5432)+    , testCase "§6 profiles" $ Jail.withJail $ \j -> do+        _ <- Jail.createFile j "App.toml" $ Text.unlines+          [ "[default]", "name = \"app\"", "port = 8080", "debug = true"+          , "[production]", "port = 80", "debug = false" ]+        dev <- F.loadExtractOrThrow (profiled F.Default)+        prod <- F.loadExtractOrThrow (profiled "production")+        dev @?= Config "app" 8080 True+        prod @?= Config "app" 80 False+    , testCase "§7 errors as values" $ do+        l <- ok (F.from (F.fromText F.toml "name = 1\n"))+        case F.extract l :: Either F.ConfigErrors Config of+          Left errs -> map F.errorKind (F.errorList errs)+            @?= [ F.InvalidType "integer 1" "a string", F.MissingField "port", F.MissingField "debug" ]+          Right v -> assertFailure (show v)+    , testCase "§8 decoding" $ do+        l <- ok (F.from (F.fromText F.yaml "listen_address: 0.0.0.0\nmax_connections: 100\nlog_level: info\n"))+        F.extract l @?= Right (Server "0.0.0.0" 100 Info)+        l2 <- ok (F.from (F.fromText F.json "{\"port\": 0, \"api\": {\"url\": \"https://x\"}}"))+        case F.extractAt (F.keyPath "port") l2 :: Either F.ConfigErrors Port of+          Left errs -> map F.errorKind (F.errorList errs) @?= [F.Message "a port must be between 1 and 65535"]+          Right v -> assertFailure (show v)+        F.extractAt (F.keyPath "api") l2 @?= Right (Endpoint "https://x" 30 3)+    , testCase "§9 provenance" $ Jail.withJail $ \j -> do+        path <- Jail.createFile j "conf/app.toml" "data_dir = \"data\"\ntoken = \"t0k3n\"\n"+        l <- ok (F.from (F.fileExact F.toml path))+        case F.extract l of+          Right (Paths d t) -> do+            F.relative d @?= Jail.jailDirectory j <> "/conf/data"+            fmap F.metaName (F.taggedMetadata t) @?= Just "TOML file"+          Left e -> assertFailure (Text.unpack (F.renderErrors e))+    , testCase "§10 partial" $ do+        l <- ok (F.from (F.fromText F.toml "appName = \"x\"\n"))+        F.extractPartial appDefaults l @?= (Right (App "x" 4 Nothing) :: Either F.ConfigErrors App)+        l2 <- ok (F.from (F.fromText F.toml ""))+        case F.extractPartial appDefaults l2 of+          Left errs -> map F.errorKind (F.errorList errs) @?= [F.MissingField "appName"]+          Right v -> assertFailure (show v)+    , testCase "§11 library figments compose" $ Jail.withJail $ \j -> do+        _ <- Jail.createFile j "MyApp.toml" "workers = 16\n"+        l <- ok applicationFigment+        F.extractAt (F.keyPath "workers") l @?= Right (16 :: Int)+    , testCase "§12 custom provider" $ do+        l <- ok (F.from (Secrets (Map.fromList [("token", "s3cret")])))+        F.extractAt (F.keyPath "token") l @?= Right ("s3cret" :: Text)+        fmap F.metaName (F.findMetadata (F.keyPath "token") l) @?= Just "secrets service"+    , testCase "§13 testing without global state" $ do+        l <- ok (F.from (Env.fromList [("APP_PORT", "1")] (F.prefixed "APP_")))+        F.extractAt (F.keyPath "port") l @?= Right (1 :: Int)+    ]
+ test/Spec.hs view
@@ -0,0 +1,33 @@+module Main (main) where++import Test.Tasty++import qualified Figment.Test.Adversarial as Adversarial+import qualified Figment.Test.Cli as Cli+import qualified Figment.Test.Decode as Decode+import qualified Figment.Test.Env as Env+import qualified Figment.Test.Errors as Errors+import qualified Figment.Test.Figment as Figment+import qualified Figment.Test.MergeLaws as MergeLaws+import qualified Figment.Test.Partial as Partial+import qualified Figment.Test.Providers as Providers+import qualified Figment.Test.Readme as Readme+import qualified Figment.Test.Tutorial as Tutorial++main :: IO ()+main =+  defaultMain $+    testGroup+      "figment"+      [ MergeLaws.tests+      , Figment.tests+      , Decode.tests+      , Partial.tests+      , Providers.tests+      , Env.tests+      , Cli.tests+      , Errors.tests+      , Adversarial.tests+      , Readme.tests+      , Tutorial.tests+      ]
+ test/compile-fail/EmptyType.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-}+-- Must fail: an empty data type cannot be decoded.+module EmptyType where++import GHC.Generics (Generic)+import Figment (FromConfig)++data Never+  deriving stock (Generic)+  deriving anyclass (FromConfig)
+ test/compile-fail/NoValueSemigroup.hs view
@@ -0,0 +1,8 @@+-- Must fail: coalescing values is not associative, so Value has no+-- Semigroup instance (the lawful monoid is on Figment).+module NoValueSemigroup where++import Figment (Value)++combineValues :: Value -> Value -> Value+combineValues = (<>)
+ test/compile-fail/Ok.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, OverloadedStrings, TypeFamilies #-}+-- Must compile: the positive control for the fixtures above.+module Ok where++import Data.Text (Text)+import GHC.Generics (Generic)+import Figment (Field, FromConfig, Partial, Figment, new, merge, prefixed)++data AppF f = App {host :: Field f Text, port :: Field f Int}+  deriving stock (Generic)++instance Partial AppF++data Plain = Plain {x :: Int}+  deriving stock (Generic)+  deriving anyclass (FromConfig)++figment :: Figment+figment = merge (prefixed "APP_") new
+ test/compile-fail/PartialSum.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveGeneric, DerivingStrategies, TypeFamilies #-}+-- Must fail: a Partial configuration must be a single-constructor record.+module PartialSum where++import Data.Text (Text)+import GHC.Generics (Generic)+import Figment (Field, Partial)++data ModeF f = A {a :: Field f Text} | B {b :: Field f Int}+  deriving stock (Generic)++instance Partial ModeF
+ test/golden/decode-many.txt view
@@ -0,0 +1,15 @@+4 configuration errors:++error: missing field `name`+  --> key `name`+  = hint: no source sets it; it can be set as `name` in TOML source string, or `APP_NAME` in environment variables (prefix APP_)++error: unknown field `hots`+  --> key `db.hots` in TOML source string at line 4, column 8+  = hint: did you mean `host`?++error: invalid value: found integer 70000, expected an integer in the range 0..65535+  --> key `db.port` in TOML source string at line 3, column 8++error: unknown variant `verbose`, expected one of `Debug`, `Info`+  --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_)
+ test/golden/err-configuration.txt view
@@ -0,0 +1,1 @@+ConfigurationError "Depth" "must be a positive Int"
+ test/golden/err-decode.txt view
@@ -0,0 +1,1 @@+DecodeError (Path [Key "port"]) "expected Int, got String"
+ test/golden/err-depth.txt view
@@ -0,0 +1,1 @@+DepthExceeded (Path [Key "a",Key "b",Key "3"]) (UnsafeDepth 64)
+ test/golden/err-missing.txt view
@@ -0,0 +1,1 @@+MissingKey (Path [Key "host"])
+ test/golden/err-source.txt view
@@ -0,0 +1,1 @@+SourceError "config.toml" "unexpected token at line 3"
+ test/golden/err-validation.txt view
@@ -0,0 +1,1 @@+ValidationError (Path []) "port must be in 1..65535"
+ test/golden/load-failures.txt view
@@ -0,0 +1,10 @@+3 configuration errors:++error: duplicate key `a`+  --> key `a` in YAML source string at line 2, column 1++error: syntax error: parse error: unexpected end-of-line+  --> top level in TOML source string at line 1, column 5++error: `APP_DB` conflicts with `APP_DB__HOST`: one sets a value where the other needs a dictionary+  --> key `db` (`APP_DB`) in environment variables (prefix APP_)
+ test/golden/missing.txt view
@@ -0,0 +1,3 @@+error: missing field `name`+  --> key `name`+  = hint: no source sets it; it can be set as `name` in JSON source string, `APP_NAME` in environment variables (prefix APP_), or `--name` in command-line arguments
+ test/golden/single.txt view
@@ -0,0 +1,2 @@+error: invalid type: found string "x", expected an integer+  --> key `db.port` in JSON source string