packages feed

tadka (empty) → 2.0.0.0

raw patch · 77 files changed

+10179/−0 lines, 77 filesdep +aesondep +ansi-terminaldep +arraybinary-added

Dependencies added: aeson, ansi-terminal, array, attoparsec, base, bytestring, containers, ghc, hedgehog, megaparsec, network-uri, prettyprinter, prettyprinter-ansi-terminal, tadka, template-haskell, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,539 @@+# Changelog for `tadka`++All notable changes are recorded here. ++## 2.0.0.0 — miette-parity hardening++### Multi-source diagnostics (Phase 12)+- **Breaking:** `Tadka.Internal.Renderer.Json`'s `LabelDTO` gains a `file`+  field, present on every label (`ldFile`/`"file"` in the serialized JSON),+  including stale ones. Every existing JSON golden fixture with at least one+  label changes shape (`json-single`, `json-cycle`, `json-truncated`);+  `json-cause` is unaffected (its diagnostic has no context at all). This+  closes a real, pre-existing gap independent of multi-source support: the+  JSON DTO never named which file a label belonged to, even for a+  single-source diagnostic.+- `Context` now holds a non-empty, ORDERED sequence of source groups+  (`SourceGroup`: one `NamedSource` plus its own non-empty, order-preserving+  label list) instead of exactly one source. This is a strict generalisation:+  a single-source `Context` is now the one-group case of the same+  representation, not a different shape. Every existing guarantee —+  label count/order preserved, `LabelStale` in place rather than dropped —+  now holds pointwise, per group; group order itself is preserved too.+- New construction API, mirroring the single-source functions one level up:+  `mkContextMulti` (strict; `Left` on the first out-of-bounds span in+  group-then-label order), `mkContextMultiDegrading` (total; degrades per+  label within its own group), and `Tadka.Internal`'s `buildContextMulti`+  (the multi-source convenience entry point, analogous to `buildContext`\/+  `buildContextWith` — a source paired with no labels contributes no group,+  mirroring `buildContext`'s empty-list convention per source). `mkContext`,+  `mkContextDegrading`, `buildContext`, and `buildContextWith` are now+  implemented as the one-group special case of their multi- counterparts —+  not a second copy of the resolution logic — and are unchanged in signature+  and behaviour (proven byte-identical: every existing graphical and+  narratable golden fixture is unchanged).+- All three renderers updated to walk every source group, in order:+  - **Graphical** — one `┌─ file:line:col` gutter block per group, separated+    by the same lone-rail-line convention `relatedChild` already uses between+    a nested diagnostic's snippet and its related forest. The gutter width is+    now the maximum needed across every group, so indentation (help/see/+    related lines) stays aligned across a multi-file report. A one-group+    context renders exactly the single block it always did, with no+    separator.+  - **Narratable** — one `Location: ...` sentence and its label readouts per+    group, in group order.+  - **JSON** — every label's DTO carries the name of its own group's source+    via the new `file` field.+- The derive macro (`deriveDiagnostic`) and `genericContext` remain+  single-source only in v1; `buildContextMulti` is a hand-written-instance+  entry point. Deferred, not forgotten, for a future release. §6.+- New `Phase12` property group (6 properties, 100 generated cases each):+  `mkContextMulti`/`mkContextMultiDegrading`'s per-group and cross-group+  count/order guarantees, the single-source functions' exact equivalence to+  their one-group multi- counterparts, and `buildContextMulti`'s empty-group+  handling. New `cross-file` / `narr-cross-file` / `json-cross-file` golden+  fixtures, exercising a real two-file diagnostic through all three handlers.+  Full existing suite (property + golden) re-verified with zero regressions+  beyond the three JSON fixtures the `file` field intentionally changes.++### Issue remediation pass+- **Breaking:** `StaleReason` loses its `SourceMismatch` constructor.+  `resolveSpan` never produced it — the only real producer path is+  out-of-bounds resolution — so it was a representable-but-unreachable state.+  Removing it also tightens `Narratable.hs`'s `staleSentence`, which handled+  it, to a total single-clause match that will now fail to compile (instead+  of silently matching a wildcard) if a future `StaleReason` constructor is+  ever added without updating every renderer.+- Fixed: multiple same-kind labels (e.g. two `Secondary` labels on one line)+  were visually indistinguishable under `ColorNever`, since `caretGlyph` only+  looked at `LabelKind`, not position. The underline glyph is now chosen by a+  per-kind rank: the first label of a kind keeps its existing anchor (`^` for+  `Primary`, `-` for `Secondary`), and a second-or-later same-kind label+  cycles through `~` (then `=`). Colour-mode output is unaffected — the glyph+  is always `^` there, exactly as before.+- Fixed: the graphical handler previously discarded `Ann` annotations+  (`AnnCode`, `AnnKeyword`, `AnnFilename`, `AnnEmphasis`) on message/label/help+  text, rendering plain, unstyled text regardless of author intent. It now+  interprets them at its own render boundary — ANSI styling under any colour+  mode, a plain-text fallback marker (backtick/quote) under `ColorNever` — the+  same way `Narratable.hs`'s `toProseMarker` already did for prose output.+- Fixed: `deriveDiagnostic` had no way to generate `diagnosticCause`. New+  `specCause` field on `DiagnosticSpec` names a `Maybe SomeDiagnostic`-typed+  field (validated at splice time, same discipline as `specRelated`); the+  generated method body is a bare field accessor. New `WrongCauseType`+  compile-fail case.++### Collection labels in `deriveDiagnostic`+- New `specLabelCollectionFields`/`specSecondaryLabelCollectionFields` on+  `DiagnosticSpec`: each names a `[Span]`-typed field (validated at splice+  time, same as `specLabelFields`), and every element of that field's runtime+  list becomes its own label sharing the given text — for a variable number of+  same-kind occurrences (every prior declaration of a name, every match of a+  banned pattern) known only when the diagnostic is built, where+  `specLabelFields` needs one field per label fixed at splice time. Rendered+  after all fixed-field labels, in field order then list order; an empty+  runtime list simply contributes no labels.+- TH-layer only, as intended: `buildContext`/`buildContextWith` are completely+  unchanged, since they already accept a plain, arbitrary-length list — the+  splice just expands a collection field into that same shape and appends it.+  A spec with no collection fields generates byte-identical code to before+  this feature existed (the expansion is only spliced in when at least one+  collection field is actually declared), so no existing derived instance's+  generated code changes shape.+- New `WrongCollectionType` compile-fail case (a `Span`-typed, not+  `[Span]`-typed, field must be rejected at the splice site) alongside the+  existing ones in `tools/check-compile-fail.sh`. A new `LabelCollection`+  property group proves a derived instance with collection fields renders+  identically, across all three handlers, to a hand-written+  `buildContext`/`buildContextWith` call expanding the same randomly generated+  list — for varying list lengths (including empty and a 200-element+  totality check), an all-primary-only collection, and a mixed+  fixed-primary-plus-secondary-collection instance.++### Terminal hyperlinks: OSC 8 for the `= see:` URL+- The graphical handler now wraps a diagnostic's `url` in an OSC 8 terminal+  hyperlink escape when `HyperlinkMode` allows it, so a supporting terminal+  renders the `= see:` line as a clickable link instead of plain text a user+  must select and copy by hand. New `HyperlinkMode` (`Auto`/`Always`/`Never`,+  mirroring `ColorMode`/`UnicodeMode`) and `withHyperlinkMode`; `TerminalCaps`+  gains `capNoHyperlink`/`capForceHyperlink` (`NO_HYPERLINK`/`FORCE_HYPERLINK`+  — the latter an existing convention from the `supports-hyperlinks` package)+  and `resolveHyperlink` resolves `Auto` the same three-tier way `resolveColor`+  does. Defaults to `HyperlinkNever`, not `Auto` (unlike colour/Unicode): OSC 8+  has no reliable capability query the way TTY-ness does, so defaulting off+  keeps every existing caller's output byte-for-byte unchanged until they opt+  in. Narratable and JSON output are untouched — this is a graphical-only+  affordance. Only ever wraps an already-validated `Url` (never raw `Text`), so+  the wrap is injection-safe by construction rather than by an extra runtime+  check: `mkUrl`'s absolute-URI grammar has no production admitting a raw+  control byte. A new `single-label-hyperlink` golden fixture pins the exact+  escape bytes; a dedicated property group proves the resolver mirrors colour's+  three-tier law, the wrap touches only the URL (a diagnostic without one+  renders identically under `Always` and `Never`), and `Never` output never+  contains an escape.++### Security hardening (untrusted-input robustness)+- **Terminal-escape / control-character injection (High).** Raw control+  characters (`ESC`, `BEL`, `BS`, DEL, C1) in attacker-controlled source or label+  text previously passed through verbatim into graphical and narratable output,+  even in `ColorNever` mode — a terminal-injection vector when diagnosing+  untrusted code. All three handlers now strip control characters from rendered+  text (source lines keep `\t` for tab expansion; the substitution is+  width-preserving so caret columns are unmoved). JSON is included because aeson+  escapes only `<0x20`, leaving DEL/C1 raw. A property asserts no control+  character other than the `\n` line separator survives in any handler's output+  over adversarial generated input.+- **Unbounded output from wide spans (Medium, availability).** A span across a+  huge line range rendered output proportional to the span (a line-1→5000 span+  produced 5002 lines). The planner now caps the contiguous range and falls back+  to a bounded context window with elision, so output is proportional to the+  diagnostic, not the span (that case now renders ~11 lines); every labelled line+  still appears. Small diagnostics are unchanged, so golden fixtures stay+  byte-identical. A property bounds output for a 10000-line span.+++### Robustness: production edge cases mined from miette's history+- Added a `Production edge cases (from miette)` property group translating+  miette's bug-fix history into tadka tests, and fixed the two gaps it exposed:+  CRLF (`\r\n`) sources left a stray carriage return in rendered lines+  (miette #37) — `SourceCode` now strips a trailing `\r` per line; and a newline+  embedded in a label or message could break the caret/gutter layout+  (miette #318) — the graphical and narratable handlers now flatten newlines in+  rendered text fragments to spaces (JSON keeps them, escaped). tadka was+  already robust to the rest: zero-length/point spans (#204/#159/#32), spans+  past end-of-line/EOF (#221/#347), empty sources (#183), offset-0 labels,+  wide-char + tab alignment (#202), combining marks (#312/#314), nested/+  overlapping spans (#316), and multi-line spans not skipping lines (#81), plus+  a totality sweep over out-of-range spans on all three targets.+++### Snippet renderer rework — Phase III: multi-line span rendering+- Multi-line spans (start line < end line) are no longer clamped to the start+  line: they render with a connector gutter between the rail and the source —+  `\x256D` opening, `\x2502` continuation, `\x2570` closing (ASCII `/`, `|`,+  `\\`) — with the label shown inline on the closing line. The pure core lives+  in `Tadka.Internal.Renderer.Layout`: greedy interval-graph lane assignment so+  overlapping spans get distinct lanes while disjoint spans reuse one, plus a+  `cellAt` classifier. It is glyph-free and Int-only, so it is fully proven:+  distinct spans on one lane never share a line (the collision proof), lanes are+  contiguous, coverage is order-preserving, and `cellAt` classifies correctly.+  End-to-end properties add that every multi-line span draws exactly one opening+  and one closing corner and that the label text is shown — the second of which+  caught a real lane-reuse bug (a lane hosting two disjoint spans rendered only+  the first) before it could ship. Single-line diagnostics are unaffected (the+  gutter has zero width when there are no multi-line spans), so all existing+  golden fixtures stay byte-identical; a `multi-line` fixture locks the art.+- Note: multiple single-line labels on the same line still render as stacked+  caret lines (correct, and unchanged) rather than horizontally packed onto one+  line with routed connectors. True same-line packing is deferred as optional+  polish; it does not fall out of the multi-line lane engine as cleanly as first+  thought, and stacked carets are unambiguous.++### Snippet renderer rework — Phase II: context lines + gap elision+- New pure planner `Tadka.Internal.Renderer.LinePlan` (`PlanEntry`, `planLines`)+  decides which source lines to render and where to elide, as an IR between+  resolved labels and glyphs. `withContextLines n` shows n lines around each+  labelled line and elides the gaps (a `⋮` marker); unset (default) renders the+  contiguous labelled range with no elision, so all golden fixtures stay+  byte-identical. The graphical window fetch now derives from the plan's shown+  lines (via `SourceCode.scLineCount`), not the anchor range. Properties prove+  the planner is total, `Nothing` reproduces the contiguous range, and with+  context every in-range anchor is shown, line numbers strictly increase and+  stay in bounds, and every elision hides at least one line.++### Snippet renderer rework — Phase I: pluggable SourceCode+- New `Tadka.Internal.SourceCode` class: a total, windowed source-reading seam+  (`scName`, `scLines (firstLine, lastLine)`). `NamedSource` is the canonical+  in-memory instance; the graphical and narratable handlers now fetch only the+  line window they render through it, so a lazy/file-backed instance is possible+  later. Pure refactor — all golden fixtures byte-identical. Properties prove the+  instance is total and its windows equal a filter of the full line enumeration.+++### Totality: no partial functions in the library+- Removed every use of a partial function primitive from `src/`. `head`/`!!`,+  `maximum`/`minimum`, and `Data.Array.(!)` are gone from all call sites: caret+  layout and line lookup now pattern-match `drop`; gutter/line-range use+  `foldr max`/`foldr min` with seeds; palette indexing uses total `NonEmpty`+  operations; and array indexing is encapsulated in a single total `atMay`+  (guarded by `inRange`, returning `Maybe`). Behaviour is unchanged — all 14+  golden fixtures remain byte-identical — so this is a pure totality hardening.+++### Primary vs secondary labels+- Labels now carry a `LabelKind` (`Primary`/`Secondary`). `buildContext` marks+  everything `Primary` (so existing callers and fixtures are unchanged); a new+  `buildContextWith` takes explicit kinds, and the derive macro gained+  `specSecondaryLabelFields`. All three handlers are kind-aware: the graphical+  and narratable reports anchor their location on the first primary label; the+  graphical handler draws primary labels with `^` in the severity colour and+  secondary labels with `-` in a palette colour; the narratable handler leads+  with "The problem is at" vs "Related context is at"; and the JSON DTO gains a+  per-label `primary` flag. Properties prove the location anchors on the primary,+  the JSON flag tracks the kind, `^`/`-` by kind, and — extending the Phase 8+  guarantee — a derived instance with secondary fields renders byte-identically+  to a hand-written `buildContextWith` instance across all three handlers.++### Cause chain (diagnostic_source analogue)+- New `diagnosticCause :: e -> Maybe SomeDiagnostic` class method (default+  `Nothing`) and a total, depth- and cycle-safe `walkCauses` (cycle detection by+  `diagnosticId`, mirroring `walkRelated`). The chain renders as lightweight+  linear provenance — graphical `= caused by: …` lines, narratable `Caused by: …`+  sentences, and a JSON `causes` array — kept deliberately distinct from the+  tree-shaped `related`. The shared generator now emits causes, so the Phase 11+  render-totality-over-every-target property covers cause chains too; dedicated+  properties prove cyclic chains terminate on every target, an id-cyclic cause's+  marker renders at most once, and a real chain produces a "caused by" line.+- Hardened `tools/check-compile-fail.sh` to build the library under the default+  configuration first, so `cabal exec` always exposes a consistent `tadka`.++### Terminal detection & ANSI colour (graphical handler)+- `reportDiagnostic` now detects the sink's capabilities and resolves `ColorAuto`+  / `UnicodeAuto` to concrete modes before rendering: `NO_COLOR` disables colour,+  `CLICOLOR_FORCE` forces it, otherwise colour follows TTY status; Unicode follows+  a UTF-8 locale check (`LC_ALL` > `LC_CTYPE` > `LANG`). So piped/CI output no+  longer risks stray escapes, and non-UTF-8 terminals get the ASCII box glyphs+  automatically. `selectRenderer` stays pure — resolution is the only new IO.+- New `Tadka.Internal.Terminal`: `detectTerminalCaps` (IO) plus the pure, total+  `resolveColor` / `resolveUnicode` / `resolveConfig`. Properties prove explicit+  modes pass through untouched; `NO_COLOR` always wins; force beats TTY; `Auto`+  otherwise follows TTY/locale; `resolveConfig` eliminates every `Auto`, is+  idempotent, and changes only the two mode fields.+- The graphical handler now emits ANSI: the severity/code header is coloured by+  severity (bold), and each label's carets + text take their palette colour+  (`withLabelPalette`) — delivering the per-label colour deferred in Phase 5.+  Under `ColorNever` no ANSI is emitted (proved over generated diagnostics) and+  underline glyphs cycle `^`/`~`/`-`, so all golden fixtures stay byte-identical.+  A structural property proves colour adds only ANSI and a uniform caret glyph,+  never a layout change.++### Tab-stop expansion (graphical handler)+- Source lines are rendered with tabs expanded to the next tab stop, and caret+  columns are computed with the same tab-aware `displayColumnAt`, so a caret now+  aligns under a span on a tab-indented line instead of drifting. Tab width is+  configurable via `withTabWidth` (default 4); character columns reported by the+  narratable and JSON handlers are unchanged (a tab is one character).+- New total helpers `Tadka.Internal.Width.displayColumnAt` / `expandTabs`, with+  properties proving: expansion leaves no tabs; expanded width equals+  `displayColumnAt` of the whole line; `displayColumnAt` is monotonic; a tab+  always lands on a tab stop; and — the alignment guarantee — a caret's display+  offset equals the width of the tab-expanded source preceding the span. A+  `tab-indented` golden fixture locks the visual result.++## 1.0.0.0 — v1++First release. All eleven phases of the implementation spec are complete; the+public API matches vision §8.++### Phase 11 — Consolidation & Release Audit+- Public API surface reconciled to vision §8: `Offset`/`Length` (and their+  constructors, accessors, error types, and the `spanOffset`/`spanLength`+  accessors that exposed them) are no longer public — spans are the public+  position type, and the offset representation lives in "Tadka.Internal.Types"+  with no compatibility guarantee. A negative compile check confirms they are+  unreachable from `Tadka`.+- Dependency upper bounds added to the library and every interop sub-library;+  `cabal check` is clean. Version set to `1.0.0.0`.+- Consolidated golden suite (10 fixtures: the six canonical renderings, the+  prose and JSON depth-truncation forms, the JSON cycle form, and the+  generated-instance discipline fixture) and property suite (all groups from+  Phases 1–9) run together via `make test` / CI.+- New consolidated properties: `render` totality broadened to a single Hedgehog+  property over *every* target; a cycle-detection marker property (a repeated+  `diagnosticId`'s marker renders at most once, on all three handlers); and the+  vision's Success Criterion end-to-end — a misspelled span field is a compile+  error (`test/compile-fail/SuccessCriterion.hs`), and a genuinely staled span+  renders a clear in-report reason (graphical, narratable, and an explicit JSON+  `"stale":true`) rather than a silently shorter report.+++### Phase 10 — Interop Helpers+- One-directional adapters turning parser positions into tadka `Span`/`Offset`,+  each a plain function against Phase 1/2 types with no new core surface:+  - `Tadka.Interop.Megaparsec`: `spanFromError` from a megaparsec+    `ParseError`'s stream `errorOffset`.+  - `Tadka.Interop.Attoparsec`: `consumedOffset`/`spanFromConsumed` (attoparsec+    reports no line/column, so position is recovered as characters consumed).+  - `Tadka.Interop.GHC`: `spanFromSrcSpan` converting a GHC `SrcSpan` (with the+    source text, to turn 1-based line/column into an offset).+- Each adapter is a **separate cabal sub-library** (`interop-megaparsec`,+  `interop-attoparsec`, `interop-ghc`) depending on `tadka`, so the core library+  never depends on a parser package and no core module can import interop — the+  adapters are one-directional by construction. Minimum upstream versions are+  pinned (`megaparsec >=9.0`, `attoparsec >=0.14`, the GHC 9.10 `ghc` library)+  and noted in each module's haddock.+- Exit criteria met: a per-library round-trip test (`test-suite interop`)+  constructs a known failure, converts its position, resolves against the same+  source, and confirms the line/column matches what the library reports+  (megaparsec, GHC) or the consumed offset (attoparsec); and an audit confirms+  the core library has no parser/ghc dependency and imports no interop module.++### Phase 9 — Generics-Based Label-Wiring Derivation+- `genericContext :: (Generic e, ...) => e -> Context` derives __only__ the+  `context` method, via GHC.Generics, for a record with exactly one+  `NamedSource` field and one or more `Span` fields — using each span field's+  record-selector name as its label text and calling the same `buildContext`.+  Used as `context = genericContext` inside an otherwise hand-written instance.+- Deliberately scoped: its type (`e -> Context`) can touch nothing else, so+  `code`/`severity`/`help`/`url`/`message`/`diagnosticId` stay hand-written+  (each defaultable). This is one method, not "most of the ergonomics" — for the+  fuller path use `deriveDiagnostic`.+- The record shape is checked at compile time (a `Nat`-counting type family over+  the generic `Rep`): zero or several `NamedSource` fields, or no `Span` field,+  is a type error — never a silent guess about which field was meant. A+  compile-fail test (`TwoSources`) covers the two-source case.+- Exit criteria met: a property proves a generics-wired instance renders+  byte-for-byte identically to a hand-written `buildContext` twin across all+  three handlers, and the `e -> Context` signature confirms no other method is+  touched.++### Phase 8 — Derive Macro (`deriveDiagnostic`)+- `DiagnosticSpec` (with `specCode`, `specSeverity`, `specHelp`, `specUrl`,+  `specSourceField`, `specLabelFields`, `specRelated`, `specId`, `specMessage`)+  and `defaultSpec`, plus `deriveDiagnostic :: DiagnosticSpec -> Name -> Q [Dec]`,+  an ordinary TH splice (no type-level DSL).+- `reify`-validated at splice time: `specSourceField` must be `NamedSource`,+  each `specLabelFields` name `Span`, `specId` `Text` or `DiagnosticId`, and+  `specRelated` `[SomeDiagnostic]`; `specCode`/`specUrl` literals run through+  `mkDiagnosticCode`/`mkUrl`. Any mismatch is a compile error at the splice site.+  The default `message` (`pretty . show`) requires `Show`, checked via `isInstance`.+- Every generated method body is a direct call to a shared function exported+  from `Tadka.Internal` (`buildContext`, `unsafeDiagnosticCode`, `unsafeUrl`,+  `mkDiagnosticId`) or the field accessor — the derive path and a hand-written+  instance are two doors into the same room. `mkDiagnosticId` was added to the+  `Tadka.Internal` export list, and that module's haddock now states the+  discipline.+- Exit criteria met: compile-fail tests (`test/compile-fail/`, run by+  `tools/check-compile-fail.sh`) reject a wrong-typed field, a non-field name,+  and an invalid code literal at compile time; a property proves a derived+  instance renders byte-for-byte identically to a hand-written twin across all+  three handlers; the generated instance source is captured as a golden fixture+  and `tools/check-generated.sh` (a **required** CI check) fails the build on any+  non-direct-call method body; and a `CONTRIBUTING.md` checklist entry records+  the review convention.++### Phase 7 — JSON Report Handler + DTO+- Dedicated `DiagnosticDTO` / `LabelDTO` with hand-written `ToJSON` — never+  `deriving ToJSON` on a `Diagnostic`-bearing type. `ToJSON` only in v1;+  `FromJSON` is deferred.+- DTO shape per the canonical example: `code`, `severity`, `message`, `labels`+  (each `line`, `column`, `length`, `text`, and an explicit `stale`), `help`,+  `url`, `related`, `truncated`, `cycleOmitted`. The `stale` flag is derived+  from `LabelState` (stale labels carry null `line`/`column`/`length`), never+  inferred from absence.+- `related` recurses into nested DTOs; `truncated`/`cycleOmitted` are set from+  the Phase 3 walk's `TerminationReason` — the same two values the graphical and+  narratable handlers consume, serialized instead of prose-rendered.+- `renderJson` builds the DTO inside the `'TJson` branch and is the only route+  to `Output 'TJson = Aeson.Value` (audited: no `Diagnostic` type produces a+  `Value` except through this conversion). `render` now dispatches `'TJson`.+- Golden fixtures: `json-single` (byte-for-byte to the vision example, modulo+  the same coherent column correction as the other handlers), `json-cycle`+  (`cycleOmitted: true`), and `json-truncated` (nested `truncated: true`). The+  runner serializes the `Value` with a deterministic ordered pretty-printer to+  match the vision's canonical layout. Property suite: ok labels serialize+  `stale:false` with positions, stale labels `stale:true` with null positions,+  and the handler is total over the shared generated set.++### Phase 6 — Narratable Report Handler+- `renderNarratable` produces the accessibility-first prose form: an+  `Error,`/`Warning,`/`Advice,` opener with an optional `code X:` clause (dropped+  when there is no code), a `Location: file, line N, column M.` sentence, a+  `Source line N: "…".` readout, and a `The problem is at column(s) …, labeled: …`+  sentence per label.+- `LabelStale` has a prose equivalent of the graphical degraded marker+  (`A labeled position could not be shown because …`, carrying the stale reason+  and label) — never silently omitted.+- Related chains render as prose, consuming the Phase 3 walk: `Related: code —+  message.`, a cycle sentence, and an `N more related diagnostics … omitted at+  the depth limit.` marker (with correct singular/plural).+- `toProseMarker :: Ann -> Text` interprets `Ann` at this handler's boundary+  (inline code and file names are surrounded with quotes); rendered via+  `renderSimplyDecorated` so annotated content reads naturally.+- `render` now dispatches the `'TNarratable` branch to `renderNarratable`.+- Golden fixtures: `narr-single` (same diagnostic as the graphical single-label+  fixture, so the two handlers stay cross-consistent) and `narr-truncated`+  (a related chain past the depth limit, exercising the prose truncation marker).+  Property suite: `AnnCode` renders quoted, and the handler is total over the+  same shared generated set (now in `GenDiag`) used by Phase 5's smoke check.+- Field-coverage cross-check confirmed: code, severity, location, source line,+  label text, stale reason, help, url, and related each have a narratable+  equivalent — no field is dropped between renderers.++### Phase 5 — Graphical Report Handler+- `renderGraphical` renders a full graphical report: `error[code]: message`+  header (no brackets when there is no code; `advice:`/`warning:`/`error:` per+  severity), a `┌─ file:line:col` location line, a line-numbered gutter with a+  `│` rail, source lines sliced from the single stored `NamedSource`, and+  underline carets positioned by display width via `Tadka.Internal.Width`+  (combining marks, East-Asian-width, and emoji handled).+- Per-label underline cycling: label index *i* selects palette entry *i mod p*+  (`labelStyle`); under `ColorNever` the underline character cycles `^`/`~`/`-`+  so labels stay distinguishable in plain text. `UnicodeAscii` degrades the+  box-drawing glyphs to `|`/`+`/`-`.+- Stale labels render as `(span unavailable — source no longer matches at this+  position)` in place of a source line, in original order.+- Related chains consume the Phase 3 walk: each `CycleOmitted` node renders+  `= related: (cycle omitted)`, each `DepthTruncated` node+  `= related: (N more related diagnostics omitted)`, and ordinary nodes render+  a `= related: code — message` summary plus their own (indented) snippet.+- `render` now dispatches the `'TGraphical` branch to `renderGraphical`.+- Golden suite (byte-for-byte): single-label, multi-label, degraded, and+  cycle-omitted fixtures, rendered `ColorNever`/`UnicodeAlways` for determinism.+  Property suite: caret layout is non-negative, never collapses, and is+  width-aware (doubling as a width-table sync check); palette cycling equals+  *i mod p*; and the handler is total over fuelled generated diagnostics+  (including stale labels and both id-bearing and `Nothing`-id self-cycles).++  Deviations from the vision's hand-drawn examples (which are internally+  inconsistent) are deliberate and documented in the fixtures: correct column+  numbers, coherent underline-character cycling, full diagnostic codes in+  related summaries, and real line numbers rather than fabricated ones.++### Phase 4 — Renderer/Config Scaffolding+- `Tadka.Internal.Config`: `Target` (`TGraphical`/`TNarratable`/`TJson`,+  closed), `ColorMode`, `UnicodeMode`, opaque `Config` with `defaultConfig` and+  the `withColorMode` / `withUnicodeMode` / `withRelatedDepthLimit` /+  `withLabelPalette` / `withTarget` setters, plus the default six-colour palette.+- Three renderer modules with opaque `GraphicalOptions` / `NarratableOptions` /+  `JsonOptions` (no public constructor or accessor) and placeholder+  `renderGraphical` / `renderNarratable` / `renderJson` bodies (Phases 5–7).+- `Tadka.Internal.Render`: the `Renderer (t :: Target)` GADT (constructors+  exported for pattern matching), the closed `Output` type family, `SomeRenderer`,+  `render`, and `reportDiagnostic`. `selectRenderer` is the sole constructor of+  any `*Options` value and the sole reader of `Config` — the "one path".+- Property suite (Phase 4): an explicit `withTarget` override always yields the+  matching renderer constructor (even after other setters), the no-target+  default is graphical, and each target's render path runs. Verified by audit+  that `selectRenderer` is the only `*Options` construction site, and by+  negative compile check that the `*Options`/`Config` constructors are+  unreachable from `Tadka`.++### Phase 3 — `Diagnostic` Typeclass & Related/Cycle Walk+- `Tadka.Internal.Diagnostic`: the `Diagnostic` class (only `message`+  mandatory, no `Show` superclass; the other seven methods defaulted) and the+  `SomeDiagnostic` existential (no `Show` constraint).+- `Tadka.Internal.Related`: the single renderer-agnostic `related`-chain walk+  (`walkRelated`) producing a `RelatedTree` of `(SomeDiagnostic,+  TerminationReason)` where `TerminationReason` is `NotTerminated` /+  `DepthTruncated` / `CycleOmitted`. Cycle detection is by `diagnosticId` along+  the current path; termination is always guaranteed by the finite depth+  budget (`defaultRelatedDepth = 8`). Factored once here so Phases 5–7 share it+  rather than reimplementing.+- Property suite (Phase 3): cycle nodes are visited once and never descended;+  a structurally infinite `Nothing`-only chain still terminates by depth (v4+  fallback intact); the walk is total and depth-bounded for any fuelled tree.++### Phase 2 — Span Resolution & `Context`+- `Tadka.Internal.Span`: resolution-indexed `SpanF` GADT (`Span` /+  `ResolvedSpan`), `mkSpan`, `resolveSpan`, `LineCol`, `StaleReason`,+  `SpanError`. `ResolvedSpan` carries positions only — no owned text (v5 fix);+  its raw constructors are hidden so a resolved span can only come from+  `resolveSpan`.+- `Tadka.Internal.Context`: `Labeled`, `LabelState` (`LabelOk` / `LabelStale`),+  `Context` (`NoContext` / `HasLabels`), `mkContext` (strict), and+  `mkContextDegrading` (total). The degrading path turns an unresolvable span+  into a `LabelStale` marker in its original position, never dropping it — so+  label count and ordering are independent of which spans stayed valid.+- `Tadka.Internal.Context.buildContext` — the single plain dispatch both the+  derive macro (Phase 8) and manual instances call; re-exported from+  `Tadka.Internal`.+- `Tadka.Internal.Ann` (`Ann`) pulled forward from Phase 3, since `Labeled` /+  `buildContext` need `Doc Ann`; the renderer-boundary interpreters remain in+  Phases 5–7.+- Property suite (Phase 2): `resolveSpan` bounds safety, `mkContext` Left iff a+  span is out of bounds, the `mkContextDegrading` count/order guarantee, and+  `buildContext` dispatch. Suite reorganised into per-phase modules.++### Phase 1 — Primitive Types, Smart Constructors & the Width Table+- `Tadka.Internal.Types`: validated `Offset`, `Length`, `NamedSource`,+  `DiagnosticCode`, `Url`, `Severity`, and `DiagnosticId`, each with a smart+  constructor that enforces its invariant and a hidden raw constructor+  ("illegal states unrepresentable"). Explicit custom error types+  (`OffsetError`, `LengthError`, `SourceError`, `CodeError`, `UrlError`).+- Diagnostic-code grammar `^[a-z][a-z0-9_]*::E[0-9]{4,}$` validated without a+  regex dependency; URLs validated as absolute URIs via `network-uri`.+- `Severity` display strings centralised in `severityLabels` /+  `severityJsonTag` (one source of truth for Phases 5–7).+- Internal `unsafeDiagnosticCode` / `unsafeUrl` exposed only via+  `Tadka.Internal` for Phase 8 splice use; verified unreachable from `Tadka`.+- `Tadka.Internal.Width`: `charWidth`, `textWidth`, `graphemeBreakProperty`,+  and `isExtendedPictographic`, backed by a generated, checked-in+  `Tadka.Internal.Width.Table` (UCD 15.1.0), with binary-searched ranges.+- `tools/gen-width-table.hs` implemented: fetches four pinned UCD 15.1.0 files+  and emits the table; UCD version recorded in the generated header.+- Property suite (Hedgehog): smart-constructor rejection (with an independent+  grammar oracle), `NamedSource` round-trip, and width point lookups.+- Gated `-Werror` behind a manual `werror` flag (enabled for dev/CI via+  `cabal.project`) so `cabal check` passes and released builds stay installable.++### Phase 0 — Repo & Tooling Setup+- Cabal package skeleton with the fixed public/internal module layout+  (`Tadka` public; `Tadka.Internal.*` no-compatibility-guarantee).+- Dependency pins: `text`, `prettyprinter`, `prettyprinter-ansi-terminal`,+  `ansi-terminal`, `template-haskell`, `aeson`.+- `tools/gen-width-table.hs` scaffold (implemented in Phase 1).+- Two independently-runnable test suites (`golden`, `props`), each passing+  trivially on zero tests.+- CI skeleton building the library and running both suites independently.+- Warnings-as-errors (`-Wall -Wcompat -Werror`) from the first commit.
+ LICENSE view
@@ -0,0 +1,151 @@+Mozilla Public License+Version 2.0+1. Definitions+1.1. “Contributor”+means each individual or legal entity that creates, contributes to the creation of, or owns Covered Software.++1.2. “Contributor Version”+means the combination of the Contributions of others (if any) used by a Contributor and that particular Contributor’s Contribution.++1.3. “Contribution”+means Covered Software of a particular Contributor.++1.4. “Covered Software”+means Source Code Form to which the initial Contributor has attached the notice in Exhibit A, the Executable Form of such Source Code Form, and Modifications of such Source Code Form, in each case including portions thereof.++1.5. “Incompatible With Secondary Licenses”+means++that the initial Contributor has attached the notice described in Exhibit B to the Covered Software; or++that the Covered Software was made available under the terms of version 1.1 or earlier of the License, but not also under the terms of a Secondary License.++1.6. “Executable Form”+means any form of the work other than Source Code Form.++1.7. “Larger Work”+means a work that combines Covered Software with other material, in a separate file or files, that is not Covered Software.++1.8. “License”+means this document.++1.9. “Licensable”+means having the right to grant, to the maximum extent possible, whether at the time of the initial grant or subsequently, any and all of the rights conveyed by this License.++1.10. “Modifications”+means any of the following:++any file in Source Code Form that results from an addition to, deletion from, or modification of the contents of Covered Software; or++any new file in Source Code Form that contains any Covered Software.++1.11. “Patent Claims” of a Contributor+means any patent claim(s), including without limitation, method, process, and apparatus claims, in any patent Licensable by such Contributor that would be infringed, but for the grant of the License, by the making, using, selling, offering for sale, having made, import, or transfer of either its Contributions or its Contributor Version.++1.12. “Secondary License”+means either the GNU General Public License, Version 2.0, the GNU Lesser General Public License, Version 2.1, the GNU Affero General Public License, Version 3.0, or any later versions of those licenses.++1.13. “Source Code Form”+means the form of the work preferred for making modifications.++1.14. “You” (or “Your”)+means an individual or a legal entity exercising rights under this License. For legal entities, “You” includes any entity that controls, is controlled by, or is under common control with You. For purposes of this definition, “control” means (a) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (b) ownership of more than fifty percent (50%) of the outstanding shares or beneficial ownership of such entity.++2. License Grants and Conditions+2.1. Grants+Each Contributor hereby grants You a world-wide, royalty-free, non-exclusive license:++under intellectual property rights (other than patent or trademark) Licensable by such Contributor to use, reproduce, make available, modify, display, perform, distribute, and otherwise exploit its Contributions, either on an unmodified basis, with Modifications, or as part of a Larger Work; and++under Patent Claims of such Contributor to make, use, sell, offer for sale, have made, import, and otherwise transfer either its Contributions or its Contributor Version.++2.2. Effective Date+The licenses granted in Section 2.1 with respect to any Contribution become effective for each Contribution on the date the Contributor first distributes such Contribution.++2.3. Limitations on Grant Scope+The licenses granted in this Section 2 are the only rights granted under this License. No additional rights or licenses will be implied from the distribution or licensing of Covered Software under this License. Notwithstanding Section 2.1(b) above, no patent license is granted by a Contributor:++for any code that a Contributor has removed from Covered Software; or++for infringements caused by: (i) Your and any other third party’s modifications of Covered Software, or (ii) the combination of its Contributions with other software (except as part of its Contributor Version); or++under Patent Claims infringed by Covered Software in the absence of its Contributions.++This License does not grant any rights in the trademarks, service marks, or logos of any Contributor (except as may be necessary to comply with the notice requirements in Section 3.4).++2.4. Subsequent Licenses+No Contributor makes additional grants as a result of Your choice to distribute the Covered Software under a subsequent version of this License (see Section 10.2) or under the terms of a Secondary License (if permitted under the terms of Section 3.3).++2.5. Representation+Each Contributor represents that the Contributor believes its Contributions are its original creation(s) or it has sufficient rights to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use+This License is not intended to limit any rights You have under applicable copyright doctrines of fair use, fair dealing, or other equivalents.++2.7. Conditions+Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted in Section 2.1.++3. Responsibilities+3.1. Distribution of Source Form+All distribution of Covered Software in Source Code Form, including any Modifications that You create or to which You contribute, must be under the terms of this License. You must inform recipients that the Source Code Form of the Covered Software is governed by the terms of this License, and how they can obtain a copy of this License. You may not attempt to alter or restrict the recipients’ rights in the Source Code Form.++3.2. Distribution of Executable Form+If You distribute Covered Software in Executable Form then:++such Covered Software must also be made available in Source Code Form, as described in Section 3.1, and You must inform recipients of the Executable Form how they can obtain a copy of such Source Code Form by reasonable means in a timely manner, at a charge no more than the cost of distribution to the recipient; and++You may distribute such Executable Form under the terms of this License, or sublicense it under different terms, provided that the license for the Executable Form does not attempt to limit or alter the recipients’ rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work+You may create and distribute a Larger Work under terms of Your choice, provided that You also comply with the requirements of this License for the Covered Software. If the Larger Work is a combination of Covered Software with a work governed by one or more Secondary Licenses, and the Covered Software is not Incompatible With Secondary Licenses, this License permits You to additionally distribute such Covered Software under the terms of such Secondary License(s), so that the recipient of the Larger Work may, at their option, further distribute the Covered Software under the terms of either this License or such Secondary License(s).++3.4. Notices+You may not remove or alter the substance of any license notices (including copyright notices, patent notices, disclaimers of warranty, or limitations of liability) contained within the Source Code Form of the Covered Software, except that You may alter any license notices to the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms+You may choose to offer, and to charge a fee for, warranty, support, indemnity or liability obligations to one or more recipients of Covered Software. However, You may do so only on Your own behalf, and not on behalf of any Contributor. You must make it absolutely clear that any such warranty, support, indemnity, or liability obligation is offered by You alone, and You hereby agree to indemnify every Contributor for any liability incurred by such Contributor as a result of warranty, support, indemnity or liability terms You offer. You may include additional disclaimers of warranty and limitations of liability specific to any jurisdiction.++4. Inability to Comply Due to Statute or Regulation+If it is impossible for You to comply with any of the terms of this License with respect to some or all of the Covered Software due to statute, judicial order, or regulation then You must: (a) comply with the terms of this License to the maximum extent possible; and (b) describe the limitations and the code they affect. Such description must be placed in a text file included with all distributions of the Covered Software under this License. Except to the extent prohibited by statute or regulation, such description must be sufficiently detailed for a recipient of ordinary skill to be able to understand it.++5. Termination+5.1. The rights granted under this License will terminate automatically if You fail to comply with any of its terms. However, if You become compliant, then the rights granted under this License from a particular Contributor are reinstated (a) provisionally, unless and until such Contributor explicitly and finally terminates Your grants, and (b) on an ongoing basis, if such Contributor fails to notify You of the non-compliance by some reasonable means prior to 60 days after You have come back into compliance. Moreover, Your grants from a particular Contributor are reinstated on an ongoing basis if such Contributor notifies You of the non-compliance by some reasonable means, this is the first time You have received notice of non-compliance with this License from such Contributor, and You become compliant prior to 30 days after Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent infringement claim (excluding declaratory judgment actions, counter-claims, and cross-claims) alleging that a Contributor Version directly or indirectly infringes any patent, then the rights granted to You by any and all Contributors for the Covered Software under Section 2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all end user license agreements (excluding distributors and resellers) which have been validly granted by You or Your distributors under this License prior to termination shall survive termination.++6. Disclaimer of Warranty+Covered Software is provided under this License on an “as is” basis, without warranty of any kind, either expressed, implied, or statutory, including, without limitation, warranties that the Covered Software is free of defects, merchantable, fit for a particular purpose or non-infringing. The entire risk as to the quality and performance of the Covered Software is with You. Should any Covered Software prove defective in any respect, You (not any Contributor) assume the cost of any necessary servicing, repair, or correction. This disclaimer of warranty constitutes an essential part of this License. No use of any Covered Software is authorized under this License except under this disclaimer.++7. Limitation of Liability+Under no circumstances and under no legal theory, whether tort (including negligence), contract, or otherwise, shall any Contributor, or anyone who distributes Covered Software as permitted above, be liable to You for any direct, indirect, special, incidental, or consequential damages of any character including, without limitation, damages for lost profits, loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses, even if such party shall have been informed of the possibility of such damages. This limitation of liability shall not apply to liability for death or personal injury resulting from such party’s negligence to the extent applicable law prohibits such limitation. Some jurisdictions do not allow the exclusion or limitation of incidental or consequential damages, so this exclusion and limitation may not apply to You.++8. Litigation+Any litigation relating to this License may be brought only in the courts of a jurisdiction where the defendant maintains its principal place of business and such litigation shall be governed by laws of that jurisdiction, without reference to its conflict-of-law provisions. Nothing in this Section shall prevent a party’s ability to bring cross-claims or counter-claims.++9. Miscellaneous+This License represents the complete agreement concerning the subject matter hereof. If any provision of this License is held to be unenforceable, such provision shall be reformed only to the extent necessary to make it enforceable. Any law or regulation which provides that the language of a contract shall be construed against the drafter shall not be used to construe this License against a Contributor.++10. Versions of the License+10.1. New Versions+Mozilla Foundation is the license steward. Except as provided in Section 10.3, no one other than the license steward has the right to modify or publish new versions of this License. Each version will be given a distinguishing version number.++10.2. Effect of New Versions+You may distribute the Covered Software under the terms of the version of the License under which You originally received the Covered Software, or under the terms of any subsequent version published by the license steward.++10.3. Modified Versions+If you create software not governed by this License, and you want to create a new license for such software, you may create and use a modified version of this License if you rename the license and remove any references to the name of the license steward (except to note that such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary Licenses+If You choose to distribute Source Code Form that is Incompatible With Secondary Licenses under the terms of this version of the License, the notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular file, then You may include the notice in a location (such as a LICENSE file in a relevant directory) where a recipient would be likely to look for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - “Incompatible With Secondary Licenses” Notice+This Source Code Form is “Incompatible With Secondary Licenses”, as defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,353 @@+# Tadka++**Tadka** is a Haskell library for structured error diagnostics and source-span reporting.++It turns ordinary error values into useful diagnostic reports with source+locations, labeled spans, error codes, help text, related diagnostics, and+underlying causes.++The same diagnostic can be rendered as graphical terminal output, accessible+prose, or JSON.++`tadka` is useful for compilers, parsers, command-line tools, static+analyzers, DSLs, and other developer tooling.++It is inspired by Rust's [`miette`](https://github.com/zkat/miette), but is+designed around Haskell's types and conventions.++A snapshot of the error produced by tadka is as under:+++![Tadka graphical diagnostic](https://raw.githubusercontent.com/Bombay-Boyz/tadka/main/assets/tadka-diagnostic.png)+++## Why tadka?++**Tadka** adds a reporting layer to your existing error types. It does not+replace your application's error-propagation mechanism.++You can keep using:++```haskell+Either MyError a+```++or:++```haskell+ExceptT MyError IO a+```++or another error-handling design. Add a `Diagnostic` instance to describe how+the error should be presented.++The main features are:++- Source-aware diagnostics with labeled spans.+- Graphical, narratable, and JSON output.+- Primary and secondary labels, including collections of labels.+- Diagnostics spanning multiple source files.+- Error codes, severity, help text, and documentation URLs.+- Related diagnostics and underlying cause chains.+- Bounded rendering and cycle protection for diagnostic chains.+- Unicode-aware source positioning, including tabs, combining characters,+  East Asian width, and emoji.+- Explicit handling of stale source spans when source text has changed.+- Adapters for GHC `SrcSpan`, Megaparsec, and Attoparsec.++## What it looks like++A graphical diagnostic can look along these lines:++```text+error[E1001]: unexpected token++ --> example.td:4:9+  |+4 | let x = foo(+  |         ^^^ expected an expression+  |+  = help: check the expression following `foo`+```++The same diagnostic can be rendered as accessible prose or as JSON, depending+on the selected target.++## Installation++Add `tadka` to your package's dependencies:++```cabal+build-depends:+    tadka+```++Then import the public API:++```haskell+import Tadka+```++`tadka` is designed to work with ordinary Cabal projects and existing+`Either`, `ExceptT`, or custom error types.++## Five-minute example++Define an ordinary error type:++```haskell+data MyError+  = UnexpectedToken Span+  | MissingName Span+  deriving stock (Show)+```++Give it a diagnostic description:++```haskell+instance Diagnostic MyError where+  message = \case+    UnexpectedToken _ -> "unexpected token"+    MissingName _     -> "missing name"++  context = \case+    UnexpectedToken span ->+      mkContext source+        (Labeled span Primary (Just "expected an expression") :| [])++    MissingName span ->+      mkContext source+        (Labeled span Primary (Just "a name is required here") :| [])++  code = const (Just (mkDiagnosticCode "E1001"))+```++Then report it:++```haskell+reportDiagnostic defaultConfig err+```++The reporting layer remains separate from the way your application creates,+returns, or handles `MyError`.++## Deriving diagnostics++For error types where the diagnostic information follows a regular structure,+`tadka` provides Template Haskell support.++For example:++```haskell+data ParseError = ParseError+  { parseMessage :: Text+  , parseSpan    :: Span+  }+  deriving stock (Show)++$(deriveDiagnostic defaultSpec+    { specMessage     = [| \e -> pretty (parseMessage e) |]+    , specSourceField = Just 'parseSpan+    })+```++The derivation API can also describe error codes, help text, URLs, primary and+secondary labels, related diagnostics, causes, and diagnostic identity.++## Source spans++`tadka` keeps source text and source locations explicit.++A `Span` identifies a range in a named source. It can be resolved against the+source text to obtain line and column information:++```haskell+resolved <- resolveSpan source span+```++The implementation accounts for details that can make source positioning+non-trivial, including:++- tabs+- Unicode characters+- combining characters+- East Asian character width+- emoji+- large source offsets++When source text has changed and a span can no longer be trusted, `tadka`+represents that condition explicitly rather than silently presenting a+misleading location.++## Labeled source context++A diagnostic can contain primary and secondary labels:++```haskell+mkContext source+  (Labeled span1 Primary (Just "the problem is here")+    :| [Labeled span2 Secondary (Just "this is also relevant")])+```++Multiple source files are supported as well.++`tadka` can also degrade stale spans when source text no longer matches the+coordinates stored by an error value.++## Rendering++**Tadka** currently provides three output targets:++- `TGraphical` — terminal-oriented diagnostic output.+- `TNarratable` — accessible prose-oriented output.+- `TJson` — machine-readable JSON output.++A `Config` controls reporting behavior such as color, Unicode, hyperlinks,+context lines, tab width, related-diagnostic depth, label palettes, and the+selected target.++For example:++```haskell+let config =+      withTarget TGraphical+      $ withColorMode ColorAuto+      $ defaultConfig++reportDiagnostic config err+```++The renderer selection and lower-level rendering APIs are also available when+applications need more control.++## Existing error types++**Tadka** does not require a new application-wide error architecture.++If an application already has error types, they can remain ordinary Haskell+values. A `Diagnostic` instance describes how each error should be presented+to a human or another tool.++This separation is useful when the same error value needs to be:++- returned through `Either`+- propagated through `ExceptT`+- logged+- displayed in a terminal+- returned as JSON+- embedded in another diagnostic++## Related diagnostics and causes++Diagnostics can contain related diagnostics and an underlying cause chain.++This lets an application represent structures such as:++```text+top-level error+    |+    +-- related diagnostic+    |+    +-- underlying cause+            |+            +-- underlying cause+```++**Tadka** bounds traversal depth and supports diagnostic identity so that+recursive or cyclic structures cannot cause unbounded rendering.++## Parser and compiler integration++**Tadka** includes integration packages for common Haskell tooling:++```text+tadka:interop-ghc+tadka:interop-megaparsec+tadka:interop-attoparsec+```++These adapters allow existing parser and compiler source locations to be+translated into **Tadka** source-span information without requiring the+application to redesign its diagnostics.++## JSON output++JSON output is intended for applications that need to pass diagnostics to+other programs, scripts, editor tooling, or services.++The JSON representation should be treated as an output format of the+corresponding Tadka release. If another program depends on its exact shape,+pinning the `tadka` version is the safest approach.++## Accessibility++The narratable renderer provides a prose-oriented representation of the same+structured diagnostic.++This is useful when graphical terminal formatting, Unicode drawing+characters, or visual source annotations are not appropriate.++## Public API boundary++The primary application-facing API is:++```haskell+import Tadka+```++The package also exposes internal modules for implementation-level use, but+they are not intended to provide the same compatibility guarantees as the+public API.++Applications should prefer the public `Tadka` module unless they have a+specific reason to use an internal module.++## Testing and engineering++**Tadka** is tested across multiple supported GHC versions and includes:++- unit and property tests+- renderer tests+- golden tests+- parser/compiler interop tests+- generated-code checks+- compile-failure checks+- adversarial source-position cases+- Unicode and tab-positioning cases+- stale-source handling+- multi-source diagnostics+- related/cause-chain protection++The project is developed with warnings enabled and maintains explicit+dependency bounds.++## Current scope++**Tadka** focuses on structured diagnostic representation and rendering.++It intentionally does not attempt to be all of the following at once:++- an application-wide error-handling framework+- an LSP implementation+- an editor integration layer+- a syntax-highlighting engine+- a general-purpose logging framework+- a replacement for parser-specific error types++Those concerns can be built around the diagnostic representation when an+application needs them.++## License++**Tadka** is released under the Mozilla Public License 2.0 (MPL-2.0).++See [`LICENSE`](LICENSE) for the complete license text.++## Acknowledgement++The design is inspired in part by Rust's [`miette`](https://github.com/zkat/miette),+particularly its approach to structured diagnostics, source snippets, labels,+and human-friendly reporting.++Tadka is an independent Haskell implementation designed around Haskell's+type system, libraries, and conventions.
+ assets/tadka-diagnostic.png view

binary file changed (absent → 1345530 bytes)

+ interop/attoparsec/Tadka/Interop/Attoparsec.hs view
@@ -0,0 +1,25 @@+-- | One-directional adapter: attoparsec failure positions → tadka+-- 'Offset'\/'Span'. attoparsec is position-agnostic (it reports+-- no line/column), so position is recovered as the number of characters+-- consumed before the failure: @length original - length remaining@.+-- Minimum supported: @attoparsec >= 0.14@.+--+-- No compatibility guarantee.+module Tadka.Interop.Attoparsec+  ( consumedOffset+  , spanFromConsumed+  ) where++import           Data.Text (Text)+import qualified Data.Text as T++import           Tadka     (Span, SpanBuildError, mkSpan)++-- | Characters consumed before a failure, given the original input and the+-- unconsumed remainder (from an attoparsec @Fail@\/@Done@ result).+consumedOffset :: Text -> Text -> Int+consumedOffset orig remaining = T.length orig - T.length remaining++-- | A 'Span' of the given length at the consumed offset.+spanFromConsumed :: Text -> Text -> Int -> Either SpanBuildError Span+spanFromConsumed orig remaining len = mkSpan (consumedOffset orig remaining) len
+ interop/ghc/Tadka/Interop/GHC.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}++-- | One-directional adapter: GHC 'SrcSpan' → tadka 'Span'.+--+-- A plain function against Phase 1/2 types; no core module depends on this.+-- Targets GHC 9.6.7 through 9.14.1 (see the @ghc@ bound in @tadka.cabal@).+-- Only 'GHC.Types.SrcLoc''s 'SrcSpan'/'RealSrcSpan' accessors are used, which+-- have been stable public GHC API across that whole range — no CPP needed,+-- but this should be reconfirmed by an actual per-version CI build rather+-- than assumed from this note.+--+-- No compatibility guarantee.+module Tadka.Interop.GHC+  ( SrcSpanConvError (..)+  , spanFromSrcSpan+  , offsetFromLineCol+  ) where++import           Data.Text        (Text)+import qualified Data.Text        as T+import           GHC.Types.SrcLoc (SrcSpan (..), srcSpanEndCol, srcSpanEndLine,+                                   srcSpanStartCol, srcSpanStartLine)++import           Tadka            (Span, mkSpan)++-- | Why a 'SrcSpan' could not be converted.+data SrcSpanConvError+  = UnhelpfulSrcSpan          -- ^ the span was an @UnhelpfulSpan@ (no real location)+  | LineColOutOfBounds Int Int -- ^ a 1-based (line, column) not present in the source+  | NegativeSpanLength        -- ^ end preceded start+  deriving (Eq, Show)++-- | Total, safe indexing into a list: 'Nothing' out of bounds, never a partial+-- crash. Kept local (mirrors 'Tadka.Internal.Width.atMay') so no caller in this+-- module ever reaches for the partial @(!!)@ directly.+atMayList :: [a] -> Int -> Maybe a+atMayList xs i+  | i < 0     = Nothing+  | otherwise = case drop i xs of+      (x : _) -> Just x+      []      -> Nothing++-- | Convert a 1-based (line, column) into a 0-based character offset within the+-- given source, or 'Nothing' if the position is not in bounds. Column may point+-- one past the end of a line (the end-of-line position GHC uses). Total: the+-- line lookup is tied directly to the 'Maybe' via 'atMayList', so an+-- out-of-range line can never reach the column check below it.+offsetFromLineCol :: Text -> Int -> Int -> Maybe Int+offsetFromLineCol src line col = do+  here <- atMayList ls (line - 1)+  if col < 1 || col > T.length here + 1+    then Nothing+    else Just (before + (col - 1))+  where+    ls     = T.splitOn "\n" src+    before = sum (map ((+ 1) . T.length) (take (line - 1) ls))  -- +1 per newline++-- | Convert a GHC 'SrcSpan' to a tadka 'Span', given the source text (needed to+-- turn GHC's 1-based line/column into a character offset and length).+--+-- The four-way case split below is exhaustive over which of the two+-- endpoints resolved: both, only the start, only the end, or neither. Each+-- arm names the specific endpoint at fault rather than defaulting to the+-- start, so 'LineColOutOfBounds' always describes the position that was+-- actually out of bounds.+spanFromSrcSpan :: Text -> SrcSpan -> Either SrcSpanConvError Span+spanFromSrcSpan _   (UnhelpfulSpan _) = Left UnhelpfulSrcSpan+spanFromSrcSpan src (RealSrcSpan rss _) =+  case (offsetFromLineCol src (srcSpanStartLine rss) (srcSpanStartCol rss),+        offsetFromLineCol src (srcSpanEndLine rss)   (srcSpanEndCol rss)) of+    (Nothing, _) -> Left (LineColOutOfBounds (srcSpanStartLine rss) (srcSpanStartCol rss))+    (_, Nothing) -> Left (LineColOutOfBounds (srcSpanEndLine rss)   (srcSpanEndCol rss))+    (Just s, Just e)+      | e >= s    -> mkSpanNonNegative s (e - s)+      | otherwise -> Left NegativeSpanLength++-- | 'mkSpan', specialised to a call site where both arguments are already+-- non-negative by construction (`max 0` is a no-op on them): 'mkSpan' can+-- only fail on a negative offset or a negative length, so with both clamped+-- here — not merely reasoned to be non-negative three functions away in+-- 'offsetFromLineCol' — its 'Left' case is unreachable by local inspection,+-- not by trusting a distant invariant. 'mkSpan' is still the one used, so a+-- future tightening of its validation is not silently bypassed here.+mkSpanNonNegative :: Int -> Int -> Either SrcSpanConvError Span+mkSpanNonNegative s len = either (const (Left NegativeSpanLength)) Right (mkSpan (max 0 s) (max 0 len))
+ interop/megaparsec/Tadka/Interop/Megaparsec.hs view
@@ -0,0 +1,18 @@+-- | One-directional adapter: megaparsec parse-error positions → tadka 'Span'+-- . megaparsec carries a stream 'errorOffset' (a character+-- offset), the natural bridge to tadka's offset-based spans.+-- Minimum supported: @megaparsec >= 9.0@.+--+-- No compatibility guarantee.+module Tadka.Interop.Megaparsec+  ( spanFromError+  ) where++import           Text.Megaparsec.Error (ParseError, errorOffset)++import           Tadka                 (Span, SpanBuildError, mkSpan)++-- | A 'Span' of the given character length starting at the error's offset+-- (length 0 for a point span).+spanFromError :: Int -> ParseError s e -> Either SpanBuildError Span+spanFromError len e = mkSpan (errorOffset e) len
+ src/Tadka.hs view
@@ -0,0 +1,120 @@+-- | Public API surface for @tadka@.+--+-- This module is the sole supported entry point. It re-exports the public+-- vocabulary defined across @Tadka.Internal.*@. Anything reachable only via+-- @Tadka.Internal.*@ carries no compatibility guarantee.+--+-- Phases 1–2 populate the validated primitive types, resolution-indexed spans,+-- and 'Context' construction. The @Diagnostic@ class, renderers, and the derive+-- macro, and interop adapters complete the surface. The public API matches+--  @Offset@\/@Length@ and other representation details live under+-- "Tadka.Internal" with no compatibility guarantee.+module Tadka+  ( -- * Named source+    NamedSource+  , sourceName+  , sourceText+  , mkNamedSource+  , SourceError (..)+    -- * Spans+    --+    -- Spans are the public position type; @Offset@\/@Length@ are the internal+    -- offset representation and live in "Tadka.Internal.Types" (no compatibility+    -- guarantee)+  , Span+  , ResolvedSpan+  , mkSpan+  , SpanBuildError (..)+  , resolvedStart+  , resolvedEnd+  , LineCol (..)+  , resolveSpan+  , SpanError (..)+  , spanErrorReason+  , StaleReason (..)+    -- * Annotations+  , Ann (..)+    -- * The Diagnostic class+  , Diagnostic (..)+  , SomeDiagnostic (..)+    -- * Context+  , Context (NoContext)+  , Labeled (..)+  , LabelKind (..)+  , LabelState (..)+  , contextLabelStates+  , mkContext+  , mkContextDegrading+  , ContextError (..)+    -- ** Multi-source context (Phase 12)+    --+    -- A 'Context' can hold labels resolved against more than one 'NamedSource'.+    -- Single-source construction above is unchanged; these are the entry+    -- points for a diagnostic whose labels span several files. The derive+    -- macro and 'genericContext' remain single-source only in v1 — these are+    -- hand-written-instance functions.+  , mkContextMulti+  , mkContextMultiDegrading+    -- * Rendering configuration+  , Config+  , defaultConfig+  , withColorMode+  , withUnicodeMode+  , withHyperlinkMode+  , withRelatedDepthLimit+  , withTabWidth+  , withContextLines+  , withLabelPalette+  , withTarget+  , ColorMode (..)+  , UnicodeMode (..)+  , HyperlinkMode (..)+    -- * Renderers and the render path+  , Target (..)+  , Output+  , Renderer (..)+  , SomeRenderer (..)+  , GraphicalOptions+  , NarratableOptions+  , JsonOptions+  , selectRenderer+  , render+  , reportDiagnostic+    -- * Derive macro+  , DiagnosticSpec (..)+  , defaultSpec+  , deriveDiagnostic+  , DiagnosticSumSpec+  , deriveDiagnosticSum+    -- * Generics label-wiring (context only)+  , genericContext+    -- * Diagnostic codes+  , DiagnosticCode+  , unDiagnosticCode+  , mkDiagnosticCode+  , CodeError (..)+    -- * URLs+  , Url+  , unUrl+  , mkUrl+  , UrlError (..)+    -- * Severity+  , Severity (..)+    -- * Diagnostic identity+  , DiagnosticId+  , unDiagnosticId+  , mkDiagnosticId+  ) where++import Tadka.Internal.Ann+import Tadka.Internal.Config+import Tadka.Internal.Context+import Tadka.Internal.Diagnostic+import Tadka.Internal.Generics (genericContext)+import Tadka.Internal.Render+import Tadka.Internal.Renderer.Graphical (GraphicalOptions)+import Tadka.Internal.Renderer.Json (JsonOptions)+import Tadka.Internal.Renderer.Narratable (NarratableOptions)+import Tadka.Internal.Span+import Tadka.Internal.TH+import Tadka.Internal.Types
+ src/Tadka/Internal.hs view
@@ -0,0 +1,26 @@+-- | Plain, exported, independently-testable functions that both the derive+-- macro ("Tadka.Internal.TH", Phase 8) and hand-written 'Tadka.Diagnostic'+-- instances call.+--+-- __The @deriveDiagnostic@ discipline.__ Every method body the+-- splice generates must be a direct, unmodified call to a function that also+-- lives in this module's export list (or a class default), so a manual instance+-- can invoke the exact same code path. If a future field needs logic the+-- current surface can't express as a plain call, the fix is to extract a new+-- plain function here first — never to add logic inside the @Q@ splice. This is+-- a code-review convention, not type-enforced; a CI grep over the generated+-- golden fixture backstops it. The one exception is the default @message@+-- (@pretty . show@), which has no manual-instance equivalent by definition.+--+-- No compatibility guarantee.+module Tadka.Internal+  ( unsafeDiagnosticCode+  , unsafeUrl+  , buildContext+  , buildContextWith+  , buildContextMulti+  , mkDiagnosticId+  ) where++import Tadka.Internal.Context (buildContext, buildContextMulti, buildContextWith)+import Tadka.Internal.Types   (mkDiagnosticId, unsafeDiagnosticCode, unsafeUrl)
+ src/Tadka/Internal/Ann.hs view
@@ -0,0 +1,13 @@++-- No compatibility guarantee.+module Tadka.Internal.Ann+  ( Ann (..)+  ) where+++data Ann+  = AnnEmphasis+  | AnnCode+  | AnnFilename+  | AnnKeyword+  deriving (Eq, Show, Enum, Bounded)
+ src/Tadka/Internal/Config.hs view
@@ -0,0 +1,126 @@++--+-- No compatibility guarantee.+module Tadka.Internal.Config+  ( -- * Target and modes+    Target (..)+  , ColorMode (..)+  , UnicodeMode (..)+  , HyperlinkMode (..)+    -- * Config (opaque)+  , Config+  , defaultConfig+  , defaultPalette+    -- * Setters+  , withColorMode+  , withUnicodeMode+  , withHyperlinkMode+  , withRelatedDepthLimit+  , withTabWidth+  , withContextLines+  , withLabelPalette+  , withTarget+    -- * Internal field accessors (for selectRenderer only; not re-exported by "Tadka")+  , configColorMode+  , configUnicodeMode+  , configHyperlinkMode+  , configRelatedDepth+  , configTabWidth+  , configContextLines+  , configPalette+  , configTarget+  ) where++import           Data.List.NonEmpty            (NonEmpty (..))+import           Numeric.Natural               (Natural)+import           Prettyprinter.Render.Terminal (AnsiStyle, Color (..), color)++import           Tadka.Internal.Related        (defaultRelatedDepth)++-- | The three render targets @tadka@ ships. Closed by design: a fourth,+-- custom target is permanently out of scope.+data Target = TGraphical | TNarratable | TJson+  deriving (Eq, Show, Enum, Bounded)++-- | When to colourise graphical output.+data ColorMode = ColorAuto | ColorAlways | ColorNever+  deriving (Eq, Show, Enum, Bounded)++-- | When to use non-ASCII box-drawing/underline glyphs.+data UnicodeMode = UnicodeAuto | UnicodeAlways | UnicodeAscii+  deriving (Eq, Show, Enum, Bounded)++-- | When to wrap displayed URLs (currently just the @= see:@ line, vision §7)+-- in an OSC 8 terminal hyperlink escape, so a supporting terminal renders them+-- as clickable text instead of plain text a user must select and open by hand.+data HyperlinkMode = HyperlinkAuto | HyperlinkAlways | HyperlinkNever+  deriving (Eq, Show, Enum, Bounded)++-- | Opaque rendering configuration. Build from 'defaultConfig' with the+-- @with*@ setters.+data Config = Config+  { configColorMode     :: ColorMode+  , configUnicodeMode   :: UnicodeMode+  , configHyperlinkMode :: HyperlinkMode+  , configRelatedDepth  :: Natural+  , configPalette       :: NonEmpty AnsiStyle+  , configTabWidth      :: Int            -- ^ tab stop width for source rendering (>= 1)+  , configContextLines  :: Maybe Int      -- ^ 'Nothing' = contiguous range; 'Just' n = n context lines + elision+  , configTarget        :: Maybe Target   -- ^ 'Nothing' = auto; 'Just' = explicit override.+  }+  deriving (Eq, Show)++-- | The default six-colour underline palette, distinguishable+-- under light and dark themes; degrades to distinct underline characters under+-- 'ColorNever' (handled by the graphical handler in Phase 5).+defaultPalette :: NonEmpty AnsiStyle+defaultPalette =+  color Red :| [color Green, color Yellow, color Blue, color Magenta, color Cyan]++-- | Sensible defaults: auto colour, auto Unicode, hyperlinks off, depth limit+-- 8, the default palette, and no explicit target (auto).+--+-- Hyperlinks default to 'HyperlinkNever' rather than 'HyperlinkAuto', unlike+-- colour/Unicode: OSC 8 has no reliable capability query the way TTY-ness+-- does, so a terminal that reports 'capIsTerminal' may still not render the+-- escape as a link. Defaulting off keeps existing callers' output+-- byte-for-byte unchanged until they opt in with 'withHyperlinkMode'.+defaultConfig :: Config+defaultConfig = Config+  { configColorMode     = ColorAuto+  , configUnicodeMode   = UnicodeAuto+  , configHyperlinkMode = HyperlinkNever+  , configRelatedDepth  = defaultRelatedDepth+  , configPalette       = defaultPalette+  , configTabWidth      = 4+  , configContextLines  = Nothing+  , configTarget        = Nothing+  }++withColorMode :: ColorMode -> Config -> Config+withColorMode m c = c { configColorMode = m }++withUnicodeMode :: UnicodeMode -> Config -> Config+withUnicodeMode m c = c { configUnicodeMode = m }++withHyperlinkMode :: HyperlinkMode -> Config -> Config+withHyperlinkMode m c = c { configHyperlinkMode = m }++withRelatedDepthLimit :: Natural -> Config -> Config+withRelatedDepthLimit n c = c { configRelatedDepth = n }++-- | Tab stop width used when rendering source lines (tabs expand to the next+-- multiple of this width). Values below 1 are treated as 1 by the renderer.+withTabWidth :: Int -> Config -> Config+withTabWidth n c = c { configTabWidth = n }+++withContextLines :: Int -> Config -> Config+withContextLines n c = c { configContextLines = Just n }++withLabelPalette :: NonEmpty AnsiStyle -> Config -> Config+withLabelPalette p c = c { configPalette = p }++-- | Explicitly force a render target, overriding auto-detection.+withTarget :: Target -> Config -> Config+withTarget t c = c { configTarget = Just t }
+ src/Tadka/Internal/Context.hs view
@@ -0,0 +1,172 @@++--+-- No compatibility guarantee.+module Tadka.Internal.Context+  ( -- * Labels+    Labeled (..)+  , LabelKind (..)+  , LabelState (..)+    -- * Context+  , Context (..)+  , SourceGroup (..)+  , contextLabelStates+  , contextSourceGroups+    -- * Construction+  , ContextError (..)+  , mkContext+  , mkContextDegrading+  , mkContextMulti+  , mkContextMultiDegrading+  , buildContext+  , buildContextWith+  , buildContextMulti+  ) where++import           Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import           Prettyprinter      (Doc)++import           Tadka.Internal.Ann   (Ann)+import           Tadka.Internal.Span+                   (ResolvedSpan, Span, SpanError, StaleReason, resolveSpan,+                    spanErrorReason)+import           Tadka.Internal.Types (NamedSource)+++data LabelKind = Primary | Secondary+  deriving (Eq, Show, Enum, Bounded, Ord)++data Labeled a = Labeled+  { labelSpan :: a+  , labelKind :: LabelKind+  , labelText :: Maybe (Doc Ann)+  }+  deriving (Show)+  -- No 'Eq': @Doc Ann@ has no 'Eq' instance. Compare via 'labelSpan'/'labelKind'.++-- | The per-label outcome of resolving against the context's source.+data LabelState+  = LabelOk ResolvedSpan+    -- ^ resolved successfully; carries positions only.+  | LabelStale StaleReason+    -- ^ resolution failed for this one label; it stays present, in its+    -- original position, with no source line to show, rather than absent.+  deriving (Eq, Show)+++data SourceGroup = SourceGroup+  { sgSource :: NamedSource+  , sgLabels :: NonEmpty (Labeled LabelState)+  }+  deriving (Show)+++data Context+  = NoContext+  | HasLabels (NonEmpty SourceGroup)+  deriving (Show)++-- | The label states of a context in order, flattened across every group in+-- group order (empty for 'NoContext'). Useful for asserting the+-- count/ordering guarantee.+contextLabelStates :: Context -> [LabelState]+contextLabelStates NoContext       = []+contextLabelStates (HasLabels gs)  =+  concatMap (fmap labelSpan . NE.toList . sgLabels) (NE.toList gs)++-- | The source groups of a context in order (empty for 'NoContext'). The+-- renderers' one shared way to walk a context group-by-group.+contextSourceGroups :: Context -> [SourceGroup]+contextSourceGroups NoContext      = []+contextSourceGroups (HasLabels gs) = NE.toList gs++-- | Why 'mkContext'\/'mkContextMulti' (the strict constructors) rejected their+-- input: the first span that failed to resolve, in group-then-label order.+newtype ContextError = ContextError SpanError+  deriving (Eq, Show)++-- | Strict, multi-source construction: succeeds only if /every/ span in+-- /every/ group resolves against its own group's source. Returns 'Left' for+-- the first out-of-bounds span encountered in group-then-label order.+mkContextMulti+  :: NonEmpty (NamedSource, NonEmpty (Labeled Span))+  -> Either ContextError Context+mkContextMulti groups = HasLabels <$> traverse resolveGroup groups+  where+    resolveGroup :: (NamedSource, NonEmpty (Labeled Span)) -> Either ContextError SourceGroup+    resolveGroup (src, labels) =+      case traverse (resolveLabel src) labels of+        Left err   -> Left (ContextError err)+        Right lbls -> Right (SourceGroup src lbls)++    resolveLabel :: NamedSource -> Labeled Span -> Either SpanError (Labeled LabelState)+    resolveLabel src (Labeled sp k txt) =+      fmap (\rs -> Labeled (LabelOk rs) k txt) (resolveSpan src sp)+++mkContextMultiDegrading :: NonEmpty (NamedSource, NonEmpty (Labeled Span)) -> Context+mkContextMultiDegrading = HasLabels . fmap resolveGroup+  where+    resolveGroup :: (NamedSource, NonEmpty (Labeled Span)) -> SourceGroup+    resolveGroup (src, labels) = SourceGroup src (fmap (resolveOrStale src) labels)++    resolveOrStale :: NamedSource -> Labeled Span -> Labeled LabelState+    resolveOrStale src (Labeled sp k txt) =+      case resolveSpan src sp of+        Right rs  -> Labeled (LabelOk rs) k txt+        Left err  -> Labeled (LabelStale (spanErrorReason err)) k txt++-- | Strict construction: succeeds only if /every/ span resolves. Intended for a+-- domain error type's own smart constructor, so that holding such a value+-- proves its context is fully resolvable. Returns 'Left' for the first+-- out-of-bounds span.+--+-- A one-group special case of 'mkContextMulti' — not a second copy of the+-- resolution logic.+mkContext :: NamedSource -> NonEmpty (Labeled Span) -> Either ContextError Context+mkContext src labels = mkContextMulti ((src, labels) :| [])++-- | Total construction: resolves every span it can; a span that fails becomes+-- 'LabelStale' /in the same position/, never dropped. The result always has+-- exactly as many labels, in the same order, as the input — this is the+-- count/ordering guarantee that is the whole point of the type.+--+-- A one-group special case of 'mkContextMultiDegrading' — not a second copy+-- of the degrading logic.+mkContextDegrading :: NamedSource -> NonEmpty (Labeled Span) -> Context+mkContextDegrading src labels = mkContextMultiDegrading ((src, labels) :| [])++-- | The shared dispatch both the derive macro and manual instances call.+-- An empty label list is the only route to 'NoContext'; a non-empty one goes+-- straight to 'mkContextDegrading'. This is intentionally a thin wrapper, not a+-- second copy of the degrading logic.+buildContext :: NamedSource -> [(Span, Maybe (Doc Ann))] -> Context+buildContext _   []       = NoContext+buildContext src (x : xs) = mkContextDegrading src (fmap toLabeled (x :| xs))+  where+    toLabeled (sp, txt) = Labeled sp Primary txt   -- unmarked labels are Primary++-- | Like 'buildContext', but each label carries an explicit 'LabelKind'. The+-- shared function both the derive macro (when secondary labels are requested)+-- and manual instances call for primary\/secondary labelling.+buildContextWith :: NamedSource -> [(Span, LabelKind, Maybe (Doc Ann))] -> Context+buildContextWith _   []       = NoContext+buildContextWith src (x : xs) = mkContextDegrading src (fmap toLabeled (x :| xs))+  where+    toLabeled (sp, k, txt) = Labeled sp k txt+++buildContextMulti :: NonEmpty (NamedSource, [(Span, LabelKind, Maybe (Doc Ann))]) -> Context+buildContextMulti groups =+  maybe NoContext mkContextMultiDegrading+    (NE.nonEmpty (concatMap nonEmptyGroup (NE.toList groups)))+  where+    nonEmptyGroup+      :: (NamedSource, [(Span, LabelKind, Maybe (Doc Ann))])+      -> [(NamedSource, NonEmpty (Labeled Span))]+    nonEmptyGroup (src, entries) =+      case NE.nonEmpty (map toLabeled entries) of+        Nothing  -> []+        Just lbs -> [(src, lbs)]++    toLabeled (sp, k, txt) = Labeled sp k txt
+ src/Tadka/Internal/Diagnostic.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ExistentialQuantification #-}+++-- No compatibility guarantee.+module Tadka.Internal.Diagnostic+  ( Diagnostic (..)+  , SomeDiagnostic (..)+  ) where++import           Prettyprinter        (Doc)++import           Tadka.Internal.Ann     (Ann)+import           Tadka.Internal.Context (Context (NoContext))+import           Tadka.Internal.Types+                   (DiagnosticCode, DiagnosticId, Severity (SevError), Url)++-- | Everything a renderer needs from an error value. Only 'message' is+-- required; every other method has a total default.+class Diagnostic e where+  -- | The headline message. Mandatory.+  message      :: e -> Doc Ann+  -- | Source-anchored labels, already resolved-or-explicitly-stale.+  context      :: e -> Context+  -- | An optional documented error code (e.g. @tadka::E0001@).+  code         :: e -> Maybe DiagnosticCode+  -- | Severity; defaults to 'SevError'.+  severity     :: e -> Severity+  -- | Optional help text.+  help         :: e -> Maybe (Doc Ann)+  -- | Optional documentation URL.+  url          :: e -> Maybe Url+  -- | Related diagnostics, walked as a (possibly cyclic) chain.+  related      :: e -> [SomeDiagnostic]+  -- | Opt-in identity, used solely for cycle detection in @related@ walks.+  diagnosticId :: e -> Maybe DiagnosticId+  -- | The underlying cause, rendered as a linear \"caused by\" chain, separate+  -- from the (tree-shaped) @related@ diagnostics. Defaults to 'Nothing'.+  diagnosticCause :: e -> Maybe SomeDiagnostic++  context      _ = NoContext+  code         _ = Nothing+  severity     _ = SevError+  help         _ = Nothing+  url          _ = Nothing+  related      _ = []+  diagnosticId _ = Nothing+  diagnosticCause _ = Nothing++-- | An existentially-wrapped diagnostic. No @Show@ constraint: every operation+-- a renderer performs goes through 'Diagnostic''s methods.+data SomeDiagnostic = forall e. Diagnostic e => SomeDiagnostic e
+ src/Tadka/Internal/Generics.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- 'OneSourceManySpans' is a compile-time shape guard: its constraints resolve+-- to () or a TypeError and carry no runtime dictionary, so GHC's+-- redundant-constraints check flags them. The guard is intentional.+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+++-- No compatibility guarantee.+module Tadka.Internal.Generics+  ( genericContext+  , GCollect+  ) where++import           Data.Kind              (Constraint, Type)+import           Data.Text              (Text)+import qualified Data.Text              as T+import           Data.Typeable          (Typeable, cast)+import           GHC.Generics+import           GHC.TypeLits           (ErrorMessage (..), Nat, TypeError, type (+))+import           Prettyprinter          (pretty)++import           Tadka.Internal.Context (Context (..), buildContext)+import           Tadka.Internal.Span    (Span)+import           Tadka.Internal.Types   (NamedSource)++-- | Derive 'context' for a record with one 'NamedSource' field and one or more+-- 'Span' fields. Intended as @context = genericContext@ inside an otherwise+-- hand-written 'Tadka.Diagnostic' instance.+genericContext+  :: forall e+   . (Generic e, GCollect (Rep e), OneSourceManySpans e)+  => e -> Context+genericContext e =+  case gcollect (from e) of+    (src : _, labels) -> buildContext src [ (sp, Just (pretty nm)) | (nm, sp) <- labels ]+    ([], _)           -> NoContext   -- unreachable given 'OneSourceManySpans'++-- === Value collection via generics =========================================++-- | Collect the 'NamedSource' fields and the @(label text, 'Span')@ pairs from+-- a generic representation. Field values are classified by 'cast', so only+-- 'NamedSource'- and 'Span'-typed fields contribute; all others are ignored.+class GCollect f where+  gcollect :: f p -> ([NamedSource], [(Text, Span)])++instance GCollect f => GCollect (M1 D d f) where gcollect (M1 x) = gcollect x+instance GCollect f => GCollect (M1 C c f) where gcollect (M1 x) = gcollect x++instance (GCollect a, GCollect b) => GCollect (a :*: b) where+  gcollect (a :*: b) = gcollect a <> gcollect b++instance (Selector s, Typeable c) => GCollect (M1 S s (K1 R c)) where+  gcollect m@(M1 (K1 v)) =+    case cast v of+      Just (src :: NamedSource) -> ([src], [])+      Nothing -> case cast v of+        Just (sp :: Span) -> ([], [(T.pack (selName m), sp)])+        Nothing -> case cast v of+          Just (sps :: [Span]) -> ([], [ (T.pack (selName m), sp) | sp <- sps ])+          Nothing               -> ([], [])++instance GCollect U1 where gcollect _ = ([], [])+instance GCollect V1 where gcollect _ = ([], [])++-- === Compile-time shape check ==============================================++type OneSourceManySpans e =+  ( CheckSource (CountField NamedSource (Rep e))+  , CheckSpans  (CountSpanFields (Rep e))+  )++-- Count record fields of a given type in a generic representation. Stays an+-- *exact*-type counter (used only for the NamedSource check): a [Span] field+-- must not accidentally satisfy a Span count, which is exactly the silent-drop+-- bug this fix removes — hence 'CountSpanFields' below is a separate family+-- rather than an overload of this one.+type family CountField (t :: Type) (f :: Type -> Type) :: Nat where+  CountField t (M1 D d f)          = CountField t f+  CountField t (M1 C c f)          = CountField t f+  CountField t (a :*: b)           = CountField t a + CountField t b+  CountField t (M1 S s (K1 R t))   = 1+  CountField t (M1 S s (K1 R c))   = 0+  CountField t U1                  = 0+  CountField t V1                  = 0++-- Count fields that 'gcollect' can turn into span labels: a scalar 'Span' or+-- a '[Span]' field, either one counting as one "this record has spans"+-- field. A record's only span-bearing field may legitimately be a '[Span]'+-- with no scalar 'Span' field at all (e.g. @E { src :: NamedSource, spans ::+-- [Span] }@), which 'gcollect' handles just fine.+type family CountSpanFields (f :: Type -> Type) :: Nat where+  CountSpanFields (M1 D d f)             = CountSpanFields f+  CountSpanFields (M1 C c f)             = CountSpanFields f+  CountSpanFields (a :*: b)              = CountSpanFields a + CountSpanFields b+  CountSpanFields (M1 S s (K1 R Span))   = 1+  CountSpanFields (M1 S s (K1 R [Span])) = 1+  CountSpanFields (M1 S s (K1 R c))      = 0+  CountSpanFields U1                     = 0+  CountSpanFields V1                     = 0++type family CheckSource (n :: Nat) :: Constraint where+  CheckSource 1 = ()+  CheckSource n = TypeError+    ('Text "genericContext: the record must have exactly one NamedSource field, but has "+       ':<>: 'ShowType n)++type family CheckSpans (n :: Nat) :: Constraint where+  CheckSpans 0 = TypeError+    ('Text "genericContext: the record must have at least one Span field")+  CheckSpans n = ()
+ src/Tadka/Internal/Related.hs view
@@ -0,0 +1,90 @@++--+-- No compatibility guarantee.+module Tadka.Internal.Related+  ( TerminationReason (..)+  , RelatedTree (..)+  , defaultRelatedDepth+  , walkRelated+  , walkCauses+  , flattenRelated+  ) where++import           Data.Set                (Set)+import qualified Data.Set                as Set+import           Numeric.Natural         (Natural)++import           Tadka.Internal.Diagnostic+                   (Diagnostic (diagnosticCause, diagnosticId, related), SomeDiagnostic (..))+import           Tadka.Internal.Types    (DiagnosticId)++-- | Why a node's @related@ list is represented the way it is.+data TerminationReason+  = NotTerminated+    -- ^ fully expanded (its children — themselves possibly truncated — are present).+  | DepthTruncated+    -- ^ the node has related diagnostics, but the depth budget was exhausted;+    -- children omitted. A handler renders "(N more related diagnostics+    -- omitted)", computing N as @length (related d)@.+  | CycleOmitted+    -- ^ this node's 'diagnosticId' was already on the current path; it is not+    -- descended into again. A handler renders "(cycle omitted)".+  deriving (Eq, Show, Enum, Bounded)++-- | The result of a walk: a diagnostic, its expanded children (empty when+-- truncated), and why. This is the renderer-agnostic shape all handlers consume.+data RelatedTree = RelatedTree+  { relatedDiag        :: SomeDiagnostic+  , relatedChildren    :: [RelatedTree]+  , relatedTermination :: TerminationReason+  }+++defaultRelatedDepth :: Natural+defaultRelatedDepth = 8++-- | Walk a diagnostic and its @related@ chain into a 'RelatedTree', detecting+-- cycles by 'diagnosticId' and bounding depth by the given budget. Total for+-- any input — even a structurally infinite one — because the budget is finite.+walkRelated :: Natural -> SomeDiagnostic -> RelatedTree+walkRelated limit = go limit Set.empty+  where+    go :: Natural -> Set DiagnosticId -> SomeDiagnostic -> RelatedTree+    go depth visited sd@(SomeDiagnostic e) =+      case diagnosticId e of+        Just i | i `Set.member` visited ->+          RelatedTree sd [] CycleOmitted+        mId ->+          let visited' = maybe visited (`Set.insert` visited) mId+              kids     = related e+          in if null kids+               then RelatedTree sd [] NotTerminated+               else if depth == 0+                      then RelatedTree sd [] DepthTruncated+                      else RelatedTree sd (map (go (depth - 1) visited') kids) NotTerminated++-- | Pre-order flatten to @(diagnostic, reason)@ pairs. Convenient for handlers+-- that render a flat list and for tests.+flattenRelated :: RelatedTree -> [(SomeDiagnostic, TerminationReason)]+flattenRelated (RelatedTree d kids term) =+  (d, term) : concatMap flattenRelated kids+++-- | Follow 'diagnosticCause' from a root into a linear chain, up to a depth+-- budget and with cycle detection by 'diagnosticId' (a cause whose id was+-- already seen ends the chain). Returns the causes in order, excluding the+-- root. Total: the budget bounds depth and the visited set bounds cycles.+walkCauses :: Natural -> SomeDiagnostic -> [SomeDiagnostic]+walkCauses limit root@(SomeDiagnostic e0) = go limit (seed e0) root+  where+    seed e = maybe Set.empty (`Set.insert` Set.empty) (diagnosticId e)+    go :: Natural -> Set DiagnosticId -> SomeDiagnostic -> [SomeDiagnostic]+    go 0 _ _ = []+    go depth visited (SomeDiagnostic e) =+      case diagnosticCause e of+        Nothing -> []+        Just c@(SomeDiagnostic ce) ->+          case diagnosticId ce of+            Just i | i `Set.member` visited -> []+            mId -> c : go (depth - 1) (insMaybe mId visited) c+    insMaybe mId v = maybe v (`Set.insert` v) mId
+ src/Tadka/Internal/Render.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+++-- No compatibility guarantee.+module Tadka.Internal.Render+  ( Output+  , Renderer (..)+  , SomeRenderer (..)+  , selectRenderer+  , render+  , reportDiagnostic+  ) where++import qualified Data.Aeson                     as Aeson+import qualified Data.ByteString.Lazy.Char8     as BSL8+import           Data.Maybe                     (fromMaybe)+import           Data.Text                      (Text)+import qualified Data.Text.IO                   as TIO+import           System.IO                       (stdout)+import           Prettyprinter                  (Doc, defaultLayoutOptions, layoutPretty)+import           Prettyprinter.Render.Text      (renderStrict)++import           Tadka.Internal.Ann             (Ann)+import           Tadka.Internal.Config+                   (Config, Target (..), configColorMode, configPalette,+                    configContextLines, configHyperlinkMode, configRelatedDepth,+                    configTabWidth, configTarget, configUnicodeMode)+import           Tadka.Internal.Diagnostic      (Diagnostic)+import           Tadka.Internal.Terminal        (detectTerminalCaps, resolveConfig)+import           Tadka.Internal.Renderer.Graphical+                   (GraphicalOptions (..), renderGraphical)+import           Tadka.Internal.Renderer.Json+                   (JsonOptions (..), renderJson)+import           Tadka.Internal.Renderer.Narratable+                   (NarratableOptions (..), renderNarratable)++-- | The output type each target renders to. Closed family.+type family Output (t :: Target) where+  Output 'TGraphical  = Doc Ann+  Output 'TNarratable = Text+  Output 'TJson       = Aeson.Value++-- | A renderer indexed by its 'Target'. The three constructors are exported so+-- call sites can pattern-match, but an @*Options@ value can only come from+-- 'selectRenderer', so this is the only route to a renderer that does anything.+data Renderer (t :: Target) where+  Graphical  :: GraphicalOptions  -> Renderer 'TGraphical+  Narratable :: NarratableOptions -> Renderer 'TNarratable+  Json       :: JsonOptions       -> Renderer 'TJson++-- | A renderer with its target hidden, as returned by 'selectRenderer'.+data SomeRenderer = forall t. SomeRenderer (Renderer t)+++selectRenderer :: Config -> SomeRenderer+selectRenderer cfg =+  case fromMaybe TGraphical (configTarget cfg) of+    TGraphical ->+      SomeRenderer . Graphical $+        GraphicalOptions+          { goColorMode     = configColorMode cfg+          , goUnicodeMode   = configUnicodeMode cfg+          , goHyperlinkMode = configHyperlinkMode cfg+          , goPalette       = configPalette cfg+          , goRelatedDepth  = configRelatedDepth cfg+          , goTabWidth      = configTabWidth cfg+          , goContextLines  = configContextLines cfg+          }+    TNarratable ->+      SomeRenderer (Narratable (NarratableOptions (configRelatedDepth cfg)))+    TJson ->+      SomeRenderer (Json (JsonOptions (configRelatedDepth cfg)))++-- | Render a diagnostic with a specific renderer. Signature fixed here; each+-- arm dispatches to its handler body.+render :: Diagnostic e => Renderer t -> e -> Output t+render (Graphical opts)  e = renderGraphical opts e+render (Narratable opts) e = renderNarratable opts e+render (Json opts)       e = renderJson opts e+++reportDiagnostic :: Diagnostic e => Config -> e -> IO ()+reportDiagnostic cfg e = do+  caps <- detectTerminalCaps stdout+  case selectRenderer (resolveConfig caps cfg) of+    SomeRenderer r@(Graphical _) ->+      TIO.putStrLn (renderStrict (layoutPretty defaultLayoutOptions (render r e)))+    SomeRenderer r@(Narratable _) ->+      TIO.putStrLn (render r e)+    SomeRenderer r@(Json _) ->+      BSL8.putStrLn (Aeson.encode (render r e))
+ src/Tadka/Internal/Renderer/Graphical.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Graphical report handler: header, gutter/snippet+-- layout with Unicode-width-correct carets, per-label underline cycling, stale+-- labels, help/see lines, and related-chain nesting via the shared Phase 3 walk.+--+-- The layout is built as explicit 'Text' lines (for exact column control) then+-- wrapped in 'pretty'. Under 'ColorNever' each label's underline uses a+-- distinct cycling character (@^@ \/ @~@ \/ @-@); under a colour mode the+-- character is @^@ and the palette (see 'labelStyle') distinguishes labels via+-- ANSI at the terminal boundary. Column maths go through+-- "Tadka.Internal.Width", so combining marks, East-Asian-width, and emoji are+-- accounted for. The @= see:@ line's URL is wrapped in an OSC 8 hyperlink+-- escape when 'HyperlinkMode' allows it (see 'hyperlink'), independently of+-- colour.+--+-- No compatibility guarantee.+module Tadka.Internal.Renderer.Graphical+  ( GraphicalOptions (..)+  , renderGraphical+    -- * Layout internals (exposed for property tests)+  , caretLayout+  , labelStyle+  , caretGlyph+  ) where++import           Data.Char                     (isControl)+import           Data.List                     (intercalate, mapAccumL)+import           Data.List.NonEmpty            (NonEmpty (..))+import qualified Data.List.NonEmpty            as NE+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Numeric.Natural               (Natural)+import           Prettyprinter                 (Doc, LayoutOptions (..),+                                                PageWidth (Unbounded), annotate,+                                                layoutPretty, pretty)+import           Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color)+import qualified Prettyprinter.Render.Terminal as Term+import           Prettyprinter.Render.Util.SimpleDocTree (renderSimplyDecorated, treeForm)++import           Tadka.Internal.Ann            (Ann (..))+import           Tadka.Internal.Config         (ColorMode (..), HyperlinkMode (..),+                                                UnicodeMode (..))+import           Tadka.Internal.Context        (Context, LabelKind (..),+                                                LabelState (..), Labeled (..),+                                                SourceGroup (..), contextSourceGroups)+import           Tadka.Internal.SourceCode     (SourceCode (..))+import           Tadka.Internal.Renderer.LinePlan (PlanEntry (..), planLines)+import           Tadka.Internal.Renderer.Layout   (CellKind (..), assignLanes,+                                                   cellAt, laneCount)+import           Tadka.Internal.Diagnostic     (Diagnostic (..), SomeDiagnostic (..))+import           Tadka.Internal.Related        (RelatedTree (..), TerminationReason (..),+                                                walkCauses, walkRelated)+import           Tadka.Internal.Span           (LineCol (..), ResolvedSpan, resolvedEnd,+                                                resolvedStart, spanLength)+import           Tadka.Internal.Types          (DiagnosticCode,+                                                Severity (..), SeverityLabels (..),+                                                Url, severityLabels,+                                                unDiagnosticCode, unLength, unUrl)+import           Tadka.Internal.Width          (displayColumnAt, expandTabs)++-- | Resolved settings the graphical handler renders from (populated only by+-- @selectRenderer@).+data GraphicalOptions = GraphicalOptions+  { goColorMode     :: ColorMode+  , goUnicodeMode   :: UnicodeMode+  , goHyperlinkMode :: HyperlinkMode+  , goPalette       :: NonEmpty AnsiStyle+  , goRelatedDepth  :: Natural+  , goTabWidth      :: Int+  , goContextLines  :: Maybe Int+  }+  deriving (Eq, Show)++-- | Box-drawing glyph set, selected by 'UnicodeMode'.+data Glyphs = Glyphs+  { gRail   :: Text   -- ^ vertical rail+  , gCorner :: Text   -- ^ top-left corner of the location line+  , gDash   :: Text   -- ^ horizontal dash following the corner+  , gEmDash :: Text   -- ^ em-dash used in prose separators+  , gVellip :: Text   -- ^ vertical ellipsis marking elided lines+  , gMLopen  :: Char  -- ^ multi-line span opening corner+  , gMLthru  :: Char  -- ^ multi-line span continuation+  , gMLclose :: Char  -- ^ multi-line span closing corner+  }++glyphsFor :: UnicodeMode -> Glyphs+glyphsFor UnicodeAscii = Glyphs "|" "+" "-" "-" "..." '/' '|' '\\'+glyphsFor _            = Glyphs "\x2502" "\x250C" "\x2500" "\x2014" "\x22EE" '\x256D' '\x2502' '\x2570'  -- │ ┌ ─ — ⋮ ╭ │ ╰++-- | Wrap text in the ANSI escapes for a style, unless colour is off. Uses the+-- terminal renderer so the escapes are correct; under 'ColorNever' the text is+-- returned untouched (so plain output — all golden fixtures — carries no ANSI).+colorize :: ColorMode -> AnsiStyle -> Text -> Text+colorize ColorNever _ t = t+colorize _ style t =+  Term.renderStrict (layoutPretty (LayoutOptions Unbounded) (annotate style (pretty t)))++-- | Wrap already-displayed text in an OSC 8 terminal-hyperlink escape pointing+-- at @url@, unless hyperlinks are off. Mirrors 'colorize': 'HyperlinkNever'+-- returns the text untouched (so plain output — every existing golden fixture+-- — carries no escape), any other mode wraps it.+--+-- Takes a 'Url', never raw 'Text', so only an already-validated value — one+-- that has passed 'Tadka.Internal.Types.mkUrl''s absolute-URI check — can ever+-- be interpolated into the escape. 'mkUrl' delegates to+-- 'Network.URI.parseAbsoluteURI', whose RFC 3986 grammar has no production+-- admitting a raw control character, so a 'Url''s text can never itself+-- contain the ESC byte that starts (or forges) a terminal escape sequence:+-- this wrap is injection-safe without any extra stripping here, by+-- construction rather than by runtime check.+hyperlink :: HyperlinkMode -> Url -> Text -> Text+hyperlink HyperlinkNever _ label  = label+hyperlink _              u label  = oscLinkStart u <> label <> oscLinkEnd++-- | The OSC 8 "open link" escape for a URL: empty params, the URL, then the+-- string terminator (see 'oscStringTerminator').+oscLinkStart :: Url -> Text+oscLinkStart u = "\ESC]8;;" <> unUrl u <> oscStringTerminator++-- | The OSC 8 "close link" escape: the same shape with an empty URL, the+-- terminal-side convention every OSC 8 implementation shares for ending the+-- link that the most recent 'oscLinkStart' opened.+oscLinkEnd :: Text+oscLinkEnd = "\ESC]8;;" <> oscStringTerminator++-- | The string terminator (@ST@, @ESC \\@) that ends an OSC escape sequence.+-- Preferred over the historical BEL (@\\a@) terminator: it is the form every+-- OSC-8-supporting terminal in current use (iTerm2, kitty, VTE-based+-- terminals, Windows Terminal, …) already documents and accepts.+oscStringTerminator :: Text+oscStringTerminator = "\ESC\\"++-- | Header colour by severity (bold + a conventional hue).+severityStyle :: Severity -> AnsiStyle+severityStyle SevError   = color Red    <> bold+severityStyle SevWarning = color Yellow <> bold+severityStyle SevAdvice  = color Blue   <> bold++-- | The underline character for a label of kind @k@, at rank @r@ among labels+-- sharing that kind (0-based, in the diagnostic's original label order; see+-- 'kindRank'). Under any colour mode the glyph is always @^@ — colour+-- ('labelDisplayStyle' / 'severityStyle') is what distinguishes labels there.+-- Under 'ColorNever', rank 0 keeps each kind's conventional anchor (@^@ for+-- 'Primary', @-@ for 'Secondary', matching every existing golden fixture); a+-- second or later label of the same kind cycles through @~@ (and, if a third+-- ever appears, @=@) so it's never confused with its rank-0 sibling.+caretGlyph :: ColorMode -> LabelKind -> Int -> Char+caretGlyph ColorNever Primary   r = cyclePick ('^' :| "~=") r+caretGlyph ColorNever Secondary r = cyclePick ('-' :| "~=") r+caretGlyph _          _         _ = '^'++-- | Total cycling by index, shared by 'caretGlyph' and 'labelStyle': drop-then+-- -pattern-match rather than @(!!)@, so wraparound needs no partial indexing+-- and the empty-list case is a documented unreachable, not a real branch.+cyclePick :: NonEmpty a -> Int -> a+cyclePick xs i =+  case drop (i `mod` NE.length xs) (NE.toList xs) of+    (x : _) -> x+    []      -> NE.head xs  -- unreachable: 0 <= i `mod` n < n++-- | 0-based rank of each label among labels sharing its 'LabelKind', in+-- original document order — "how many earlier labels share this one's kind".+kindRank :: [LabelKind] -> [Int]+kindRank = snd . mapAccumL step (0, 0)+  where+    step (nP, nS) Primary   = ((nP + 1, nS), nP)+    step (nP, nS) Secondary = ((nP, nS + 1), nS)++-- | The ANSI style for a label: primary labels take the (bold) severity colour;+-- secondary labels cycle the configured palette by index.+labelDisplayStyle :: Severity -> NonEmpty AnsiStyle -> LabelKind -> Int -> AnsiStyle+labelDisplayStyle sev _       Primary   _ = severityStyle sev+labelDisplayStyle _   palette Secondary i = labelStyle palette i++-- | The palette entry for label index @i@: entry @i `mod` p@ where+-- @p@ is the palette length. Shares 'cyclePick''s cycling logic with+-- 'caretGlyph' — proven once, used twice.+labelStyle :: NonEmpty AnsiStyle -> Int -> AnsiStyle+labelStyle = cyclePick++-- | Given a source line, a 1-based start column, and a character length,+-- compute @(displayColumnsBefore, caretWidth)@ using display widths. Both are+-- non-negative and @caretWidth >= 1@, so a caret can never sit at a negative+-- offset nor collapse to nothing.+-- | Given a tab width, a source line, a 1-based start column, and a character+-- length, compute @(displayColumnsBefore, caretWidth)@ using tab-aware display+-- columns. Both are non-negative and @caretWidth >= 1@; @displayColumnsBefore@+-- equals the display width of the tab-expanded source preceding the span, so+-- the caret can never sit at a negative offset, collapse to nothing, nor drift+-- out of alignment with a tab-indented source line.+caretLayout :: Int -> Text -> Int -> Int -> (Int, Int)+caretLayout tw srcLine startCol len = (dispStart, caretWidth)+  where+    dispStart  = displayColumnAt tw srcLine (max 0 (startCol - 1))+    dispEnd    = displayColumnAt tw srcLine (max 0 (startCol - 1) + max 0 len)+    caretWidth = max 1 (dispEnd - dispStart)++-- | Render a diagnostic to a graphical report 'Doc'.+renderGraphical :: Diagnostic e => GraphicalOptions -> e -> Doc Ann+renderGraphical opts e =+  pretty (T.intercalate "\n" (renderRoot opts (SomeDiagnostic e)))++-- Whole-report line list for the top-level diagnostic.+renderRoot :: GraphicalOptions -> SomeDiagnostic -> [Text]+renderRoot opts sd@(SomeDiagnostic e) =+     header : snip ++ sep ++ trailer+  where+    glyphs   = glyphsFor (goUnicodeMode opts)+    cmode    = goColorMode opts+    gw       = gutterWidth (context e)+    eqIndent = T.replicate (gw + 1) " "+    header   = headerLine cmode (severity e) (code e) (docToStyledText cmode (message e))+    snip     = snippetLines glyphs (severity e) cmode (goPalette opts) (goTabWidth opts) (goContextLines opts) gw (context e)+    trailer  = helpSeeLines gw (fmap (docToStyledText cmode) (help e))+                 (fmap (\u -> hyperlink (goHyperlinkMode opts) u (unUrl u)) (url e))+                 ++ causeLinesFor opts cmode glyphs eqIndent sd+                 ++ relatedForest opts glyphs gw eqIndent (walkRelated (goRelatedDepth opts) sd)+    sep      = [T.replicate (gw + 1) " " <> gRail glyphs | not (null snip) && not (null trailer)]++-- | The "= caused by: ..." lines for a diagnostic's own 'diagnosticCause'+-- chain, indented to the given column. Shared by 'renderRoot' and every+-- 'relatedChild' so a diagnostic's causes render identically regardless of+-- where in the report it appears: a related diagnostic's cause chain is not+-- a second-class citizen relative to the root's.+causeLinesFor :: GraphicalOptions -> ColorMode -> Glyphs -> Text -> SomeDiagnostic -> [Text]+causeLinesFor opts cmode glyphs indent sd =+  [ indent <> "= caused by: " <> summaryOf cmode glyphs c+  | c <- walkCauses (goRelatedDepth opts) sd ]++-- === Header ===============================================================++headerLine :: ColorMode -> Severity -> Maybe DiagnosticCode -> Text -> Text+headerLine cmode sev mcode msg =+  colorize cmode (severityStyle sev) (word <> codePart <> ":") <> " " <> msg+  where+    word     = T.takeWhile (/= ':') (severityGraphicalHeader (severityLabels sev))+    codePart = maybe "" (\c -> "[" <> unDiagnosticCode c <> "]") mcode++-- === Snippet ==============================================================++-- Width of the line-number gutter: enough for the largest displayed line+-- number across every source group (Phase 12: one shared width keeps the+-- gutter, and everything indented to it -- help/see/related lines -- aligned+-- across a multi-file report), or 1 when there are no resolved labels+-- anywhere. A one-group context yields exactly the width it always did.+gutterWidth :: Context -> Int+gutterWidth ctx = length (show (foldr max 1 (concatMap okEndLines (contextSourceGroups ctx))))+  where+    okEndLines (SourceGroup _ lbls) =+      [ lcLine (resolvedEnd rs) | Labeled (LabelOk rs) _ _ <- NE.toList lbls ]++-- | One graphical block (location line, gutter, source, carets) per source+-- group, in group order, separated by a lone rail line -- the same+-- separator convention 'relatedChild' already uses between a nested+-- diagnostic's own snippet and its related forest. A one-group context (the+-- only shape v1 ever produced before Phase 12) yields exactly the single+-- block 'groupSnippetLines' always produced, with no separator: this is a+-- strict generalisation, not a different rendering for the case that already+-- worked.+snippetLines :: Glyphs -> Severity -> ColorMode -> NonEmpty AnsiStyle -> Int -> Maybe Int -> Int -> Context -> [Text]+snippetLines glyphs sev cmode palette tabW ctxLines gw ctx =+  intercalate [groupSep] (map (groupSnippetLines glyphs sev cmode palette tabW ctxLines gw)+                              (contextSourceGroups ctx))+  where+    groupSep = T.replicate (gw + 1) " " <> gRail glyphs++groupSnippetLines+  :: Glyphs -> Severity -> ColorMode -> NonEmpty AnsiStyle -> Int -> Maybe Int -> Int+  -> SourceGroup -> [Text]+groupSnippetLines glyphs sev cmode palette tabW ctxLines gw (SourceGroup src labels) =+  [locationLine, railBlank] ++ body+  where+    indexed = zip [0 ..] (NE.toList labels)+    -- Per-kind rank (0-based, "how many earlier labels share this one's+    -- kind"), computed once over the OK labels in original document order and+    -- zipped alongside the global index @i@. @i@ still drives colour cycling+    -- (labelDisplayStyle / mlSuffix, a separate and already-correct+    -- mechanism); @rank@ drives only the ColorNever glyph (caretGlyph).+    okLabelKinds = [ k | (_, Labeled (LabelOk _) k _) <- indexed ]+    ranks        = kindRank okLabelKinds+    oks   = [ (i, rs, k, rank, docToStyledText cmode <$> txt)+            | ((i, Labeled (LabelOk rs) k txt), rank) <- zip indexed ranks ]+    stale = [ ()                      |     Labeled (LabelStale _) _ _   <- map snd indexed ]++    railIndent = T.replicate (gw + 1) " "+    railBlank  = railIndent <> gRail glyphs+    locationLine = railIndent <> gCorner glyphs <> gDash glyphs <> " " <> locText+    locText = maybe (scName src) posText locRs+    posText rs = scName src+                   <> ":" <> tshow (lcLine (resolvedStart rs))+                   <> ":" <> tshow (lcColumn (resolvedStart rs))+    locRs = case [ rs | (_, rs, Primary, _, _) <- oks ] of+      (rs:_) -> Just rs+      []     -> case oks of ((_, rs, _, _, _):_) -> Just rs; _ -> Nothing++    -- Multi-line spans get connector lanes; single-line labels get carets.+    startLineOf rs = lcLine (resolvedStart rs)+    endLineOf   rs = lcLine (resolvedEnd rs)+    isMulti     rs = startLineOf rs < endLineOf rs+    multis = [ (startLineOf rs, endLineOf rs, k, txt) | (_, rs, k, _, txt) <- oks, isMulti rs ]+    laneAssign = assignLanes [ (s, e) | (s, e, _, _) <- multis ]+    nLanes = laneCount laneAssign+    laneInfo = zipWith (\(lane, iv) (_, _, k, txt) -> (lane, iv, k, txt)) laneAssign multis+    gsep = if nLanes > 0 then T.singleton ' ' else T.empty+    laneIvAt lane l = case [ iv | (lane', iv@(s, e), _, _) <- laneInfo+                                , lane' == lane, s <= l, l <= e ] of+      (iv : _) -> Just iv+      []       -> Nothing+    glyphOfCell Open    = gMLopen glyphs+    glyphOfCell Through = gMLthru glyphs+    glyphOfCell Close   = gMLclose glyphs+    glyphOfCell Blank   = ' '+    srcGutter l = if nLanes == 0 then T.empty+                  else T.pack [ maybe ' ' (\iv -> glyphOfCell (cellAt iv l)) (laneIvAt lane l)+                              | lane <- [0 .. nLanes - 1] ] <> gsep+    contBelow lane l = case laneIvAt lane l of+      Just (s, e) -> s <= l && l < e+      Nothing     -> False+    caretGutter l = if nLanes == 0 then T.empty+                    else T.pack [ if contBelow lane l then gMLthru glyphs else ' '+                                | lane <- [0 .. nLanes - 1] ] <> gsep+    mlSuffix l = T.concat+      [ "  " <> colorize cmode (labelDisplayStyle sev palette k lane) t+      | (lane, (_, e), k, mt) <- laneInfo, e == l, Just t <- [mt] ]++    body = okBlock ++ staleBlock+    okBlock = case ([ startLineOf rs | (_, rs, _, _, _) <- oks ]+                    ++ [ endLineOf rs | (_, rs, _, _, _) <- oks, isMulti rs ]) of+      []       -> []+      (s : ss) -> concatMap (renderEntry win) plan+        where plan   = planLines ctxLines (scLineCount src) (s : ss)+              showns = [ l | ShowLine l <- plan ]+              win    = case showns of+                         (w : ws) -> scLines src (foldr min w ws, foldr max w ws)+                         []       -> []+    renderEntry _   (ElideLines _) = [railIndent <> gVellip glyphs]+    renderEntry win (ShowLine l)   = lineWithCarets win l+    lineWithCarets win l = numbered : caretsHere+      where+        srcLine  = sanitizeLine (lineLookup win l)+        numbered = T.justifyRight gw ' ' (tshow l) <> " " <> gRail glyphs <> " "+                     <> srcGutter l <> expandTabs tabW srcLine <> mlSuffix l+        caretsHere =+          [ caretLine l i rs k rank txt srcLine+          | (i, rs, k, rank, txt) <- oks, not (isMulti rs), startLineOf rs == l ]+    caretLine l i rs k rank txt srcLine =+      railIndent <> gRail glyphs <> " " <> caretGutter l+        <> T.replicate dispStart " "+        <> colorize cmode (labelDisplayStyle sev palette k i)+             (T.replicate cw (T.singleton (caretGlyph cmode k rank)) <> maybe "" (" " <>) txt)+      where+        (dispStart, cw) = caretLayout tabW srcLine (lcColumn (resolvedStart rs))+                                      (spanCharLen rs)++    staleBlock =+      [ railIndent <> gRail glyphs <> " (span unavailable "+          <> gEmDash glyphs <> " source no longer matches at this position)"+      | _ <- stale ]++spanCharLen :: ResolvedSpan -> Int+spanCharLen = unLength . spanLength++-- === Help / See ===========================================================++helpSeeLines :: Int -> Maybe Text -> Maybe Text -> [Text]+helpSeeLines gw mhelp murl =+     [ eqIndent <> "= help: " <> h | Just h <- [mhelp] ]+  ++ [ eqIndent <> "= see: "  <> u | Just u <- [murl] ]+  where eqIndent = T.replicate (gw + 1) " "++-- === Related nesting ======================================================++-- Render the related section under a parent, given the parent's eq-line indent.+relatedForest :: GraphicalOptions -> Glyphs -> Int -> Text -> RelatedTree -> [Text]+relatedForest opts glyphs _gw indent (RelatedTree parentDiag children term) =+     concatMap (relatedChild opts glyphs indent) children+  ++ depthNote+  where+    depthNote = case term of+      DepthTruncated ->+        [indent <> "= related: (" <> tshow (numRelated parentDiag)+                <> " more related diagnostics omitted)"]+      _ -> []++relatedChild :: GraphicalOptions -> Glyphs -> Text -> RelatedTree -> [Text]+relatedChild opts glyphs indent node@(RelatedTree childDiag _ term) =+  case term of+    CycleOmitted -> [indent <> "= related: (cycle omitted)"]+    _ ->+        (indent <> "= related: " <> summaryOf (goColorMode opts) glyphs childDiag)+      : map (nest <>) (childSnippet ++ childSep ++ childCauses ++ childRelated)+  where+    nest        = "  "+    childGw     = withDiag childDiag (gutterWidth . context)+    childIndent = T.replicate (childGw + 1) " "+    childSnippet = withDiag childDiag+      (\ce -> snippetLines glyphs (severity ce) (goColorMode opts) (goPalette opts) (goTabWidth opts) (goContextLines opts) childGw (context ce))+    -- Same call, same shape, as 'renderRoot': a related diagnostic's own+    -- "caused by" chain renders exactly as the root's would, just nested.+    childCauses  = causeLinesFor opts (goColorMode opts) glyphs childIndent childDiag+    childRelated = relatedForest opts glyphs childGw childIndent node+    childSep     = [childIndent <> gRail glyphs+                   | not (null childSnippet) && not (null (childCauses ++ childRelated))]++summaryOf :: ColorMode -> Glyphs -> SomeDiagnostic -> Text+summaryOf cmode glyphs (SomeDiagnostic e) =+  case code e of+    Just c  -> unDiagnosticCode c <> " " <> gEmDash glyphs <> " " <> msg+    Nothing -> msg+  where msg = docToStyledText cmode (message e)++numRelated :: SomeDiagnostic -> Int+numRelated (SomeDiagnostic e) = length (related e)++-- Apply a function that needs the concrete diagnostic behind a 'SomeDiagnostic'.+withDiag :: SomeDiagnostic -> (forall e. Diagnostic e => e -> a) -> a+withDiag (SomeDiagnostic e) f = f e++-- === Small helpers ========================================================++-- | ANSI style for each semantic annotation, interpreted at the graphical+-- handler's boundary (Ann.hs's own promised "toAnsiStyle in Phase 5").+toAnsiStyle :: Ann -> AnsiStyle+toAnsiStyle AnnCode     = Term.italicized+toAnsiStyle AnnKeyword  = Term.bold+toAnsiStyle AnnFilename = Term.underlined+toAnsiStyle AnnEmphasis = Term.bold <> Term.italicized++-- | Plain-text fallback marker for an 'Ann' under 'ColorNever', so the+-- information isn't lost in plain-text terminals either. Independent of+-- "Tadka.Internal.Renderer.Narratable"'s @toProseMarker@: each renderer+-- interprets 'Ann' at its own boundary, per Ann.hs's design comment.+plainAnnMarker :: Ann -> Text+plainAnnMarker AnnCode     = "`"+plainAnnMarker AnnFilename = "\""+plainAnnMarker AnnEmphasis = ""+plainAnnMarker AnnKeyword  = ""++-- | Render an annotated 'Doc' for the graphical handler to a single line+-- (embedded newlines are flattened to spaces so they can never break the+-- caret/gutter layout, mirroring miette's multi-line-label robustness fix,+-- #318). Sanitizes each raw text leaf (newlines and other control chars ->+-- space) BEFORE any annotation wrapping is applied, so a colour wrap's own+-- ANSI bytes are never mistaken for content needing sanitization — the bug a+-- naive "docToText but with a different renderer" fix would have+-- reintroduced (see remediation notes, issue #1).+docToStyledText :: ColorMode -> Doc Ann -> Text+docToStyledText cmode =+    renderSimplyDecorated sanitizeLeaf wrap . treeForm . layoutPretty (LayoutOptions Unbounded)+  where+    sanitizeLeaf = T.map (\c -> if c == '\n' || isControl c then ' ' else c)+    wrap ann inner = case cmode of+      ColorNever -> plainAnnMarker ann <> inner <> plainAnnMarker ann+      _          -> colorize cmode (toAnsiStyle ann) inner++-- | Replace control characters (except tab, handled by 'expandTabs') with a+-- space, so attacker-controlled source can't inject terminal escape sequences.+-- Width-preserving (every control char is width 1), so caret columns are unmoved.+sanitizeLine :: Text -> Text+sanitizeLine = T.map (\c -> if isControl c && c /= '\t' then ' ' else c)++-- | Text of line @n@ within a fetched window, or @""@ if absent. Total.+lineLookup :: [(Int, Text)] -> Int -> Text+lineLookup win n = case [ t | (m, t) <- win, m == n ] of+  (t : _) -> t+  []      -> ""++tshow :: Show a => a -> Text+tshow = T.pack . show
+ src/Tadka/Internal/Renderer/Json.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings #-}++-- | JSON report handler: the machine-readable+-- renderer. @Output 'TJson = Aeson.Value@ is produced only here, from a+-- dedicated 'DiagnosticDTO' — never by @deriving ToJSON@ on a+-- @Diagnostic@-bearing type. @ToJSON@ only in v1; a reviewed @FromJSON@ decode+-- path is deferred.+--+-- The DTO carries an explicit @"stale"@ flag per label (from+-- 'Tadka.Internal.Context.LabelState', not inferred from absence) and+-- @"truncated"@\/@"cycleOmitted"@ flags per level (from the Phase 3 walk's+-- 'TerminationReason'), so a machine consumer sees every state the graphical+-- and narratable handlers show visually.+--+-- No compatibility guarantee.+module Tadka.Internal.Renderer.Json+  ( JsonOptions (..)+  , DiagnosticDTO (..)+  , LabelDTO (..)+  , CauseDTO (..)+  , toDTO+  , renderJson+  ) where++import           Data.Aeson                (ToJSON (..), Value, object, (.=))+import qualified Data.List.NonEmpty        as NE+import           Data.Char                 (isControl)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import           Numeric.Natural           (Natural)+import           Prettyprinter             (Doc, LayoutOptions (..),+                                            PageWidth (Unbounded), layoutPretty)+import           Prettyprinter.Render.Text (renderStrict)++import           Tadka.Internal.Ann        (Ann)+import           Tadka.Internal.Context    (Context, LabelKind (..),+                                            LabelState (..), Labeled (..),+                                            SourceGroup (..), contextSourceGroups)+import           Tadka.Internal.Diagnostic (Diagnostic (..), SomeDiagnostic (..))+import           Tadka.Internal.Related    (RelatedTree (..), TerminationReason (..),+                                            walkCauses, walkRelated)+import           Tadka.Internal.Span       (LineCol (..), resolvedStart, spanLength)+import           Tadka.Internal.Types      (severityJsonTag, sourceName, unDiagnosticCode,+                                            unLength, unUrl)++-- | Resolved settings for the JSON handler (populated only by @selectRenderer@).+newtype JsonOptions = JsonOptions+  { joRelatedDepth :: Natural }+  deriving (Eq, Show)++-- | One label in the DTO. @line@\/@column@\/@length@ are 'Nothing' (JSON null)+-- when the label is stale; @stale@ always reflects+-- 'Tadka.Internal.Context.LabelState' explicitly. @file@ is always present+-- : it names the source the label belongs to, even when the label+-- is stale, so a machine consumer never has to infer which file a label was+-- meant for from position alone.+data LabelDTO = LabelDTO+  { ldFile    :: Text+  , ldLine    :: Maybe Int+  , ldColumn  :: Maybe Int+  , ldLength  :: Maybe Int+  , ldText    :: Maybe Text+  , ldPrimary :: Bool+  , ldStale   :: Bool+  }+  deriving (Eq, Show)++-- | The machine-readable diagnostic. @truncated@\/@cycleOmitted@ record whether+-- related entries at this level were dropped at the depth limit or as a cycle.+data DiagnosticDTO = DiagnosticDTO+  { dtoCode         :: Maybe Text+  , dtoSeverity     :: Text+  , dtoMessage      :: Text+  , dtoLabels       :: [LabelDTO]+  , dtoHelp         :: Maybe Text+  , dtoUrl          :: Maybe Text+  , dtoRelated      :: [DiagnosticDTO]+  , dtoCauses       :: [CauseDTO]+  , dtoTruncated    :: Bool+  , dtoCycleOmitted :: Bool+  }+  deriving (Eq, Show)++instance ToJSON LabelDTO where+  toJSON l = object+    [ "file"    .= ldFile l+    , "line"    .= ldLine l+    , "column"  .= ldColumn l+    , "length"  .= ldLength l+    , "text"    .= ldText l+    , "primary" .= ldPrimary l+    , "stale"   .= ldStale l+    ]++-- | A cause is rendered as lightweight provenance (code + message), matching+-- the summary treatment the graphical and narratable handlers give the chain.+data CauseDTO = CauseDTO+  { causeCode    :: Maybe Text+  , causeMessage :: Text+  }+  deriving (Eq, Show)++instance ToJSON CauseDTO where+  toJSON c = object [ "code" .= causeCode c, "message" .= causeMessage c ]++instance ToJSON DiagnosticDTO where+  toJSON d = object+    [ "code"         .= dtoCode d+    , "severity"     .= dtoSeverity d+    , "message"      .= dtoMessage d+    , "labels"       .= dtoLabels d+    , "help"         .= dtoHelp d+    , "url"          .= dtoUrl d+    , "related"      .= dtoRelated d+    , "causes"       .= dtoCauses d+    , "truncated"    .= dtoTruncated d+    , "cycleOmitted" .= dtoCycleOmitted d+    ]++-- | Convert a Phase 3 walk tree into a DTO. Cycle-marker children become the+-- @cycleOmitted@ flag (not nested entries); depth-truncation becomes+-- @truncated@ on the node whose children were cut. The same 'depth' budget+-- used to build the 'related' tree also bounds each node's own 'causes'+-- chain — one recursive definition, applied uniformly to the root and to+-- every related diagnostic, so a node's causes never depend on whether it+-- happens to be the one the caller started from.+toDTO :: Natural -> RelatedTree -> DiagnosticDTO+toDTO depth (RelatedTree sd@(SomeDiagnostic e) children term) = DiagnosticDTO+  { dtoCode         = unDiagnosticCode <$> code e+  , dtoSeverity     = severityJsonTag (severity e)+  , dtoMessage      = docToText (message e)+  , dtoLabels       = labelsDTO (context e)+  , dtoHelp         = docToText <$> help e+  , dtoUrl          = unUrl <$> url e+  , dtoRelated      = [ toDTO depth c | c <- children, not (isCycle c) ]+  , dtoCauses       = map causeDTO (walkCauses depth sd)+  , dtoTruncated    = term == DepthTruncated+  , dtoCycleOmitted = any isCycle children+  }+  where isCycle (RelatedTree _ _ t) = t == CycleOmitted++labelsDTO :: Context -> [LabelDTO]+labelsDTO = concatMap groupLabels . contextSourceGroups+  where+    groupLabels :: SourceGroup -> [LabelDTO]+    groupLabels (SourceGroup src lbls) = map (toLabel (sourceName src)) (NE.toList lbls)++    toLabel :: Text -> Labeled LabelState -> LabelDTO+    toLabel file (Labeled (LabelOk rs) k txt) = LabelDTO+      { ldFile    = file+      , ldLine    = Just (lcLine (resolvedStart rs))+      , ldColumn  = Just (lcColumn (resolvedStart rs))+      , ldLength  = Just (unLength (spanLength rs))+      , ldText    = docToText <$> txt+      , ldPrimary = k == Primary+      , ldStale   = False+      }+    toLabel file (Labeled (LabelStale _) k txt) = LabelDTO+      { ldFile = file, ldLine = Nothing, ldColumn = Nothing, ldLength = Nothing+      , ldText = docToText <$> txt, ldPrimary = k == Primary, ldStale = True+      }++renderJson :: Diagnostic e => JsonOptions -> e -> Value+renderJson opts e = toJSON (toDTO depth (walkRelated depth root))+  where+    root  = SomeDiagnostic e+    depth = joRelatedDepth opts++causeDTO :: SomeDiagnostic -> CauseDTO+causeDTO (SomeDiagnostic e) = CauseDTO (unDiagnosticCode <$> code e) (docToText (message e))++-- Plain-text rendering of an annotated document (annotations discarded); JSON+-- string values carry the raw message\/label\/help text.+docToText :: Doc Ann -> Text+docToText = T.map (\c -> if isControl c then ' ' else c)+          . renderStrict . layoutPretty (LayoutOptions Unbounded)
+ src/Tadka/Internal/Renderer/Layout.hs view
@@ -0,0 +1,79 @@+-- | Phase III of the snippet-renderer rework: the pure core of multi-line span+-- rendering — assigning each multi-line span a /lane/ (a column in the connector+-- gutter) so that spans sharing any line never collide, and deciding what each+-- lane shows on a given line.+--+-- This module is deliberately free of glyphs, colour, and label text: it works+-- only on @(startLine, endLine)@ intervals, so the fiddly assignment algorithm+-- is fully property-testable. The graphical handler maps its labels to+-- intervals, assigns lanes here, then draws.+--+-- No compatibility guarantee (see "Tadka.Internal").+module Tadka.Internal.Renderer.Layout+  ( CellKind (..)+  , assignLanes+  , laneCount+  , cellAt+  ) where++import           Data.List (sortOn)++-- | What a lane shows at a particular line, for the span occupying it.+data CellKind+  = Open      -- ^ the span starts on this line+  | Through   -- ^ the span passes through (strictly between start and end)+  | Close     -- ^ the span ends on this line+  | Blank     -- ^ the span does not touch this line+  deriving (Eq, Show)++-- | Assign a 0-based lane to each inclusive @(start, end)@ interval by greedy+-- interval-graph colouring: intervals that share any line get distinct lanes,+-- while disjoint intervals may reuse a lane. The result is paired back in the+-- original input order, so callers can zip it against their labels.+--+-- Total: any list of intervals (including inverted or negative ones) yields an+-- assignment; no partial functions are used.+assignLanes :: [(Int, Int)] -> [(Int, (Int, Int))]+assignLanes ivs =+  let indexed  = zip [0 :: Int ..] ivs+      sorted   = sortOn (\(_, (s, _)) -> s) indexed+      assigned = go [] sorted                       -- [(originalIndex, lane)]+  in [ (laneOf i assigned, iv) | (i, iv) <- indexed ]+  where+    go :: [Int] -> [(Int, (Int, Int))] -> [(Int, Int)]+    go _        []                    = []+    go laneEnds ((idx, (s, e)) : rest) =+      let lane = pickLane laneEnds s+      in (idx, lane) : go (setLane lane e laneEnds) rest++    laneOf i assigned = case lookup i assigned of+      Just l  -> l+      Nothing -> 0        -- unreachable: every index is assigned++-- | Lowest lane whose current occupant ends before this span starts, or a new+-- lane (the current count) if none is free.+pickLane :: [Int] -> Int -> Int+pickLane ends s = go 0 ends+  where+    go i []       = i+    go i (e : es)+      | e < s     = i+      | otherwise = go (i + 1) es++-- | Record that @lane@ now ends at @e@, extending the list if it is a new lane.+setLane :: Int -> Int -> [Int] -> [Int]+setLane lane e ends =+  let (before, after) = splitAt lane ends+  in before ++ [e] ++ drop 1 after++-- | Number of lanes an assignment uses (0 when empty).+laneCount :: [(Int, (Int, Int))] -> Int+laneCount = foldr (\(l, _) acc -> max (l + 1) acc) 0++-- | What an interval shows on a given line. Total.+cellAt :: (Int, Int) -> Int -> CellKind+cellAt (s, e) l+  | l == s && s < e        = Open+  | l == e && s < e        = Close+  | s < l && l < e         = Through+  | otherwise              = Blank
+ src/Tadka/Internal/Renderer/LinePlan.hs view
@@ -0,0 +1,81 @@+-- | Phase II of the snippet-renderer rework: a pure planner that decides which+-- source lines to render and where to elide, independent of any glyph drawing.+--+-- Keeping this as a pure IR between resolved labels and rendered text means the+-- fiddly selection logic (context windows, window merging, gap elision) is+-- fully property-testable without producing a single character of output.+--+-- No compatibility guarantee (see "Tadka.Internal").+module Tadka.Internal.Renderer.LinePlan+  ( PlanEntry (..)+  , planLines+  , mergeIntervals+  ) where++import           Data.List (sortOn)++-- | One entry in a rendered snippet: either show a specific 1-based source+-- line, or elide a run of @n@ hidden lines (@n >= 1@).+data PlanEntry+  = ShowLine !Int+  | ElideLines !Int+  deriving (Eq, Show)++-- | Decide which 1-based source lines to render for a set of labelled anchor+-- lines, given the total number of available lines.+--+--   * 'Nothing' context: render the contiguous range from the lowest to the+--     highest anchor — the historical behaviour, with no elision.+--   * @'Just' ctx@: render each anchor with @ctx@ lines of context above and+--     below, merge overlapping or adjacent windows, and elide the gaps between+--     them.+--+-- Total: an empty anchor list yields an empty plan, negative context is treated+-- as zero, and every line number is clamped to @[1, total]@.+planLines :: Maybe Int -> Int -> [Int] -> [PlanEntry]+planLines _ _ [] = []+planLines Nothing total anchors@(a : as)+  | hi - lo + 1 <= safetyCap = [ ShowLine l | l <- [lo .. hi] ]+  | otherwise                = planLines (Just fallbackContext) total anchors  -- bound huge ranges+  where+    lo = clamp1 (foldr min a as)+    hi = clampTop total (foldr max a as)+planLines (Just ctx) total (a : as) =+  emit (mergeIntervals [ (clamp1 (x - c), clampTop total (x + c)) | x <- a : as ])+  where c = max 0 ctx++-- | Upper bound on lines rendered contiguously (with no context set) before+-- falling back to a context window with elision. This keeps a span across a+-- huge line range from producing output proportional to the span rather than+-- to the diagnostic — every labelled line still appears, the gaps are elided.+safetyCap :: Int+safetyCap = 100++fallbackContext :: Int+fallbackContext = 2++-- | Merge inclusive intervals, combining those that overlap or merely touch+-- (a gap of at most one line), returned sorted and disjoint.+mergeIntervals :: [(Int, Int)] -> [(Int, Int)]+mergeIntervals ivs = go (sortOn fst ivs)+  where+    go []  = []+    go [i] = [i]+    go ((lo, hi) : (lo2, hi2) : rest)+      | lo2 <= hi + 1 = go ((lo, max hi hi2) : rest)+      | otherwise     = (lo, hi) : go ((lo2, hi2) : rest)++-- | Turn disjoint, sorted intervals into a plan, eliding the gaps between them.+emit :: [(Int, Int)] -> [PlanEntry]+emit []                              = []+emit [(lo, hi)]                      = [ ShowLine l | l <- [lo .. hi] ]+emit ((lo, hi) : nxt@((lo2, _) : _)) =+     [ ShowLine l   | l <- [lo .. hi] ]+  ++ [ ElideLines g | let g = lo2 - hi - 1, g > 0 ]+  ++ emit nxt++clamp1 :: Int -> Int+clamp1 = max 1++clampTop :: Int -> Int -> Int+clampTop total = min (max 1 total)
+ src/Tadka/Internal/Renderer/Narratable.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Narratable (accessibility-first) report handler:+-- prose, not layout. Every field the graphical handler can show has a prose+-- equivalent here — nothing is silently dropped between renderers.+--+-- 'Ann' is interpreted for prose via 'toProseMarker' (e.g. inline code is+-- surrounded with quotes), so annotated message\/label\/help content reads+-- naturally aloud.+--+-- No compatibility guarantee.+module Tadka.Internal.Renderer.Narratable+  ( NarratableOptions (..)+  , renderNarratable+  , toProseMarker+  ) where++import qualified Data.List.NonEmpty                    as NE+import           Data.Text                             (Text)+import           Data.Char                             (isControl)+import qualified Data.Text                             as T+import           Numeric.Natural                       (Natural)+import           Prettyprinter                         (Doc, LayoutOptions (..),+                                                        PageWidth (Unbounded),+                                                        layoutPretty)+import           Prettyprinter.Render.Util.SimpleDocTree (renderSimplyDecorated, treeForm)++import           Tadka.Internal.Ann                    (Ann (..))+import           Tadka.Internal.Context                (Context, LabelKind (..),+                                                        LabelState (..), Labeled (..),+                                                        SourceGroup (..), contextSourceGroups)+import           Tadka.Internal.SourceCode             (SourceCode (..))+import           Tadka.Internal.Diagnostic             (Diagnostic (..), SomeDiagnostic (..))+import           Tadka.Internal.Related                (RelatedTree (..),+                                                        TerminationReason (..), walkCauses,+                                                        walkRelated)+import           Tadka.Internal.Span                   (LineCol (..),+                                                        StaleReason (..), resolvedStart,+                                                        spanLength)+import           Tadka.Internal.Types                  (Severity, SeverityLabels (..),+                                                        severityLabels, unDiagnosticCode,+                                                        unLength, unUrl)++-- | Resolved settings for the narratable handler (populated only by+-- @selectRenderer@).+newtype NarratableOptions = NarratableOptions+  { noRelatedDepth :: Natural }+  deriving (Eq, Show)++-- | How an 'Ann' is marked in prose. Inline code and file names are surrounded+-- with quotes so they read as distinct tokens; emphasis and keywords carry no+-- prose marker.+toProseMarker :: Ann -> Text+toProseMarker AnnCode     = "\""+toProseMarker AnnFilename = "\""+toProseMarker AnnEmphasis = ""+toProseMarker AnnKeyword  = ""++-- | Render an annotated document to prose, wrapping each annotated span with+-- its 'toProseMarker'.+docToProse :: Doc Ann -> Text+docToProse =+    T.map flat . renderSimplyDecorated id wrap . treeForm . layoutPretty (LayoutOptions Unbounded)+  where wrap ann inner = toProseMarker ann <> inner <> toProseMarker ann+        flat c = if isControl c then ' ' else c   -- one line per sentence; strip control chars++renderNarratable :: Diagnostic e => NarratableOptions -> e -> Text+renderNarratable opts e = T.intercalate "\n" (renderProse opts (SomeDiagnostic e))++renderProse :: NarratableOptions -> SomeDiagnostic -> [Text]+renderProse opts sd@(SomeDiagnostic e) =+     headerSentence (severity e) (fmap unDiagnosticCode (code e)) (docToProse (message e))+   : contextSentences (context e)+  ++ helpSentences (fmap docToProse (help e)) (fmap unUrl (url e))+  ++ causeSentences (walkCauses (noRelatedDepth opts) sd)+  ++ relatedSentences opts (walkRelated (noRelatedDepth opts) sd)++-- === Header ===============================================================++headerSentence :: Severity -> Maybe Text -> Text -> Text+headerSentence sev mcode msg = prefix <> " " <> codeClause <> msg <> "."+  where+    prefix     = severityNarratablePrefix (severityLabels sev)     -- e.g. "Error,"+    codeClause = maybe "" (\c -> "code " <> c <> ": ") mcode++-- === Context (location, source, labels) ===================================++-- | One prose block per source group, in group order (Phase 12: a context can+-- now span more than one source; each group gets its own \"Location: ...\"+-- sentence anchored on that group's own first primary label, exactly as the+-- single-group case always has). A one-group context — the only shape v1 ever+-- produced before Phase 12 — yields exactly the same sentences, in the same+-- order, as before: this is a strict generalisation of the prior behaviour,+-- not a different rendering for the case that already worked.+contextSentences :: Context -> [Text]+contextSentences = concatMap groupSentences . contextSourceGroups++groupSentences :: SourceGroup -> [Text]+groupSentences (SourceGroup src labels) = locationSentence ++ labelReadouts+  where+    indexed = NE.toList labels+    oks     = [ (k, rs) | Labeled (LabelOk rs) k _ <- indexed ]++    locRs = case [ rs | (Primary, rs) <- oks ] of+      (rs:_) -> Just rs+      []     -> case oks of ((_, rs):_) -> Just rs; _ -> Nothing+    locationSentence = case locRs of+      Just rs -> [ "Location: " <> scName src+                     <> ", line "   <> tshow (lcLine (resolvedStart rs))+                     <> ", column " <> tshow (lcColumn (resolvedStart rs)) <> "." ]+      Nothing -> [ "Location: " <> scName src <> "." ]++    labelReadouts = concatMap readout indexed+    readout (Labeled (LabelOk rs) k txt) =+      [ "Source line " <> tshow n <> ": \"" <> lineTextAt src n <> "\"."+      , leadIn k <> colClause <> labeled ]+      where+        n       = lcLine (resolvedStart rs)+        startC  = lcColumn (resolvedStart rs)+        effLen  = max 1 (unLength (spanLength rs))+        endC    = startC + effLen - 1+        colClause | startC == endC = "column " <> tshow startC+                  | otherwise      = "columns " <> tshow startC <> " through " <> tshow endC+        labeled = maybe "." (\t -> ", labeled: " <> docToProse t <> ".") txt+    readout (Labeled (LabelStale reason) _ txt) = [ staleSentence reason txt ]++    leadIn Primary   = "The problem is at "+    leadIn Secondary = "Related context is at "++staleSentence :: StaleReason -> Maybe (Doc Ann) -> Text+staleSentence reason txt =+  "A labeled position could not be shown because " <> reasonText reason+    <> maybe "." (\t -> ", labeled: " <> docToProse t <> ".") txt+  where+    reasonText SpanOutOfBounds = "the span is out of bounds for the current source"++-- === Help / URL ===========================================================++helpSentences :: Maybe Text -> Maybe Text -> [Text]+helpSentences mhelp murl =+     [ "Help: " <> h             | Just h <- [mhelp] ]+  ++ [ "More information: " <> u | Just u <- [murl] ]++-- === Related ==============================================================++relatedSentences :: NarratableOptions -> RelatedTree -> [Text]+relatedSentences opts (RelatedTree rootDiag children term) =+     concatMap (relatedChild opts) children+  ++ truncationNote term (numRelated rootDiag)++relatedChild :: NarratableOptions -> RelatedTree -> [Text]+relatedChild opts (RelatedTree childDiag kids term) = case term of+  CycleOmitted -> [ "A related diagnostic was omitted because it forms a cycle." ]+  _ ->+       ("Related: " <> summaryProse childDiag <> ".")+       -- Same call, same shape, as 'renderProse': a related diagnostic's own+       -- cause chain reads exactly as the root's would, just nested here.+     : causeSentences (walkCauses (noRelatedDepth opts) childDiag)+    ++ concatMap (relatedChild opts) kids+    ++ truncationNote term (numRelated childDiag)++truncationNote :: TerminationReason -> Int -> [Text]+truncationNote DepthTruncated n =+  [ tshow n <> " more related diagnostic" <> plural n <> " omitted at the depth limit." ]+truncationNote _ _ = []++plural :: Int -> Text+plural 1 = " was"+plural _ = "s were"++causeSentences :: [SomeDiagnostic] -> [Text]+causeSentences = map (\c -> "Caused by: " <> summaryProse c <> ".")++summaryProse :: SomeDiagnostic -> Text+summaryProse (SomeDiagnostic e) = case code e of+  Just c  -> unDiagnosticCode c <> " \x2014 " <> msg    -- em dash+  Nothing -> msg+  where msg = docToProse (message e)++numRelated :: SomeDiagnostic -> Int+numRelated (SomeDiagnostic e) = length (related e)++-- === Helpers ==============================================================++-- | Text of source line @n@ (1-based), fetched as a one-line window. Total.+lineTextAt :: SourceCode a => a -> Int -> Text+lineTextAt src n = case scLines src (n, n) of+  ((_, t) : _) -> T.map (\c -> if isControl c then ' ' else c) t+  []           -> ""++tshow :: Show a => a -> Text+tshow = T.pack . show
+ src/Tadka/Internal/SourceCode.hs view
@@ -0,0 +1,37 @@++--+-- No compatibility guarantee (see "Tadka.Internal").+module Tadka.Internal.SourceCode+  ( SourceCode (..)+  ) where++import           Data.Text            (Text)+import qualified Data.Text            as T++import           Tadka.Internal.Types (NamedSource, sourceName, sourceText)++-- | Read-only, windowed access to a source for rendering.+class SourceCode a where+  -- | Display name of the source (e.g. a file path).+  scName  :: a -> Text+  -- | The 1-based inclusive line range @(firstLine, lastLine)@ as+  -- @(lineNumber, lineText)@ pairs, clamped to the lines that exist and+  -- returned in ascending order. An empty or inverted range yields @[]@.+  scLines :: a -> (Int, Int) -> [(Int, Text)]+  -- | Total number of lines available (used to clamp context windows).+  scLineCount :: a -> Int++-- | The canonical, in-memory instance: the whole source is split once and the+-- requested window is filtered out of it. A trailing @\\r@ is stripped from each+-- line so @\\r\\n@ (CRLF) sources render without stray carriage returns.+instance SourceCode NamedSource where+  scName = sourceName+  scLineCount = length . T.splitOn (T.singleton '\n') . sourceText+  scLines ns (lo, hi)+    | hi < lo   = []+    | otherwise = [ p | p@(n, _) <- numbered, n >= lo, n <= hi ]+    where+      numbered = zip [1 ..] (map dropCR (T.splitOn (T.singleton '\n') (sourceText ns)))+      dropCR t = case T.stripSuffix (T.singleton '\r') t of+        Just t' -> t'+        Nothing -> t
+ src/Tadka/Internal/Span.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+++--+-- No compatibility guarantee.+module Tadka.Internal.Span+  ( -- * Resolution index+    Resolution (..)+  , SpanF+  , Span+  , ResolvedSpan+    -- * Building unresolved spans+  , mkSpan+  , SpanBuildError (..)+    -- * Accessors+  , spanOffset+  , spanLength+  , resolvedStart+  , resolvedEnd+  , LineCol (..)+    -- * Resolution+  , resolveSpan+  , SpanError (..)+  , spanErrorReason+  , StaleReason (..)+  ) where++import           Data.Bifunctor (first)+import           Data.Text      (Text)+import qualified Data.Text      as T++import           Tadka.Internal.Types+                   (Length, NamedSource, Offset, LengthError, OffsetError,+                    mkLength, mkOffset, sourceText, unLength, unOffset)++-- | Whether a span has been checked against a concrete source.+data Resolution = Unresolved | Resolved++-- | A span, indexed by whether it has been resolved. The data constructors are+-- not exported: an unresolved span is built with 'mkSpan', and a resolved span+-- can only be produced by 'resolveSpan', so a 'ResolvedSpan' with inconsistent+-- line/column data is unrepresentable.+data SpanF (r :: Resolution) where+  RawSpan      :: Offset -> Length -> SpanF 'Unresolved+  ResolvedSpan :: Offset -> Length -> LineCol -> LineCol -> SpanF 'Resolved++deriving instance Show (SpanF r)+deriving instance Eq (SpanF r)++-- | An unresolved span: raw offset and length, not yet checked against a source.+type Span = SpanF 'Unresolved++-- | A resolved span: positions checked against a specific source, with+-- computed start/end line-column pairs.+type ResolvedSpan = SpanF 'Resolved++-- | A one-based line/column position.+data LineCol = LineCol+  { lcLine   :: !Int+  , lcColumn :: !Int+  }+  deriving (Eq, Ord, Show)++-- | Why 'mkSpan' rejected its inputs.+data SpanBuildError+  = SpanBadOffset OffsetError+  | SpanBadLength LengthError+  deriving (Eq, Show)++-- | Build an unresolved 'Span' from a raw offset and length, validating both+-- (non-negative). This is the only exported way to construct a 'Span'.+mkSpan :: Int -> Int -> Either SpanBuildError Span+mkSpan o l = do+  off <- first SpanBadOffset (mkOffset o)+  len <- first SpanBadLength (mkLength l)+  pure (RawSpan off len)++-- | The starting offset of any span.+spanOffset :: SpanF r -> Offset+spanOffset (RawSpan o _)          = o+spanOffset (ResolvedSpan o _ _ _) = o++-- | The length of any span.+spanLength :: SpanF r -> Length+spanLength (RawSpan _ l)          = l+spanLength (ResolvedSpan _ l _ _) = l++-- | The start position of a resolved span.+resolvedStart :: ResolvedSpan -> LineCol+resolvedStart (ResolvedSpan _ _ s _) = s++-- | The end position of a resolved span.+resolvedEnd :: ResolvedSpan -> LineCol+resolvedEnd (ResolvedSpan _ _ _ e) = e+++data StaleReason+  = SpanOutOfBounds+  deriving (Eq, Show)++-- | The concrete failure returned by 'resolveSpan'.+data SpanError = SpanOutOfBoundsError+  { spanErrorSpanEnd     :: !Integer  -- ^ offset + length (character index)+  , spanErrorSourceChars :: !Int      -- ^ number of characters in the source+  }+  deriving (Eq, Show)++-- | Map a 'SpanError' to the 'StaleReason' recorded in a degraded label.+spanErrorReason :: SpanError -> StaleReason+spanErrorReason SpanOutOfBoundsError{} = SpanOutOfBounds++-- | Resolve a span against a source, computing its line/column positions.+-- Fails with 'SpanOutOfBoundsError' if the span's end lies beyond the source.+-- Offsets and lengths are measured in characters (code points).+resolveSpan :: NamedSource -> Span -> Either SpanError ResolvedSpan+resolveSpan src (RawSpan off len) =+  if end > toInteger n+    then Left+      (SpanOutOfBoundsError+        { spanErrorSpanEnd = end+        , spanErrorSourceChars = n+        })+    else+      Right+        (ResolvedSpan+          off+          len+          (offsetToLineCol txt o)+          (offsetToLineCol txt (fromInteger end)))+  where+    txt = sourceText src+    o   = unOffset off+    l   = unLength len+    end = toInteger o + toInteger l+    n   = T.length txt++-- | One-based line/column of a character offset into the text. Assumes+-- @0 <= off <= T.length txt@ (guaranteed by 'resolveSpan''s bounds check).+offsetToLineCol :: Text -> Int -> LineCol+offsetToLineCol txt off = LineCol lineNo col+  where+    prefix = T.take off txt+    lineNo = T.count "\n" prefix + 1+    col    = T.length (snd (T.breakOnEnd "\n" prefix)) + 1
+ src/Tadka/Internal/TH.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE TemplateHaskell #-}++-- | The @deriveDiagnostic@ Template Haskell splice:+-- an ordinary @Q@-monad splice, validated via 'reify', that generates a+-- 'Diagnostic' instance whose every method body is a direct, unmodified call to+-- a plain function exported from "Tadka.Internal" (or a class default) — so the+-- derive path and a hand-written instance are two doors into the same room.+--+-- The one exception is the default @message@ (@pretty . show@), which has no+-- manual-instance equivalent by definition.+--+-- No compatibility guarantee.+module Tadka.Internal.TH+  ( DiagnosticSpec (..)+  , defaultSpec+  , deriveDiagnostic+  , DiagnosticSumSpec+  , deriveDiagnosticSum+  ) where++import           Control.Monad              (forM)+import           Data.List                  (intercalate, nub, (\\))+import           Data.Maybe                 (catMaybes)+import           Data.Text                  (Text, pack, unpack)+import           Language.Haskell.TH+import           Prettyprinter              (pretty)++import           Tadka.Internal             (buildContext, buildContextWith,+                                             unsafeDiagnosticCode, unsafeUrl)+import           Tadka.Internal.Context     (Context (NoContext), LabelKind (..))+import           Tadka.Internal.Diagnostic  (Diagnostic (..), SomeDiagnostic)+import           Tadka.Internal.Span        (Span, SpanF)+import           Tadka.Internal.Types       (DiagnosticId, NamedSource, Severity (..),+                                             mkDiagnosticCode, mkDiagnosticId, mkUrl)++-- | Declarative description of a 'Diagnostic' instance to generate. See+-- 'defaultSpec' for the starting point.+data DiagnosticSpec = DiagnosticSpec+  { specCode        :: Maybe Text        -- ^ validated by 'mkDiagnosticCode' at splice time+  , specSeverity    :: Severity+  , specHelp        :: Maybe Text+  , specUrl         :: Maybe Text         -- ^ validated by 'mkUrl' at splice time+  , specSourceField :: Maybe Name         -- ^ must name a 'NamedSource'-typed field+  , specLabelFields :: [(Name, Text)]     -- ^ each 'Name' must name a 'Span'-typed field (primary)+  , specSecondaryLabelFields :: [(Name, Text)] -- ^ 'Span'-typed fields rendered as secondary labels+  , specLabelCollectionFields :: [(Name, Text)]+    -- ^ each 'Name' must name a @[Span]@-typed field; every element of that+    -- field's runtime list becomes its own primary label, all sharing the+    -- given text. For a variable number of same-kind occurrences (e.g. every+    -- prior binding of a name) known only at runtime, where 'specLabelFields'+    -- needs one field per label fixed at splice time. Rendered after all+    -- 'specLabelFields' entries, in field order, then list order; an empty+    -- runtime list simply contributes no labels.+  , specSecondaryLabelCollectionFields :: [(Name, Text)]+    -- ^ like 'specLabelCollectionFields', but each element is a secondary+    -- label — the collection counterpart of 'specSecondaryLabelFields'.+  , specRelated     :: Maybe Name         -- ^ must name a @['SomeDiagnostic']@-typed field+  , specCause       :: Maybe Name         -- ^ must name a @Maybe SomeDiagnostic@-typed field+                                          --   (diagnosticCause's own return type — an exact+                                          --   match, so the generated method is a bare field+                                          --   accessor, same discipline as specRelated/relatedMethod)+  , specId          :: Maybe Name         -- ^ must name a 'Text'- or 'DiagnosticId'-typed field+  , specMessage     :: Maybe (Q Exp)      -- ^ an @e -> Doc Ann@ expression; else @pretty . show@+  }++-- | Everything absent, severity 'SevError'.+defaultSpec :: DiagnosticSpec+defaultSpec = DiagnosticSpec+  { specCode = Nothing, specSeverity = SevError, specHelp = Nothing, specUrl = Nothing+  , specSourceField = Nothing, specLabelFields = [], specSecondaryLabelFields = []+  , specLabelCollectionFields = [], specSecondaryLabelCollectionFields = []+  , specRelated = Nothing, specCause = Nothing+  , specId = Nothing, specMessage = Nothing+  }++-- | Field kind for the @diagnosticId@ generator.+data IdKind = IdText | IdDiag++-- | Generate a 'Diagnostic' instance for the named record type.+deriveDiagnostic :: DiagnosticSpec -> Name -> Q [Dec]+deriveDiagnostic spec tyName = do+  fields <- reifyRecordFields tyName+  idInfo <- validateSpecAgainstFields tyName fields spec++  methods <- fmap catMaybes . sequence $+    [ Just <$> messageMethod spec+    , codeMethod (specCode spec)+    , Just <$> severityMethod (specSeverity spec)+    , helpMethod (specHelp spec)+    , urlMethod (specUrl spec)+    , contextMethod (specSourceField spec) (specLabelFields spec) (specSecondaryLabelFields spec)+                    (specLabelCollectionFields spec) (specSecondaryLabelCollectionFields spec)+    , relatedMethod (specRelated spec)+    , causeMethod (specCause spec)+    , diagIdMethod idInfo+    ]++  inst <- instanceD (pure []) [t| Diagnostic $(conT tyName) |] (map pure methods)+  pure [inst]++-- | Every field-reference/literal/precondition check a 'DiagnosticSpec'+-- needs, run against one constructor's field list. Shared between+-- 'deriveDiagnostic' (one constructor) and 'deriveDiagnosticSum' (one call+-- per constructor in the sum) so the two entry points can never validate+-- differently -- pulled out unchanged from what was previously+-- 'deriveDiagnostic''s own body.+validateSpecAgainstFields :: Name -> [(Name, Type)] -> DiagnosticSpec -> Q (Maybe (Name, IdKind))+validateSpecAgainstFields tyName fields spec = do+  -- Validate field references and types (compile errors on mismatch).+  mapM_ (\n -> expectHead fields n [''NamedSource] "specSourceField") (specSourceField spec)+  mapM_ (\(n, _) -> expectHead fields n [''Span, ''SpanF] "specLabelFields") (specLabelFields spec)+  mapM_ (\(n, _) -> expectHead fields n [''Span, ''SpanF] "specSecondaryLabelFields") (specSecondaryLabelFields spec)+  mapM_ (\(n, _) -> expectListHead fields n [''Span, ''SpanF] "specLabelCollectionFields")+        (specLabelCollectionFields spec)+  mapM_ (\(n, _) -> expectListHead fields n [''Span, ''SpanF] "specSecondaryLabelCollectionFields")+        (specSecondaryLabelCollectionFields spec)+  mapM_ (validateRelated fields) (specRelated spec)+  mapM_ (validateCause fields) (specCause spec)+  idInfo <- traverse (\n -> (,) n <$> validateId fields n) (specId spec)++  -- Validate literal code/url at splice time.+  mapM_ (validateLiteral mkDiagnosticCode "specCode") (specCode spec)+  mapM_ (validateLiteral mkUrl            "specUrl")  (specUrl spec)++  -- The default message needs Show.+  requireShowIfDefaultMessage spec tyName++  -- A label with no source field is not a smaller feature, it is a dropped+  -- one: 'contextMethod' can only emit a 'context' method when it has a+  -- source to anchor labels to, so with no 'specSourceField' it emits no+  -- method at all and every label below silently falls back to the class+  -- default ('NoContext') instead of failing loudly. Reject that combination+  -- here, at the one call site that already owns "malformed spec, fail now".+  requireSourceFieldForLabels spec tyName++  pure idInfo++-- === Sum-type (multi-constructor) derivation ==============================++-- | One (constructor name, per-variant spec) entry. A sum-type spec is a+-- list of these, one per constructor of the target type -- checked for+-- completeness (every constructor covered, no unknown constructor named) at+-- splice time in 'deriveDiagnosticSum'.+type DiagnosticSumSpec = [(Name, DiagnosticSpec)]++-- | Sum-type counterpart to 'deriveDiagnostic'. Generates one 'Diagnostic'+-- instance whose every method dispatches on the value's constructor via a+-- single top-level 'case', each arm computed by the same per-field logic+-- 'deriveDiagnostic''s own generators use -- so a sum-type instance and+-- 'deriveDiagnostic' on each variant standing alone produce, per arm,+-- expressions built the identical way (proven in+-- @test/props/Phase13.hs@ the same way Phase 8 proves it for the+-- single-constructor path).+deriveDiagnosticSum :: DiagnosticSumSpec -> Name -> Q [Dec]+deriveDiagnosticSum sumSpec tyName = do+  allCons <- reifyAllConstructors tyName+  requireCompleteSumSpec tyName allCons sumSpec++  enriched <- forM sumSpec $ \(cName, spec) -> do+    fields <- case lookup cName allCons of+      Just fs -> pure fs+      Nothing -> fail (nameBase tyName ++ ": internal error: constructor " ++ nameBase cName+                         ++ " missing from reified constructors after completeness check")+    idInfo <- validateSpecAgainstFields tyName fields spec+    pure (cName, spec, idInfo)++  methods <- sequence+    [ genSumMethod enriched 'message         (\e (_, spec, _)     -> messageMethodArm e spec)+    , genSumMethod enriched 'code            (\_ (_, spec, _)     -> codeMethodArm spec)+    , genSumMethod enriched 'severity        (\_ (_, spec, _)     -> severityMethodArm spec)+    , genSumMethod enriched 'help            (\_ (_, spec, _)     -> helpMethodArm spec)+    , genSumMethod enriched 'url             (\_ (_, spec, _)     -> urlMethodArm spec)+    , genSumMethod enriched 'context         (\e (_, spec, _)     -> contextMethodArm e spec)+    , genSumMethod enriched 'related         (\e (_, spec, _)     -> relatedMethodArm e spec)+    , genSumMethod enriched 'diagnosticCause (\e (_, spec, _)     -> causeMethodArm e spec)+    , genSumMethod enriched 'diagnosticId    (\e (_, _, idInfo)   -> diagIdMethodArm e idInfo)+    ]+  inst <- instanceD (pure []) [t| Diagnostic $(conT tyName) |] (map pure methods)+  pure [inst]++-- | Every constructor of the type must appear exactly once in the sum spec:+-- not missing, not named twice, and not naming a constructor the type+-- doesn't have. A missing constructor would silently produce an incomplete+-- instance rather than a deliberate decision; a duplicated constructor+-- (a plausible copy-paste mistake) is checked and reported before the+-- missing/unknown check below, since the list-difference logic that check+-- uses would otherwise report a duplicated-but-real constructor as+-- "not on this type" -- a correct symptom, but a confusing diagnosis for+-- what is actually a duplicate, not an unknown name; a typo'd constructor+-- name is far easier to debug as a splice-time failure than as a GHC+-- "non-exhaustive case" warning discovered at runtime.+requireCompleteSumSpec :: Name -> [(Name, [(Name, Type)])] -> DiagnosticSumSpec -> Q ()+requireCompleteSumSpec tyName allCons sumSpec = do+  let declaredNames = map fst allCons+      specNames     = map fst sumSpec+      dupes         = nub (specNames \\ nub specNames)+  if not (null dupes)+    then fail (nameBase tyName ++ ": deriveDiagnosticSum spec names constructor(s) more than once: "+                 ++ intercalate ", " (map nameBase dupes))+    else do+      let missing = declaredNames \\ specNames+          unknown = specNames \\ declaredNames+      case (missing, unknown) of+        ([], []) -> pure ()+        (ms, []) -> fail (nameBase tyName ++ ": deriveDiagnosticSum spec is missing constructor(s): "+                            ++ intercalate ", " (map nameBase ms))+        ([], us) -> fail (nameBase tyName ++ ": deriveDiagnosticSum spec names constructor(s) "+                            ++ "not on this type: " ++ intercalate ", " (map nameBase us))+        (ms, us) -> fail (nameBase tyName ++ ": deriveDiagnosticSum spec both is missing "+                            ++ intercalate ", " (map nameBase ms) ++ " and names unknown "+                            ++ intercalate ", " (map nameBase us))++-- | Like 'reifyRecordFields', but for every constructor of a (possibly+-- multi-constructor) 'data' declaration. Each result pairs a constructor's+-- 'Name' with its record field list, in declaration order. Still requires+-- record syntax on every constructor -- mixing record and positional+-- constructors in one sum type is not supported, since 'DiagnosticSpec's+-- field references are name-based.+reifyAllConstructors :: Name -> Q [(Name, [(Name, Type)])]+reifyAllConstructors tyName = do+  info <- reify tyName+  cons <- case info of+    TyConI (DataD _ _ _ _ cs _)   -> pure cs+    TyConI (NewtypeD _ _ _ _ c _) -> pure [c]+    _ -> fail (nameBase tyName ++ ": deriveDiagnosticSum expects a data or newtype declaration")+  traverse fieldsOf cons+  where+    fieldsOf (RecC cName vbts) = pure (cName, [(n, t) | (n, _, t) <- vbts])+    fieldsOf con = fail (nameBase tyName ++ ": deriveDiagnosticSum needs record syntax "+                           ++ "on every constructor (constructor " ++ conNameOf con+                           ++ " is not a record)")+    conNameOf (NormalC n _)     = nameBase n+    conNameOf (RecC n _)        = nameBase n+    conNameOf (InfixC _ n _)    = nameBase n+    conNameOf (ForallC _ _ c)   = conNameOf c+    conNameOf (GadtC ns _ _)    = intercalate "/" (map nameBase ns)+    conNameOf (RecGadtC ns _ _) = intercalate "/" (map nameBase ns)++-- | Build one instance method as a single top-level 'case' over the value's+-- constructor, each arm's RHS produced by @mkArm@ from that constructor's+-- own '(Name, DiagnosticSpec, Maybe (Name, IdKind))' entry. @mkArm@ receives+-- the SAME bound variable ('Name') the outer 'clause' binds, so every arm's+-- body references the one argument the whole method was called with, not a+-- variable local to that arm.+--+-- A constructor whose spec doesn't set a given optional field (help, url,+-- code, related, cause, id) still gets a real arm returning the class+-- default expression (@Nothing@, @[]@, @NoContext@) -- every method is+-- generated for every sum-type instance, never omitted, which keeps this+-- function's shape uniform across all nine methods at the cost of a few+-- bytes of always-@Nothing@ instance code for a spec that never uses a+-- given optional field on any of its constructors.+genSumMethod+  :: [(Name, DiagnosticSpec, Maybe (Name, IdKind))]+  -> Name+  -> (Name -> (Name, DiagnosticSpec, Maybe (Name, IdKind)) -> Q Exp)+  -> Q Dec+genSumMethod enriched methodName mkArm = do+  e <- newName "e"+  arms <- forM enriched $ \entry@(cName, _, _) -> do+    rhs <- mkArm e entry+    pure (match (recP cName []) (normalB (pure rhs)) [])+  funD methodName [clause [varP e] (normalB (caseE (varE e) arms)) []]++-- === Reflection helpers ===================================================++reifyRecordFields :: Name -> Q [(Name, Type)]+reifyRecordFields tyName = do+  info <- reify tyName+  con <- case info of+    TyConI (DataD _ _ _ _ [c] _)  -> pure c+    TyConI (NewtypeD _ _ _ _ c _) -> pure c+    TyConI DataD{}                -> fail (nameBase tyName ++ ": deriveDiagnostic needs a single-constructor record")+    _                             -> fail (nameBase tyName ++ ": deriveDiagnostic expects a data or newtype declaration")+  case con of+    RecC _ vbts -> pure [(n, t) | (n, _, t) <- vbts]+    _           -> fail (nameBase tyName ++ ": deriveDiagnostic needs record syntax with named fields")++fieldType :: [(Name, Type)] -> Name -> Q Type+fieldType fields n = case lookup n fields of+  Just t  -> pure t+  Nothing -> fail ("deriveDiagnostic: " ++ nameBase n ++ " is not a field of the target type")++-- Head 'Name' of a type application, peeling arguments and wrappers.+headName :: Type -> Maybe Name+headName (ConT n)    = Just n+headName (AppT t _)  = headName t+headName (SigT t _)  = headName t+headName (ParensT t) = headName t+headName _           = Nothing++expectHead :: [(Name, Type)] -> Name -> [Name] -> String -> Q ()+expectHead fields n allowed ctx = do+  ty <- fieldType fields n+  case headName ty of+    Just h | h `elem` allowed -> pure ()+    _ -> fail (ctx ++ ": field " ++ nameBase n ++ " has type " ++ pprint ty+                 ++ ", but must be one of " ++ show (map nameBase allowed))++-- | Like 'expectHead', but for a @specLabelCollectionFields@/+-- @specSecondaryLabelCollectionFields@ entry: the field must be a /list/ of+-- one of the allowed heads (@[Span]@, not @Span@).+expectListHead :: [(Name, Type)] -> Name -> [Name] -> String -> Q ()+expectListHead fields n allowed ctx = do+  ty <- fieldType fields n+  case ty of+    AppT ListT inner+      | Just h <- headName inner, h `elem` allowed -> pure ()+    _ -> fail (ctx ++ ": field " ++ nameBase n ++ " has type " ++ pprint ty+                 ++ ", but must be a list of one of " ++ show (map nameBase allowed))++validateRelated :: [(Name, Type)] -> Name -> Q ()+validateRelated fields n = do+  ty <- fieldType fields n+  case ty of+    AppT ListT inner | headName inner == Just ''SomeDiagnostic -> pure ()+    _ -> fail ("specRelated: field " ++ nameBase n ++ " has type " ++ pprint ty+                 ++ ", but must be [SomeDiagnostic]")++-- | Validate that a @specCause@ field is exactly @Maybe SomeDiagnostic@ —+-- 'diagnosticCause''s own return type — so 'causeMethod''s body can be a bare+-- accessor with no wrapping, preserving TH.hs's "every generated method body+-- is an unmodified call" invariant.+validateCause :: [(Name, Type)] -> Name -> Q ()+validateCause fields n = do+  ty <- fieldType fields n+  case ty of+    AppT (ConT m) inner | m == ''Maybe, headName inner == Just ''SomeDiagnostic -> pure ()+    _ -> fail ("specCause: field " ++ nameBase n ++ " has type " ++ pprint ty+                 ++ ", but must be Maybe SomeDiagnostic")++validateId :: [(Name, Type)] -> Name -> Q IdKind+validateId fields n = do+  ty <- fieldType fields n+  case headName ty of+    Just h | h == ''DiagnosticId -> pure IdDiag+           | h == ''Text         -> pure IdText+    _ -> fail ("specId: field " ++ nameBase n ++ " has type " ++ pprint ty+                 ++ ", but must be Text or DiagnosticId")++validateLiteral :: (Text -> Either e a) -> String -> Text -> Q ()+validateLiteral mk ctx t = case mk t of+  Right _ -> pure ()+  Left _  -> fail (ctx ++ ": invalid literal " ++ show (unpack t))++requireShowIfDefaultMessage :: DiagnosticSpec -> Name -> Q ()+requireShowIfDefaultMessage spec tyName = case specMessage spec of+  Just _  -> pure ()+  Nothing -> do+    ok <- isInstance ''Show [ConT tyName]+    if ok then pure ()+          else fail (nameBase tyName ++ ": the default message needs a Show instance"+                       ++ " (add `deriving Show`, or set specMessage)")++-- | 'contextMethod' below only produces a @context@ method when it is given+-- a 'specSourceField'; with none, it produces nothing at all, and the+-- generated instance falls back to the 'Diagnostic' class default+-- (@context _ = NoContext@) regardless of how many label fields the spec+-- names. That fallback is correct for a spec with no labels at all, and+-- wrong for one with labels and no source: every label reference the author+-- wrote would be compiled, accepted, and then never consulted. So this is+-- the one precondition 'contextMethod' cannot check for itself (by the time+-- it pattern-matches on @Nothing@, the label lists are already out of+-- scope) and must instead be enforced here, alongside the spec's other+-- "fail now or silently misbehave later" checks.+requireSourceFieldForLabels :: DiagnosticSpec -> Name -> Q ()+requireSourceFieldForLabels spec tyName = case specSourceField spec of+  Just _  -> pure ()+  Nothing+    | null allLabelFieldNames -> pure ()+    | otherwise -> fail+        (nameBase tyName ++ ": specLabelFields/specSecondaryLabelFields/"+          ++ "specLabelCollectionFields/specSecondaryLabelCollectionFields "+          ++ "name a field (" ++ intercalate ", " (map nameBase allLabelFieldNames)+          ++ ") but specSourceField is Nothing, so no `context` method would "+          ++ "be generated at all and every one of those labels would be "+          ++ "silently dropped. Set specSourceField to the record's "+          ++ "NamedSource field, or remove the label fields.")+  where+    allLabelFieldNames =+         map fst (specLabelFields spec)+      ++ map fst (specSecondaryLabelFields spec)+      ++ map fst (specLabelCollectionFields spec)+      ++ map fst (specSecondaryLabelCollectionFields spec)++-- === Method generators (each body is a direct call to a shared function) ===++messageMethod :: DiagnosticSpec -> Q Dec+messageMethod spec = case specMessage spec of+  Just qe -> funD 'message [clause [] (normalB qe) []]+  Nothing -> funD 'message [clause [] (normalB [| pretty . show |]) []]++codeMethod :: Maybe Text -> Q (Maybe Dec)+codeMethod Nothing  = pure Nothing+codeMethod (Just t) = Just <$>+  funD 'code [clause [wildP]+    (normalB [| Just (unsafeDiagnosticCode (pack $(strLit t))) |]) []]++severityMethod :: Severity -> Q Dec+severityMethod sev = funD 'severity [clause [wildP] (normalB (conE (sevCon sev))) []]+  where+    sevCon SevError   = 'SevError+    sevCon SevWarning = 'SevWarning+    sevCon SevAdvice  = 'SevAdvice++helpMethod :: Maybe Text -> Q (Maybe Dec)+helpMethod Nothing  = pure Nothing+helpMethod (Just t) = Just <$>+  funD 'help [clause [wildP] (normalB [| Just (pretty (pack $(strLit t))) |]) []]++urlMethod :: Maybe Text -> Q (Maybe Dec)+urlMethod Nothing  = pure Nothing+urlMethod (Just t) = Just <$>+  funD 'url [clause [wildP] (normalB [| Just (unsafeUrl (pack $(strLit t))) |]) []]++contextMethod :: Maybe Name -> [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)] -> Q (Maybe Dec)+contextMethod Nothing _ _ _ _ = pure Nothing+contextMethod (Just srcN) primFields secFields primColl secColl = do+  e <- newName "e"+  -- Body is a single direct call to a shared function: buildContext when every+  -- label (fixed-field or collection) is primary, buildContextWith otherwise.+  -- A collection field's list is expanded to one tuple per element, at the+  -- same shape buildContext/buildContextWith already accept, then `concat`ed+  -- in after the fixed-field tuples — buildContext/buildContextWith need no+  -- change at all to accept however many that expansion produces at runtime,+  -- including zero.+  --+  -- `null primColl`/`null secColl` are decided here at splice time (these are+  -- plain lists in the 'DiagnosticSpec' value, not runtime record fields), so+  -- a spec with no collection fields generates the exact same code this+  -- function produced before collection labels existed — not merely+  -- equivalent code with a harmless no-op tail appended.+  body <- if null secFields && null secColl+            then do+              let single (lf, txt) = [| ($(varE lf) $(varE e), Just (pretty (pack $(strLit txt)))) |]+                  fixedList        = listE (map single primFields)+              if null primColl+                then [| buildContext ($(varE srcN) $(varE e)) $(fixedList) |]+                else do+                  let coll (lf, txt) = [| [ (s, Just (pretty (pack $(strLit txt)))) | s <- $(varE lf) $(varE e) ] |]+                  [| buildContext ($(varE srcN) $(varE e))+                       ($(fixedList) ++ concat $(listE (map coll primColl))) |]+            else do+              let single k (lf, txt) = [| ($(varE lf) $(varE e), $(k), Just (pretty (pack $(strLit txt)))) |]+                  fixedEntries       = listE (map (single [| Primary |]) primFields+                                            ++ map (single [| Secondary |]) secFields)+              if null primColl && null secColl+                then [| buildContextWith ($(varE srcN) $(varE e)) $(fixedEntries) |]+                else do+                  let coll k (lf, txt) = [| [ (s, $(k), Just (pretty (pack $(strLit txt)))) | s <- $(varE lf) $(varE e) ] |]+                      collEntries      = listE (map (coll [| Primary |]) primColl+                                              ++ map (coll [| Secondary |]) secColl)+                  [| buildContextWith ($(varE srcN) $(varE e))+                       ($(fixedEntries) ++ concat $(collEntries)) |]+  Just <$> funD 'context [clause [varP e] (normalB (pure body)) []]++relatedMethod :: Maybe Name -> Q (Maybe Dec)+relatedMethod Nothing   = pure Nothing+relatedMethod (Just rn) = do+  e <- newName "e"+  Just <$> funD 'related [clause [varP e] (normalB [| $(varE rn) $(varE e) |]) []]++causeMethod :: Maybe Name -> Q (Maybe Dec)+causeMethod Nothing   = pure Nothing+causeMethod (Just cn) = do+  e <- newName "e"+  Just <$> funD 'diagnosticCause [clause [varP e] (normalB [| $(varE cn) $(varE e) |]) []]++-- | The 'Name' and its validated 'IdKind' travel together as one value, so a+-- field name can never reach this function without a kind decided for it (the+-- two could previously desync as separately-computed 'Maybe's).+diagIdMethod :: Maybe (Name, IdKind) -> Q (Maybe Dec)+diagIdMethod Nothing = pure Nothing+diagIdMethod (Just (idN, kind)) = do+  e <- newName "e"+  let body = case kind of+        IdText -> [| Just (mkDiagnosticId ($(varE idN) $(varE e))) |]+        IdDiag -> [| Just ($(varE idN) $(varE e)) |]+  Just <$> funD 'diagnosticId [clause [varP e] (normalB body) []]++strLit :: Text -> Q Exp+strLit = litE . stringL . unpack++-- === Sum-type arm generators (each mirrors the method generator above it,+-- returning the VALUE for one constructor instead of a whole method Dec) ===++messageMethodArm :: Name -> DiagnosticSpec -> Q Exp+messageMethodArm e spec = case specMessage spec of+  Just qe -> [| $(qe) $(varE e) |]+  Nothing -> [| pretty (show $(varE e)) |]++codeMethodArm :: DiagnosticSpec -> Q Exp+codeMethodArm spec = case specCode spec of+  Nothing -> [| Nothing |]+  Just t  -> [| Just (unsafeDiagnosticCode (pack $(strLit t))) |]++severityMethodArm :: DiagnosticSpec -> Q Exp+severityMethodArm spec = conE (sevCon (specSeverity spec))+  where+    sevCon SevError   = 'SevError+    sevCon SevWarning = 'SevWarning+    sevCon SevAdvice  = 'SevAdvice++helpMethodArm :: DiagnosticSpec -> Q Exp+helpMethodArm spec = case specHelp spec of+  Nothing -> [| Nothing |]+  Just t  -> [| Just (pretty (pack $(strLit t))) |]++urlMethodArm :: DiagnosticSpec -> Q Exp+urlMethodArm spec = case specUrl spec of+  Nothing -> [| Nothing |]+  Just t  -> [| Just (unsafeUrl (pack $(strLit t))) |]++contextMethodArm :: Name -> DiagnosticSpec -> Q Exp+contextMethodArm e spec = case specSourceField spec of+  Nothing -> [| NoContext |]+  Just srcN ->+    let primFields = specLabelFields spec+        secFields  = specSecondaryLabelFields spec+        primColl   = specLabelCollectionFields spec+        secColl    = specSecondaryLabelCollectionFields spec+    in if null secFields && null secColl+         then+           let single (lf, txt) = [| ($(varE lf) $(varE e), Just (pretty (pack $(strLit txt)))) |]+               fixedList         = listE (map single primFields)+           in if null primColl+                then [| buildContext ($(varE srcN) $(varE e)) $(fixedList) |]+                else+                  let coll (lf, txt) = [| [ (s, Just (pretty (pack $(strLit txt)))) | s <- $(varE lf) $(varE e) ] |]+                  in [| buildContext ($(varE srcN) $(varE e))+                          ($(fixedList) ++ concat $(listE (map coll primColl))) |]+         else+           let single k (lf, txt) = [| ($(varE lf) $(varE e), $(k), Just (pretty (pack $(strLit txt)))) |]+               fixedEntries       = listE (map (single [| Primary |]) primFields+                                         ++ map (single [| Secondary |]) secFields)+           in if null primColl && null secColl+                then [| buildContextWith ($(varE srcN) $(varE e)) $(fixedEntries) |]+                else+                  let coll k (lf, txt) = [| [ (s, $(k), Just (pretty (pack $(strLit txt)))) | s <- $(varE lf) $(varE e) ] |]+                      collEntries      = listE (map (coll [| Primary |]) primColl+                                              ++ map (coll [| Secondary |]) secColl)+                  in [| buildContextWith ($(varE srcN) $(varE e))+                          ($(fixedEntries) ++ concat $(collEntries)) |]++relatedMethodArm :: Name -> DiagnosticSpec -> Q Exp+relatedMethodArm e spec = case specRelated spec of+  Nothing -> [| [] |]+  Just rn -> [| $(varE rn) $(varE e) |]++causeMethodArm :: Name -> DiagnosticSpec -> Q Exp+causeMethodArm e spec = case specCause spec of+  Nothing -> [| Nothing |]+  Just cn -> [| $(varE cn) $(varE e) |]++-- | Mirrors 'diagIdMethod': the 'Name' and its validated 'IdKind' travel+-- together, computed once by 'validateSpecAgainstFields' and threaded+-- through 'deriveDiagnosticSum's @enriched@ list rather than re-derived per+-- arm.+diagIdMethodArm :: Name -> Maybe (Name, IdKind) -> Q Exp+diagIdMethodArm _ Nothing = [| Nothing |]+diagIdMethodArm e (Just (idN, kind)) = case kind of+  IdText -> [| Just (mkDiagnosticId ($(varE idN) $(varE e))) |]+  IdDiag -> [| Just ($(varE idN) $(varE e)) |]
+ src/Tadka/Internal/Terminal.hs view
@@ -0,0 +1,107 @@+-- | Terminal-capability detection and the pure resolution of @Auto@ render+-- modes into concrete ones (post-v1 hardening). Detection (the only IO here)+-- gathers capabilities; 'resolveConfig' — pure and total — turns 'ColorAuto',+-- 'UnicodeAuto', and 'HyperlinkAuto' into concrete modes, so+-- 'Tadka.Internal.Render.selectRenderer' stays pure. Explicit modes are always+-- passed through unchanged.+--+-- No compatibility guarantee.+module Tadka.Internal.Terminal+  ( TerminalCaps (..)+  , detectTerminalCaps+  , resolveColor+  , resolveUnicode+  , resolveHyperlink+  , resolveConfig+  ) where++import           Data.Maybe          (isJust, listToMaybe)+import qualified Data.Text           as T+import           System.Environment  (lookupEnv)+import           System.IO           (Handle, hIsTerminalDevice)++import           Tadka.Internal.Config (ColorMode (..), Config, HyperlinkMode (..),+                                        UnicodeMode (..), configColorMode,+                                        configHyperlinkMode, configUnicodeMode,+                                        withColorMode, withHyperlinkMode,+                                        withUnicodeMode)++-- | Detected capabilities of an output destination and environment.+data TerminalCaps = TerminalCaps+  { capIsTerminal      :: Bool   -- ^ the handle is an interactive terminal+  , capNoColor         :: Bool   -- ^ @NO_COLOR@ is present (any value)+  , capForceColor      :: Bool   -- ^ @CLICOLOR_FORCE@ is present and not @"0"@+  , capUnicode         :: Bool   -- ^ the active locale looks UTF-8+  , capNoHyperlink     :: Bool   -- ^ @NO_HYPERLINK@ is present (any value)+  , capForceHyperlink  :: Bool   -- ^ @FORCE_HYPERLINK@ is present and not @"0"@+  }+  deriving (Eq, Show)++-- | Gather capabilities for a handle: TTY status, @NO_COLOR@\/@CLICOLOR_FORCE@,+-- a UTF-8 locale check (@LC_ALL@ > @LC_CTYPE@ > @LANG@, POSIX precedence), and+-- the hyperlink pair below.+--+-- @FORCE_HYPERLINK@ is the convention the @supports-hyperlinks@ package (used+-- by Yarn and other JS CLIs) already established for forcing OSC 8 on.+-- @NO_HYPERLINK@ has no equivalent cross-tool precedent the way @NO_COLOR@+-- does; it is a tadka-local variable that simply mirrors @NO_COLOR@'s shape+-- (any value disables) for consistency and so a future shared convention could+-- slot in without an API change.+detectTerminalCaps :: Handle -> IO TerminalCaps+detectTerminalCaps h = do+  term        <- hIsTerminalDevice h+  noColor     <- isJust <$> lookupEnv "NO_COLOR"+  force       <- maybe False (/= "0") <$> lookupEnv "CLICOLOR_FORCE"+  uni         <- localeIsUtf8+  noHyper     <- isJust <$> lookupEnv "NO_HYPERLINK"+  forceHyper  <- maybe False (/= "0") <$> lookupEnv "FORCE_HYPERLINK"+  pure TerminalCaps { capIsTerminal = term, capNoColor = noColor+                    , capForceColor = force, capUnicode = uni+                    , capNoHyperlink = noHyper, capForceHyperlink = forceHyper }++localeIsUtf8 :: IO Bool+localeIsUtf8 = do+  vals <- traverse lookupEnv ["LC_ALL", "LC_CTYPE", "LANG"]+  let active = listToMaybe [ v | Just v <- vals, not (null v) ]+  pure (maybe False (T.isInfixOf (T.pack "utf") . T.toLower . T.pack) active)++-- | Resolve a colour mode against capabilities. Explicit modes pass through;+-- @Auto@ obeys @NO_COLOR@ (off), then @CLICOLOR_FORCE@ (on), then TTY status.+resolveColor :: TerminalCaps -> ColorMode -> ColorMode+resolveColor _    ColorAlways = ColorAlways+resolveColor _    ColorNever  = ColorNever+resolveColor caps ColorAuto+  | capNoColor caps    = ColorNever+  | capForceColor caps = ColorAlways+  | capIsTerminal caps = ColorAlways+  | otherwise          = ColorNever++-- | Resolve a Unicode mode against capabilities. Explicit modes pass through;+-- @Auto@ becomes 'UnicodeAlways' on a UTF-8 locale, else 'UnicodeAscii'.+resolveUnicode :: TerminalCaps -> UnicodeMode -> UnicodeMode+resolveUnicode _    UnicodeAlways = UnicodeAlways+resolveUnicode _    UnicodeAscii  = UnicodeAscii+resolveUnicode caps UnicodeAuto+  | capUnicode caps = UnicodeAlways+  | otherwise       = UnicodeAscii++-- | Resolve a hyperlink mode against capabilities. Explicit modes pass+-- through; @Auto@ obeys @NO_HYPERLINK@ (off), then @FORCE_HYPERLINK@ (on),+-- then TTY status — the same three-tier shape as 'resolveColor', since both+-- ultimately answer "can this destination usefully show a terminal escape?".+resolveHyperlink :: TerminalCaps -> HyperlinkMode -> HyperlinkMode+resolveHyperlink _    HyperlinkAlways = HyperlinkAlways+resolveHyperlink _    HyperlinkNever  = HyperlinkNever+resolveHyperlink caps HyperlinkAuto+  | capNoHyperlink caps    = HyperlinkNever+  | capForceHyperlink caps = HyperlinkAlways+  | capIsTerminal caps     = HyperlinkAlways+  | otherwise              = HyperlinkNever++-- | Resolve all three @Auto@ modes in a 'Config' to concrete modes.+resolveConfig :: TerminalCaps -> Config -> Config+resolveConfig caps cfg =+    withUnicodeMode   (resolveUnicode   caps (configUnicodeMode   cfg))+  . withColorMode     (resolveColor     caps (configColorMode     cfg))+  . withHyperlinkMode (resolveHyperlink caps (configHyperlinkMode cfg))+  $ cfg
+ src/Tadka/Internal/Types.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+++module Tadka.Internal.Types+  ( -- * Offsets and lengths+    Offset+  , unOffset+  , mkOffset+  , OffsetError (..)+  , Length+  , unLength+  , mkLength+  , LengthError (..)+    -- * Named source+  , NamedSource+  , sourceName+  , sourceText+  , mkNamedSource+  , SourceError (..)+    -- * Diagnostic codes+  , DiagnosticCode+  , unDiagnosticCode+  , mkDiagnosticCode+  , CodeError (..)+    -- * URLs+  , Url+  , unUrl+  , mkUrl+  , UrlError (..)+    -- * Severity+  , Severity (..)+  , SeverityLabels (..)+  , severityLabels+  , severityJsonTag+    -- * Diagnostic identity+  , DiagnosticId+  , unDiagnosticId+  , mkDiagnosticId+    -- * Unsafe constructors (internal; no validation)+  , unsafeDiagnosticCode+  , unsafeUrl+  ) where++import           Data.Char (isAsciiLower, isDigit)+import           Data.Maybe (isJust)+import           Data.Text (Text)+import qualified Data.Text as T+import           Network.URI (parseAbsoluteURI)++-- ---------------------------------------------------------------------------+-- Offset / Length+-- ---------------------------------------------------------------------------++-- | A non-negative byte/char offset into a source. Construct via 'mkOffset'.+newtype Offset = Offset Int+  deriving (Eq, Ord, Show)++unOffset :: Offset -> Int+unOffset (Offset n) = n++-- | Why 'mkOffset' rejected an input.+newtype OffsetError = NegativeOffset Int+  deriving (Eq, Show)++-- | Build an 'Offset', rejecting negatives.+mkOffset :: Int -> Either OffsetError Offset+mkOffset n+  | n < 0     = Left (NegativeOffset n)+  | otherwise = Right (Offset n)++-- | A non-negative span length. Zero is a valid point span. Construct via+-- 'mkLength'.+newtype Length = Length Int+  deriving (Eq, Ord, Show)++unLength :: Length -> Int+unLength (Length n) = n++-- | Why 'mkLength' rejected an input.+newtype LengthError = NegativeLength Int+  deriving (Eq, Show)++-- | Build a 'Length', rejecting negatives (zero is allowed).+mkLength :: Int -> Either LengthError Length+mkLength n+  | n < 0     = Left (NegativeLength n)+  | otherwise = Right (Length n)++-- ---------------------------------------------------------------------------+-- NamedSource+-- ---------------------------------------------------------------------------++-- | A named blob of source text. The constructor is not exported; the+-- 'sourceName' / 'sourceText' selectors are read-only. Construct via+-- 'mkNamedSource'.+data NamedSource = NamedSource+  { sourceName :: !Text+  , sourceText :: !Text+  }+  deriving (Eq, Show)++-- | Why 'mkNamedSource' rejected an input.+data SourceError = EmptySourceName+  deriving (Eq, Show)++-- | Build a 'NamedSource'. Rejects an empty name; empty /content/ is+-- legitimate (an empty file is a real thing to point at).+mkNamedSource :: Text -> Text -> Either SourceError NamedSource+mkNamedSource name txt+  | T.null name = Left EmptySourceName+  | otherwise   = Right (NamedSource name txt)++-- ---------------------------------------------------------------------------+-- DiagnosticCode+-- ---------------------------------------------------------------------------++-- | A validated diagnostic code such as @tadka::E0001@. Construct via+-- 'mkDiagnosticCode' (or, internally only, 'unsafeDiagnosticCode').+newtype DiagnosticCode = DiagnosticCode Text+  deriving (Eq, Show)++unDiagnosticCode :: DiagnosticCode -> Text+unDiagnosticCode (DiagnosticCode t) = t++-- | Why 'mkDiagnosticCode' rejected an input.+data CodeError+  = EmptyCode+  | MalformedCode Text+  deriving (Eq, Show)++-- | Build a 'DiagnosticCode', enforcing the grammar+-- @^[a-z][a-z0-9_]*::E[0-9]{4,}$@.+mkDiagnosticCode :: Text -> Either CodeError DiagnosticCode+mkDiagnosticCode t+  | T.null t              = Left EmptyCode+  | matchesCodeGrammar t  = Right (DiagnosticCode t)+  | otherwise             = Left (MalformedCode t)++-- | @^[a-z][a-z0-9_]*::E[0-9]{4,}$@ without a regex dependency.+matchesCodeGrammar :: Text -> Bool+matchesCodeGrammar t =+  case T.stripPrefix "::" rest of+    Just body -> validNamespace ns && validBody body+    Nothing   -> False+  where+    (ns, rest) = T.breakOn "::" t++    validNamespace n = case T.uncons n of+      Just (c0, cs) ->+        isAsciiLower c0+          && T.all (\c -> isAsciiLower c || isDigit c || c == '_') cs+      Nothing -> False++    validBody b = case T.uncons b of+      Just ('E', ds) -> T.length ds >= 4 && T.all isDigit ds+      _              -> False++-- | Internal only: wrap already-validated text with no checks. Used by the+-- derive macro after splice-time validation. Never reachable from+-- "Tadka".+unsafeDiagnosticCode :: Text -> DiagnosticCode+unsafeDiagnosticCode = DiagnosticCode++-- ---------------------------------------------------------------------------+-- Url+-- ---------------------------------------------------------------------------++-- | A validated absolute URL. Construct via 'mkUrl' (or, internally only,+-- 'unsafeUrl').+newtype Url = Url Text+  deriving (Eq, Show)++unUrl :: Url -> Text+unUrl (Url t) = t++-- | Why 'mkUrl' rejected an input.+data UrlError+  = EmptyUrl+  | NotAbsoluteUri Text+  deriving (Eq, Show)++-- | Build a 'Url', requiring it to parse as an absolute URI.+mkUrl :: Text -> Either UrlError Url+mkUrl t+  | T.null t                            = Left EmptyUrl+  | isJust (parseAbsoluteURI (T.unpack t)) = Right (Url t)+  | otherwise                           = Left (NotAbsoluteUri t)++-- | Internal only: wrap already-validated text with no checks.+unsafeUrl :: Text -> Url+unsafeUrl = Url++-- ---------------------------------------------------------------------------+-- Severity+-- ---------------------------------------------------------------------------++-- | Diagnostic severity. Ordered 'SevAdvice' < 'SevWarning' < 'SevError'.+data Severity+  = SevAdvice+  | SevWarning+  | SevError+  deriving (Eq, Ord, Show, Enum, Bounded)++-- | The display strings for a severity, kept in one place so the graphical+-- and narratable handlers read from a single source of+-- truth rather than scattered literals. The JSON handler uses+-- 'severityJsonTag' instead.+data SeverityLabels = SeverityLabels+  { severityGraphicalHeader  :: !Text  -- ^ e.g. @"error:"@+  , severityNarratablePrefix :: !Text  -- ^ e.g. @"Error,"@+  }+  deriving (Eq, Show)++-- | The single mapping from 'Severity' to its human-facing display strings.+severityLabels :: Severity -> SeverityLabels+severityLabels = \case+  SevAdvice  -> SeverityLabels "advice:"  "Advice,"+  SevWarning -> SeverityLabels "warning:" "Warning,"+  SevError   -> SeverityLabels "error:"   "Error,"++-- | The bare lowercase JSON tag for a 'Severity'.+severityJsonTag :: Severity -> Text+severityJsonTag = \case+  SevAdvice  -> "advice"+  SevWarning -> "warning"+  SevError   -> "error"++-- ---------------------------------------------------------------------------+-- DiagnosticId+-- ---------------------------------------------------------------------------++-- | An opaque identity key used only to detect cycles in @related@ chains+-- . Any 'Text' is a valid id, so 'mkDiagnosticId' is total; the+-- constructor stays hidden so an invariant could be added later without an API+-- break.+newtype DiagnosticId = DiagnosticId Text+  deriving (Eq, Ord, Show)++unDiagnosticId :: DiagnosticId -> Text+unDiagnosticId (DiagnosticId t) = t++-- | Build a 'DiagnosticId'. Total: any 'Text' is a valid comparison key.+mkDiagnosticId :: Text -> DiagnosticId+mkDiagnosticId = DiagnosticId
+ src/Tadka/Internal/Width.hs view
@@ -0,0 +1,165 @@++--+-- No compatibility guarantee.+module Tadka.Internal.Width+  ( -- * Display width+    charWidth+  , textWidth+    -- * Tab-aware display columns+  , displayColumnAt+  , expandTabs+    -- * Grapheme-cluster-break properties (UAX #29)+  , GBProp (..)+  , graphemeBreakProperty+  , isExtendedPictographic+    -- * Provenance+  , ucdVersion+  ) where++import           Data.Array            (Array, bounds, inRange, listArray, (!))+import           Data.Char             (ord)+import qualified Data.Text.Lazy         as TL+import qualified Data.Text.Lazy.Builder as TB+import           Data.List             (sortOn)+import           Data.Maybe            (fromMaybe)+import           Data.Text             (Text)+import qualified Data.Text             as T+import           Tadka.Internal.Width.Table++-- | The Grapheme_Cluster_Break property value of a code point (UAX #29),+-- with 'GBOther' as the catch-all. @Extended_Pictographic@ is tracked+-- separately (see 'isExtendedPictographic') because it is an independent+-- property, not a Grapheme_Cluster_Break value.+data GBProp+  = GBOther+  | GBCR+  | GBLF+  | GBControl+  | GBExtend+  | GBZWJ+  | GBRegionalIndicator+  | GBPrepend+  | GBSpacingMark+  | GBL+  | GBV+  | GBT+  | GBLV+  | GBLVT+  deriving (Eq, Show, Enum, Bounded)+++charWidth :: Char -> Int+charWidth c =+  let x = ord c+  in if inRanges zeroArr x+       then 0+       else if inRanges wideArr x then 2 else 1++-- | Display width of a 'Text' as the sum of its code-point widths. Zero-width+-- combining marks contribute @0@, so this is correct for the common case;+-- exotic ZWJ/emoji clusters are refined by the Phase 5 segmentation.+textWidth :: Text -> Int+textWidth = T.foldl' (\acc c -> acc + charWidth c) 0++-- | The 0-based display column reached after the first @n@ characters of a+-- line, expanding tabs to the next multiple of the tab width and counting every+-- other character by its 'charWidth'. Total: a tab width below 1 is treated as+-- 1, and @n@ is clamped to the line. This is exactly @textWidth@ of the+-- tab-expanded prefix (see 'expandTabs'), so a caret placed at this column sits+-- under the rendered source.+displayColumnAt :: Int -> Text -> Int -> Int+displayColumnAt tw line n = T.foldl' step 0 (T.take (max 0 n) line)+  where+    w = max 1 tw+    step col c+      | c == '\t' = col + (w - (col `mod` w))+      | otherwise = col + charWidth c++-- | Expand tabs in a line to spaces, honouring tab stops at multiples of the+-- tab width and the display width of preceding characters. The result contains+-- no tab characters, and its 'textWidth' equals @'displayColumnAt' tw line+-- (T.length line)@. Total; a tab width below 1 is treated as 1.+expandTabs :: Int -> Text -> Text+expandTabs tw line = TL.toStrict (TB.toLazyText (snd (T.foldl' step (0, mempty) line)))+  where+    w = max 1 tw+    step :: (Int, TB.Builder) -> Char -> (Int, TB.Builder)+    step (col, acc) c+      | c == '\t' = let n = w - (col `mod` w) in (col + n, acc <> TB.fromText (T.replicate n (T.singleton ' ')))+      | otherwise = (col + charWidth c, acc <> TB.singleton c)++-- | The Grapheme_Cluster_Break property of a code point, or 'GBOther'.+graphemeBreakProperty :: Char -> GBProp+graphemeBreakProperty c = fromMaybe GBOther (searchRanges gbArr (ord c))++-- | Whether a code point has the @Extended_Pictographic@ property (needed by+-- UAX #29 rule GB11 in Phase 5).+isExtendedPictographic :: Char -> Bool+isExtendedPictographic c = inRanges extPictArr (ord c)++-- Range arrays, built once from the generated ascending, coalesced lists.++wideArr :: Array Int (Int, Int)+wideArr = mkArr wideRanges++zeroArr :: Array Int (Int, Int)+zeroArr = mkArr zeroWidthRanges++extPictArr :: Array Int (Int, Int)+extPictArr = mkArr gbExtendedPictographic++gbArr :: Array Int (Int, Int, GBProp)+gbArr = listArray (0, length tagged - 1) (sortOn (\(lo, _, _) -> lo) tagged)+  where+    tagged =+      concat+        [ tag GBCR gbCR, tag GBLF gbLF, tag GBControl gbControl+        , tag GBExtend gbExtend, tag GBZWJ gbZWJ+        , tag GBRegionalIndicator gbRegionalIndicator+        , tag GBPrepend gbPrepend, tag GBSpacingMark gbSpacingMark+        , tag GBL gbL, tag GBV gbV, tag GBT gbT, tag GBLV gbLV, tag GBLVT gbLVT+        ]+    tag p = map (\(lo, hi) -> (lo, hi, p))++mkArr :: [(Int, Int)] -> Array Int (Int, Int)+mkArr xs = listArray (0, length xs - 1) xs++-- | Binary search: is @x@ inside any inclusive range in the (ascending) array?+-- | Total array indexing: 'Nothing' when the index is out of bounds. The+-- binary searches below only ever index in bounds, but this keeps the partial+-- @(!)@ encapsulated so no caller uses a partial function.+atMay :: Array Int e -> Int -> Maybe e+atMay arr i+  | inRange (bounds arr) i = Just (arr ! i)+  | otherwise              = Nothing++inRanges :: Array Int (Int, Int) -> Int -> Bool+inRanges arr x = go lo0 hi0+  where+    (lo0, hi0) = bounds arr+    go lo hi+      | lo > hi = False+      | otherwise =+          case atMay arr ((lo + hi) `div` 2) of+            Nothing     -> False          -- unreachable: lo <= mid <= hi+            Just (a, b)+              | x < a     -> go lo (mid - 1)+              | x > b     -> go (mid + 1) hi+              | otherwise -> True+          where mid = (lo + hi) `div` 2++-- | Binary search returning the payload of the range containing @x@, if any.+searchRanges :: Array Int (Int, Int, a) -> Int -> Maybe a+searchRanges arr x = go lo0 hi0+  where+    (lo0, hi0) = bounds arr+    go lo hi+      | lo > hi = Nothing+      | otherwise =+          case atMay arr ((lo + hi) `div` 2) of+            Nothing        -> Nothing      -- unreachable: lo <= mid <= hi+            Just (a, b, v)+              | x < a     -> go lo (mid - 1)+              | x > b     -> go (mid + 1) hi+              | otherwise -> Just v+          where mid = (lo + hi) `div` 2
+ src/Tadka/Internal/Width/Table.hs view
@@ -0,0 +1,2009 @@+-- | GENERATED by tools/gen-width-table.hs - DO NOT EDIT BY HAND.+-- Unicode Character Database version: 15.1.0.+-- Regenerate with: runghc tools/gen-width-table.hs+--+-- No compatibility guarantee (internal). Each list is ascending and+-- coalesced; entries are inclusive @(lo, hi)@ code-point ranges.+module Tadka.Internal.Width.Table+  ( ucdVersion+  , wideRanges+  , zeroWidthRanges+  , gbCR, gbLF, gbControl, gbExtend, gbZWJ, gbRegionalIndicator+  , gbPrepend, gbSpacingMark, gbL, gbV, gbT, gbLV, gbLVT+  , gbExtendedPictographic+  ) where++-- | The UCD version this table was generated from.+ucdVersion :: String+ucdVersion = "15.1.0"++wideRanges :: [(Int, Int)]+wideRanges =+  [ (0x1100, 0x115F)+  , (0x231A, 0x231B)+  , (0x2329, 0x232A)+  , (0x23E9, 0x23EC)+  , (0x23F0, 0x23F0)+  , (0x23F3, 0x23F3)+  , (0x25FD, 0x25FE)+  , (0x2614, 0x2615)+  , (0x2648, 0x2653)+  , (0x267F, 0x267F)+  , (0x2693, 0x2693)+  , (0x26A1, 0x26A1)+  , (0x26AA, 0x26AB)+  , (0x26BD, 0x26BE)+  , (0x26C4, 0x26C5)+  , (0x26CE, 0x26CE)+  , (0x26D4, 0x26D4)+  , (0x26EA, 0x26EA)+  , (0x26F2, 0x26F3)+  , (0x26F5, 0x26F5)+  , (0x26FA, 0x26FA)+  , (0x26FD, 0x26FD)+  , (0x2705, 0x2705)+  , (0x270A, 0x270B)+  , (0x2728, 0x2728)+  , (0x274C, 0x274C)+  , (0x274E, 0x274E)+  , (0x2753, 0x2755)+  , (0x2757, 0x2757)+  , (0x2795, 0x2797)+  , (0x27B0, 0x27B0)+  , (0x27BF, 0x27BF)+  , (0x2B1B, 0x2B1C)+  , (0x2B50, 0x2B50)+  , (0x2B55, 0x2B55)+  , (0x2E80, 0x2E99)+  , (0x2E9B, 0x2EF3)+  , (0x2F00, 0x2FD5)+  , (0x2FF0, 0x303E)+  , (0x3041, 0x3096)+  , (0x3099, 0x30FF)+  , (0x3105, 0x312F)+  , (0x3131, 0x318E)+  , (0x3190, 0x31E3)+  , (0x31EF, 0x321E)+  , (0x3220, 0x3247)+  , (0x3250, 0x4DBF)+  , (0x4E00, 0xA48C)+  , (0xA490, 0xA4C6)+  , (0xA960, 0xA97C)+  , (0xAC00, 0xD7A3)+  , (0xF900, 0xFAFF)+  , (0xFE10, 0xFE19)+  , (0xFE30, 0xFE52)+  , (0xFE54, 0xFE66)+  , (0xFE68, 0xFE6B)+  , (0xFF01, 0xFF60)+  , (0xFFE0, 0xFFE6)+  , (0x16FE0, 0x16FE4)+  , (0x16FF0, 0x16FF1)+  , (0x17000, 0x187F7)+  , (0x18800, 0x18CD5)+  , (0x18D00, 0x18D08)+  , (0x1AFF0, 0x1AFF3)+  , (0x1AFF5, 0x1AFFB)+  , (0x1AFFD, 0x1AFFE)+  , (0x1B000, 0x1B122)+  , (0x1B132, 0x1B132)+  , (0x1B150, 0x1B152)+  , (0x1B155, 0x1B155)+  , (0x1B164, 0x1B167)+  , (0x1B170, 0x1B2FB)+  , (0x1F004, 0x1F004)+  , (0x1F0CF, 0x1F0CF)+  , (0x1F18E, 0x1F18E)+  , (0x1F191, 0x1F19A)+  , (0x1F200, 0x1F202)+  , (0x1F210, 0x1F23B)+  , (0x1F240, 0x1F248)+  , (0x1F250, 0x1F251)+  , (0x1F260, 0x1F265)+  , (0x1F300, 0x1F320)+  , (0x1F32D, 0x1F335)+  , (0x1F337, 0x1F37C)+  , (0x1F37E, 0x1F393)+  , (0x1F3A0, 0x1F3CA)+  , (0x1F3CF, 0x1F3D3)+  , (0x1F3E0, 0x1F3F0)+  , (0x1F3F4, 0x1F3F4)+  , (0x1F3F8, 0x1F43E)+  , (0x1F440, 0x1F440)+  , (0x1F442, 0x1F4FC)+  , (0x1F4FF, 0x1F53D)+  , (0x1F54B, 0x1F54E)+  , (0x1F550, 0x1F567)+  , (0x1F57A, 0x1F57A)+  , (0x1F595, 0x1F596)+  , (0x1F5A4, 0x1F5A4)+  , (0x1F5FB, 0x1F64F)+  , (0x1F680, 0x1F6C5)+  , (0x1F6CC, 0x1F6CC)+  , (0x1F6D0, 0x1F6D2)+  , (0x1F6D5, 0x1F6D7)+  , (0x1F6DC, 0x1F6DF)+  , (0x1F6EB, 0x1F6EC)+  , (0x1F6F4, 0x1F6FC)+  , (0x1F7E0, 0x1F7EB)+  , (0x1F7F0, 0x1F7F0)+  , (0x1F90C, 0x1F93A)+  , (0x1F93C, 0x1F945)+  , (0x1F947, 0x1F9FF)+  , (0x1FA70, 0x1FA7C)+  , (0x1FA80, 0x1FA88)+  , (0x1FA90, 0x1FABD)+  , (0x1FABF, 0x1FAC5)+  , (0x1FACE, 0x1FADB)+  , (0x1FAE0, 0x1FAE8)+  , (0x1FAF0, 0x1FAF8)+  , (0x20000, 0x2FFFD)+  , (0x30000, 0x3FFFD)+  ]++zeroWidthRanges :: [(Int, Int)]+zeroWidthRanges =+  [ (0x00AD, 0x00AD)+  , (0x0300, 0x036F)+  , (0x0483, 0x0489)+  , (0x0591, 0x05BD)+  , (0x05BF, 0x05BF)+  , (0x05C1, 0x05C2)+  , (0x05C4, 0x05C5)+  , (0x05C7, 0x05C7)+  , (0x0600, 0x0605)+  , (0x0610, 0x061A)+  , (0x061C, 0x061C)+  , (0x064B, 0x065F)+  , (0x0670, 0x0670)+  , (0x06D6, 0x06DD)+  , (0x06DF, 0x06E4)+  , (0x06E7, 0x06E8)+  , (0x06EA, 0x06ED)+  , (0x070F, 0x070F)+  , (0x0711, 0x0711)+  , (0x0730, 0x074A)+  , (0x07A6, 0x07B0)+  , (0x07EB, 0x07F3)+  , (0x07FD, 0x07FD)+  , (0x0816, 0x0819)+  , (0x081B, 0x0823)+  , (0x0825, 0x0827)+  , (0x0829, 0x082D)+  , (0x0859, 0x085B)+  , (0x0890, 0x0891)+  , (0x0898, 0x089F)+  , (0x08CA, 0x0902)+  , (0x093A, 0x093A)+  , (0x093C, 0x093C)+  , (0x0941, 0x0948)+  , (0x094D, 0x094D)+  , (0x0951, 0x0957)+  , (0x0962, 0x0963)+  , (0x0981, 0x0981)+  , (0x09BC, 0x09BC)+  , (0x09C1, 0x09C4)+  , (0x09CD, 0x09CD)+  , (0x09E2, 0x09E3)+  , (0x09FE, 0x09FE)+  , (0x0A01, 0x0A02)+  , (0x0A3C, 0x0A3C)+  , (0x0A41, 0x0A42)+  , (0x0A47, 0x0A48)+  , (0x0A4B, 0x0A4D)+  , (0x0A51, 0x0A51)+  , (0x0A70, 0x0A71)+  , (0x0A75, 0x0A75)+  , (0x0A81, 0x0A82)+  , (0x0ABC, 0x0ABC)+  , (0x0AC1, 0x0AC5)+  , (0x0AC7, 0x0AC8)+  , (0x0ACD, 0x0ACD)+  , (0x0AE2, 0x0AE3)+  , (0x0AFA, 0x0AFF)+  , (0x0B01, 0x0B01)+  , (0x0B3C, 0x0B3C)+  , (0x0B3F, 0x0B3F)+  , (0x0B41, 0x0B44)+  , (0x0B4D, 0x0B4D)+  , (0x0B55, 0x0B56)+  , (0x0B62, 0x0B63)+  , (0x0B82, 0x0B82)+  , (0x0BC0, 0x0BC0)+  , (0x0BCD, 0x0BCD)+  , (0x0C00, 0x0C00)+  , (0x0C04, 0x0C04)+  , (0x0C3C, 0x0C3C)+  , (0x0C3E, 0x0C40)+  , (0x0C46, 0x0C48)+  , (0x0C4A, 0x0C4D)+  , (0x0C55, 0x0C56)+  , (0x0C62, 0x0C63)+  , (0x0C81, 0x0C81)+  , (0x0CBC, 0x0CBC)+  , (0x0CBF, 0x0CBF)+  , (0x0CC6, 0x0CC6)+  , (0x0CCC, 0x0CCD)+  , (0x0CE2, 0x0CE3)+  , (0x0D00, 0x0D01)+  , (0x0D3B, 0x0D3C)+  , (0x0D41, 0x0D44)+  , (0x0D4D, 0x0D4D)+  , (0x0D62, 0x0D63)+  , (0x0D81, 0x0D81)+  , (0x0DCA, 0x0DCA)+  , (0x0DD2, 0x0DD4)+  , (0x0DD6, 0x0DD6)+  , (0x0E31, 0x0E31)+  , (0x0E34, 0x0E3A)+  , (0x0E47, 0x0E4E)+  , (0x0EB1, 0x0EB1)+  , (0x0EB4, 0x0EBC)+  , (0x0EC8, 0x0ECE)+  , (0x0F18, 0x0F19)+  , (0x0F35, 0x0F35)+  , (0x0F37, 0x0F37)+  , (0x0F39, 0x0F39)+  , (0x0F71, 0x0F7E)+  , (0x0F80, 0x0F84)+  , (0x0F86, 0x0F87)+  , (0x0F8D, 0x0F97)+  , (0x0F99, 0x0FBC)+  , (0x0FC6, 0x0FC6)+  , (0x102D, 0x1030)+  , (0x1032, 0x1037)+  , (0x1039, 0x103A)+  , (0x103D, 0x103E)+  , (0x1058, 0x1059)+  , (0x105E, 0x1060)+  , (0x1071, 0x1074)+  , (0x1082, 0x1082)+  , (0x1085, 0x1086)+  , (0x108D, 0x108D)+  , (0x109D, 0x109D)+  , (0x135D, 0x135F)+  , (0x1712, 0x1714)+  , (0x1732, 0x1733)+  , (0x1752, 0x1753)+  , (0x1772, 0x1773)+  , (0x17B4, 0x17B5)+  , (0x17B7, 0x17BD)+  , (0x17C6, 0x17C6)+  , (0x17C9, 0x17D3)+  , (0x17DD, 0x17DD)+  , (0x180B, 0x180F)+  , (0x1885, 0x1886)+  , (0x18A9, 0x18A9)+  , (0x1920, 0x1922)+  , (0x1927, 0x1928)+  , (0x1932, 0x1932)+  , (0x1939, 0x193B)+  , (0x1A17, 0x1A18)+  , (0x1A1B, 0x1A1B)+  , (0x1A56, 0x1A56)+  , (0x1A58, 0x1A5E)+  , (0x1A60, 0x1A60)+  , (0x1A62, 0x1A62)+  , (0x1A65, 0x1A6C)+  , (0x1A73, 0x1A7C)+  , (0x1A7F, 0x1A7F)+  , (0x1AB0, 0x1ACE)+  , (0x1B00, 0x1B03)+  , (0x1B34, 0x1B34)+  , (0x1B36, 0x1B3A)+  , (0x1B3C, 0x1B3C)+  , (0x1B42, 0x1B42)+  , (0x1B6B, 0x1B73)+  , (0x1B80, 0x1B81)+  , (0x1BA2, 0x1BA5)+  , (0x1BA8, 0x1BA9)+  , (0x1BAB, 0x1BAD)+  , (0x1BE6, 0x1BE6)+  , (0x1BE8, 0x1BE9)+  , (0x1BED, 0x1BED)+  , (0x1BEF, 0x1BF1)+  , (0x1C2C, 0x1C33)+  , (0x1C36, 0x1C37)+  , (0x1CD0, 0x1CD2)+  , (0x1CD4, 0x1CE0)+  , (0x1CE2, 0x1CE8)+  , (0x1CED, 0x1CED)+  , (0x1CF4, 0x1CF4)+  , (0x1CF8, 0x1CF9)+  , (0x1DC0, 0x1DFF)+  , (0x200B, 0x200F)+  , (0x202A, 0x202E)+  , (0x2060, 0x2064)+  , (0x2066, 0x206F)+  , (0x20D0, 0x20F0)+  , (0x2CEF, 0x2CF1)+  , (0x2D7F, 0x2D7F)+  , (0x2DE0, 0x2DFF)+  , (0x302A, 0x302D)+  , (0x3099, 0x309A)+  , (0xA66F, 0xA672)+  , (0xA674, 0xA67D)+  , (0xA69E, 0xA69F)+  , (0xA6F0, 0xA6F1)+  , (0xA802, 0xA802)+  , (0xA806, 0xA806)+  , (0xA80B, 0xA80B)+  , (0xA825, 0xA826)+  , (0xA82C, 0xA82C)+  , (0xA8C4, 0xA8C5)+  , (0xA8E0, 0xA8F1)+  , (0xA8FF, 0xA8FF)+  , (0xA926, 0xA92D)+  , (0xA947, 0xA951)+  , (0xA980, 0xA982)+  , (0xA9B3, 0xA9B3)+  , (0xA9B6, 0xA9B9)+  , (0xA9BC, 0xA9BD)+  , (0xA9E5, 0xA9E5)+  , (0xAA29, 0xAA2E)+  , (0xAA31, 0xAA32)+  , (0xAA35, 0xAA36)+  , (0xAA43, 0xAA43)+  , (0xAA4C, 0xAA4C)+  , (0xAA7C, 0xAA7C)+  , (0xAAB0, 0xAAB0)+  , (0xAAB2, 0xAAB4)+  , (0xAAB7, 0xAAB8)+  , (0xAABE, 0xAABF)+  , (0xAAC1, 0xAAC1)+  , (0xAAEC, 0xAAED)+  , (0xAAF6, 0xAAF6)+  , (0xABE5, 0xABE5)+  , (0xABE8, 0xABE8)+  , (0xABED, 0xABED)+  , (0xFB1E, 0xFB1E)+  , (0xFE00, 0xFE0F)+  , (0xFE20, 0xFE2F)+  , (0xFEFF, 0xFEFF)+  , (0xFFF9, 0xFFFB)+  , (0x101FD, 0x101FD)+  , (0x102E0, 0x102E0)+  , (0x10376, 0x1037A)+  , (0x10A01, 0x10A03)+  , (0x10A05, 0x10A06)+  , (0x10A0C, 0x10A0F)+  , (0x10A38, 0x10A3A)+  , (0x10A3F, 0x10A3F)+  , (0x10AE5, 0x10AE6)+  , (0x10D24, 0x10D27)+  , (0x10EAB, 0x10EAC)+  , (0x10EFD, 0x10EFF)+  , (0x10F46, 0x10F50)+  , (0x10F82, 0x10F85)+  , (0x11001, 0x11001)+  , (0x11038, 0x11046)+  , (0x11070, 0x11070)+  , (0x11073, 0x11074)+  , (0x1107F, 0x11081)+  , (0x110B3, 0x110B6)+  , (0x110B9, 0x110BA)+  , (0x110BD, 0x110BD)+  , (0x110C2, 0x110C2)+  , (0x110CD, 0x110CD)+  , (0x11100, 0x11102)+  , (0x11127, 0x1112B)+  , (0x1112D, 0x11134)+  , (0x11173, 0x11173)+  , (0x11180, 0x11181)+  , (0x111B6, 0x111BE)+  , (0x111C9, 0x111CC)+  , (0x111CF, 0x111CF)+  , (0x1122F, 0x11231)+  , (0x11234, 0x11234)+  , (0x11236, 0x11237)+  , (0x1123E, 0x1123E)+  , (0x11241, 0x11241)+  , (0x112DF, 0x112DF)+  , (0x112E3, 0x112EA)+  , (0x11300, 0x11301)+  , (0x1133B, 0x1133C)+  , (0x11340, 0x11340)+  , (0x11366, 0x1136C)+  , (0x11370, 0x11374)+  , (0x11438, 0x1143F)+  , (0x11442, 0x11444)+  , (0x11446, 0x11446)+  , (0x1145E, 0x1145E)+  , (0x114B3, 0x114B8)+  , (0x114BA, 0x114BA)+  , (0x114BF, 0x114C0)+  , (0x114C2, 0x114C3)+  , (0x115B2, 0x115B5)+  , (0x115BC, 0x115BD)+  , (0x115BF, 0x115C0)+  , (0x115DC, 0x115DD)+  , (0x11633, 0x1163A)+  , (0x1163D, 0x1163D)+  , (0x1163F, 0x11640)+  , (0x116AB, 0x116AB)+  , (0x116AD, 0x116AD)+  , (0x116B0, 0x116B5)+  , (0x116B7, 0x116B7)+  , (0x1171D, 0x1171F)+  , (0x11722, 0x11725)+  , (0x11727, 0x1172B)+  , (0x1182F, 0x11837)+  , (0x11839, 0x1183A)+  , (0x1193B, 0x1193C)+  , (0x1193E, 0x1193E)+  , (0x11943, 0x11943)+  , (0x119D4, 0x119D7)+  , (0x119DA, 0x119DB)+  , (0x119E0, 0x119E0)+  , (0x11A01, 0x11A0A)+  , (0x11A33, 0x11A38)+  , (0x11A3B, 0x11A3E)+  , (0x11A47, 0x11A47)+  , (0x11A51, 0x11A56)+  , (0x11A59, 0x11A5B)+  , (0x11A8A, 0x11A96)+  , (0x11A98, 0x11A99)+  , (0x11C30, 0x11C36)+  , (0x11C38, 0x11C3D)+  , (0x11C3F, 0x11C3F)+  , (0x11C92, 0x11CA7)+  , (0x11CAA, 0x11CB0)+  , (0x11CB2, 0x11CB3)+  , (0x11CB5, 0x11CB6)+  , (0x11D31, 0x11D36)+  , (0x11D3A, 0x11D3A)+  , (0x11D3C, 0x11D3D)+  , (0x11D3F, 0x11D45)+  , (0x11D47, 0x11D47)+  , (0x11D90, 0x11D91)+  , (0x11D95, 0x11D95)+  , (0x11D97, 0x11D97)+  , (0x11EF3, 0x11EF4)+  , (0x11F00, 0x11F01)+  , (0x11F36, 0x11F3A)+  , (0x11F40, 0x11F40)+  , (0x11F42, 0x11F42)+  , (0x13430, 0x13440)+  , (0x13447, 0x13455)+  , (0x16AF0, 0x16AF4)+  , (0x16B30, 0x16B36)+  , (0x16F4F, 0x16F4F)+  , (0x16F8F, 0x16F92)+  , (0x16FE4, 0x16FE4)+  , (0x1BC9D, 0x1BC9E)+  , (0x1BCA0, 0x1BCA3)+  , (0x1CF00, 0x1CF2D)+  , (0x1CF30, 0x1CF46)+  , (0x1D167, 0x1D169)+  , (0x1D173, 0x1D182)+  , (0x1D185, 0x1D18B)+  , (0x1D1AA, 0x1D1AD)+  , (0x1D242, 0x1D244)+  , (0x1DA00, 0x1DA36)+  , (0x1DA3B, 0x1DA6C)+  , (0x1DA75, 0x1DA75)+  , (0x1DA84, 0x1DA84)+  , (0x1DA9B, 0x1DA9F)+  , (0x1DAA1, 0x1DAAF)+  , (0x1E000, 0x1E006)+  , (0x1E008, 0x1E018)+  , (0x1E01B, 0x1E021)+  , (0x1E023, 0x1E024)+  , (0x1E026, 0x1E02A)+  , (0x1E08F, 0x1E08F)+  , (0x1E130, 0x1E136)+  , (0x1E2AE, 0x1E2AE)+  , (0x1E2EC, 0x1E2EF)+  , (0x1E4EC, 0x1E4EF)+  , (0x1E8D0, 0x1E8D6)+  , (0x1E944, 0x1E94A)+  , (0xE0001, 0xE0001)+  , (0xE0020, 0xE007F)+  , (0xE0100, 0xE01EF)+  ]++gbCR :: [(Int, Int)]+gbCR =+  [ (0x000D, 0x000D)+  ]++gbLF :: [(Int, Int)]+gbLF =+  [ (0x000A, 0x000A)+  ]++gbControl :: [(Int, Int)]+gbControl =+  [ (0x0000, 0x0009)+  , (0x000B, 0x000C)+  , (0x000E, 0x001F)+  , (0x007F, 0x009F)+  , (0x00AD, 0x00AD)+  , (0x061C, 0x061C)+  , (0x180E, 0x180E)+  , (0x200B, 0x200B)+  , (0x200E, 0x200F)+  , (0x2028, 0x202E)+  , (0x2060, 0x206F)+  , (0xFEFF, 0xFEFF)+  , (0xFFF0, 0xFFFB)+  , (0x13430, 0x1343F)+  , (0x1BCA0, 0x1BCA3)+  , (0x1D173, 0x1D17A)+  , (0xE0000, 0xE001F)+  , (0xE0080, 0xE00FF)+  , (0xE01F0, 0xE0FFF)+  ]++gbExtend :: [(Int, Int)]+gbExtend =+  [ (0x0300, 0x036F)+  , (0x0483, 0x0489)+  , (0x0591, 0x05BD)+  , (0x05BF, 0x05BF)+  , (0x05C1, 0x05C2)+  , (0x05C4, 0x05C5)+  , (0x05C7, 0x05C7)+  , (0x0610, 0x061A)+  , (0x064B, 0x065F)+  , (0x0670, 0x0670)+  , (0x06D6, 0x06DC)+  , (0x06DF, 0x06E4)+  , (0x06E7, 0x06E8)+  , (0x06EA, 0x06ED)+  , (0x0711, 0x0711)+  , (0x0730, 0x074A)+  , (0x07A6, 0x07B0)+  , (0x07EB, 0x07F3)+  , (0x07FD, 0x07FD)+  , (0x0816, 0x0819)+  , (0x081B, 0x0823)+  , (0x0825, 0x0827)+  , (0x0829, 0x082D)+  , (0x0859, 0x085B)+  , (0x0898, 0x089F)+  , (0x08CA, 0x08E1)+  , (0x08E3, 0x0902)+  , (0x093A, 0x093A)+  , (0x093C, 0x093C)+  , (0x0941, 0x0948)+  , (0x094D, 0x094D)+  , (0x0951, 0x0957)+  , (0x0962, 0x0963)+  , (0x0981, 0x0981)+  , (0x09BC, 0x09BC)+  , (0x09BE, 0x09BE)+  , (0x09C1, 0x09C4)+  , (0x09CD, 0x09CD)+  , (0x09D7, 0x09D7)+  , (0x09E2, 0x09E3)+  , (0x09FE, 0x09FE)+  , (0x0A01, 0x0A02)+  , (0x0A3C, 0x0A3C)+  , (0x0A41, 0x0A42)+  , (0x0A47, 0x0A48)+  , (0x0A4B, 0x0A4D)+  , (0x0A51, 0x0A51)+  , (0x0A70, 0x0A71)+  , (0x0A75, 0x0A75)+  , (0x0A81, 0x0A82)+  , (0x0ABC, 0x0ABC)+  , (0x0AC1, 0x0AC5)+  , (0x0AC7, 0x0AC8)+  , (0x0ACD, 0x0ACD)+  , (0x0AE2, 0x0AE3)+  , (0x0AFA, 0x0AFF)+  , (0x0B01, 0x0B01)+  , (0x0B3C, 0x0B3C)+  , (0x0B3E, 0x0B3F)+  , (0x0B41, 0x0B44)+  , (0x0B4D, 0x0B4D)+  , (0x0B55, 0x0B57)+  , (0x0B62, 0x0B63)+  , (0x0B82, 0x0B82)+  , (0x0BBE, 0x0BBE)+  , (0x0BC0, 0x0BC0)+  , (0x0BCD, 0x0BCD)+  , (0x0BD7, 0x0BD7)+  , (0x0C00, 0x0C00)+  , (0x0C04, 0x0C04)+  , (0x0C3C, 0x0C3C)+  , (0x0C3E, 0x0C40)+  , (0x0C46, 0x0C48)+  , (0x0C4A, 0x0C4D)+  , (0x0C55, 0x0C56)+  , (0x0C62, 0x0C63)+  , (0x0C81, 0x0C81)+  , (0x0CBC, 0x0CBC)+  , (0x0CBF, 0x0CBF)+  , (0x0CC2, 0x0CC2)+  , (0x0CC6, 0x0CC6)+  , (0x0CCC, 0x0CCD)+  , (0x0CD5, 0x0CD6)+  , (0x0CE2, 0x0CE3)+  , (0x0D00, 0x0D01)+  , (0x0D3B, 0x0D3C)+  , (0x0D3E, 0x0D3E)+  , (0x0D41, 0x0D44)+  , (0x0D4D, 0x0D4D)+  , (0x0D57, 0x0D57)+  , (0x0D62, 0x0D63)+  , (0x0D81, 0x0D81)+  , (0x0DCA, 0x0DCA)+  , (0x0DCF, 0x0DCF)+  , (0x0DD2, 0x0DD4)+  , (0x0DD6, 0x0DD6)+  , (0x0DDF, 0x0DDF)+  , (0x0E31, 0x0E31)+  , (0x0E34, 0x0E3A)+  , (0x0E47, 0x0E4E)+  , (0x0EB1, 0x0EB1)+  , (0x0EB4, 0x0EBC)+  , (0x0EC8, 0x0ECE)+  , (0x0F18, 0x0F19)+  , (0x0F35, 0x0F35)+  , (0x0F37, 0x0F37)+  , (0x0F39, 0x0F39)+  , (0x0F71, 0x0F7E)+  , (0x0F80, 0x0F84)+  , (0x0F86, 0x0F87)+  , (0x0F8D, 0x0F97)+  , (0x0F99, 0x0FBC)+  , (0x0FC6, 0x0FC6)+  , (0x102D, 0x1030)+  , (0x1032, 0x1037)+  , (0x1039, 0x103A)+  , (0x103D, 0x103E)+  , (0x1058, 0x1059)+  , (0x105E, 0x1060)+  , (0x1071, 0x1074)+  , (0x1082, 0x1082)+  , (0x1085, 0x1086)+  , (0x108D, 0x108D)+  , (0x109D, 0x109D)+  , (0x135D, 0x135F)+  , (0x1712, 0x1714)+  , (0x1732, 0x1733)+  , (0x1752, 0x1753)+  , (0x1772, 0x1773)+  , (0x17B4, 0x17B5)+  , (0x17B7, 0x17BD)+  , (0x17C6, 0x17C6)+  , (0x17C9, 0x17D3)+  , (0x17DD, 0x17DD)+  , (0x180B, 0x180D)+  , (0x180F, 0x180F)+  , (0x1885, 0x1886)+  , (0x18A9, 0x18A9)+  , (0x1920, 0x1922)+  , (0x1927, 0x1928)+  , (0x1932, 0x1932)+  , (0x1939, 0x193B)+  , (0x1A17, 0x1A18)+  , (0x1A1B, 0x1A1B)+  , (0x1A56, 0x1A56)+  , (0x1A58, 0x1A5E)+  , (0x1A60, 0x1A60)+  , (0x1A62, 0x1A62)+  , (0x1A65, 0x1A6C)+  , (0x1A73, 0x1A7C)+  , (0x1A7F, 0x1A7F)+  , (0x1AB0, 0x1ACE)+  , (0x1B00, 0x1B03)+  , (0x1B34, 0x1B3A)+  , (0x1B3C, 0x1B3C)+  , (0x1B42, 0x1B42)+  , (0x1B6B, 0x1B73)+  , (0x1B80, 0x1B81)+  , (0x1BA2, 0x1BA5)+  , (0x1BA8, 0x1BA9)+  , (0x1BAB, 0x1BAD)+  , (0x1BE6, 0x1BE6)+  , (0x1BE8, 0x1BE9)+  , (0x1BED, 0x1BED)+  , (0x1BEF, 0x1BF1)+  , (0x1C2C, 0x1C33)+  , (0x1C36, 0x1C37)+  , (0x1CD0, 0x1CD2)+  , (0x1CD4, 0x1CE0)+  , (0x1CE2, 0x1CE8)+  , (0x1CED, 0x1CED)+  , (0x1CF4, 0x1CF4)+  , (0x1CF8, 0x1CF9)+  , (0x1DC0, 0x1DFF)+  , (0x200C, 0x200C)+  , (0x20D0, 0x20F0)+  , (0x2CEF, 0x2CF1)+  , (0x2D7F, 0x2D7F)+  , (0x2DE0, 0x2DFF)+  , (0x302A, 0x302F)+  , (0x3099, 0x309A)+  , (0xA66F, 0xA672)+  , (0xA674, 0xA67D)+  , (0xA69E, 0xA69F)+  , (0xA6F0, 0xA6F1)+  , (0xA802, 0xA802)+  , (0xA806, 0xA806)+  , (0xA80B, 0xA80B)+  , (0xA825, 0xA826)+  , (0xA82C, 0xA82C)+  , (0xA8C4, 0xA8C5)+  , (0xA8E0, 0xA8F1)+  , (0xA8FF, 0xA8FF)+  , (0xA926, 0xA92D)+  , (0xA947, 0xA951)+  , (0xA980, 0xA982)+  , (0xA9B3, 0xA9B3)+  , (0xA9B6, 0xA9B9)+  , (0xA9BC, 0xA9BD)+  , (0xA9E5, 0xA9E5)+  , (0xAA29, 0xAA2E)+  , (0xAA31, 0xAA32)+  , (0xAA35, 0xAA36)+  , (0xAA43, 0xAA43)+  , (0xAA4C, 0xAA4C)+  , (0xAA7C, 0xAA7C)+  , (0xAAB0, 0xAAB0)+  , (0xAAB2, 0xAAB4)+  , (0xAAB7, 0xAAB8)+  , (0xAABE, 0xAABF)+  , (0xAAC1, 0xAAC1)+  , (0xAAEC, 0xAAED)+  , (0xAAF6, 0xAAF6)+  , (0xABE5, 0xABE5)+  , (0xABE8, 0xABE8)+  , (0xABED, 0xABED)+  , (0xFB1E, 0xFB1E)+  , (0xFE00, 0xFE0F)+  , (0xFE20, 0xFE2F)+  , (0xFF9E, 0xFF9F)+  , (0x101FD, 0x101FD)+  , (0x102E0, 0x102E0)+  , (0x10376, 0x1037A)+  , (0x10A01, 0x10A03)+  , (0x10A05, 0x10A06)+  , (0x10A0C, 0x10A0F)+  , (0x10A38, 0x10A3A)+  , (0x10A3F, 0x10A3F)+  , (0x10AE5, 0x10AE6)+  , (0x10D24, 0x10D27)+  , (0x10EAB, 0x10EAC)+  , (0x10EFD, 0x10EFF)+  , (0x10F46, 0x10F50)+  , (0x10F82, 0x10F85)+  , (0x11001, 0x11001)+  , (0x11038, 0x11046)+  , (0x11070, 0x11070)+  , (0x11073, 0x11074)+  , (0x1107F, 0x11081)+  , (0x110B3, 0x110B6)+  , (0x110B9, 0x110BA)+  , (0x110C2, 0x110C2)+  , (0x11100, 0x11102)+  , (0x11127, 0x1112B)+  , (0x1112D, 0x11134)+  , (0x11173, 0x11173)+  , (0x11180, 0x11181)+  , (0x111B6, 0x111BE)+  , (0x111C9, 0x111CC)+  , (0x111CF, 0x111CF)+  , (0x1122F, 0x11231)+  , (0x11234, 0x11234)+  , (0x11236, 0x11237)+  , (0x1123E, 0x1123E)+  , (0x11241, 0x11241)+  , (0x112DF, 0x112DF)+  , (0x112E3, 0x112EA)+  , (0x11300, 0x11301)+  , (0x1133B, 0x1133C)+  , (0x1133E, 0x1133E)+  , (0x11340, 0x11340)+  , (0x11357, 0x11357)+  , (0x11366, 0x1136C)+  , (0x11370, 0x11374)+  , (0x11438, 0x1143F)+  , (0x11442, 0x11444)+  , (0x11446, 0x11446)+  , (0x1145E, 0x1145E)+  , (0x114B0, 0x114B0)+  , (0x114B3, 0x114B8)+  , (0x114BA, 0x114BA)+  , (0x114BD, 0x114BD)+  , (0x114BF, 0x114C0)+  , (0x114C2, 0x114C3)+  , (0x115AF, 0x115AF)+  , (0x115B2, 0x115B5)+  , (0x115BC, 0x115BD)+  , (0x115BF, 0x115C0)+  , (0x115DC, 0x115DD)+  , (0x11633, 0x1163A)+  , (0x1163D, 0x1163D)+  , (0x1163F, 0x11640)+  , (0x116AB, 0x116AB)+  , (0x116AD, 0x116AD)+  , (0x116B0, 0x116B5)+  , (0x116B7, 0x116B7)+  , (0x1171D, 0x1171F)+  , (0x11722, 0x11725)+  , (0x11727, 0x1172B)+  , (0x1182F, 0x11837)+  , (0x11839, 0x1183A)+  , (0x11930, 0x11930)+  , (0x1193B, 0x1193C)+  , (0x1193E, 0x1193E)+  , (0x11943, 0x11943)+  , (0x119D4, 0x119D7)+  , (0x119DA, 0x119DB)+  , (0x119E0, 0x119E0)+  , (0x11A01, 0x11A0A)+  , (0x11A33, 0x11A38)+  , (0x11A3B, 0x11A3E)+  , (0x11A47, 0x11A47)+  , (0x11A51, 0x11A56)+  , (0x11A59, 0x11A5B)+  , (0x11A8A, 0x11A96)+  , (0x11A98, 0x11A99)+  , (0x11C30, 0x11C36)+  , (0x11C38, 0x11C3D)+  , (0x11C3F, 0x11C3F)+  , (0x11C92, 0x11CA7)+  , (0x11CAA, 0x11CB0)+  , (0x11CB2, 0x11CB3)+  , (0x11CB5, 0x11CB6)+  , (0x11D31, 0x11D36)+  , (0x11D3A, 0x11D3A)+  , (0x11D3C, 0x11D3D)+  , (0x11D3F, 0x11D45)+  , (0x11D47, 0x11D47)+  , (0x11D90, 0x11D91)+  , (0x11D95, 0x11D95)+  , (0x11D97, 0x11D97)+  , (0x11EF3, 0x11EF4)+  , (0x11F00, 0x11F01)+  , (0x11F36, 0x11F3A)+  , (0x11F40, 0x11F40)+  , (0x11F42, 0x11F42)+  , (0x13440, 0x13440)+  , (0x13447, 0x13455)+  , (0x16AF0, 0x16AF4)+  , (0x16B30, 0x16B36)+  , (0x16F4F, 0x16F4F)+  , (0x16F8F, 0x16F92)+  , (0x16FE4, 0x16FE4)+  , (0x1BC9D, 0x1BC9E)+  , (0x1CF00, 0x1CF2D)+  , (0x1CF30, 0x1CF46)+  , (0x1D165, 0x1D165)+  , (0x1D167, 0x1D169)+  , (0x1D16E, 0x1D172)+  , (0x1D17B, 0x1D182)+  , (0x1D185, 0x1D18B)+  , (0x1D1AA, 0x1D1AD)+  , (0x1D242, 0x1D244)+  , (0x1DA00, 0x1DA36)+  , (0x1DA3B, 0x1DA6C)+  , (0x1DA75, 0x1DA75)+  , (0x1DA84, 0x1DA84)+  , (0x1DA9B, 0x1DA9F)+  , (0x1DAA1, 0x1DAAF)+  , (0x1E000, 0x1E006)+  , (0x1E008, 0x1E018)+  , (0x1E01B, 0x1E021)+  , (0x1E023, 0x1E024)+  , (0x1E026, 0x1E02A)+  , (0x1E08F, 0x1E08F)+  , (0x1E130, 0x1E136)+  , (0x1E2AE, 0x1E2AE)+  , (0x1E2EC, 0x1E2EF)+  , (0x1E4EC, 0x1E4EF)+  , (0x1E8D0, 0x1E8D6)+  , (0x1E944, 0x1E94A)+  , (0x1F3FB, 0x1F3FF)+  , (0xE0020, 0xE007F)+  , (0xE0100, 0xE01EF)+  ]++gbZWJ :: [(Int, Int)]+gbZWJ =+  [ (0x200D, 0x200D)+  ]++gbRegionalIndicator :: [(Int, Int)]+gbRegionalIndicator =+  [ (0x1F1E6, 0x1F1FF)+  ]++gbPrepend :: [(Int, Int)]+gbPrepend =+  [ (0x0600, 0x0605)+  , (0x06DD, 0x06DD)+  , (0x070F, 0x070F)+  , (0x0890, 0x0891)+  , (0x08E2, 0x08E2)+  , (0x0D4E, 0x0D4E)+  , (0x110BD, 0x110BD)+  , (0x110CD, 0x110CD)+  , (0x111C2, 0x111C3)+  , (0x1193F, 0x1193F)+  , (0x11941, 0x11941)+  , (0x11A3A, 0x11A3A)+  , (0x11A84, 0x11A89)+  , (0x11D46, 0x11D46)+  , (0x11F02, 0x11F02)+  ]++gbSpacingMark :: [(Int, Int)]+gbSpacingMark =+  [ (0x0903, 0x0903)+  , (0x093B, 0x093B)+  , (0x093E, 0x0940)+  , (0x0949, 0x094C)+  , (0x094E, 0x094F)+  , (0x0982, 0x0983)+  , (0x09BF, 0x09C0)+  , (0x09C7, 0x09C8)+  , (0x09CB, 0x09CC)+  , (0x0A03, 0x0A03)+  , (0x0A3E, 0x0A40)+  , (0x0A83, 0x0A83)+  , (0x0ABE, 0x0AC0)+  , (0x0AC9, 0x0AC9)+  , (0x0ACB, 0x0ACC)+  , (0x0B02, 0x0B03)+  , (0x0B40, 0x0B40)+  , (0x0B47, 0x0B48)+  , (0x0B4B, 0x0B4C)+  , (0x0BBF, 0x0BBF)+  , (0x0BC1, 0x0BC2)+  , (0x0BC6, 0x0BC8)+  , (0x0BCA, 0x0BCC)+  , (0x0C01, 0x0C03)+  , (0x0C41, 0x0C44)+  , (0x0C82, 0x0C83)+  , (0x0CBE, 0x0CBE)+  , (0x0CC0, 0x0CC1)+  , (0x0CC3, 0x0CC4)+  , (0x0CC7, 0x0CC8)+  , (0x0CCA, 0x0CCB)+  , (0x0CF3, 0x0CF3)+  , (0x0D02, 0x0D03)+  , (0x0D3F, 0x0D40)+  , (0x0D46, 0x0D48)+  , (0x0D4A, 0x0D4C)+  , (0x0D82, 0x0D83)+  , (0x0DD0, 0x0DD1)+  , (0x0DD8, 0x0DDE)+  , (0x0DF2, 0x0DF3)+  , (0x0E33, 0x0E33)+  , (0x0EB3, 0x0EB3)+  , (0x0F3E, 0x0F3F)+  , (0x0F7F, 0x0F7F)+  , (0x1031, 0x1031)+  , (0x103B, 0x103C)+  , (0x1056, 0x1057)+  , (0x1084, 0x1084)+  , (0x1715, 0x1715)+  , (0x1734, 0x1734)+  , (0x17B6, 0x17B6)+  , (0x17BE, 0x17C5)+  , (0x17C7, 0x17C8)+  , (0x1923, 0x1926)+  , (0x1929, 0x192B)+  , (0x1930, 0x1931)+  , (0x1933, 0x1938)+  , (0x1A19, 0x1A1A)+  , (0x1A55, 0x1A55)+  , (0x1A57, 0x1A57)+  , (0x1A6D, 0x1A72)+  , (0x1B04, 0x1B04)+  , (0x1B3B, 0x1B3B)+  , (0x1B3D, 0x1B41)+  , (0x1B43, 0x1B44)+  , (0x1B82, 0x1B82)+  , (0x1BA1, 0x1BA1)+  , (0x1BA6, 0x1BA7)+  , (0x1BAA, 0x1BAA)+  , (0x1BE7, 0x1BE7)+  , (0x1BEA, 0x1BEC)+  , (0x1BEE, 0x1BEE)+  , (0x1BF2, 0x1BF3)+  , (0x1C24, 0x1C2B)+  , (0x1C34, 0x1C35)+  , (0x1CE1, 0x1CE1)+  , (0x1CF7, 0x1CF7)+  , (0xA823, 0xA824)+  , (0xA827, 0xA827)+  , (0xA880, 0xA881)+  , (0xA8B4, 0xA8C3)+  , (0xA952, 0xA953)+  , (0xA983, 0xA983)+  , (0xA9B4, 0xA9B5)+  , (0xA9BA, 0xA9BB)+  , (0xA9BE, 0xA9C0)+  , (0xAA2F, 0xAA30)+  , (0xAA33, 0xAA34)+  , (0xAA4D, 0xAA4D)+  , (0xAAEB, 0xAAEB)+  , (0xAAEE, 0xAAEF)+  , (0xAAF5, 0xAAF5)+  , (0xABE3, 0xABE4)+  , (0xABE6, 0xABE7)+  , (0xABE9, 0xABEA)+  , (0xABEC, 0xABEC)+  , (0x11000, 0x11000)+  , (0x11002, 0x11002)+  , (0x11082, 0x11082)+  , (0x110B0, 0x110B2)+  , (0x110B7, 0x110B8)+  , (0x1112C, 0x1112C)+  , (0x11145, 0x11146)+  , (0x11182, 0x11182)+  , (0x111B3, 0x111B5)+  , (0x111BF, 0x111C0)+  , (0x111CE, 0x111CE)+  , (0x1122C, 0x1122E)+  , (0x11232, 0x11233)+  , (0x11235, 0x11235)+  , (0x112E0, 0x112E2)+  , (0x11302, 0x11303)+  , (0x1133F, 0x1133F)+  , (0x11341, 0x11344)+  , (0x11347, 0x11348)+  , (0x1134B, 0x1134D)+  , (0x11362, 0x11363)+  , (0x11435, 0x11437)+  , (0x11440, 0x11441)+  , (0x11445, 0x11445)+  , (0x114B1, 0x114B2)+  , (0x114B9, 0x114B9)+  , (0x114BB, 0x114BC)+  , (0x114BE, 0x114BE)+  , (0x114C1, 0x114C1)+  , (0x115B0, 0x115B1)+  , (0x115B8, 0x115BB)+  , (0x115BE, 0x115BE)+  , (0x11630, 0x11632)+  , (0x1163B, 0x1163C)+  , (0x1163E, 0x1163E)+  , (0x116AC, 0x116AC)+  , (0x116AE, 0x116AF)+  , (0x116B6, 0x116B6)+  , (0x11726, 0x11726)+  , (0x1182C, 0x1182E)+  , (0x11838, 0x11838)+  , (0x11931, 0x11935)+  , (0x11937, 0x11938)+  , (0x1193D, 0x1193D)+  , (0x11940, 0x11940)+  , (0x11942, 0x11942)+  , (0x119D1, 0x119D3)+  , (0x119DC, 0x119DF)+  , (0x119E4, 0x119E4)+  , (0x11A39, 0x11A39)+  , (0x11A57, 0x11A58)+  , (0x11A97, 0x11A97)+  , (0x11C2F, 0x11C2F)+  , (0x11C3E, 0x11C3E)+  , (0x11CA9, 0x11CA9)+  , (0x11CB1, 0x11CB1)+  , (0x11CB4, 0x11CB4)+  , (0x11D8A, 0x11D8E)+  , (0x11D93, 0x11D94)+  , (0x11D96, 0x11D96)+  , (0x11EF5, 0x11EF6)+  , (0x11F03, 0x11F03)+  , (0x11F34, 0x11F35)+  , (0x11F3E, 0x11F3F)+  , (0x11F41, 0x11F41)+  , (0x16F51, 0x16F87)+  , (0x16FF0, 0x16FF1)+  , (0x1D166, 0x1D166)+  , (0x1D16D, 0x1D16D)+  ]++gbL :: [(Int, Int)]+gbL =+  [ (0x1100, 0x115F)+  , (0xA960, 0xA97C)+  ]++gbV :: [(Int, Int)]+gbV =+  [ (0x1160, 0x11A7)+  , (0xD7B0, 0xD7C6)+  ]++gbT :: [(Int, Int)]+gbT =+  [ (0x11A8, 0x11FF)+  , (0xD7CB, 0xD7FB)+  ]++gbLV :: [(Int, Int)]+gbLV =+  [ (0xAC00, 0xAC00)+  , (0xAC1C, 0xAC1C)+  , (0xAC38, 0xAC38)+  , (0xAC54, 0xAC54)+  , (0xAC70, 0xAC70)+  , (0xAC8C, 0xAC8C)+  , (0xACA8, 0xACA8)+  , (0xACC4, 0xACC4)+  , (0xACE0, 0xACE0)+  , (0xACFC, 0xACFC)+  , (0xAD18, 0xAD18)+  , (0xAD34, 0xAD34)+  , (0xAD50, 0xAD50)+  , (0xAD6C, 0xAD6C)+  , (0xAD88, 0xAD88)+  , (0xADA4, 0xADA4)+  , (0xADC0, 0xADC0)+  , (0xADDC, 0xADDC)+  , (0xADF8, 0xADF8)+  , (0xAE14, 0xAE14)+  , (0xAE30, 0xAE30)+  , (0xAE4C, 0xAE4C)+  , (0xAE68, 0xAE68)+  , (0xAE84, 0xAE84)+  , (0xAEA0, 0xAEA0)+  , (0xAEBC, 0xAEBC)+  , (0xAED8, 0xAED8)+  , (0xAEF4, 0xAEF4)+  , (0xAF10, 0xAF10)+  , (0xAF2C, 0xAF2C)+  , (0xAF48, 0xAF48)+  , (0xAF64, 0xAF64)+  , (0xAF80, 0xAF80)+  , (0xAF9C, 0xAF9C)+  , (0xAFB8, 0xAFB8)+  , (0xAFD4, 0xAFD4)+  , (0xAFF0, 0xAFF0)+  , (0xB00C, 0xB00C)+  , (0xB028, 0xB028)+  , (0xB044, 0xB044)+  , (0xB060, 0xB060)+  , (0xB07C, 0xB07C)+  , (0xB098, 0xB098)+  , (0xB0B4, 0xB0B4)+  , (0xB0D0, 0xB0D0)+  , (0xB0EC, 0xB0EC)+  , (0xB108, 0xB108)+  , (0xB124, 0xB124)+  , (0xB140, 0xB140)+  , (0xB15C, 0xB15C)+  , (0xB178, 0xB178)+  , (0xB194, 0xB194)+  , (0xB1B0, 0xB1B0)+  , (0xB1CC, 0xB1CC)+  , (0xB1E8, 0xB1E8)+  , (0xB204, 0xB204)+  , (0xB220, 0xB220)+  , (0xB23C, 0xB23C)+  , (0xB258, 0xB258)+  , (0xB274, 0xB274)+  , (0xB290, 0xB290)+  , (0xB2AC, 0xB2AC)+  , (0xB2C8, 0xB2C8)+  , (0xB2E4, 0xB2E4)+  , (0xB300, 0xB300)+  , (0xB31C, 0xB31C)+  , (0xB338, 0xB338)+  , (0xB354, 0xB354)+  , (0xB370, 0xB370)+  , (0xB38C, 0xB38C)+  , (0xB3A8, 0xB3A8)+  , (0xB3C4, 0xB3C4)+  , (0xB3E0, 0xB3E0)+  , (0xB3FC, 0xB3FC)+  , (0xB418, 0xB418)+  , (0xB434, 0xB434)+  , (0xB450, 0xB450)+  , (0xB46C, 0xB46C)+  , (0xB488, 0xB488)+  , (0xB4A4, 0xB4A4)+  , (0xB4C0, 0xB4C0)+  , (0xB4DC, 0xB4DC)+  , (0xB4F8, 0xB4F8)+  , (0xB514, 0xB514)+  , (0xB530, 0xB530)+  , (0xB54C, 0xB54C)+  , (0xB568, 0xB568)+  , (0xB584, 0xB584)+  , (0xB5A0, 0xB5A0)+  , (0xB5BC, 0xB5BC)+  , (0xB5D8, 0xB5D8)+  , (0xB5F4, 0xB5F4)+  , (0xB610, 0xB610)+  , (0xB62C, 0xB62C)+  , (0xB648, 0xB648)+  , (0xB664, 0xB664)+  , (0xB680, 0xB680)+  , (0xB69C, 0xB69C)+  , (0xB6B8, 0xB6B8)+  , (0xB6D4, 0xB6D4)+  , (0xB6F0, 0xB6F0)+  , (0xB70C, 0xB70C)+  , (0xB728, 0xB728)+  , (0xB744, 0xB744)+  , (0xB760, 0xB760)+  , (0xB77C, 0xB77C)+  , (0xB798, 0xB798)+  , (0xB7B4, 0xB7B4)+  , (0xB7D0, 0xB7D0)+  , (0xB7EC, 0xB7EC)+  , (0xB808, 0xB808)+  , (0xB824, 0xB824)+  , (0xB840, 0xB840)+  , (0xB85C, 0xB85C)+  , (0xB878, 0xB878)+  , (0xB894, 0xB894)+  , (0xB8B0, 0xB8B0)+  , (0xB8CC, 0xB8CC)+  , (0xB8E8, 0xB8E8)+  , (0xB904, 0xB904)+  , (0xB920, 0xB920)+  , (0xB93C, 0xB93C)+  , (0xB958, 0xB958)+  , (0xB974, 0xB974)+  , (0xB990, 0xB990)+  , (0xB9AC, 0xB9AC)+  , (0xB9C8, 0xB9C8)+  , (0xB9E4, 0xB9E4)+  , (0xBA00, 0xBA00)+  , (0xBA1C, 0xBA1C)+  , (0xBA38, 0xBA38)+  , (0xBA54, 0xBA54)+  , (0xBA70, 0xBA70)+  , (0xBA8C, 0xBA8C)+  , (0xBAA8, 0xBAA8)+  , (0xBAC4, 0xBAC4)+  , (0xBAE0, 0xBAE0)+  , (0xBAFC, 0xBAFC)+  , (0xBB18, 0xBB18)+  , (0xBB34, 0xBB34)+  , (0xBB50, 0xBB50)+  , (0xBB6C, 0xBB6C)+  , (0xBB88, 0xBB88)+  , (0xBBA4, 0xBBA4)+  , (0xBBC0, 0xBBC0)+  , (0xBBDC, 0xBBDC)+  , (0xBBF8, 0xBBF8)+  , (0xBC14, 0xBC14)+  , (0xBC30, 0xBC30)+  , (0xBC4C, 0xBC4C)+  , (0xBC68, 0xBC68)+  , (0xBC84, 0xBC84)+  , (0xBCA0, 0xBCA0)+  , (0xBCBC, 0xBCBC)+  , (0xBCD8, 0xBCD8)+  , (0xBCF4, 0xBCF4)+  , (0xBD10, 0xBD10)+  , (0xBD2C, 0xBD2C)+  , (0xBD48, 0xBD48)+  , (0xBD64, 0xBD64)+  , (0xBD80, 0xBD80)+  , (0xBD9C, 0xBD9C)+  , (0xBDB8, 0xBDB8)+  , (0xBDD4, 0xBDD4)+  , (0xBDF0, 0xBDF0)+  , (0xBE0C, 0xBE0C)+  , (0xBE28, 0xBE28)+  , (0xBE44, 0xBE44)+  , (0xBE60, 0xBE60)+  , (0xBE7C, 0xBE7C)+  , (0xBE98, 0xBE98)+  , (0xBEB4, 0xBEB4)+  , (0xBED0, 0xBED0)+  , (0xBEEC, 0xBEEC)+  , (0xBF08, 0xBF08)+  , (0xBF24, 0xBF24)+  , (0xBF40, 0xBF40)+  , (0xBF5C, 0xBF5C)+  , (0xBF78, 0xBF78)+  , (0xBF94, 0xBF94)+  , (0xBFB0, 0xBFB0)+  , (0xBFCC, 0xBFCC)+  , (0xBFE8, 0xBFE8)+  , (0xC004, 0xC004)+  , (0xC020, 0xC020)+  , (0xC03C, 0xC03C)+  , (0xC058, 0xC058)+  , (0xC074, 0xC074)+  , (0xC090, 0xC090)+  , (0xC0AC, 0xC0AC)+  , (0xC0C8, 0xC0C8)+  , (0xC0E4, 0xC0E4)+  , (0xC100, 0xC100)+  , (0xC11C, 0xC11C)+  , (0xC138, 0xC138)+  , (0xC154, 0xC154)+  , (0xC170, 0xC170)+  , (0xC18C, 0xC18C)+  , (0xC1A8, 0xC1A8)+  , (0xC1C4, 0xC1C4)+  , (0xC1E0, 0xC1E0)+  , (0xC1FC, 0xC1FC)+  , (0xC218, 0xC218)+  , (0xC234, 0xC234)+  , (0xC250, 0xC250)+  , (0xC26C, 0xC26C)+  , (0xC288, 0xC288)+  , (0xC2A4, 0xC2A4)+  , (0xC2C0, 0xC2C0)+  , (0xC2DC, 0xC2DC)+  , (0xC2F8, 0xC2F8)+  , (0xC314, 0xC314)+  , (0xC330, 0xC330)+  , (0xC34C, 0xC34C)+  , (0xC368, 0xC368)+  , (0xC384, 0xC384)+  , (0xC3A0, 0xC3A0)+  , (0xC3BC, 0xC3BC)+  , (0xC3D8, 0xC3D8)+  , (0xC3F4, 0xC3F4)+  , (0xC410, 0xC410)+  , (0xC42C, 0xC42C)+  , (0xC448, 0xC448)+  , (0xC464, 0xC464)+  , (0xC480, 0xC480)+  , (0xC49C, 0xC49C)+  , (0xC4B8, 0xC4B8)+  , (0xC4D4, 0xC4D4)+  , (0xC4F0, 0xC4F0)+  , (0xC50C, 0xC50C)+  , (0xC528, 0xC528)+  , (0xC544, 0xC544)+  , (0xC560, 0xC560)+  , (0xC57C, 0xC57C)+  , (0xC598, 0xC598)+  , (0xC5B4, 0xC5B4)+  , (0xC5D0, 0xC5D0)+  , (0xC5EC, 0xC5EC)+  , (0xC608, 0xC608)+  , (0xC624, 0xC624)+  , (0xC640, 0xC640)+  , (0xC65C, 0xC65C)+  , (0xC678, 0xC678)+  , (0xC694, 0xC694)+  , (0xC6B0, 0xC6B0)+  , (0xC6CC, 0xC6CC)+  , (0xC6E8, 0xC6E8)+  , (0xC704, 0xC704)+  , (0xC720, 0xC720)+  , (0xC73C, 0xC73C)+  , (0xC758, 0xC758)+  , (0xC774, 0xC774)+  , (0xC790, 0xC790)+  , (0xC7AC, 0xC7AC)+  , (0xC7C8, 0xC7C8)+  , (0xC7E4, 0xC7E4)+  , (0xC800, 0xC800)+  , (0xC81C, 0xC81C)+  , (0xC838, 0xC838)+  , (0xC854, 0xC854)+  , (0xC870, 0xC870)+  , (0xC88C, 0xC88C)+  , (0xC8A8, 0xC8A8)+  , (0xC8C4, 0xC8C4)+  , (0xC8E0, 0xC8E0)+  , (0xC8FC, 0xC8FC)+  , (0xC918, 0xC918)+  , (0xC934, 0xC934)+  , (0xC950, 0xC950)+  , (0xC96C, 0xC96C)+  , (0xC988, 0xC988)+  , (0xC9A4, 0xC9A4)+  , (0xC9C0, 0xC9C0)+  , (0xC9DC, 0xC9DC)+  , (0xC9F8, 0xC9F8)+  , (0xCA14, 0xCA14)+  , (0xCA30, 0xCA30)+  , (0xCA4C, 0xCA4C)+  , (0xCA68, 0xCA68)+  , (0xCA84, 0xCA84)+  , (0xCAA0, 0xCAA0)+  , (0xCABC, 0xCABC)+  , (0xCAD8, 0xCAD8)+  , (0xCAF4, 0xCAF4)+  , (0xCB10, 0xCB10)+  , (0xCB2C, 0xCB2C)+  , (0xCB48, 0xCB48)+  , (0xCB64, 0xCB64)+  , (0xCB80, 0xCB80)+  , (0xCB9C, 0xCB9C)+  , (0xCBB8, 0xCBB8)+  , (0xCBD4, 0xCBD4)+  , (0xCBF0, 0xCBF0)+  , (0xCC0C, 0xCC0C)+  , (0xCC28, 0xCC28)+  , (0xCC44, 0xCC44)+  , (0xCC60, 0xCC60)+  , (0xCC7C, 0xCC7C)+  , (0xCC98, 0xCC98)+  , (0xCCB4, 0xCCB4)+  , (0xCCD0, 0xCCD0)+  , (0xCCEC, 0xCCEC)+  , (0xCD08, 0xCD08)+  , (0xCD24, 0xCD24)+  , (0xCD40, 0xCD40)+  , (0xCD5C, 0xCD5C)+  , (0xCD78, 0xCD78)+  , (0xCD94, 0xCD94)+  , (0xCDB0, 0xCDB0)+  , (0xCDCC, 0xCDCC)+  , (0xCDE8, 0xCDE8)+  , (0xCE04, 0xCE04)+  , (0xCE20, 0xCE20)+  , (0xCE3C, 0xCE3C)+  , (0xCE58, 0xCE58)+  , (0xCE74, 0xCE74)+  , (0xCE90, 0xCE90)+  , (0xCEAC, 0xCEAC)+  , (0xCEC8, 0xCEC8)+  , (0xCEE4, 0xCEE4)+  , (0xCF00, 0xCF00)+  , (0xCF1C, 0xCF1C)+  , (0xCF38, 0xCF38)+  , (0xCF54, 0xCF54)+  , (0xCF70, 0xCF70)+  , (0xCF8C, 0xCF8C)+  , (0xCFA8, 0xCFA8)+  , (0xCFC4, 0xCFC4)+  , (0xCFE0, 0xCFE0)+  , (0xCFFC, 0xCFFC)+  , (0xD018, 0xD018)+  , (0xD034, 0xD034)+  , (0xD050, 0xD050)+  , (0xD06C, 0xD06C)+  , (0xD088, 0xD088)+  , (0xD0A4, 0xD0A4)+  , (0xD0C0, 0xD0C0)+  , (0xD0DC, 0xD0DC)+  , (0xD0F8, 0xD0F8)+  , (0xD114, 0xD114)+  , (0xD130, 0xD130)+  , (0xD14C, 0xD14C)+  , (0xD168, 0xD168)+  , (0xD184, 0xD184)+  , (0xD1A0, 0xD1A0)+  , (0xD1BC, 0xD1BC)+  , (0xD1D8, 0xD1D8)+  , (0xD1F4, 0xD1F4)+  , (0xD210, 0xD210)+  , (0xD22C, 0xD22C)+  , (0xD248, 0xD248)+  , (0xD264, 0xD264)+  , (0xD280, 0xD280)+  , (0xD29C, 0xD29C)+  , (0xD2B8, 0xD2B8)+  , (0xD2D4, 0xD2D4)+  , (0xD2F0, 0xD2F0)+  , (0xD30C, 0xD30C)+  , (0xD328, 0xD328)+  , (0xD344, 0xD344)+  , (0xD360, 0xD360)+  , (0xD37C, 0xD37C)+  , (0xD398, 0xD398)+  , (0xD3B4, 0xD3B4)+  , (0xD3D0, 0xD3D0)+  , (0xD3EC, 0xD3EC)+  , (0xD408, 0xD408)+  , (0xD424, 0xD424)+  , (0xD440, 0xD440)+  , (0xD45C, 0xD45C)+  , (0xD478, 0xD478)+  , (0xD494, 0xD494)+  , (0xD4B0, 0xD4B0)+  , (0xD4CC, 0xD4CC)+  , (0xD4E8, 0xD4E8)+  , (0xD504, 0xD504)+  , (0xD520, 0xD520)+  , (0xD53C, 0xD53C)+  , (0xD558, 0xD558)+  , (0xD574, 0xD574)+  , (0xD590, 0xD590)+  , (0xD5AC, 0xD5AC)+  , (0xD5C8, 0xD5C8)+  , (0xD5E4, 0xD5E4)+  , (0xD600, 0xD600)+  , (0xD61C, 0xD61C)+  , (0xD638, 0xD638)+  , (0xD654, 0xD654)+  , (0xD670, 0xD670)+  , (0xD68C, 0xD68C)+  , (0xD6A8, 0xD6A8)+  , (0xD6C4, 0xD6C4)+  , (0xD6E0, 0xD6E0)+  , (0xD6FC, 0xD6FC)+  , (0xD718, 0xD718)+  , (0xD734, 0xD734)+  , (0xD750, 0xD750)+  , (0xD76C, 0xD76C)+  , (0xD788, 0xD788)+  ]++gbLVT :: [(Int, Int)]+gbLVT =+  [ (0xAC01, 0xAC1B)+  , (0xAC1D, 0xAC37)+  , (0xAC39, 0xAC53)+  , (0xAC55, 0xAC6F)+  , (0xAC71, 0xAC8B)+  , (0xAC8D, 0xACA7)+  , (0xACA9, 0xACC3)+  , (0xACC5, 0xACDF)+  , (0xACE1, 0xACFB)+  , (0xACFD, 0xAD17)+  , (0xAD19, 0xAD33)+  , (0xAD35, 0xAD4F)+  , (0xAD51, 0xAD6B)+  , (0xAD6D, 0xAD87)+  , (0xAD89, 0xADA3)+  , (0xADA5, 0xADBF)+  , (0xADC1, 0xADDB)+  , (0xADDD, 0xADF7)+  , (0xADF9, 0xAE13)+  , (0xAE15, 0xAE2F)+  , (0xAE31, 0xAE4B)+  , (0xAE4D, 0xAE67)+  , (0xAE69, 0xAE83)+  , (0xAE85, 0xAE9F)+  , (0xAEA1, 0xAEBB)+  , (0xAEBD, 0xAED7)+  , (0xAED9, 0xAEF3)+  , (0xAEF5, 0xAF0F)+  , (0xAF11, 0xAF2B)+  , (0xAF2D, 0xAF47)+  , (0xAF49, 0xAF63)+  , (0xAF65, 0xAF7F)+  , (0xAF81, 0xAF9B)+  , (0xAF9D, 0xAFB7)+  , (0xAFB9, 0xAFD3)+  , (0xAFD5, 0xAFEF)+  , (0xAFF1, 0xB00B)+  , (0xB00D, 0xB027)+  , (0xB029, 0xB043)+  , (0xB045, 0xB05F)+  , (0xB061, 0xB07B)+  , (0xB07D, 0xB097)+  , (0xB099, 0xB0B3)+  , (0xB0B5, 0xB0CF)+  , (0xB0D1, 0xB0EB)+  , (0xB0ED, 0xB107)+  , (0xB109, 0xB123)+  , (0xB125, 0xB13F)+  , (0xB141, 0xB15B)+  , (0xB15D, 0xB177)+  , (0xB179, 0xB193)+  , (0xB195, 0xB1AF)+  , (0xB1B1, 0xB1CB)+  , (0xB1CD, 0xB1E7)+  , (0xB1E9, 0xB203)+  , (0xB205, 0xB21F)+  , (0xB221, 0xB23B)+  , (0xB23D, 0xB257)+  , (0xB259, 0xB273)+  , (0xB275, 0xB28F)+  , (0xB291, 0xB2AB)+  , (0xB2AD, 0xB2C7)+  , (0xB2C9, 0xB2E3)+  , (0xB2E5, 0xB2FF)+  , (0xB301, 0xB31B)+  , (0xB31D, 0xB337)+  , (0xB339, 0xB353)+  , (0xB355, 0xB36F)+  , (0xB371, 0xB38B)+  , (0xB38D, 0xB3A7)+  , (0xB3A9, 0xB3C3)+  , (0xB3C5, 0xB3DF)+  , (0xB3E1, 0xB3FB)+  , (0xB3FD, 0xB417)+  , (0xB419, 0xB433)+  , (0xB435, 0xB44F)+  , (0xB451, 0xB46B)+  , (0xB46D, 0xB487)+  , (0xB489, 0xB4A3)+  , (0xB4A5, 0xB4BF)+  , (0xB4C1, 0xB4DB)+  , (0xB4DD, 0xB4F7)+  , (0xB4F9, 0xB513)+  , (0xB515, 0xB52F)+  , (0xB531, 0xB54B)+  , (0xB54D, 0xB567)+  , (0xB569, 0xB583)+  , (0xB585, 0xB59F)+  , (0xB5A1, 0xB5BB)+  , (0xB5BD, 0xB5D7)+  , (0xB5D9, 0xB5F3)+  , (0xB5F5, 0xB60F)+  , (0xB611, 0xB62B)+  , (0xB62D, 0xB647)+  , (0xB649, 0xB663)+  , (0xB665, 0xB67F)+  , (0xB681, 0xB69B)+  , (0xB69D, 0xB6B7)+  , (0xB6B9, 0xB6D3)+  , (0xB6D5, 0xB6EF)+  , (0xB6F1, 0xB70B)+  , (0xB70D, 0xB727)+  , (0xB729, 0xB743)+  , (0xB745, 0xB75F)+  , (0xB761, 0xB77B)+  , (0xB77D, 0xB797)+  , (0xB799, 0xB7B3)+  , (0xB7B5, 0xB7CF)+  , (0xB7D1, 0xB7EB)+  , (0xB7ED, 0xB807)+  , (0xB809, 0xB823)+  , (0xB825, 0xB83F)+  , (0xB841, 0xB85B)+  , (0xB85D, 0xB877)+  , (0xB879, 0xB893)+  , (0xB895, 0xB8AF)+  , (0xB8B1, 0xB8CB)+  , (0xB8CD, 0xB8E7)+  , (0xB8E9, 0xB903)+  , (0xB905, 0xB91F)+  , (0xB921, 0xB93B)+  , (0xB93D, 0xB957)+  , (0xB959, 0xB973)+  , (0xB975, 0xB98F)+  , (0xB991, 0xB9AB)+  , (0xB9AD, 0xB9C7)+  , (0xB9C9, 0xB9E3)+  , (0xB9E5, 0xB9FF)+  , (0xBA01, 0xBA1B)+  , (0xBA1D, 0xBA37)+  , (0xBA39, 0xBA53)+  , (0xBA55, 0xBA6F)+  , (0xBA71, 0xBA8B)+  , (0xBA8D, 0xBAA7)+  , (0xBAA9, 0xBAC3)+  , (0xBAC5, 0xBADF)+  , (0xBAE1, 0xBAFB)+  , (0xBAFD, 0xBB17)+  , (0xBB19, 0xBB33)+  , (0xBB35, 0xBB4F)+  , (0xBB51, 0xBB6B)+  , (0xBB6D, 0xBB87)+  , (0xBB89, 0xBBA3)+  , (0xBBA5, 0xBBBF)+  , (0xBBC1, 0xBBDB)+  , (0xBBDD, 0xBBF7)+  , (0xBBF9, 0xBC13)+  , (0xBC15, 0xBC2F)+  , (0xBC31, 0xBC4B)+  , (0xBC4D, 0xBC67)+  , (0xBC69, 0xBC83)+  , (0xBC85, 0xBC9F)+  , (0xBCA1, 0xBCBB)+  , (0xBCBD, 0xBCD7)+  , (0xBCD9, 0xBCF3)+  , (0xBCF5, 0xBD0F)+  , (0xBD11, 0xBD2B)+  , (0xBD2D, 0xBD47)+  , (0xBD49, 0xBD63)+  , (0xBD65, 0xBD7F)+  , (0xBD81, 0xBD9B)+  , (0xBD9D, 0xBDB7)+  , (0xBDB9, 0xBDD3)+  , (0xBDD5, 0xBDEF)+  , (0xBDF1, 0xBE0B)+  , (0xBE0D, 0xBE27)+  , (0xBE29, 0xBE43)+  , (0xBE45, 0xBE5F)+  , (0xBE61, 0xBE7B)+  , (0xBE7D, 0xBE97)+  , (0xBE99, 0xBEB3)+  , (0xBEB5, 0xBECF)+  , (0xBED1, 0xBEEB)+  , (0xBEED, 0xBF07)+  , (0xBF09, 0xBF23)+  , (0xBF25, 0xBF3F)+  , (0xBF41, 0xBF5B)+  , (0xBF5D, 0xBF77)+  , (0xBF79, 0xBF93)+  , (0xBF95, 0xBFAF)+  , (0xBFB1, 0xBFCB)+  , (0xBFCD, 0xBFE7)+  , (0xBFE9, 0xC003)+  , (0xC005, 0xC01F)+  , (0xC021, 0xC03B)+  , (0xC03D, 0xC057)+  , (0xC059, 0xC073)+  , (0xC075, 0xC08F)+  , (0xC091, 0xC0AB)+  , (0xC0AD, 0xC0C7)+  , (0xC0C9, 0xC0E3)+  , (0xC0E5, 0xC0FF)+  , (0xC101, 0xC11B)+  , (0xC11D, 0xC137)+  , (0xC139, 0xC153)+  , (0xC155, 0xC16F)+  , (0xC171, 0xC18B)+  , (0xC18D, 0xC1A7)+  , (0xC1A9, 0xC1C3)+  , (0xC1C5, 0xC1DF)+  , (0xC1E1, 0xC1FB)+  , (0xC1FD, 0xC217)+  , (0xC219, 0xC233)+  , (0xC235, 0xC24F)+  , (0xC251, 0xC26B)+  , (0xC26D, 0xC287)+  , (0xC289, 0xC2A3)+  , (0xC2A5, 0xC2BF)+  , (0xC2C1, 0xC2DB)+  , (0xC2DD, 0xC2F7)+  , (0xC2F9, 0xC313)+  , (0xC315, 0xC32F)+  , (0xC331, 0xC34B)+  , (0xC34D, 0xC367)+  , (0xC369, 0xC383)+  , (0xC385, 0xC39F)+  , (0xC3A1, 0xC3BB)+  , (0xC3BD, 0xC3D7)+  , (0xC3D9, 0xC3F3)+  , (0xC3F5, 0xC40F)+  , (0xC411, 0xC42B)+  , (0xC42D, 0xC447)+  , (0xC449, 0xC463)+  , (0xC465, 0xC47F)+  , (0xC481, 0xC49B)+  , (0xC49D, 0xC4B7)+  , (0xC4B9, 0xC4D3)+  , (0xC4D5, 0xC4EF)+  , (0xC4F1, 0xC50B)+  , (0xC50D, 0xC527)+  , (0xC529, 0xC543)+  , (0xC545, 0xC55F)+  , (0xC561, 0xC57B)+  , (0xC57D, 0xC597)+  , (0xC599, 0xC5B3)+  , (0xC5B5, 0xC5CF)+  , (0xC5D1, 0xC5EB)+  , (0xC5ED, 0xC607)+  , (0xC609, 0xC623)+  , (0xC625, 0xC63F)+  , (0xC641, 0xC65B)+  , (0xC65D, 0xC677)+  , (0xC679, 0xC693)+  , (0xC695, 0xC6AF)+  , (0xC6B1, 0xC6CB)+  , (0xC6CD, 0xC6E7)+  , (0xC6E9, 0xC703)+  , (0xC705, 0xC71F)+  , (0xC721, 0xC73B)+  , (0xC73D, 0xC757)+  , (0xC759, 0xC773)+  , (0xC775, 0xC78F)+  , (0xC791, 0xC7AB)+  , (0xC7AD, 0xC7C7)+  , (0xC7C9, 0xC7E3)+  , (0xC7E5, 0xC7FF)+  , (0xC801, 0xC81B)+  , (0xC81D, 0xC837)+  , (0xC839, 0xC853)+  , (0xC855, 0xC86F)+  , (0xC871, 0xC88B)+  , (0xC88D, 0xC8A7)+  , (0xC8A9, 0xC8C3)+  , (0xC8C5, 0xC8DF)+  , (0xC8E1, 0xC8FB)+  , (0xC8FD, 0xC917)+  , (0xC919, 0xC933)+  , (0xC935, 0xC94F)+  , (0xC951, 0xC96B)+  , (0xC96D, 0xC987)+  , (0xC989, 0xC9A3)+  , (0xC9A5, 0xC9BF)+  , (0xC9C1, 0xC9DB)+  , (0xC9DD, 0xC9F7)+  , (0xC9F9, 0xCA13)+  , (0xCA15, 0xCA2F)+  , (0xCA31, 0xCA4B)+  , (0xCA4D, 0xCA67)+  , (0xCA69, 0xCA83)+  , (0xCA85, 0xCA9F)+  , (0xCAA1, 0xCABB)+  , (0xCABD, 0xCAD7)+  , (0xCAD9, 0xCAF3)+  , (0xCAF5, 0xCB0F)+  , (0xCB11, 0xCB2B)+  , (0xCB2D, 0xCB47)+  , (0xCB49, 0xCB63)+  , (0xCB65, 0xCB7F)+  , (0xCB81, 0xCB9B)+  , (0xCB9D, 0xCBB7)+  , (0xCBB9, 0xCBD3)+  , (0xCBD5, 0xCBEF)+  , (0xCBF1, 0xCC0B)+  , (0xCC0D, 0xCC27)+  , (0xCC29, 0xCC43)+  , (0xCC45, 0xCC5F)+  , (0xCC61, 0xCC7B)+  , (0xCC7D, 0xCC97)+  , (0xCC99, 0xCCB3)+  , (0xCCB5, 0xCCCF)+  , (0xCCD1, 0xCCEB)+  , (0xCCED, 0xCD07)+  , (0xCD09, 0xCD23)+  , (0xCD25, 0xCD3F)+  , (0xCD41, 0xCD5B)+  , (0xCD5D, 0xCD77)+  , (0xCD79, 0xCD93)+  , (0xCD95, 0xCDAF)+  , (0xCDB1, 0xCDCB)+  , (0xCDCD, 0xCDE7)+  , (0xCDE9, 0xCE03)+  , (0xCE05, 0xCE1F)+  , (0xCE21, 0xCE3B)+  , (0xCE3D, 0xCE57)+  , (0xCE59, 0xCE73)+  , (0xCE75, 0xCE8F)+  , (0xCE91, 0xCEAB)+  , (0xCEAD, 0xCEC7)+  , (0xCEC9, 0xCEE3)+  , (0xCEE5, 0xCEFF)+  , (0xCF01, 0xCF1B)+  , (0xCF1D, 0xCF37)+  , (0xCF39, 0xCF53)+  , (0xCF55, 0xCF6F)+  , (0xCF71, 0xCF8B)+  , (0xCF8D, 0xCFA7)+  , (0xCFA9, 0xCFC3)+  , (0xCFC5, 0xCFDF)+  , (0xCFE1, 0xCFFB)+  , (0xCFFD, 0xD017)+  , (0xD019, 0xD033)+  , (0xD035, 0xD04F)+  , (0xD051, 0xD06B)+  , (0xD06D, 0xD087)+  , (0xD089, 0xD0A3)+  , (0xD0A5, 0xD0BF)+  , (0xD0C1, 0xD0DB)+  , (0xD0DD, 0xD0F7)+  , (0xD0F9, 0xD113)+  , (0xD115, 0xD12F)+  , (0xD131, 0xD14B)+  , (0xD14D, 0xD167)+  , (0xD169, 0xD183)+  , (0xD185, 0xD19F)+  , (0xD1A1, 0xD1BB)+  , (0xD1BD, 0xD1D7)+  , (0xD1D9, 0xD1F3)+  , (0xD1F5, 0xD20F)+  , (0xD211, 0xD22B)+  , (0xD22D, 0xD247)+  , (0xD249, 0xD263)+  , (0xD265, 0xD27F)+  , (0xD281, 0xD29B)+  , (0xD29D, 0xD2B7)+  , (0xD2B9, 0xD2D3)+  , (0xD2D5, 0xD2EF)+  , (0xD2F1, 0xD30B)+  , (0xD30D, 0xD327)+  , (0xD329, 0xD343)+  , (0xD345, 0xD35F)+  , (0xD361, 0xD37B)+  , (0xD37D, 0xD397)+  , (0xD399, 0xD3B3)+  , (0xD3B5, 0xD3CF)+  , (0xD3D1, 0xD3EB)+  , (0xD3ED, 0xD407)+  , (0xD409, 0xD423)+  , (0xD425, 0xD43F)+  , (0xD441, 0xD45B)+  , (0xD45D, 0xD477)+  , (0xD479, 0xD493)+  , (0xD495, 0xD4AF)+  , (0xD4B1, 0xD4CB)+  , (0xD4CD, 0xD4E7)+  , (0xD4E9, 0xD503)+  , (0xD505, 0xD51F)+  , (0xD521, 0xD53B)+  , (0xD53D, 0xD557)+  , (0xD559, 0xD573)+  , (0xD575, 0xD58F)+  , (0xD591, 0xD5AB)+  , (0xD5AD, 0xD5C7)+  , (0xD5C9, 0xD5E3)+  , (0xD5E5, 0xD5FF)+  , (0xD601, 0xD61B)+  , (0xD61D, 0xD637)+  , (0xD639, 0xD653)+  , (0xD655, 0xD66F)+  , (0xD671, 0xD68B)+  , (0xD68D, 0xD6A7)+  , (0xD6A9, 0xD6C3)+  , (0xD6C5, 0xD6DF)+  , (0xD6E1, 0xD6FB)+  , (0xD6FD, 0xD717)+  , (0xD719, 0xD733)+  , (0xD735, 0xD74F)+  , (0xD751, 0xD76B)+  , (0xD76D, 0xD787)+  , (0xD789, 0xD7A3)+  ]++gbExtendedPictographic :: [(Int, Int)]+gbExtendedPictographic =+  [ (0x00A9, 0x00A9)+  , (0x00AE, 0x00AE)+  , (0x203C, 0x203C)+  , (0x2049, 0x2049)+  , (0x2122, 0x2122)+  , (0x2139, 0x2139)+  , (0x2194, 0x2199)+  , (0x21A9, 0x21AA)+  , (0x231A, 0x231B)+  , (0x2328, 0x2328)+  , (0x2388, 0x2388)+  , (0x23CF, 0x23CF)+  , (0x23E9, 0x23F3)+  , (0x23F8, 0x23FA)+  , (0x24C2, 0x24C2)+  , (0x25AA, 0x25AB)+  , (0x25B6, 0x25B6)+  , (0x25C0, 0x25C0)+  , (0x25FB, 0x25FE)+  , (0x2600, 0x2605)+  , (0x2607, 0x2612)+  , (0x2614, 0x2685)+  , (0x2690, 0x2705)+  , (0x2708, 0x2712)+  , (0x2714, 0x2714)+  , (0x2716, 0x2716)+  , (0x271D, 0x271D)+  , (0x2721, 0x2721)+  , (0x2728, 0x2728)+  , (0x2733, 0x2734)+  , (0x2744, 0x2744)+  , (0x2747, 0x2747)+  , (0x274C, 0x274C)+  , (0x274E, 0x274E)+  , (0x2753, 0x2755)+  , (0x2757, 0x2757)+  , (0x2763, 0x2767)+  , (0x2795, 0x2797)+  , (0x27A1, 0x27A1)+  , (0x27B0, 0x27B0)+  , (0x27BF, 0x27BF)+  , (0x2934, 0x2935)+  , (0x2B05, 0x2B07)+  , (0x2B1B, 0x2B1C)+  , (0x2B50, 0x2B50)+  , (0x2B55, 0x2B55)+  , (0x3030, 0x3030)+  , (0x303D, 0x303D)+  , (0x3297, 0x3297)+  , (0x3299, 0x3299)+  , (0x1F000, 0x1F0FF)+  , (0x1F10D, 0x1F10F)+  , (0x1F12F, 0x1F12F)+  , (0x1F16C, 0x1F171)+  , (0x1F17E, 0x1F17F)+  , (0x1F18E, 0x1F18E)+  , (0x1F191, 0x1F19A)+  , (0x1F1AD, 0x1F1E5)+  , (0x1F201, 0x1F20F)+  , (0x1F21A, 0x1F21A)+  , (0x1F22F, 0x1F22F)+  , (0x1F232, 0x1F23A)+  , (0x1F23C, 0x1F23F)+  , (0x1F249, 0x1F3FA)+  , (0x1F400, 0x1F53D)+  , (0x1F546, 0x1F64F)+  , (0x1F680, 0x1F6FF)+  , (0x1F774, 0x1F77F)+  , (0x1F7D5, 0x1F7FF)+  , (0x1F80C, 0x1F80F)+  , (0x1F848, 0x1F84F)+  , (0x1F85A, 0x1F85F)+  , (0x1F888, 0x1F88F)+  , (0x1F8AE, 0x1F8FF)+  , (0x1F90C, 0x1F93A)+  , (0x1F93C, 0x1F945)+  , (0x1F947, 0x1FAFF)+  , (0x1FC00, 0x1FFFD)+  ]+
+ tadka.cabal view
@@ -0,0 +1,228 @@+cabal-version:      3.0+name:               tadka+version:            2.0.0.0+synopsis:           Structured error diagnostics & source-span reporting + like Rust's miette+description:+  Tadka is a Haskell library for structured error diagnostics and source-span+  reporting. It turns ordinary error values into diagnostic reports with+  source locations, labeled spans, error codes, severity, help text,+  documentation URLs, related diagnostics, and underlying causes. It provides+  graphical terminal, accessible prose, and JSON renderers, with support for+  diagnostics spanning multiple source files. Tadka also provides integrations+  for GHC SrcSpan, Megaparsec, and Attoparsec, plus Template Haskell derivation+  support for reducing diagnostic boilerplate. It is inspired by Rust's miette+  but is designed around Haskell's types and conventions.+category:           Development, Error Handling+license: MPL-2.0+license-file:       LICENSE+author:             Sabrinathan Nair+maintainer:         259497327+Bombay-Boyz@users.noreply.github.com+copyright:          (c) 2026 Bombay-Boyz+homepage:           https://github.com/Bombay-Boyz/tadka+bug-reports:        https://github.com/Bombay-Boyz/tadka/issues+build-type:         Simple+tested-with:        GHC ==9.6.7, GHC ==9.8.4, GHC ==9.10.3, GHC ==9.12.4, GHC ==9.14.1+extra-doc-files:    CHANGELOG.md+                    README.md+                    assets/tadka-diagnostic.png+extra-source-files: test/golden/fixtures/*.txt++-- Treat warnings as errors during development and CI, but not in released+-- builds: new GHC versions add warnings that would otherwise break downstream+-- installs (cabal check rejects an unconditional -Werror). Enabled via+-- cabal.project for our own builds.+flag werror+  description: Treat warnings as errors (enable in dev/CI, off for releases).+  default:     False+  manual:      True++-- Shared build settings. Warnings-as-errors are honoured under the `werror`++common warnings+  default-language: GHC2021+  ghc-options:      -Wall+                    -Wcompat+                    -Wredundant-constraints+                    -Wincomplete-record-updates+                    -Wincomplete-uni-patterns+                    -Wpartial-fields+  if flag(werror)+    ghc-options:    -Werror++-- The public library. Exposes exactly one supported module, @Tadka@; everything+-- under @Tadka.Internal.*@ is exposed for the derive-macro/manual-instance+-- shared-function discipline but carries NO compatibility guarantee.+library+  import:           warnings+  hs-source-dirs:   src+  exposed-modules:  Tadka+                    -- Internal surface (no compatibility guarantee):+                    Tadka.Internal+                    Tadka.Internal.Types+                    Tadka.Internal.Ann+                    Tadka.Internal.Span+                    Tadka.Internal.Width+                    Tadka.Internal.Context+                    Tadka.Internal.Diagnostic+                    Tadka.Internal.Related+                    Tadka.Internal.Config+                    Tadka.Internal.Render+                    Tadka.Internal.SourceCode+                    Tadka.Internal.Terminal+                    Tadka.Internal.Renderer.Graphical+                    Tadka.Internal.Renderer.Narratable+                    Tadka.Internal.Renderer.Json+                    Tadka.Internal.Renderer.LinePlan+                    Tadka.Internal.Renderer.Layout+                    Tadka.Internal.TH+                    Tadka.Internal.Generics+                    +  -- Generated, checked-in Unicode table (regenerate via tools/gen-width-table.hs):+  other-modules:    Tadka.Internal.Width.Table+  -- Dependency pins widened for multi-GHC support: GHC 9.6.7 through 9.14.1+  -- (vision Infrastructure). `array` backs the width table's binary-searched+  -- ranges; `network-uri` validates absolute URLs.+  --+  -- `base` and `template-haskell` are the two bounds tied directly to GHC's+  -- own release cadence (each GHC major ships an exact base/TH pair), so+  -- their floors/ceilings below are chosen from that mapping, not guessed:+  +  --   GHC 9.6.x  -> base-4.18.x,   template-haskell-2.20+  --   GHC 9.8.x  -> base-4.19.x,   template-haskell-2.21+  --   GHC 9.10.x -> base-4.20.x,   template-haskell-2.22+  --   GHC 9.12.x -> base-4.21.x,   template-haskell-2.23+  --   GHC 9.14.1 -> base-4.22.0.0, template-haskell-2.24+  +  -- The remaining bounds (text/array/bytestring/containers/network-uri/+  -- prettyprinter*/ansi-terminal/aeson) are not GHC-version-locked the same+  -- way; the ranges below are a reasoned starting point, not a substitute for+  -- letting `cabal build` actually solve against each GHC version in CI and+  -- narrowing/widening from real solver failures.+  build-depends:    base                          >=4.18   && <4.23+                  , text                          >=2.0    && <2.3+                  , array                          >=0.5    && <0.6+                  , bytestring                     >=0.11   && <0.13+                  , containers                     >=0.6    && <0.9+                  , network-uri                    >=2.6    && <2.7+                  , prettyprinter                  >=1.7    && <1.8+                  , prettyprinter-ansi-terminal    >=1.1    && <1.2+                  , ansi-terminal                  >=1.0    && <1.2+                  , template-haskell               >=2.20   && <2.25+                  , aeson                          >=2.1    && <2.4++-- Golden test suite: independently runnable (`cabal test golden`).+test-suite golden+  import:           warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/golden+  main-is:          Main.hs+  other-modules:    Fixtures+  build-depends:    base                  >=4.18 && <4.23+                  , tadka+                  , text                  >=2.0  && <2.3+                  , aeson                 >=2.1  && <2.4+                  , prettyprinter         >=1.7  && <1.8+                  , template-haskell      >=2.20 && <2.25++-- Property (Hedgehog) test suite: independently runnable (`cabal test props`).+test-suite props+  import:           warnings+  if impl(ghc >= 9.10)+      ghc-options:    -Wno-incomplete-record-selectors+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/props+  main-is:          Main.hs+  other-modules:    Phase1+                    Phase2+                    Phase3+                    Phase4+                    Phase5+                    Phase6+                    Phase7+                    Phase8+                    Phase9+                    Phase11+                    Phase12+                    Phase13+                    Tabs+                    TermColor+                    Hyperlink+                    LabelCollection+                    Labels+                    Cause+                    Source+                    LinePlanSpec+                    LayoutSpec+                    MultiLine+                    EdgeCases+                    GenDiag+  build-depends:    base                          >=4.18 && <4.23+                  , tadka+                  , text                          >=2.0  && <2.3+                  , aeson                         >=2.1  && <2.4+                  , prettyprinter                 >=1.7  && <1.8+                  , prettyprinter-ansi-terminal   >=1.1  && <1.2+                  , template-haskell              >=2.20 && <2.25+                  , hedgehog                      >=1.7  && <1.8++-- One-directional interop adapters. Each is a separate sub-library so the core+-- library never depends on a parser package; core modules cannot import these.+library interop-ghc+  import:           warnings+  visibility:       public+  hs-source-dirs:   interop/ghc+  exposed-modules:  Tadka.Interop.GHC+  -- Unlike every other bound in this file, `ghc`'s version is always exactly+  -- the compiler's own version (there is no independently-versioned `ghc`+  -- library to solve against on Hackage in the usual sense) — so this bound+  -- exists only to state the supported compiler range, not to be solved+  -- against multiple candidate versions the way `aeson` or `text` are.+  -- `Tadka.Interop.GHC` uses only `GHC.Types.SrcLoc`'s `SrcSpan`/`RealSrcSpan`+  -- accessors, which have been stable public GHC API since long before 9.4;+  -- no CPP has been needed for the range below, but that should be confirmed+  -- by an actual per-version build in CI, not assumed from the bound alone.+  build-depends:    base       >=4.18 && <4.23+                  , tadka+                  , text       >=2.0  && <2.3+                  , ghc        >=9.6  && <9.15++library interop-megaparsec+  import:           warnings+  visibility:       public+  hs-source-dirs:   interop/megaparsec+  exposed-modules:  Tadka.Interop.Megaparsec+  build-depends:    base        >=4.18 && <4.23+                  , tadka+                  , text        >=2.0  && <2.3+                  , megaparsec  >=9.0  && <9.9++library interop-attoparsec+  import:           warnings+  visibility:       public+  hs-source-dirs:   interop/attoparsec+  exposed-modules:  Tadka.Interop.Attoparsec+  build-depends:    base        >=4.18 && <4.23+                  , tadka+                  , text        >=2.0  && <2.3+                  , attoparsec  >=0.14 && <0.15++test-suite interop+  import:           warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test/interop+  main-is:          Main.hs+  build-depends:    base                       >=4.18 && <4.23+                  , tadka+                  , tadka:interop-ghc+                  , tadka:interop-megaparsec+                  , tadka:interop-attoparsec+                  , text                       >=2.0  && <2.3+                  , containers                 >=0.6  && <0.9+                  , megaparsec                 >=9.0  && <9.9+                  , attoparsec                 >=0.14 && <0.15+                  , ghc                        >=9.6  && <9.15++source-repository head+  type:     git+  location: https://github.com/Bombay-Boyz/tadka.git
+ test/golden/Fixtures.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Concrete diagnostics for the graphical golden fixtures (spec Phase 5).+-- Offsets are computed from prefix lengths so the labelled spans are exact.+module Fixtures+  ( fixtures+  , narratableFixtures+  , jsonFixtures+  , contextFixtures+  , generatedSource+  , single+  ) where++import           Data.List.NonEmpty (NonEmpty (..))+import           Data.Text     (Text)+import qualified Data.Text     as T+import           Prettyprinter (Doc, pretty)+import           Language.Haskell.TH (litE, pprint, stringL)++import           Tadka+import           Tadka.Internal (buildContext, buildContextMulti, buildContextWith)++-- A general-purpose Diagnostic carrier for fixtures.+data Fix = Fix+  { fMsg  :: Text+  , fCode :: Maybe DiagnosticCode+  , fCtx  :: Context+  , fHelp :: Maybe Text+  , fUrl  :: Maybe Url+  , fRel  :: [SomeDiagnostic]+  , fId   :: Maybe DiagnosticId+  }++instance Diagnostic Fix where+  message      = pretty . fMsg+  code         = fCode+  context      = fCtx+  help         = fmap pretty . fHelp+  url          = fUrl+  related      = fRel+  diagnosticId = fId++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++mkCode :: Text -> DiagnosticCode+mkCode = rightOrErr . mkDiagnosticCode++label :: Text -> Maybe (Doc Ann)+label t = Just (pretty t)++-- 1. Single label -----------------------------------------------------------+src1 :: NamedSource+src1 = rightOrErr (mkNamedSource "example.hs" "line1\nline2\nlet x = foo + 1\n")++-- A span that crosses lines, to exercise the connector lanes (Phase III).+multiLine :: Fix+multiLine = Fix+  { fMsg  = "unterminated function call"+  , fCode = Just (mkCode "tadka::E0300")+  , fCtx  = buildContext srcCall+              [ (rightOrErr (mkSpan 8 22), label "opened here, never closed") ]+  , fHelp = Just "add a closing `)`"+  , fUrl  = Nothing, fRel = [], fId = Nothing+  }++srcCall :: NamedSource+srcCall = rightOrErr (mkNamedSource "call.hs" "let x = foo(\n    bar,\n    baz)\n")++-- Labels far apart, to exercise context lines + gap elision (rendered with+-- withContextLines 1 in the golden harness).+farApart :: Fix+farApart = Fix+  { fMsg  = "two distant problems"+  , fCode = Just (mkCode "tadka::E0200")+  , fCtx  = buildContextWith srcTen+              [ (rightOrErr (mkSpan 4 2),  Secondary, label "first")+              , (rightOrErr (mkSpan 40 4), Primary,   label "second")+              ]+  , fHelp = Nothing, fUrl = Nothing, fRel = [], fId = Nothing+  }++srcTen :: NamedSource+srcTen = rightOrErr (mkNamedSource "big.hs"+  "one aaa\ntwo bbb\nthree c\nfour dd\nfive ee\nsix fff\nseven g\neight h\nnine ii\nten jjj\n")++-- A minimal chainable diagnostic for exercising the cause chain (Part B).+data CauseNode = CauseNode Text (Maybe DiagnosticCode) (Maybe SomeDiagnostic)++instance Diagnostic CauseNode where+  message (CauseNode m _ _) = pretty m+  code    (CauseNode _ c _) = c+  diagnosticCause (CauseNode _ _ mc) = mc++-- E0100 caused by E0042 caused by an uncoded leaf.+withCause :: CauseNode+withCause = CauseNode "failed to compile `Main`" (Just (mkCode "tadka::E0100"))+  (Just (SomeDiagnostic (CauseNode "type mismatch in `foo`" (Just (mkCode "tadka::E0042"))+    (Just (SomeDiagnostic (CauseNode "unbound variable `x`" Nothing Nothing))))))++single :: Fix+single = Fix+  { fMsg  = "undefined variable `foo`"+  , fCode = Just (mkCode "tadka::E0001")+  , fCtx  = buildContext src1+              [ (rightOrErr (mkSpan (T.length "line1\nline2\nlet x = ") 3), label "not in scope") ]+  , fHelp = Just "did you mean `bar`?"+  , fUrl  = Just (rightOrErr (mkUrl "https://example.org/errors/E0001"))+  , fRel  = []+  , fId   = Nothing+  }++-- 2. Multiple labels + related ----------------------------------------------+src2 :: NamedSource+src2 = rightOrErr (mkNamedSource "example.hs"+         "addOne :: Int -> Int\naddOne x = x\nresult = addOne \"hi\"\n")++related43 :: Fix+related43 = Fix+  { fMsg  = "conflicting instance defined here"+  , fCode = Just (mkCode "tadka::E0043")+  , fCtx  = buildContext (rightOrErr (mkNamedSource "Prelude.hs" "instance Num String where ...\n"))+              [ (rightOrErr (mkSpan 0 8), label "conflicting instance") ]+  , fHelp = Nothing, fUrl = Nothing, fRel = [], fId = Nothing+  }++multi :: Fix+multi = Fix+  { fMsg  = "type mismatch"+  , fCode = Just (mkCode "tadka::E0042")+  , fCtx  = buildContextWith src2+              [ (rightOrErr (mkSpan (T.length "addOne :: ") 3), Secondary, label "expected because of this")+              , (rightOrErr (mkSpan (T.length "addOne :: Int -> Int\naddOne x = x\nresult = addOne ") 4),+                 Primary, label "found `String`, expected `Int`")+              ]+  , fHelp = Just "convert with `show` or change the annotation"+  , fUrl  = Nothing+  , fRel  = [SomeDiagnostic related43]+  , fId   = Nothing+  }++-- 3. Degraded (stale) label -------------------------------------------------+degraded :: Fix+degraded = Fix+  { fMsg  = "undefined variable `foo`"+  , fCode = Just (mkCode "tadka::E0001")+  , fCtx  = buildContext (rightOrErr (mkNamedSource "example.hs" "let x = 1\n"))+              [ (rightOrErr (mkSpan 100 3), label "not in scope") ]  -- out of bounds -> stale+  , fHelp = Just "did you mean `bar`?"+  , fUrl  = Nothing, fRel = [], fId = Nothing+  }++-- 4. Cycle-omitted related --------------------------------------------------+cyc :: Fix+cyc =+  let d = Fix+            { fMsg  = "conflicting instance defined here"+            , fCode = Just (mkCode "tadka::E0043")+            , fCtx  = buildContext (rightOrErr (mkNamedSource "Prelude.hs" "instance Num String where ...\n"))+                        [ (rightOrErr (mkSpan 0 8), label "conflicting instance") ]+            , fHelp = Nothing, fUrl = Nothing+            , fRel  = [SomeDiagnostic d]                 -- self-reference => cycle+            , fId   = Just (mkDiagnosticId "e0043")+            }+  in d++-- 5. Cross-file (Phase 12) -----------------------------------------------+-- Two sources, each contributing one label: the shape a real "this import+-- disagrees with that definition" diagnostic takes once a Context can span+-- more than one file. Exercises all three renderers via the shared fixture+-- lists below, same as 'single'/'withCause' already do.+srcModA :: NamedSource+srcModA = rightOrErr (mkNamedSource "ModuleA.hs" "import ModuleB (widget)\nmain = widget\n")++srcModB :: NamedSource+srcModB = rightOrErr (mkNamedSource "ModuleB.hs" "widget :: Int\nwidget = 42\n")++crossFile :: Fix+crossFile = Fix+  { fMsg  = "type mismatch across modules"+  , fCode = Just (mkCode "tadka::E0500")+  , fCtx  = buildContextMulti+              ( ( srcModA+                , [ (rightOrErr (mkSpan (T.length "import ModuleB (") 6), Secondary,+                     label "imported here")+                  ]+                )+              :| [ ( srcModB+                   , [ (rightOrErr (mkSpan 0 6), Primary, label "defined here as `Int`") ]+                   )+                 ]+              )+  , fHelp = Just "the two declarations must agree"+  , fUrl  = Nothing, fRel = [], fId = Nothing+  }++fixtures :: [(String, SomeDiagnostic)]+fixtures =+  [ ("single-label",  SomeDiagnostic single)+  , ("multi-label",   SomeDiagnostic multi)+  , ("degraded",      SomeDiagnostic degraded)+  , ("cycle-omitted", SomeDiagnostic cyc)+  , ("tab-indented",  SomeDiagnostic tabIndented)+  , ("with-cause",    SomeDiagnostic withCause)+  , ("multi-line",     SomeDiagnostic multiLine)+  , ("cross-file",     SomeDiagnostic crossFile)+  ]++-- Tab-indented source: the caret must align under the tab-EXPANDED position.+tabIndented :: Fix+tabIndented = Fix+  { fMsg  = "undefined variable `foo`"+  , fCode = Just (mkCode "tadka::E0001")+  , fCtx  = buildContext+              (rightOrErr (mkNamedSource "tab.hs" "func x =\n\t  return foo\n"))+              [ (rightOrErr (mkSpan (T.length "func x =\n\t  return ") 3), label "not in scope") ]+  , fHelp = Nothing, fUrl = Nothing, fRel = [], fId = Nothing+  }++-- Narratable fixtures ------------------------------------------------------+-- A related chain deeper than the depth limit the golden runner renders at,+-- so the prose truncation marker fires.+relB :: Fix+relB = Fix "second related problem" (Just (mkCode "pkg::E1002"))+           NoContext Nothing Nothing [] Nothing++relA :: Fix+relA = Fix "first related problem" (Just (mkCode "pkg::E1001"))+           NoContext Nothing Nothing [SomeDiagnostic relB] Nothing++truncatedRoot :: Fix+truncatedRoot = Fix+  { fMsg  = "top-level problem"+  , fCode = Just (mkCode "pkg::E1000")+  , fCtx  = buildContext src1+              [ (rightOrErr (mkSpan (T.length "line1\nline2\nlet x = ") 3), label "here") ]+  , fHelp = Just "see the related items"+  , fUrl  = Nothing+  , fRel  = [SomeDiagnostic relA]+  , fId   = Nothing+  }++narratableFixtures :: [(String, SomeDiagnostic)]+narratableFixtures =+  [ ("narr-single",    SomeDiagnostic single)+  , ("narr-truncated", SomeDiagnostic truncatedRoot)+  , ("narr-cause",     SomeDiagnostic withCause)+  , ("narr-cross-file", SomeDiagnostic crossFile)+  ]++-- JSON fixtures (rendered at depth limit 1 by the runner): single (matches the+-- vision example), cycle (cycleOmitted flag), truncated (nested truncated flag).+contextFixtures :: [(String, SomeDiagnostic)]+contextFixtures =+  [ ("context-elision", SomeDiagnostic farApart) ]++jsonFixtures :: [(String, SomeDiagnostic)]+jsonFixtures =+  [ ("json-single",    SomeDiagnostic single)+  , ("json-cycle",     SomeDiagnostic cyc)+  , ("json-truncated", SomeDiagnostic truncatedRoot)+  , ("json-cause",     SomeDiagnostic withCause)+  , ("json-cross-file", SomeDiagnostic crossFile)+  ]+++data ParseError = UnexpectedToken+  { errSource :: NamedSource+  , got       :: Text+  , expected  :: Text+  , at        :: Span+  }+  deriving (Show)++$(do+    decs <- deriveDiagnostic defaultSpec+              { specCode        = Just "tadka::E0001"+              , specHelp        = Just "did you forget a semicolon?"+              , specSourceField = Just 'errSource+              , specLabelFields = [('at, "unexpected token here")]+              }+              ''ParseError+    dump <- [d| generatedSource :: String+                generatedSource = $(litE (stringL (pprint decs))) |]+    pure (decs ++ dump))
+ test/golden/Main.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Golden test suite: renders each graphical fixture and compares byte-for-byte+-- against a committed expected file. Set GEN_GOLDEN=1 to (re)generate the+-- expected files instead of checking.+module Main (main) where++import qualified Data.Aeson                as A+import qualified Data.Aeson.Key            as K+import qualified Data.Aeson.KeyMap         as KM+import           Control.Monad             (forM, unless)+import           Data.Foldable             (toList)+import           Data.List                 (elemIndex, sortBy)+import           Data.Ord                  (comparing)+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.IO              as TIO+import qualified Data.Text.Lazy            as TL+import qualified Data.Text.Lazy.Encoding   as TLE+import           GHC.IO.Encoding           (setLocaleEncoding, utf8)+import           Prettyprinter             (LayoutOptions (..), PageWidth (Unbounded),+                                            layoutPretty)+import           Prettyprinter.Render.Text (renderStrict)+import           System.Environment        (lookupEnv)+import           System.Exit               (exitFailure)++import           Fixtures                  (contextFixtures, fixtures, generatedSource, jsonFixtures,+                                            narratableFixtures, single)+import           Tadka++cfg :: Config+cfg = withColorMode ColorNever+    . withUnicodeMode UnicodeAlways+    . withTarget TGraphical+    $ defaultConfig++renderFix :: SomeDiagnostic -> Text+cfgCtx :: Config+cfgCtx = withContextLines 1 cfg++renderCtx :: SomeDiagnostic -> Text+renderCtx (SomeDiagnostic e) = case selectRenderer cfgCtx of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++renderFix (SomeDiagnostic e) = case selectRenderer cfg of+  SomeRenderer r@(Graphical _) ->+    renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _ -> "<<not graphical>>"++-- Same as 'cfg' but with hyperlinks turned on, to pin the OSC 8 escape bytes+-- byte-for-byte (proves the wrap touches only the "= see:" line — everything+-- else must match "single-label" exactly).+hyperlinkCfg :: Config+hyperlinkCfg = withHyperlinkMode HyperlinkAlways cfg++renderHyperlink :: SomeDiagnostic -> Text+renderHyperlink (SomeDiagnostic e) = case selectRenderer hyperlinkCfg of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> "<<not graphical>>"++-- Narratable fixtures render at a low depth limit so the truncation marker fires.+narrCfg :: Config+narrCfg = withRelatedDepthLimit 1 (withTarget TNarratable defaultConfig)++renderNarr :: SomeDiagnostic -> Text+renderNarr (SomeDiagnostic e) = case selectRenderer narrCfg of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> "<<not narratable>>"++-- JSON fixtures render at depth 1 too, then serialize with a deterministic+-- ordered pretty-printer matching the vision's canonical layout.+jsonCfg :: Config+jsonCfg = withRelatedDepthLimit 1 (withTarget TJson defaultConfig)++renderJs :: SomeDiagnostic -> Text+renderJs (SomeDiagnostic e) = case selectRenderer jsonCfg of+  SomeRenderer r@(Json _) -> prettyJSON (render r e)+  _                       -> "<<not json>>"++-- Deterministic pretty-printer for an 'A.Value': object keys in the canonical+-- field order, all-scalar objects inline, empty arrays inline, 2-space indent.+prettyJSON :: A.Value -> Text+prettyJSON = go 0+  where+    prefOrder =+      [ "code","severity","message","labels","file","line","column","length","text"+      , "primary","stale","help","url","related","causes","truncated","cycleOmitted" ]+    go :: Int -> A.Value -> Text+    go ind v = case v of+      A.Object o -> renderObj ind o+      A.Array a  -> renderArr ind (toList a)+      _          -> TL.toStrict (TLE.decodeUtf8 (A.encode v))+    renderObj ind o+      | KM.null o  = "{}"+      | inlineable = "{ " <> T.intercalate ", " (map field pairs) <> " }"+      | otherwise  = "{\n" <> T.intercalate ",\n" (map (\p -> pad (ind + 1) <> field p) pairs)+                       <> "\n" <> pad ind <> "}"+      where+        pairs      = sortBy (comparing (rank . fst)) (KM.toList o)+        inlineable = all (isSimple . snd) pairs+        field (k, val) = "\"" <> K.toText k <> "\": " <> go (ind + 1) val+        rank k = maybe (1 :: Int, 0) (\i -> (0, i)) (elemIndex (K.toText k) prefOrder)+    renderArr _ []   = "[]"+    renderArr ind xs = "[\n" <> T.intercalate ",\n" (map (\x -> pad (ind + 1) <> go (ind + 1) x) xs)+                         <> "\n" <> pad ind <> "]"+    isSimple (A.Object o) = KM.null o+    isSimple (A.Array a)  = null (toList a)+    isSimple _            = True+    pad n = T.replicate (2 * n) " "++-- | Collapse GHC's base/ghc-internal module-qualification split so the+-- 'generatedSource' fixture (the only one containing TH-'pprint'd references+-- to base internals like @show@/@(.)@/@Just@) isn't tied to which GHC release+-- produced it. Pre-split GHC (9.4-9.8-ish) qualifies these as @GHC.Base@,+-- @GHC.Show@, @GHC.Maybe@; post-split GHC (9.10+) qualifies the same+-- identifiers as @GHC.Internal.Base@, @GHC.Internal.Show@,+-- @GHC.Internal.Maybe@ — and this is an ongoing, multi-release GHC-internal+-- migration (further reshuffling is expected at GHC 10.0), not a one-off+-- two-way difference. Collapsing @GHC.Internal.@ down to @GHC.@ normalizes+-- every release's spelling to one canonical form, so this fixture checks what+-- it's actually meant to check — that the derived method bodies are still+-- direct calls to the same functions — without re-pinning to base's internal+-- module layout every time GHC reorganizes it.+normalizeGhcInternal :: Text -> Text+normalizeGhcInternal = T.replace (T.pack "GHC.Internal.") (T.pack "GHC.")++-- (name, rendered output) across all three handlers.+allFixtures :: [(String, Text)]+allFixtures =+     [ (n, renderFix d)  | (n, d) <- fixtures ]+  ++ [ (n, renderNarr d) | (n, d) <- narratableFixtures ]+  ++ [ (n, renderJs d)   | (n, d) <- jsonFixtures ]+  ++ [ (n, renderCtx d) | (n, d) <- contextFixtures ]+  ++ [ ("generated-parseerror", normalizeGhcInternal (T.pack generatedSource)) ]+  ++ [ ("single-label-hyperlink", renderHyperlink (SomeDiagnostic single)) ]++fixturePath :: String -> FilePath+fixturePath name = "test/golden/fixtures/" <> name <> ".txt"++main :: IO ()+main = do+  setLocaleEncoding utf8+  mode <- lookupEnv "GEN_GOLDEN"+  case mode of+    Just _  -> do+      mapM_ (\(n, out) -> TIO.writeFile (fixturePath n) out) allFixtures+      putStrLn "[golden] regenerated fixtures"+    Nothing -> do+      results <- forM allFixtures $ \(n, actual) -> do+        expected <- TIO.readFile (fixturePath n)+        if actual == expected+          then putStrLn ("  ok  " <> n) >> pure True+          else do+            putStrLn ("  FAIL " <> n <> "\n--- expected ---\n" <> T.unpack expected+                        <> "\n--- actual ---\n" <> T.unpack actual)+            pure False+      unless (and results) exitFailure
+ test/golden/fixtures/context-elision.txt view
@@ -0,0 +1,11 @@+error[tadka::E0200]: two distant problems+  ┌─ big.hs:6:1+  │+1 │ one aaa+  │     -- first+2 │ two bbb+  ⋮+5 │ five ee+6 │ six fff+  │ ^^^^ second+7 │ seven g
+ test/golden/fixtures/cross-file.txt view
@@ -0,0 +1,12 @@+error[tadka::E0500]: type mismatch across modules+  ┌─ ModuleA.hs:1:17+  │+1 │ import ModuleB (widget)+  │                 ------ imported here+  │+  ┌─ ModuleB.hs:1:1+  │+1 │ widget :: Int+  │ ^^^^^^ defined here as `Int`+  │+  = help: the two declarations must agree
+ test/golden/fixtures/cycle-omitted.txt view
@@ -0,0 +1,7 @@+error[tadka::E0043]: conflicting instance defined here+  ┌─ Prelude.hs:1:1+  │+1 │ instance Num String where ...+  │ ^^^^^^^^ conflicting instance+  │+  = related: (cycle omitted)
+ test/golden/fixtures/degraded.txt view
@@ -0,0 +1,6 @@+error[tadka::E0001]: undefined variable `foo`+  ┌─ example.hs+  │+  │ (span unavailable — source no longer matches at this position)+  │+  = help: did you mean `bar`?
+ test/golden/fixtures/generated-parseerror.txt view
@@ -0,0 +1,7 @@+instance Tadka.Internal.Diagnostic.Diagnostic Fixtures.ParseError+    where {Tadka.Internal.Diagnostic.message = Prettyprinter.Internal.pretty GHC.Base.. GHC.Show.show;+           Tadka.Internal.Diagnostic.code _ = GHC.Maybe.Just (Tadka.Internal.Types.unsafeDiagnosticCode (Data.Text.Internal.pack "tadka::E0001"));+           Tadka.Internal.Diagnostic.severity _ = Tadka.Internal.Types.SevError;+           Tadka.Internal.Diagnostic.help _ = GHC.Maybe.Just (Prettyprinter.Internal.pretty (Data.Text.Internal.pack "did you forget a semicolon?"));+           Tadka.Internal.Diagnostic.context e_0 = Tadka.Internal.Context.buildContext (Fixtures.errSource e_0) [(Fixtures.at e_0,+                                                                                                                  GHC.Maybe.Just (Prettyprinter.Internal.pretty (Data.Text.Internal.pack "unexpected token here")))]}
+ test/golden/fixtures/json-cause.txt view
@@ -0,0 +1,14 @@+{+  "code": "tadka::E0100",+  "severity": "error",+  "message": "failed to compile `Main`",+  "labels": [],+  "help": null,+  "url": null,+  "related": [],+  "causes": [+    { "code": "tadka::E0042", "message": "type mismatch in `foo`" }+  ],+  "truncated": false,+  "cycleOmitted": false+}
+ test/golden/fixtures/json-cross-file.txt view
@@ -0,0 +1,15 @@+{+  "code": "tadka::E0500",+  "severity": "error",+  "message": "type mismatch across modules",+  "labels": [+    { "file": "ModuleA.hs", "line": 1, "column": 17, "length": 6, "text": "imported here", "primary": false, "stale": false },+    { "file": "ModuleB.hs", "line": 1, "column": 1, "length": 6, "text": "defined here as `Int`", "primary": true, "stale": false }+  ],+  "help": "the two declarations must agree",+  "url": null,+  "related": [],+  "causes": [],+  "truncated": false,+  "cycleOmitted": false+}
+ test/golden/fixtures/json-cycle.txt view
@@ -0,0 +1,14 @@+{+  "code": "tadka::E0043",+  "severity": "error",+  "message": "conflicting instance defined here",+  "labels": [+    { "file": "Prelude.hs", "line": 1, "column": 1, "length": 8, "text": "conflicting instance", "primary": true, "stale": false }+  ],+  "help": null,+  "url": null,+  "related": [],+  "causes": [],+  "truncated": false,+  "cycleOmitted": true+}
+ test/golden/fixtures/json-single.txt view
@@ -0,0 +1,14 @@+{+  "code": "tadka::E0001",+  "severity": "error",+  "message": "undefined variable `foo`",+  "labels": [+    { "file": "example.hs", "line": 3, "column": 9, "length": 3, "text": "not in scope", "primary": true, "stale": false }+  ],+  "help": "did you mean `bar`?",+  "url": "https://example.org/errors/E0001",+  "related": [],+  "causes": [],+  "truncated": false,+  "cycleOmitted": false+}
+ test/golden/fixtures/json-truncated.txt view
@@ -0,0 +1,16 @@+{+  "code": "pkg::E1000",+  "severity": "error",+  "message": "top-level problem",+  "labels": [+    { "file": "example.hs", "line": 3, "column": 9, "length": 3, "text": "here", "primary": true, "stale": false }+  ],+  "help": "see the related items",+  "url": null,+  "related": [+    { "code": "pkg::E1001", "severity": "error", "message": "first related problem", "labels": [], "help": null, "url": null, "related": [], "causes": [], "truncated": true, "cycleOmitted": false }+  ],+  "causes": [],+  "truncated": false,+  "cycleOmitted": false+}
+ test/golden/fixtures/multi-label.txt view
@@ -0,0 +1,15 @@+error[tadka::E0042]: type mismatch+  ┌─ example.hs:3:17+  │+1 │ addOne :: Int -> Int+  │           --- expected because of this+2 │ addOne x = x+3 │ result = addOne "hi"+  │                 ^^^^ found `String`, expected `Int`+  │+  = help: convert with `show` or change the annotation+  = related: tadka::E0043 — conflicting instance defined here+    ┌─ Prelude.hs:1:1+    │+  1 │ instance Num String where ...+    │ ^^^^^^^^ conflicting instance
+ test/golden/fixtures/multi-line.txt view
@@ -0,0 +1,8 @@+error[tadka::E0300]: unterminated function call+  ┌─ call.hs:1:9+  │+1 │ ╭ let x = foo(+2 │ │     bar,+3 │ ╰     baz)  opened here, never closed+  │+  = help: add a closing `)`
+ test/golden/fixtures/narr-cause.txt view
@@ -0,0 +1,2 @@+Error, code tadka::E0100: failed to compile `Main`.+Caused by: tadka::E0042 — type mismatch in `foo`.
+ test/golden/fixtures/narr-cross-file.txt view
@@ -0,0 +1,8 @@+Error, code tadka::E0500: type mismatch across modules.+Location: ModuleA.hs, line 1, column 17.+Source line 1: "import ModuleB (widget)".+Related context is at columns 17 through 22, labeled: imported here.+Location: ModuleB.hs, line 1, column 1.+Source line 1: "widget :: Int".+The problem is at columns 1 through 6, labeled: defined here as `Int`.+Help: the two declarations must agree
+ test/golden/fixtures/narr-single.txt view
@@ -0,0 +1,6 @@+Error, code tadka::E0001: undefined variable `foo`.+Location: example.hs, line 3, column 9.+Source line 3: "let x = foo + 1".+The problem is at columns 9 through 11, labeled: not in scope.+Help: did you mean `bar`?+More information: https://example.org/errors/E0001
+ test/golden/fixtures/narr-truncated.txt view
@@ -0,0 +1,7 @@+Error, code pkg::E1000: top-level problem.+Location: example.hs, line 3, column 9.+Source line 3: "let x = foo + 1".+The problem is at columns 9 through 11, labeled: here.+Help: see the related items+Related: pkg::E1001 — first related problem.+1 more related diagnostic was omitted at the depth limit.
+ test/golden/fixtures/single-label-hyperlink.txt view
@@ -0,0 +1,8 @@+error[tadka::E0001]: undefined variable `foo`+  ┌─ example.hs:3:9+  │+3 │ let x = foo + 1+  │         ^^^ not in scope+  │+  = help: did you mean `bar`?+  = see: ]8;;https://example.org/errors/E0001\https://example.org/errors/E0001]8;;\
+ test/golden/fixtures/single-label.txt view
@@ -0,0 +1,8 @@+error[tadka::E0001]: undefined variable `foo`+  ┌─ example.hs:3:9+  │+3 │ let x = foo + 1+  │         ^^^ not in scope+  │+  = help: did you mean `bar`?+  = see: https://example.org/errors/E0001
+ test/golden/fixtures/tab-indented.txt view
@@ -0,0 +1,5 @@+error[tadka::E0001]: undefined variable `foo`+  ┌─ tab.hs:2:11+  │+2 │       return foo+  │              ^^^ not in scope
+ test/golden/fixtures/with-cause.txt view
@@ -0,0 +1,3 @@+error[tadka::E0100]: failed to compile `Main`+  = caused by: tadka::E0042 — type mismatch in `foo`+  = caused by: unbound variable `x`
+ test/interop/Main.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Round-trip interop tests: for each supported library, construct a known+-- failure position, convert it, resolve against the same source, and confirm+-- the line/column matches what the library itself reports (attoparsec, which+-- reports no line/column, is checked on consumed-offset instead).+module Main (main) where++import           Control.Monad             (unless)+import           Data.Text                 (Text)+import           Data.Void                 (Void)+import           System.Exit               (exitFailure)++import qualified Data.Attoparsec.Text      as A+import qualified GHC.Data.Strict            as Strict+import           GHC.Data.FastString        (fsLit)+import           GHC.Types.SrcLoc          (SrcSpan (..), mkRealSrcLoc, mkRealSrcSpan,+                                            srcSpanEndCol, srcSpanEndLine, srcSpanStartCol,+                                            srcSpanStartLine)+import qualified Data.List.NonEmpty         as NE+import           Text.Megaparsec           (Parsec, attachSourcePos, bundleErrors,+                                            bundlePosState, runParser)+import           Text.Megaparsec.Char      (char, string)+import           Text.Megaparsec.Error     (errorOffset)+import           Text.Megaparsec.Pos       (sourceColumn, sourceLine, unPos)++import           Tadka+import           Tadka.Interop.Attoparsec  (consumedOffset)+import           Tadka.Interop.GHC         (SrcSpanConvError (..), spanFromSrcSpan)+import           Tadka.Interop.Megaparsec  (spanFromError)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++resolveAt :: NamedSource -> Span -> (Int, Int)+resolveAt ns sp =+  let rs = rightOrErr (resolveSpan ns sp)+      lc = resolvedStart rs+  in (lcLine lc, lcColumn lc)++-- === GHC ===================================================================+ghcCheck :: (String, Bool)+ghcCheck =+  let src = "aaaa\nbbbbbb\ncccc\n"+      ns  = rightOrErr (mkNamedSource "f.hs" src)+      rss = mkRealSrcSpan (mkRealSrcLoc (fsLit "f.hs") 2 3) (mkRealSrcLoc (fsLit "f.hs") 2 6)+      ss  = RealSrcSpan rss Strict.Nothing+      sp  = rightOrErr (spanFromSrcSpan src ss)+      mine = resolveAt ns sp+      ghc  = (srcSpanStartLine rss, srcSpanStartCol rss)+  in ("ghc SrcSpan line/col round-trips", mine == ghc && mine == (2, 3))++-- A span whose start resolves but whose end is out of bounds must name the+-- END position in the error, not fall back to reporting the start.+ghcEndAttributionCheck :: (String, Bool)+ghcEndAttributionCheck =+  let src = "aaaa\nbbbbbb\ncccc\n"+      rss = mkRealSrcSpan (mkRealSrcLoc (fsLit "f.hs") 2 3) (mkRealSrcLoc (fsLit "f.hs") 99 1)+      ss  = RealSrcSpan rss Strict.Nothing+  in ( "ghc SrcSpan out-of-bounds end is attributed to the end, not the start"+     , spanFromSrcSpan src ss == Left (LineColOutOfBounds (srcSpanEndLine rss) (srcSpanEndCol rss))+     )++-- === megaparsec ============================================================+type P = Parsec Void Text++megaCheck :: (String, Bool)+megaCheck =+  let src   = "abc\ndef"+      ns    = rightOrErr (mkNamedSource "f.hs" src)+      p     = string "abc" *> char '\n' *> string "xyz" :: P Text+  in case runParser p "f.hs" src of+       Right _     -> ("megaparsec offset line/col round-trips", False)+       Left bundle ->+         let err        = NE.head (bundleErrors bundle)+             (withPos,_) = attachSourcePos errorOffset (bundleErrors bundle) (bundlePosState bundle)+             sp'         = snd (NE.head withPos)+             mega        = (unPos (sourceLine sp'), unPos (sourceColumn sp'))+             sp          = rightOrErr (spanFromError 0 err)+             mine        = resolveAt ns sp+         in ("megaparsec offset line/col round-trips", mine == mega && mine == (2, 1))++-- === attoparsec ============================================================+attoCheck :: (String, Bool)+attoCheck =+  let src = "hello\nworld"+      ns  = rightOrErr (mkNamedSource "f.hs" src)+      p   = A.string "hello" *> A.char '\n' *> A.string "xxx"+      res = A.feed (A.parse p src) ""+  in case res of+       A.Fail remaining _ _ ->+         let off  = consumedOffset src remaining+             sp   = rightOrErr (mkSpan off 0)+             mine = resolveAt ns sp+         in ("attoparsec consumed offset resolves", off == 6 && mine == (2, 1))+       _ -> ("attoparsec consumed offset resolves", False)++main :: IO ()+main = do+  let checks = [ghcCheck, ghcEndAttributionCheck, megaCheck, attoCheck]+  results <- mapM report checks+  unless (and results) exitFailure+  where+    report (name, ok) = do+      putStrLn ((if ok then "  ok   " else "  FAIL ") <> name)+      pure ok
+ test/props/Cause.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Cause chain (post-v1 hardening): the "caused by" chain is depth- and+-- cycle-safe exactly like @related@. A cause that loops back by 'diagnosticId'+-- is cut (its marker renders at most once); an id-less loop is bounded by the+-- depth budget. Generated cause chains are additionally covered by the+-- render-totality property in the Phase 11 group (genGD now emits causes).+module Cause (group) where++import           Control.Exception          (SomeException, evaluate, try)+import           Control.Monad.IO.Class      (liftIO)+import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen               as Gen++import           GenDiag                    (GD (..), selfCauseJust, selfCauseNothing)+import           Tadka+import           Tadka.Internal             (buildContext)++renderT :: Diagnostic e => Target -> e -> Text+renderT tgt e =+  case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget tgt defaultConfig))) of+    SomeRenderer r@(Graphical _)  -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+    SomeRenderer r@(Narratable _) -> render r e+    SomeRenderer r@(Json _)       -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))++prop_cyclicTerminates :: Property+prop_cyclicTerminates = property $ do+  tgt <- forAll (Gen.element [TGraphical, TNarratable, TJson])+  d   <- forAllWith (const "<self-causing>") (Gen.element [selfCauseJust, selfCauseNothing])+  res <- liftIO (try (evaluate (T.length (renderT tgt d))) :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure++marker :: Text+marker = "ZZCAUSEZZ"++-- A node whose cause is itself, sharing one diagnosticId: cycle detection cuts+-- the chain, so the marker (in its message) renders once.+idCyclic :: GD+idCyclic =+  let d = GD ("boom " <> marker) Nothing NoContext Nothing Nothing []+             (Just (mkDiagnosticId "self")) (Just (SomeDiagnostic d))+  in d++prop_markerAtMostOnce :: Property+prop_markerAtMostOnce = withTests 1 . property $+  mapM_ (\tgt -> assert (T.count marker (renderT tgt idCyclic) <= 1))+        [TGraphical, TNarratable, TJson]++-- Root with a distinct-id cause: a "caused by" line must appear.+leaf :: GD+leaf = GD "root cause here" Nothing NoContext Nothing Nothing [] (Just (mkDiagnosticId "leaf")) Nothing++rooted :: GD+rooted = GD "top failure" Nothing NoContext Nothing Nothing [] (Just (mkDiagnosticId "root"))+            (Just (SomeDiagnostic leaf))++prop_causedByAppears :: Property+prop_causedByAppears = withTests 1 . property $ do+  assert ("caused by" `T.isInfixOf` renderT TGraphical rooted)+  assert ("Caused by" `T.isInfixOf` renderT TNarratable rooted)++-- A *related* diagnostic with its own, distinct cause: the cause must render+-- wherever the related diagnostic itself renders, not only at the root. Each+-- renderer's related-child path is expected to call the exact same+-- cause-rendering function the root does (Graphical: 'causeLinesFor';+-- Narratable: 'causeSentences'; Json: 'toDTO's own recursive 'dtoCauses'),+-- so this exercises that shared path one level down instead of at the root.+relatedLeafCause :: GD+relatedLeafCause = GD ("relative's own root cause " <> marker) Nothing NoContext Nothing Nothing []+                      (Just (mkDiagnosticId "relatedLeafCause")) Nothing++relatedWithOwnCause :: GD+relatedWithOwnCause = GD "a related diagnostic" Nothing NoContext Nothing Nothing []+                         (Just (mkDiagnosticId "relatedWithOwnCause")) (Just (SomeDiagnostic relatedLeafCause))++rootWithRelatedCause :: GD+rootWithRelatedCause = GD "top-level failure" Nothing NoContext Nothing Nothing+                           [SomeDiagnostic relatedWithOwnCause]+                           (Just (mkDiagnosticId "rootWithRelatedCause")) Nothing++prop_causedByAppearsForRelated :: Property+prop_causedByAppearsForRelated = withTests 1 . property $+  mapM_ (\tgt -> assert (marker `T.isInfixOf` renderT tgt rootWithRelatedCause))+        [TGraphical, TNarratable, TJson]++-- === specCause: derive == manual ==========================================++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++srcC :: NamedSource+srcC = rightOrErr (mkNamedSource "f.hs" "let a = bb")++data DErr3 = DErr3 { d3src :: NamedSource, d3prim :: Span, d3cause :: Maybe SomeDiagnostic }++deriveDiagnostic defaultSpec+  { specSourceField = Just 'd3src, specLabelFields = [('d3prim, "here")]+  , specCause = Just 'd3cause, specMessage = Just [| \_ -> "boom" |] }+  ''DErr3++data MErr3 = MErr3 { m3src :: NamedSource, m3prim :: Span, m3cause :: Maybe SomeDiagnostic }++instance Diagnostic MErr3 where+  message _ = "boom"+  context e = buildContext (m3src e) [ (m3prim e, Just "here") ]+  diagnosticCause e = m3cause e++dCauseVal, dNoCauseVal :: DErr3+dCauseVal   = DErr3 srcC (rightOrErr (mkSpan 4 1)) (Just (SomeDiagnostic leaf))+dNoCauseVal = DErr3 srcC (rightOrErr (mkSpan 4 1)) Nothing++mCauseVal, mNoCauseVal :: MErr3+mCauseVal   = MErr3 srcC (rightOrErr (mkSpan 4 1)) (Just (SomeDiagnostic leaf))+mNoCauseVal = MErr3 srcC (rightOrErr (mkSpan 4 1)) Nothing++prop_deriveCauseEqualsManual :: Property+prop_deriveCauseEqualsManual = withTests 1 . property $+  mapM_ (\tgt -> do+            renderT tgt dCauseVal   === renderT tgt mCauseVal+            renderT tgt dNoCauseVal === renderT tgt mNoCauseVal)+        [TGraphical, TNarratable, TJson]++group :: Group+group = Group "Cause chain"+  [ ("cyclic cause chains render (every target)", prop_cyclicTerminates)+  , ("id-cyclic cause marker renders at most once", prop_markerAtMostOnce)+  , ("a cause chain renders a 'caused by' line",  prop_causedByAppears)+  , ("a related diagnostic's own cause also renders, not just the root's", prop_causedByAppearsForRelated)+  , ("derived specCause == manual diagnosticCause, all handlers", prop_deriveCauseEqualsManual)+  ]
+ test/props/EdgeCases.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Production edge cases mined from miette's bug-fix history (learning from+-- their scars so tadka is robust at release). Each property names the miette+-- issue it mirrors. "No crash" is enforced by forcing the rendered length+-- inside 'try'; the rest assert structural expectations.+module EdgeCases (group) where++import           Control.Exception          (SomeException, evaluate, try)+import           Control.Monad.IO.Class      (liftIO)+import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import           Data.Char                  (isControl)+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           Tadka+import           Tadka.Internal             (buildContext)++group :: Group+group = Group "Production edge cases (from miette)"+  [ ("zero-length span renders a point (miette #204/#159/#32)", prop_zeroLen)+  , ("zero-length span at end of line (miette #204)",           prop_zeroLenEol)+  , ("span past end of line does not crash (miette #221)",      prop_pastEol)+  , ("span past EOF is stale, not a crash (miette #347)",       prop_pastEof)+  , ("empty source does not crash (miette #183)",               prop_emptySource)+  , ("label at offset 0 (miette 2.1.0)",                        prop_offsetZero)+  , ("CRLF line endings leave no stray CR (miette #37)",        prop_crlf)+  , ("wide chars + tabs do not crash (miette #202)",            prop_wideTab)+  , ("combining marks do not crash (miette #312/#314)",         prop_combining)+  , ("nested / overlapping spans both render (miette #316)",    prop_nested)+  , ("newline inside a label does not corrupt layout (#318)",   prop_newlineLabel)+  , ("multi-line span shows every intermediate line (#81)",     prop_noSkip)+  , ("totality over out-of-range spans (all targets)",          prop_totality)+  , ("no terminal-escape injection from source/labels (VULN #1)", prop_noInjection)+  , ("output is bounded for a huge multi-line span (VULN #2)",    prop_bounded)+  ]++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Build + graphically render a single-label diagnostic from a source and a span.+data Ed = Ed Context+instance Diagnostic Ed where+  message _      = "edge"+  context (Ed c) = c++ctxOf :: Text -> Int -> Int -> Text -> Context+ctxOf srcTxt off len lbl =+  buildContext (rightOrErr (mkNamedSource "e.hs" srcTxt))+               [ (rightOrErr (mkSpan off len), Just (pretty lbl)) ]++gfx :: Context -> Text+gfx c = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r (Ed c)))+  _                            -> ""++renderAll :: Context -> [Text]+renderAll c =+  [ gfx c+  , case selectRenderer (withTarget TNarratable defaultConfig) of+      SomeRenderer r@(Narratable _) -> render r (Ed c); _ -> ""+  , case selectRenderer (withTarget TJson defaultConfig) of+      SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r (Ed c)))); _ -> ""+  ]++noCrash :: [Text] -> PropertyT IO ()+noCrash outs = do+  res <- liftIO (try (evaluate (sum (map T.length outs))) :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure++-- === the cases ============================================================++prop_zeroLen :: Property+prop_zeroLen = withTests 1 . property $ do+  let out = gfx (ctxOf "abcdef" 2 0 "here")+  noCrash [out]+  assert ("^" `T.isInfixOf` out)              -- a point still gets a caret++prop_zeroLenEol :: Property+prop_zeroLenEol = withTests 1 . property $+  noCrash (renderAll (ctxOf "abc\ndef" 3 0 "eol"))    -- offset 3 = the newline++prop_pastEol :: Property+prop_pastEol = withTests 1 . property $+  noCrash (renderAll (ctxOf "abc\ndef" 1 10 "long"))  -- length runs past the line++prop_pastEof :: Property+prop_pastEof = withTests 1 . property $ do+  let out = gfx (ctxOf "abc" 100 3 "gone")            -- entirely out of bounds+  noCrash [out]+  assert ("unavailable" `T.isInfixOf` out)            -- stale reason surfaces++prop_emptySource :: Property+prop_emptySource = withTests 1 . property $+  noCrash (renderAll (ctxOf "" 0 0 "empty"))++prop_offsetZero :: Property+prop_offsetZero = withTests 1 . property $ do+  let out = gfx (ctxOf "abcdef" 0 3 "start")+  noCrash [out]+  assert ("e.hs:1:1" `T.isInfixOf` out)               -- points at column 1++prop_crlf :: Property+prop_crlf = withTests 1 . property $ do+  -- 'def' is on line 2; offset of 'd' = len "abc\r\n" = 5+  let out = gfx (ctxOf "abc\r\ndef\r\nghi" 5 3 "on line two")+  noCrash [out]+  assert (not ('\r' `T.elem` out))                    -- no stray carriage returns+  assert ("e.hs:2:1" `T.isInfixOf` out)               -- correct line/col++prop_wideTab :: Property+prop_wideTab = withTests 1 . property $+  noCrash [gfx (ctxOf "\t\x4E2D\x6587 x = 1" 4 1 "wide+tab")]   -- tab + CJK before span++prop_combining :: Property+prop_combining = withTests 1 . property $+  noCrash [gfx (ctxOf "e\x0301clair = 1" 0 7 "accented")]        -- combining acute++prop_nested :: Property+prop_nested = withTests 1 . property $ do+  let c = buildContext (rightOrErr (mkNamedSource "e.hs" "abcdefgh"))+            [ (rightOrErr (mkSpan 1 6), Just "outer")+            , (rightOrErr (mkSpan 2 2), Just "inner") ]+      out = gfx c+  noCrash [out]+  assert ("outer" `T.isInfixOf` out && "inner" `T.isInfixOf` out)++prop_newlineLabel :: Property+prop_newlineLabel = withTests 1 . property $ do+  let out = gfx (ctxOf "abcdef" 1 3 "line one\nline two")+  noCrash [out]+  -- the caret rail must not be broken: every non-empty output line after the+  -- header should still start with a gutter/rail column, i.e. the injected+  -- newline must not produce a bare "line two" with no rail.+  assert (not (any (== "line two") (T.lines out)))++prop_noSkip :: Property+prop_noSkip = withTests 1 . property $ do+  -- multi-line span lines 1..4 in a 5-line source; all four must appear+  let src5 = "L1xxx\nL2xxx\nL3xxx\nL4xxx\nL5xxx"+      out  = gfx (ctxOf src5 0 22 "spans four lines")   -- offset 0..21 -> line 1..4+  noCrash [out]+  assert (all (\n -> n `T.isInfixOf` out) ["L1xxx", "L2xxx", "L3xxx", "L4xxx"])++prop_totality :: Property+prop_totality = property $ do+  off <- forAll (Gen.int (Range.linear 0 40))+  len <- forAll (Gen.int (Range.linear 0 40))+  let c = buildContext (rightOrErr (mkNamedSource "e.hs" "abc\ndef\nghi"))+            [ (rightOrErr (mkSpan off len), Just "x") | off + len <= 200 ]+  noCrash (renderAll c)++-- Text mixing printable and control characters (ESC, C0, C1, DEL).+genCtrlText :: Gen Text+genCtrlText = Gen.text (Range.linear 0 24) $ Gen.frequency+  [ (6, Gen.enum ' ' '~')+  , (2, Gen.enum '\x00' '\x1F')   -- C0 controls (incl ESC, BEL, BS)+  , (1, pure '\x7F')               -- DEL+  , (1, Gen.enum '\x80' '\x9F')   -- C1 controls+  ]++-- VULN #1: no raw control character (other than the '\n' line separator) may+-- appear in the terminal-facing output, no matter what the source or label+-- contains.+prop_noInjection :: Property+prop_noInjection = property $ do+  srcTxt <- forAll genCtrlText+  lbl    <- forAll genCtrlText+  off    <- forAll (Gen.int (Range.linear 0 (max 0 (T.length srcTxt))))+  let c    = buildContext (rightOrErr (mkNamedSource "s.hs" srcTxt))+                          [ (rightOrErr (mkSpan off 1), Just (pretty lbl)) ]+      bad t = [ ch | ch <- T.unpack t, isControl ch, ch /= '\n' ]+  mapM_ (\out -> bad out === []) (renderAll c)++-- VULN #2: a span across a huge line range must not render output proportional+-- to the span (default config falls back to a bounded context window).+prop_bounded :: Property+prop_bounded = withTests 1 . property $ do+  let big = T.intercalate (T.singleton '\n') (replicate 10000 "x")+      c   = buildContext (rightOrErr (mkNamedSource "s.hs" big))+                         [ (rightOrErr (mkSpan 0 (10000 * 2 - 3)), Just "huge") ]+  assert (length (T.lines (gfx c)) < 40)
+ test/props/GenDiag.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shared Hedgehog generators for arbitrary diagnostics, used by the Phase 5+-- and Phase 6 totality smoke checks so both exercise the same fuel-bounded set.+module GenDiag+  ( GD (..)+  , genGD+  , selfNothing+  , selfJust+  , selfCauseJust+  , selfCauseNothing+  , genScalar+  , genLine+  ) where++import           Data.Text      (Text)+import qualified Data.Text      as T+import           Prettyprinter  (Doc, pretty)++import           Hedgehog       (Gen)+import qualified Hedgehog.Gen   as Gen+import qualified Hedgehog.Range as Range++import           Tadka+import           Tadka.Internal (buildContext)++-- | A generated diagnostic carrier (no 'Show'; use @forAllWith@).+data GD = GD+  { gdMsg  :: Text+  , gdCode :: Maybe DiagnosticCode+  , gdCtx  :: Context+  , gdHelp :: Maybe Text+  , gdUrl  :: Maybe Url+  , gdRel  :: [SomeDiagnostic]+  , gdId   :: Maybe DiagnosticId+  , gdCause :: Maybe SomeDiagnostic+  }++instance Diagnostic GD where+  message      = pretty . gdMsg+  code         = gdCode+  context      = gdCtx+  help         = fmap pretty . gdHelp+  url          = gdUrl+  related      = gdRel+  diagnosticId = gdId+  diagnosticCause = gdCause++-- Scalars spanning ASCII, combining marks, wide CJK, and emoji.+genScalar :: Gen Char+genScalar = Gen.frequency+  [ (6, Gen.filterT (/= '\n') (Gen.enum ' ' '~'))+  , (2, Gen.enum '\x0300' '\x036F')    -- combining marks (width 0)+  , (2, Gen.enum '\x4E00' '\x4E30')    -- CJK (width 2)+  , (1, Gen.enum '\x1F600' '\x1F610')  -- emoji (width 2)+  ]++genLine :: Gen Text+genLine = Gen.text (Range.linear 0 30) genScalar++genCode :: Gen DiagnosticCode+genCode = Gen.element (map mk ["tadka::E0001", "pkg::E4242", "z9::E00000"])+  where mk t = either (error "bad code") id (mkDiagnosticCode t)++genCtx :: Gen Context+genCtx = do+  txt <- Gen.text (Range.linear 0 40) genScalar+  k   <- Gen.int (Range.linear 0 3)+  ls  <- Gen.list (Range.singleton k) (genSpanLabel (T.length txt))+  pure $ case (ls, mkNamedSource "gen.hs" (if T.null txt then "x" else txt)) of+    ([], _)        -> NoContext+    (_, Right src) -> buildContext src ls+    (_, Left _)    -> NoContext++genSpanLabel :: Int -> Gen (Span, Maybe (Doc Ann))+genSpanLabel maxOff = do+  off <- Gen.int (Range.linear 0 (maxOff + 20))  -- may exceed source => stale label+  len <- Gen.int (Range.linear 0 6)+  lbl <- Gen.maybe (pretty <$> Gen.text (Range.linear 1 10) genScalar)+  pure (either (error "bad span") id (mkSpan off len), lbl)++genGD :: Int -> Gen GD+genGD fuel = do+  msg   <- Gen.text (Range.linear 0 20) genScalar+  mcode <- Gen.maybe genCode+  ctx   <- genCtx+  mhelp <- Gen.maybe (Gen.text (Range.linear 1 15) genScalar)+  rel   <- if fuel <= 0+             then pure []+             else Gen.list (Range.linear 0 2) (SomeDiagnostic <$> genGD (fuel - 1))+  mid   <- Gen.maybe (mkDiagnosticId <$> Gen.text (Range.linear 1 6) (Gen.enum 'a' 'z'))+  mcause <- if fuel <= 0+              then pure Nothing+              else Gen.maybe (SomeDiagnostic <$> genGD (fuel - 1))+  pure (GD msg mcode ctx mhelp Nothing rel mid mcause)++-- Self-referential related chains: one detected by id (cycle), one relying on+-- the depth budget (Nothing id).+selfNothing, selfJust :: GD+selfNothing = let d = GD "loops (no id)" Nothing NoContext Nothing Nothing [SomeDiagnostic d] Nothing Nothing in d+selfJust    = let d = GD "loops (id)"    Nothing NoContext Nothing Nothing [SomeDiagnostic d]+                        (Just (mkDiagnosticId "loop")) Nothing in d++-- Self-referential CAUSE chains: one detected by id (cycle), one relying on the+-- depth budget (Nothing id).+selfCauseJust, selfCauseNothing :: GD+selfCauseJust    = let d = GD "cause loops (id)" Nothing NoContext Nothing Nothing []+                            (Just (mkDiagnosticId "cloop")) (Just (SomeDiagnostic d)) in d+selfCauseNothing = let d = GD "cause loops (no id)" Nothing NoContext Nothing Nothing []+                            Nothing (Just (SomeDiagnostic d)) in d
+ test/props/Hyperlink.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | OSC 8 hyperlinks (post-v1 hardening item 1). The resolver proofs pin+-- exactly how 'HyperlinkAuto' becomes concrete, one-for-one with+-- "TermColor"'s colour proofs; the render proofs pin that wrapping touches+-- only the @= see:@ URL and nothing else — so a diagnostic with no URL is+-- byte-identical whether hyperlinks are on or off, and 'HyperlinkNever'+-- output is always the escape-free baseline regardless of what the message,+-- help text, or URL contain.+--+-- Deliberately independent of "GenDiag"/"Fixtures": a small dedicated carrier+-- and generator here keep this module's coverage from being perturbed by an+-- unrelated change to generators several other suites also depend on.+module Hyperlink (group) where++import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Prettyprinter               (pretty)+import           Prettyprinter.Render.Text  (renderStrict)+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty)++import           Hedgehog                   (Group (..), Gen, Property, forAll, property,+                                             withTests, (===), assert)+import qualified Hedgehog.Gen                as Gen+import qualified Hedgehog.Range              as Range++import           Tadka+import           Tadka.Internal.Config       (configHyperlinkMode)+import           Tadka.Internal.Terminal     (TerminalCaps (..), resolveConfig, resolveHyperlink)++group :: Group+group = Group "OSC 8 hyperlinks"+  [ ("explicit hyperlink modes pass through",                prop_explicitPassthrough)+  , ("auto hyperlink: NO_HYPERLINK always wins",             prop_noHyperlinkWins)+  , ("auto hyperlink: force beats tty",                      prop_forceHyperlink)+  , ("auto hyperlink: else follows tty",                     prop_ttyHyperlink)+  , ("resolveConfig eliminates HyperlinkAuto",               prop_noAutoAfter)+  , ("resolveConfig is idempotent on hyperlink mode",        prop_idempotentHyperlink)+  , ("HyperlinkNever never emits an escape",                 prop_neverNoEsc)+  , ("HyperlinkAlways wraps a present URL in OSC 8",         prop_alwaysWrapsUrl)+  , ("no URL: Always and Never render identically",         prop_noUrlNoDifference)+  , ("the wrap adds only the OSC 8 escape, nothing else",    prop_structureInvariant)+  , ("unresolved Auto behaves like Always (mirrors colour)", prop_autoUnresolvedWraps)+  , ("a raw ESC in the message is neutralised, not leaked",  prop_messageEscNeverLeaks)+  ]++-- === generators ============================================================++genCaps :: Gen TerminalCaps+genCaps = TerminalCaps <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool++genHyperlinkMode :: Gen HyperlinkMode+genHyperlinkMode = Gen.element [HyperlinkAuto, HyperlinkAlways, HyperlinkNever]++-- A representative sample of the absolute URIs 'mkUrl' accepts: ordinary+-- https, an IPv6 host, a non-http scheme, userinfo + port + path params,+-- percent-encoding, a bare query string, and the shortest legal form (a+-- scheme with an opaque, non-hierarchical part). Verified individually+-- against 'mkUrl' while writing this module; kept as a fixed set (rather than+-- a from-scratch URI generator) so every case here is independently known+-- valid.+genUrlText :: Gen Text+genUrlText = Gen.element+  [ "https://example.org/errors/E0001"+  , "https://[::1]:8080/path"+  , "mailto:foo@example.com"+  , "a:b"+  , "https://example.com/a%20b"+  , "https://user:pass@host.example/path;p=1"+  , "urn:isbn:0451450523"+  , "https://example.com/x?y=1"+  , "https://example.com:65535/"+  , "file:///etc/passwd"+  ]++genUrl :: Gen Url+genUrl = mkUrlOrErr <$> genUrlText+  where mkUrlOrErr t = either (\e -> error ("Hyperlink.genUrl: " <> show e)) id (mkUrl t)++-- ASCII plus a literal ESC, so properties can confirm the escape is+-- neutralised by 'message''s existing control-character stripping rather than+-- leaking into the rendered report.+genMsgChar :: Gen Char+genMsgChar = Gen.frequency+  [ (8, Gen.filterT (/= '\n') (Gen.enum ' ' '~'))+  , (1, pure '\ESC')+  , (1, pure '\a')+  ]++genMsg :: Gen Text+genMsg = Gen.text (Range.linear 0 20) genMsgChar++-- | A minimal diagnostic carrier: only 'message' and (optionally) 'url' are+-- ever non-default here, which is all these properties need.+data HD = HD Text (Maybe Url)++instance Diagnostic HD where+  message (HD m _) = pretty m+  url     (HD _ u) = u++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++renderGfx :: HyperlinkMode -> HD -> Text+renderGfx hm d =+  case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways+                         (withHyperlinkMode hm (withTarget TGraphical defaultConfig)))) of+    SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r d))+    _                            -> ""++esc :: Char+esc = '\ESC'++-- | Remove OSC 8 escapes (@ESC ]8;; <label> ESC \\@ / @ESC ]8;; ESC \\@),+-- leaving whatever sits between the open and close escapes untouched. Total:+-- a malformed/truncated tail (never produced by 'hyperlink', only reachable if+-- a property here were given bad input) is left as-is rather than crashing.+stripOsc8 :: Text -> Text+stripOsc8 = T.pack . go . T.unpack+  where+    go [] = []+    go (c : ']' : '8' : ';' : ';' : rest)+      | c == esc = case break (== esc) rest of+          (_, _ : '\\' : rest') -> go rest'+          _                     -> rest+    go (c : rest) = c : go rest++-- === pure resolution proofs (mirrors "TermColor"'s colour proofs) =========++prop_explicitPassthrough :: Property+prop_explicitPassthrough = property $ do+  caps <- forAll genCaps+  resolveHyperlink caps HyperlinkAlways === HyperlinkAlways+  resolveHyperlink caps HyperlinkNever  === HyperlinkNever++prop_noHyperlinkWins :: Property+prop_noHyperlinkWins = property $ do+  caps <- forAll (fmap (\c -> c { capNoHyperlink = True }) genCaps)+  resolveHyperlink caps HyperlinkAuto === HyperlinkNever++prop_forceHyperlink :: Property+prop_forceHyperlink = property $ do+  caps <- forAll (fmap (\c -> c { capNoHyperlink = False, capForceHyperlink = True }) genCaps)+  resolveHyperlink caps HyperlinkAuto === HyperlinkAlways++prop_ttyHyperlink :: Property+prop_ttyHyperlink = property $ do+  caps0 <- forAll genCaps+  let caps = caps0 { capNoHyperlink = False, capForceHyperlink = False }+  resolveHyperlink caps HyperlinkAuto === (if capIsTerminal caps then HyperlinkAlways else HyperlinkNever)++prop_noAutoAfter :: Property+prop_noAutoAfter = property $ do+  caps <- forAll genCaps+  hm   <- forAll genHyperlinkMode+  let r = resolveConfig caps (withHyperlinkMode hm defaultConfig)+  assert (configHyperlinkMode r `elem` [HyperlinkAlways, HyperlinkNever])++prop_idempotentHyperlink :: Property+prop_idempotentHyperlink = property $ do+  caps <- forAll genCaps+  hm   <- forAll genHyperlinkMode+  let c1 = resolveConfig caps (withHyperlinkMode hm defaultConfig)+      c2 = resolveConfig caps c1+  configHyperlinkMode c2 === configHyperlinkMode c1++-- === render proofs ==========================================================++prop_neverNoEsc :: Property+prop_neverNoEsc = property $ do+  msg <- forAll genMsg+  mu  <- forAll (Gen.maybe genUrl)+  assert (not (T.any (== esc) (renderGfx HyperlinkNever (HD msg mu))))++prop_alwaysWrapsUrl :: Property+prop_alwaysWrapsUrl = property $ do+  msg <- forAll genMsg+  u   <- forAll genUrl+  let out    = renderGfx HyperlinkAlways (HD msg (Just u))+      label  = unUrl u+      wanted = "\ESC]8;;" <> label <> "\ESC\\" <> label <> "\ESC]8;;\ESC\\"+  assert (T.isInfixOf wanted out)++prop_noUrlNoDifference :: Property+prop_noUrlNoDifference = property $ do+  msg <- forAll genMsg+  renderGfx HyperlinkAlways (HD msg Nothing) === renderGfx HyperlinkNever (HD msg Nothing)++prop_structureInvariant :: Property+prop_structureInvariant = property $ do+  msg <- forAll genMsg+  u   <- forAll genUrl+  stripOsc8 (renderGfx HyperlinkAlways (HD msg (Just u))) === renderGfx HyperlinkNever (HD msg (Just u))++-- 'hyperlink' (like 'colorize') treats any mode that is not the "off" mode as+-- "on"; a raw, unresolved 'HyperlinkAuto' reaching the renderer therefore+-- behaves exactly like 'HyperlinkAlways'. Pinned as a single deterministic+-- case (not a property over generated input) because it documents a specific+-- design choice rather than a general law.+prop_autoUnresolvedWraps :: Property+prop_autoUnresolvedWraps = withTests 1 . property $+  let d = HD "type mismatch" (Just (rightOrErr (mkUrl "https://example.org/errors/E0001")))+  in renderGfx HyperlinkAuto d === renderGfx HyperlinkAlways d++-- A raw ESC embedded in the message text must never reach the rendered+-- report: 'Tadka.Internal.Renderer.Graphical.docToText' already strips+-- control characters from message/help/label text (unrelated to this+-- feature), and this hyperlink work must not weaken that. Checked+-- independently of 'prop_structureInvariant' (which proves the same thing via+-- structural equality): here every ESC in the output is counted directly, so+-- the proof holds even if the two OSC 8 escapes this feature adds were+-- themselves malformed in a way structural comparison could miss.+prop_messageEscNeverLeaks :: Property+prop_messageEscNeverLeaks = property $ do+  msg <- forAll genMsg+  u   <- forAll genUrl+  let out = renderGfx HyperlinkAlways (HD msg (Just u))+  T.count (T.singleton esc) out === 4   -- introducer + terminator, for both the open and close escapes
+ test/props/LabelCollection.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Collection labels in @deriveDiagnostic@ (post-v1 hardening item 3): a+-- single @[Span]@-typed field expands, at runtime, to one label per element —+-- for a variable number of same-kind occurrences (every prior declaration of+-- a name, every match of a banned pattern) known only when the diagnostic is+-- built, where 'specLabelFields'/'specSecondaryLabelFields' need one field per+-- label fixed at splice time.+--+-- "Context.hs already supports variable-length label lists" is the load-+-- bearing fact this feature rests on: 'buildContext'/'buildContextWith' are+-- unchanged (they already take a plain, arbitrary-length list); this is a+-- TH-layer-only addition that expands a collection field's runtime list into+-- that same shape. The properties below therefore compare the derived+-- instance against a /manually/-expanded 'buildContextWith' call for the same+-- randomly generated list, across every list length and mix of primary/+-- secondary, fixed and collection fields — proving the splice is exactly+-- equivalent to writing the expansion out by hand, not just plausible for one+-- example.+module LabelCollection (group) where++import qualified Data.Aeson                as A+import           Data.Text                 (Text)+import qualified Data.Text                 as T+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog                  (Group (..), Gen, Property, assert, forAll, property,+                                             withTests, (===))+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           Tadka+import           Tadka.Internal            (buildContext, buildContextWith)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- A source with distinct single-character spans at offsets 0, 5, 10, ...,+-- long enough that a handful of 1-character spans always land in-bounds.+srcText :: Text+srcText = "a bb ccc dddd eeeee ffffff ggggggg hhhhhhhh"++srcV :: NamedSource+srcV = rightOrErr (mkNamedSource "f.hs" srcText)++-- === derive == manual, for a range of collection sizes ====================++-- Primary-only: a single primary collection field, no fixed fields at all —+-- exercises the `buildContext` (no-secondary) branch purely through a+-- collection, and specifically that "anchor on the first primary label"+-- falls on the collection's first element when it is the only label source.+data AllOcc = AllOcc { aoSrc :: NamedSource, aoSpans :: [Span] }++deriveDiagnostic defaultSpec+  { specSourceField           = Just 'aoSrc+  , specLabelCollectionFields = [('aoSpans, "matches the banned pattern")]+  , specMessage               = Just [| \_ -> pretty ("banned pattern used" :: Text) |]+  }+  ''AllOcc++data AllOccManual = AllOccManual { aomSrc :: NamedSource, aomSpans :: [Span] }++instance Diagnostic AllOccManual where+  message _ = pretty ("banned pattern used" :: Text)+  context e = buildContext (aomSrc e)+    [ (s, Just "matches the banned pattern") | s <- aomSpans e ]++-- Mixed: one fixed primary field (the offending redeclaration) plus a+-- secondary *collection* field (every prior declaration) — exercises the+-- `buildContextWith` branch with both a fixed and a collection source in the+-- same instance, fixed field first as documented.+data Dup = Dup { dSrc :: NamedSource, dNew :: Span, dPrev :: [Span] }++deriveDiagnostic defaultSpec+  { specSourceField                    = Just 'dSrc+  , specLabelFields                    = [('dNew, "redeclared here")]+  , specSecondaryLabelCollectionFields = [('dPrev, "previously declared here")]+  , specMessage                        = Just [| \_ -> pretty ("duplicate declaration" :: Text) |]+  }+  ''Dup++data DupManual = DupManual { dmSrc :: NamedSource, dmNew :: Span, dmPrev :: [Span] }++instance Diagnostic DupManual where+  message _ = pretty ("duplicate declaration" :: Text)+  context e = buildContextWith (dmSrc e)+    (  [ (dmNew e, Primary, Just "redeclared here") ]+    ++ [ (s, Secondary, Just "previously declared here") | s <- dmPrev e ] )++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++nar :: Diagnostic e => e -> Text+nar e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++jsn :: Diagnostic e => e -> Text+jsn e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++-- A handful of valid, in-bounds single-character offsets to draw spans from+-- ('srcText' is 43 characters, offsets 0..42).+genSpanList :: Gen [Span]+genSpanList = Gen.list (Range.linear 0 8) genSpan+  where+    genSpan = (\off -> rightOrErr (mkSpan off 1)) <$> Gen.element [0, 2, 5, 9, 14, 20, 27, 35, 42]++prop_allPrimaryCollectionDerivedEqualsManual :: Property+prop_allPrimaryCollectionDerivedEqualsManual = property $ do+  spans_ <- forAll genSpanList+  let d = AllOcc srcV spans_+      m = AllOccManual srcV spans_+  gfx d === gfx m+  nar d === nar m+  jsn d === jsn m++prop_mixedFixedAndSecondaryCollectionDerivedEqualsManual :: Property+prop_mixedFixedAndSecondaryCollectionDerivedEqualsManual = property $ do+  prevSpans <- forAll genSpanList+  let newSpan = rightOrErr (mkSpan 40 1)+      d = Dup srcV newSpan prevSpans+      m = DupManual srcV newSpan prevSpans+  gfx d === gfx m+  nar d === nar m+  jsn d === jsn m++-- === specific edge cases (not just "some random N") ========================++prop_emptyCollectionIsFixedFieldsOnly :: Property+prop_emptyCollectionIsFixedFieldsOnly = withTests 1 . property $ do+  let newSpan = rightOrErr (mkSpan 40 1)+      withEmptyColl = Dup srcV newSpan []+      -- A hand-written instance with *no* collection field at all: if the+      -- splice's `++ concat []` addition is truly a no-op, these must match.+      manualNoColl = DupManual srcV newSpan []+  gfx withEmptyColl === gfx manualNoColl+  nar withEmptyColl === nar manualNoColl+  jsn withEmptyColl === jsn manualNoColl++prop_emptyEverythingIsNoContext :: Property+prop_emptyEverythingIsNoContext = withTests 1 . property $ do+  let d = AllOcc srcV []+  -- No fixed fields and an empty collection: NoContext, i.e. no location+  -- line at all, same as a diagnostic with no context whatsoever.+  gfx d === gfx (AllOccManual srcV [])++prop_totalityLargeCollection :: Property+prop_totalityLargeCollection = withTests 1 . property $ do+  let manySpans = replicate 200 (rightOrErr (mkSpan 0 1))+      d = AllOcc srcV manySpans+  -- Must not crash or hang; a non-empty rendered report is a cheap total+  -- witness that rendering actually completed for 200 expanded labels.+  assert (T.length (gfx d) > 0)++group :: Group+group = Group "Collection labels in deriveDiagnostic"+  [ ("all-primary collection: derived == manual (varying N)",       prop_allPrimaryCollectionDerivedEqualsManual)+  , ("fixed primary + secondary collection: derived == manual",     prop_mixedFixedAndSecondaryCollectionDerivedEqualsManual)+  , ("empty collection list == field omitted entirely",             prop_emptyCollectionIsFixedFieldsOnly)+  , ("no fixed fields + empty collection == NoContext",              prop_emptyEverythingIsNoContext)+  , ("a large collection renders without crashing (totality)",      prop_totalityLargeCollection)+  ]
+ test/props/Labels.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Primary/secondary labels (post-v1 hardening): the report location anchors+-- on the first primary label, JSON exposes an explicit @primary@ flag, and the+-- derive path (with @specSecondaryLabelFields@) renders identically to a manual+-- @buildContextWith@ instance — keeping the two doors symmetric for kinds too.+module Labels (group) where++import qualified Data.Aeson                       as A+import           Data.Text                        (Text)+import qualified Data.Text                        as T+import qualified Data.Text.Lazy                   as TL+import qualified Data.Text.Lazy.Encoding          as TLE+import           Prettyprinter                    (LayoutOptions (..),+                                                   PageWidth (Unbounded), layoutPretty,+                                                   pretty)+import           Prettyprinter.Render.Text        (renderStrict)++import           Hedgehog                         (Group (..), Property, property,+                                                   withTests, (===), assert)++import           Tadka+import           Tadka.Internal                   (buildContextWith)+import           Tadka.Internal.Related           (walkRelated)+import           Tadka.Internal.Renderer.Json     (LabelDTO (..), dtoLabels, toDTO)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- A source with two labels on different lines: secondary on line 1, primary on 3.+src3 :: NamedSource+src3 = rightOrErr (mkNamedSource "f.hs" "aaaa\nbbbb\ncccc\n")++kindFix :: Context+kindFix = buildContextWith src3+  [ (rightOrErr (mkSpan 0 2), Secondary, Just "context here")   -- line 1+  , (rightOrErr (mkSpan 10 2), Primary,  Just "the error")      -- line 3 (offset 10 = "aaaa\nbbbb\n" + 0)+  ]++data KindDiag = KindDiag+instance Diagnostic KindDiag where+  message _ = "boom"+  context _ = kindFix++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++prop_anchorPrimary :: Property+prop_anchorPrimary = withTests 1 . property $ do+  let out = gfx KindDiag+  -- the location line must point at the primary label's line 3, not line 1+  assert (T.isInfixOf "f.hs:3:" out)++prop_glyphs :: Property+prop_glyphs = withTests 1 . property $ do+  let out = gfx KindDiag+  assert (T.isInfixOf "-- context here" out)   -- secondary uses '-'+  assert (T.isInfixOf "^^ the error"   out)    -- primary uses '^'++-- Two Secondary labels on the same line (both on line 1, "aaaa"): must be+-- distinguishable under ColorNever even though they share a LabelKind.+kindFix3 :: Context+kindFix3 = buildContextWith src3+  [ (rightOrErr (mkSpan 0 2), Secondary, Just "first")   -- "aa"+  , (rightOrErr (mkSpan 2 2), Secondary, Just "second")  -- "aa"+  ]++data KindDiag3 = KindDiag3+instance Diagnostic KindDiag3 where+  message _ = "boom"+  context _ = kindFix3++prop_glyphsSameKindDistinct :: Property+prop_glyphsSameKindDistinct = withTests 1 . property $ do+  let out = gfx KindDiag3+  -- rank 0 keeps the Secondary anchor '-', rank 1 cycles to '~'+  assert (T.isInfixOf "-- first"  out)+  assert (T.isInfixOf "~~ second" out)++prop_jsonFlag :: Property+prop_jsonFlag = withTests 1 . property $ do+  let labels = dtoLabels (toDTO 8 (walkRelated 8 (SomeDiagnostic KindDiag)))+  map ldPrimary labels === [False, True]        -- secondary first, primary second++-- === derive (with secondary) == manual ====================================++data DErr2 = DErr2 { d2src :: NamedSource, d2prim :: Span, d2sec :: Span, d2got :: Text }+  deriving (Show)++deriveDiagnostic defaultSpec+  { specSourceField          = Just 'd2src+  , specLabelFields          = [('d2prim, "here")]+  , specSecondaryLabelFields = [('d2sec,  "context")]+  , specMessage              = Just [| \e -> pretty ("undefined " <> d2got e) |]+  }+  ''DErr2++data MErr2 = MErr2 { m2src :: NamedSource, m2prim :: Span, m2sec :: Span, m2got :: Text }++instance Diagnostic MErr2 where+  message e = pretty ("undefined " <> m2got e)+  context e = buildContextWith (m2src e)+    [ (m2prim e, Primary,   Just "here")+    , (m2sec e,  Secondary, Just "context")+    ]++srcV :: NamedSource+srcV = rightOrErr (mkNamedSource "f.hs" "let a = bb")++dVal :: DErr2+dVal = DErr2 srcV (rightOrErr (mkSpan 4 1)) (rightOrErr (mkSpan 8 2)) "x"++mVal :: MErr2+mVal = MErr2 srcV (rightOrErr (mkSpan 4 1)) (rightOrErr (mkSpan 8 2)) "x"++nar :: Diagnostic e => e -> Text+nar e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++jsn :: Diagnostic e => e -> Text+jsn e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++prop_deriveEqualsManual :: Property+prop_deriveEqualsManual = withTests 1 . property $ do+  gfx dVal === gfx mVal+  nar dVal === nar mVal+  jsn dVal === jsn mVal++group :: Group+group = Group "Primary/secondary labels"+  [ ("graphical location anchors on the primary label", prop_anchorPrimary)+  , ("JSON marks primary vs secondary explicitly",      prop_jsonFlag)+  , ("graphical uses ^ for primary, - for secondary",   prop_glyphs)+  , ("same-kind labels on one line get distinct glyphs", prop_glyphsSameKindDistinct)+  , ("derived (with secondary) == manual, all handlers",prop_deriveEqualsManual)+  ]+
+ test/props/LayoutSpec.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Phase III core — lane assignment. The load-bearing proof is that any two+-- distinct spans placed on the same lane have disjoint line ranges+-- (collision-free interval colouring); supporting properties pin coverage,+-- lane contiguity, and the cell classifier.+module LayoutSpec (group) where++import           Hedgehog+import qualified Hedgehog.Gen                    as Gen+import qualified Hedgehog.Range                  as Range++import           Tadka.Internal.Renderer.Layout  (CellKind (..), assignLanes,+                                                  cellAt, laneCount)++group :: Group+group = Group "Layout: lane assignment (Phase III)"+  [ ("same lane implies disjoint line ranges", prop_noCollision)+  , ("one lane per input interval, in order",  prop_coverage)+  , ("lanes are contiguous 0..count-1",        prop_contiguous)+  , ("cellAt classifies open/through/close",   prop_cellAt)+  ]++genIv :: Gen (Int, Int)+genIv = do+  a <- Gen.int (Range.linear 1 12)+  b <- Gen.int (Range.linear 1 12)+  pure (min a b, max a b)++genIvs :: Gen [(Int, Int)]+genIvs = Gen.list (Range.linear 0 8) genIv++overlaps :: (Int, Int) -> (Int, Int) -> Bool+overlaps (s1, e1) (s2, e2) = s1 <= e2 && s2 <= e1++-- THE proof: two distinct assigned spans on one lane never share a line.+prop_noCollision :: Property+prop_noCollision = property $ do+  ivs <- forAll genIvs+  let assigned = zip [0 :: Int ..] (assignLanes ivs)   -- (position, (lane, iv))+  assert $ and+    [ not (overlaps a b)+    | (i, (la, a)) <- assigned+    , (j, (lb, b)) <- assigned+    , i < j+    , la == lb+    ]++prop_coverage :: Property+prop_coverage = property $ do+  ivs <- forAll genIvs+  map snd (assignLanes ivs) === ivs        -- one entry per input, order preserved++prop_contiguous :: Property+prop_contiguous = property $ do+  ivs <- forAll genIvs+  let assigned = assignLanes ivs+      lanes    = map fst assigned+      n        = laneCount assigned+  assert (all (>= 0) lanes)+  assert (all (< n) lanes)+  assert (null lanes || all (`elem` lanes) [0 .. n - 1])   -- no unused lane below the count++prop_cellAt :: Property+prop_cellAt = property $ do+  (s, e) <- forAll (Gen.filterT (\(a, b) -> a < b) genIv)+  l      <- forAll (Gen.int (Range.linear 0 14))+  cellAt (s, e) s === Open+  cellAt (s, e) e === Close+  let expected | l == s         = Open+               | l == e         = Close+               | s < l && l < e = Through+               | otherwise      = Blank+  cellAt (s, e) l === expected
+ test/props/LinePlanSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Phase II — the pure line planner. Properties pin selection/elision without+-- rendering: the plan is total, 'Nothing' reproduces the contiguous range with+-- no elision, and with context every in-range anchor is shown, line numbers are+-- strictly increasing and in bounds, and every elision hides at least one line.+module LinePlanSpec (group) where++import           Hedgehog+import qualified Hedgehog.Gen                     as Gen+import qualified Hedgehog.Range                   as Range++import           Tadka.Internal.Renderer.LinePlan (PlanEntry (..), planLines)++group :: Group+group = Group "Line plan (Phase II)"+  [ ("empty anchors give an empty plan",        prop_empty)+  , ("Nothing is the contiguous range, no elision", prop_contiguous)+  , ("context shows every in-range anchor",     prop_covers)+  , ("shown line numbers strictly increase",    prop_monotonic)+  , ("shown lines are within [1, total]",       prop_bounds)+  , ("every elision hides at least one line",   prop_elidePos)+  ]++genCtx :: Gen (Maybe Int)+genCtx = Gen.choice [pure Nothing, Just <$> Gen.int (Range.linear 0 4)]++genTotal :: Gen Int+genTotal = Gen.int (Range.linear 0 20)++genAnchors :: Gen [Int]+genAnchors = Gen.list (Range.linear 0 6) (Gen.int (Range.linear (-2) 22))++shown :: [PlanEntry] -> [Int]+shown p = [ l | ShowLine l <- p ]++elides :: [PlanEntry] -> [Int]+elides p = [ n | ElideLines n <- p ]++prop_empty :: Property+prop_empty = property $ do+  mc <- forAll genCtx+  t  <- forAll genTotal+  planLines mc t [] === []++prop_contiguous :: Property+prop_contiguous = property $ do+  t  <- forAll genTotal+  as <- forAll (Gen.filterT (not . null) genAnchors)+  let p   = planLines Nothing t as+      lo  = max 1 (minimum as)+      hi  = min (max 1 t) (maximum as)+  shown p === [lo .. hi]+  elides p === []++prop_covers :: Property+prop_covers = property $ do+  c  <- forAll (Gen.int (Range.linear 0 4))+  t  <- forAll genTotal+  as <- forAll genAnchors+  let p        = planLines (Just c) t as+      capped   = max 1 t+      inRange  = [ x | x <- as, x >= 1, x <= capped ]+  assert (all (`elem` shown p) inRange)++prop_monotonic :: Property+prop_monotonic = property $ do+  mc <- forAll genCtx+  t  <- forAll genTotal+  as <- forAll genAnchors+  let ls = shown (planLines mc t as)+  assert (and (zipWith (<) ls (drop 1 ls)))++prop_bounds :: Property+prop_bounds = property $ do+  mc <- forAll genCtx+  t  <- forAll genTotal+  as <- forAll genAnchors+  let ls = shown (planLines mc t as)+  assert (all (\l -> l >= 1 && l <= max 1 t) ls)++prop_elidePos :: Property+prop_elidePos = property $ do+  mc <- forAll genCtx+  t  <- forAll genTotal+  as <- forAll genAnchors+  assert (all (>= 1) (elides (planLines mc t as)))
+ test/props/Main.hs view
@@ -0,0 +1,39 @@+-- | Property test suite entry point. Each phase contributes a Hedgehog 'Group';+-- Main runs them all and fails if any property fails.+module Main (main) where++import           Control.Monad   (unless)+import           GHC.IO.Encoding (setLocaleEncoding, utf8)+import           System.Exit     (exitFailure)++import           Hedgehog        (checkParallel)++import qualified Phase1+import qualified Phase2+import qualified Phase3+import qualified Phase4+import qualified Phase5+import qualified Phase6+import qualified Phase7+import qualified Phase8+import qualified Phase9+import qualified Phase11+import qualified Phase12+import qualified Phase13+import qualified Tabs+import qualified TermColor+import qualified Hyperlink+import qualified LabelCollection+import qualified Labels+import qualified Cause+import qualified Source+import qualified LinePlanSpec+import qualified LayoutSpec+import qualified MultiLine+import qualified EdgeCases++main :: IO ()+main = do+  setLocaleEncoding utf8   -- tadka emits Unicode; be locale-independent+  results <- traverse checkParallel [Phase1.group, Phase2.group, Phase3.group, Phase4.group, Phase5.group, Phase6.group, Phase7.group, Phase8.group, Phase9.group, Phase11.group, Phase12.group, Phase13.group, Tabs.group, TermColor.group, Hyperlink.group, LabelCollection.group, Labels.group, Cause.group, Source.group, LinePlanSpec.group, LayoutSpec.group, MultiLine.group, EdgeCases.group]+  unless (and results) exitFailure
+ test/props/MultiLine.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Phase III end-to-end: rendering multi-line spans. The invariant proved here+-- ties the pure lane engine to actual output — every multi-line span draws+-- exactly one opening corner and one closing corner (every opened lane closes),+-- regardless of how lanes overlap.+module MultiLine (group) where++import           Data.Text                  (Text)+import qualified Data.Text                  as T+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           Tadka+import           Tadka.Internal             (buildContext)++group :: Group+group = Group "Multi-line rendering (Phase III)"+  [ ("every multi-line span opens and closes once", prop_balanced)+  , ("a multi-line label's text is shown",          prop_labelShown)+  ]++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- 10 lines of 5 chars each; line L (1-based) starts at offset (L-1)*6.+srcTen :: NamedSource+srcTen = rightOrErr (mkNamedSource "m.hs" (T.intercalate (T.singleton '\n') (replicate 10 "aaaaa")))++spanOfLines :: Int -> Int -> Span+spanOfLines a b = rightOrErr (mkSpan start (endOff - start))+  where start  = (a - 1) * 6+        endOff = (b - 1) * 6 + 3++data ML = ML Context+instance Diagnostic ML where+  message _   = "multi-line diagnostic"+  context (ML c) = c++mkDiag :: [(Int, Int)] -> ML+mkDiag pairs = ML (buildContext srcTen [ (spanOfLines a b, Just "here") | (a, b) <- pairs ])++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++open, close :: Text+open  = T.singleton '\x256D'   -- ╭+close = T.singleton '\x2570'   -- ╰++genPairs :: Gen [(Int, Int)]+genPairs = Gen.list (Range.linear 0 4) $ do+  a <- Gen.int (Range.linear 1 9)+  b <- Gen.int (Range.linear (a + 1) 10)   -- strictly multi-line+  pure (a, b)++prop_balanced :: Property+prop_balanced = property $ do+  pairs <- forAll genPairs+  let out = gfx (mkDiag pairs)+  T.count open  out === length pairs+  T.count close out === length pairs++prop_labelShown :: Property+prop_labelShown = withTests 1 . property $ do+  let out = gfx (mkDiag [(2, 5)])+  assert ("here" `T.isInfixOf` out)+  assert (T.count open out == 1 && T.count close out == 1)
+ test/props/Phase1.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Phase 1 properties: primitive types, smart constructors, width lookups.+module Phase1 (group) where++import           Data.Char           (isAsciiLower, isDigit)+import           Data.Text           (Text)+import qualified Data.Text           as T++import           Hedgehog+                   (Gen, Group (..), Property, assert, forAll, property,+                    withTests, (===))+import qualified Hedgehog.Gen        as Gen+import qualified Hedgehog.Range      as Range++import           Tadka+import           Tadka.Internal.Types (LengthError (..), OffsetError (..), mkLength,+                                             mkOffset, unLength, unOffset)+import           Tadka.Internal.Width+                   (GBProp (..), charWidth, graphemeBreakProperty,+                    isExtendedPictographic, textWidth)++group :: Group+group = Group "Phase 1 - primitive types & width"+  [ ("mkOffset rejects exactly negatives",                  prop_mkOffset)+  , ("mkLength rejects exactly negatives",                  prop_mkLength)+  , ("mkNamedSource: empty name rejected; else round-trip", prop_mkNamedSource)+  , ("mkDiagnosticCode agrees with grammar oracle",         prop_mkDiagnosticCode)+  , ("mkDiagnosticId is total and round-trips",             prop_mkDiagnosticId)+  , ("mkUrl accepts absolute URIs only",                    prop_mkUrl)+  , ("Tadka.Internal.Width point lookups",                  prop_width)+  ]++genInt :: Gen Int+genInt = Gen.int (Range.linearFrom 0 (-100000) 100000)++genText :: Gen Text+genText = Gen.text (Range.linear 0 30) Gen.unicode++genCodeish :: Gen Text+genCodeish = Gen.choice [genValidCode, genNoisyCode]+  where+    genValidCode = do+      ns   <- genNamespace+      digs <- Gen.text (Range.linear 4 8) Gen.digit+      pure (ns <> "::E" <> digs)+    genNamespace = do+      c0 <- Gen.lower+      cs <- Gen.text (Range.linear 0 6)+              (Gen.choice [Gen.lower, Gen.digit, Gen.constant '_'])+      pure (T.cons c0 cs)+    genNoisyCode =+      Gen.text (Range.linear 0 16)+        (Gen.choice (map Gen.constant "abcdeEZ0123:_# "))++prop_mkOffset :: Property+prop_mkOffset = property $ do+  n <- forAll genInt+  case mkOffset n of+    Left (NegativeOffset m) -> do assert (n < 0);  m === n+    Right o                 -> do assert (n >= 0); unOffset o === n++prop_mkLength :: Property+prop_mkLength = property $ do+  n <- forAll genInt+  case mkLength n of+    Left (NegativeLength m) -> do assert (n < 0);  m === n+    Right l                 -> do assert (n >= 0); unLength l === n++prop_mkNamedSource :: Property+prop_mkNamedSource = property $ do+  name <- forAll genText+  txt  <- forAll genText+  case mkNamedSource name txt of+    Left EmptySourceName -> T.null name === True+    Right ns             -> do+      assert (not (T.null name))+      sourceName ns === name+      sourceText ns === txt++oracleCode :: Text -> Bool+oracleCode t = case T.splitOn "::" t of+  [ns, body] -> okNs (T.unpack ns) && okBody (T.unpack body)+  _          -> False+  where+    okNs []       = False+    okNs (c : cs) = isAsciiLower c+                      && all (\x -> isAsciiLower x || isDigit x || x == '_') cs+    okBody ('E' : ds) = length ds >= 4 && all isDigit ds+    okBody _          = False++prop_mkDiagnosticCode :: Property+prop_mkDiagnosticCode = property $ do+  t <- forAll genCodeish+  case mkDiagnosticCode t of+    Right c                -> do oracleCode t === True; unDiagnosticCode c === t+    Left EmptyCode         -> T.null t === True+    Left (MalformedCode m) -> do m === t+                                 assert (not (T.null t))+                                 oracleCode t === False++prop_mkDiagnosticId :: Property+prop_mkDiagnosticId = property $ do+  t <- forAll genText+  unDiagnosticId (mkDiagnosticId t) === t++urlCases :: [(Text, Bool)]+urlCases =+  [ ("https://example.org/errors/E0001", True)+  , ("http://a.example/",                True)+  , ("ftp://host/path",                  True)+  , ("mailto:person@example.org",        True)+  , ("",                                 False)+  , ("example.org",                      False)+  , ("/relative/path",                   False)+  , ("not a url",                        False)+  , ("http://x.example/#fragment",       False)+  ]++prop_mkUrl :: Property+prop_mkUrl = property $ do+  (input, valid) <- forAll (Gen.choice (map Gen.constant urlCases))+  case mkUrl input of+    Right u                 -> do assert valid; unUrl u === input+    Left EmptyUrl           -> T.null input === True+    Left (NotAbsoluteUri m) -> do assert (not valid); m === input++prop_width :: Property+prop_width = withTests 1 . property $ do+  charWidth 'A'        === 1+  charWidth ' '        === 1+  charWidth '\x0301'   === 0+  charWidth '\xAC00'   === 2+  charWidth '\xD55C'   === 2+  charWidth '\x4E00'   === 2+  textWidth "AB"       === 2+  textWidth "a\x0301"  === 1+  textWidth "\xD55C\xAC00\xC5B4" === 6+  graphemeBreakProperty '\r'      === GBCR+  graphemeBreakProperty '\n'      === GBLF+  graphemeBreakProperty '\x200D'  === GBZWJ+  graphemeBreakProperty 'A'       === GBOther+  assert (isExtendedPictographic '\x1F600')+  assert (not (isExtendedPictographic 'A'))
+ test/props/Phase11.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Phase 11 consolidation: the render-totality property broadened to every+-- 'Renderer' target, the cycle-detection marker property, and the vision's+-- Success Criterion exercised end-to-end (a genuinely staled span renders a+-- clear in-report reason rather than a silently shorter report).+module Phase11 (group) where++import           Control.Exception          (SomeException, evaluate, try)+import           Control.Monad.IO.Class     (liftIO)+import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           GenDiag                    (GD (..), genGD)+import           Tadka+import           Tadka.Internal             (buildContext)++group :: Group+group = Group "Phase 11 - consolidation & release audit"+  [ ("render is total for every target (Hedgehog)", prop_totalAllTargets)+  , ("cycle marker renders at most once",           prop_cycleMarker)+  , ("staled span renders a clear reason",          prop_staleReason)+  , ("staled label is explicit in JSON",            prop_staleJson)+  ]++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Render any diagnostic through the chosen target, collapsed to Text.+renderTarget :: Target -> SomeDiagnostic -> Text+renderTarget tgt (SomeDiagnostic e) =+  case selectRenderer cfg of+    SomeRenderer r@(Graphical _)  -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+    SomeRenderer r@(Narratable _) -> render r e+    SomeRenderer r@(Json _)       -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  where+    cfg = withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget tgt defaultConfig))++-- Broadens the phase-local smoke checks into one Hedgehog property over every+-- Renderer target and fuel-bounded generated diagnostics.+prop_totalAllTargets :: Property+prop_totalAllTargets = property $ do+  fuel <- forAll (Gen.int (Range.linear 0 3))+  tgt  <- forAll (Gen.element [TGraphical, TNarratable, TJson])+  d    <- forAllWith (const "<generated diagnostic>") (genGD fuel)+  res  <- liftIO (try (evaluate (T.length (renderTarget tgt (SomeDiagnostic d))))+                    :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure++-- A node that relates to itself (same diagnosticId): the repeat is cycle-omitted,+-- so a marker in its message renders at most once, on every target.+marker :: Text+marker = "ZZMARKERZZ"++cyclic :: GD+cyclic =+  let d = GD ("dup problem " <> marker) Nothing NoContext Nothing Nothing+             [SomeDiagnostic d] (Just (mkDiagnosticId "dup")) Nothing+  in d++prop_cycleMarker :: Property+prop_cycleMarker = withTests 1 . property $+  mapM_ (\tgt -> assert (T.count marker (renderTarget tgt (SomeDiagnostic cyclic)) <= 1))+        [TGraphical, TNarratable, TJson]++-- Success Criterion: a genuinely staled span (out of bounds) renders a clear+-- in-report reason, not a silently shorter report.+staleDiag :: GD+staleDiag = GD "undefined variable" (Just (rightOrErr (mkDiagnosticCode "tadka::E0001")))+               ctx Nothing Nothing [] Nothing Nothing+  where+    ctx = buildContext (rightOrErr (mkNamedSource "f.hs" "abc"))+            [ (rightOrErr (mkSpan 100 3), Just (pretty ("not in scope" :: Text))) ]++prop_staleReason :: Property+prop_staleReason = withTests 1 . property $ do+  let g = renderTarget TGraphical (SomeDiagnostic staleDiag)+      n = renderTarget TNarratable (SomeDiagnostic staleDiag)+  assert ("span unavailable" `T.isInfixOf` g)+  assert ("could not be shown" `T.isInfixOf` n)++prop_staleJson :: Property+prop_staleJson = withTests 1 . property $ do+  let j = renderTarget TJson (SomeDiagnostic staleDiag)+  assert ("\"stale\":true" `T.isInfixOf` j)
+ test/props/Phase12.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Phase 12 properties: multi-source 'Context' construction. The crux is the+-- same as Phase 2's, extended pointwise across sources: 'mkContextMultiDegrading'+-- never changes a group's label count or order, group order itself is never+-- changed, and every single-source function is exactly the one-group special+-- case of its multi-source counterpart -- never a second, divergent+-- implementation.+module Phase12 (group) where++import           Data.Either        (isLeft)+import           Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import           Data.Text          (Text)+import           Prettyprinter      (Doc, pretty)++import           Hedgehog+                   (Gen, Group (..), Property, failure, forAll, property,+                    success, withTests, (===))+import qualified Hedgehog.Gen       as Gen+import qualified Hedgehog.Range     as Range++import           Tadka+import           Tadka.Internal     (buildContextMulti)++group :: Group+group = Group "Phase 12 - multi-source context"+  [ ("mkContextMulti is Left iff any span, in any group, is out of bounds",+      prop_multiStrict)+  , ("mkContextMultiDegrading never changes any group's label count/order",+      prop_multiDegradingCount)+  , ("mkContext/mkContextDegrading are the one-group case of their multi- counterparts",+      prop_singleGroupMatchesMulti)+  , ("buildContextMulti with every group empty = NoContext",+      prop_buildContextMultiAllEmpty)+  , ("buildContextMulti dispatches to mkContextMultiDegrading",+      prop_buildContextMultiDispatch)+  , ("buildContextMulti drops an empty group without affecting the others",+      prop_buildContextMultiDropsEmptyGroups)+  ]++-- === Generators (mirroring Phase2's, one source/label-list pair per group) ==++genSourceText :: Gen Text+genSourceText =+  Gen.text (Range.linear 0 40)+    (Gen.frequency [(6, Gen.alphaNum), (2, Gen.constant ' '), (2, Gen.constant '\n')])++genNamedSource :: Gen NamedSource+genNamedSource = do+  name <- Gen.text (Range.linear 1 8) Gen.alpha+  txt  <- genSourceText+  either (const Gen.discard) pure (mkNamedSource name txt)++genSpan :: Gen Span+genSpan = do+  o <- Gen.int (Range.linear 0 50)+  l <- Gen.int (Range.linear 0 50)+  either (const Gen.discard) pure (mkSpan o l)++genLabelText :: Gen (Maybe (Doc Ann))+genLabelText =+  Gen.choice [pure Nothing, Just . pretty <$> Gen.text (Range.linear 1 10) Gen.alpha]++genLabelKind :: Gen LabelKind+genLabelKind = Gen.element [Primary, Secondary]++genLabeledSpan :: Gen (Labeled Span)+genLabeledSpan = Labeled <$> genSpan <*> genLabelKind <*> genLabelText++genLabeledSpans :: Gen (NonEmpty (Labeled Span))+genLabeledSpans = do+  x  <- genLabeledSpan+  xs <- Gen.list (Range.linear 0 6) genLabeledSpan+  pure (x :| xs)++-- One group: a source, and the non-empty label list resolved against it.+genGroup :: Gen (NamedSource, NonEmpty (Labeled Span))+genGroup = (,) <$> genNamedSource <*> genLabeledSpans++-- One to four groups, in generation order (order matters -- these properties+-- check it's preserved).+genGroups :: Gen (NonEmpty (NamedSource, NonEmpty (Labeled Span)))+genGroups = do+  g  <- genGroup+  gs <- Gen.list (Range.linear 0 3) genGroup+  pure (g :| gs)++isStale :: LabelState -> Bool+isStale (LabelStale _) = True+isStale (LabelOk _)    = False++-- Entries shape 'buildContextMulti' takes, from a group's already-resolved-+-- shaped input -- the same (span, kind, text) triples 'buildContextWith'+-- takes per label, one source per group.+asEntries :: (NamedSource, NonEmpty (Labeled Span)) -> (NamedSource, [(Span, LabelKind, Maybe (Doc Ann))])+asEntries (src, lbls) = (src, map toEntry (NE.toList lbls))+  where toEntry (Labeled sp k txt) = (sp, k, txt)++-- === Properties ==============================================================++prop_multiStrict :: Property+prop_multiStrict = property $ do+  groups <- forAll genGroups+  let anyOOB = any groupHasOOB (NE.toList groups)+      groupHasOOB (src, lbls) =+        any (\(Labeled sp _ _) -> isLeft (resolveSpan src sp)) (NE.toList lbls)+  isLeft (mkContextMulti groups) === anyOOB++prop_multiDegradingCount :: Property+prop_multiDegradingCount = property $ do+  groups <- forAll genGroups+  let states   = contextLabelStates (mkContextMultiDegrading groups)+      expected = concatMap expectGroup (NE.toList groups)+      expectGroup (src, lbls) =+        [ isLeft (resolveSpan src sp) | Labeled sp _ _ <- NE.toList lbls ]+  -- 1. total count preserved across every group+  length states === sum (fmap (NE.length . snd) groups)+  -- 2. LabelStale in exactly the positions whose span fails to resolve,+  --    per group, in group order -- never dropped, never reordered, and+  --    never attributed to the wrong group's source.+  map isStale states === expected++prop_singleGroupMatchesMulti :: Property+prop_singleGroupMatchesMulti = property $ do+  src  <- forAll genNamedSource+  lbls <- forAll genLabeledSpans+  -- The total constructor: single-source result matches the one-group+  -- multi-source result, label for label.+  contextLabelStates (mkContextDegrading src lbls)+    === contextLabelStates (mkContextMultiDegrading ((src, lbls) :| []))+  -- The strict constructor: same success/failure shape, and the same+  -- resulting labels on success.+  case (mkContext src lbls, mkContextMulti ((src, lbls) :| [])) of+    (Left _,    Left _)    -> success+    (Right c1,  Right c2)  -> contextLabelStates c1 === contextLabelStates c2+    (Left _,    Right _)   -> failure+    (Right _,   Left _)    -> failure++prop_buildContextMultiAllEmpty :: Property+prop_buildContextMultiAllEmpty = withTests 20 . property $ do+  srcs <- forAll (Gen.list (Range.linear 1 4) genNamedSource)+  case NE.nonEmpty srcs of+    Nothing -> success   -- unreachable: Range.linear 1 4 never generates []+    Just ne -> case buildContextMulti (fmap (, []) ne) of+      NoContext -> success+      _         -> failure++prop_buildContextMultiDispatch :: Property+prop_buildContextMultiDispatch = property $ do+  groups <- forAll genGroups+  let built  = buildContextMulti (fmap asEntries groups)+      viaDeg = mkContextMultiDegrading groups+  contextLabelStates built === contextLabelStates viaDeg++prop_buildContextMultiDropsEmptyGroups :: Property+prop_buildContextMultiDropsEmptyGroups = property $ do+  groups   <- forAll genGroups+  emptySrc <- forAll genNamedSource+  let withEmpty = (emptySrc, []) <| fmap asEntries groups+  contextLabelStates (buildContextMulti withEmpty)+    === contextLabelStates (buildContextMulti (fmap asEntries groups))
+ test/props/Phase13.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}++-- | Every constructor below needs its own source/span/message shape, so at+-- least one field per constructor (the payload distinguishing that variant)+-- is inherently partial: GHC's auto-generated accessor for e.g. 'tmExpected'+-- can only be total if every constructor has a 'tmExpected' field of the+-- same type, which isn't true of a genuinely heterogeneous sum type by+-- definition. Shared fields ('crSrc', 'crAt') are named and typed+-- identically across all three constructors specifically to avoid this+-- where the shape genuinely allows it; the rest ('peId', 'tmExpected',+-- 'tmActual', 'uvName', 'uvPrior', 'uvRelated', 'uvCause', 'uvId') cannot be+-- shared without losing the type-level distinction the test exists to+-- exercise, so the warning is suppressed here rather than upstream —+-- any real 'deriveDiagnosticSum' consumer with a similarly heterogeneous+-- sum type hits the same tradeoff and makes the same call locally.+{-# OPTIONS_GHC -Wno-partial-fields #-}+#if __GLASGOW_HASKELL__ >= 910+{-# OPTIONS_GHC -Wno-incomplete-record-selectors #-}+#endif+++module Phase13 (group) where++import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog                   (Group (..), Property, property, withTests, (===))++import           Tadka+import           Tadka.Internal             (buildContext, buildContextWith)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- === Derived via deriveDiagnosticSum =======================================++data CompileError+  = ParseFailure { crSrc :: NamedSource, crAt :: Span, peId :: DiagnosticId }+  | TypeMismatch { crSrc :: NamedSource, crAt :: Span, tmExpected :: Text, tmActual :: Text }+  | UndefinedVar { crSrc :: NamedSource, crAt :: Span, uvName :: Text, uvPrior :: [Span]+                 , uvRelated :: [SomeDiagnostic], uvCause :: Maybe SomeDiagnostic, uvId :: Text }++deriveDiagnosticSum+  [ ( 'ParseFailure+    , defaultSpec+        { specCode        = Just "tadka::E0101"+        , specSourceField = Just 'crSrc+        , specLabelFields = [('crAt, "here")]+        , specId          = Just 'peId+        , specMessage     = Just [| \_ -> pretty ("unexpected token" :: Text) |]+        }+    )+  , ( 'TypeMismatch+    , defaultSpec+        { specSeverity    = SevWarning+        , specHelp        = Just "check the type annotation"+        , specSourceField = Just 'crSrc+        , specLabelFields = [('crAt, "here")]+        , specMessage     = Just [| \e -> pretty ("type mismatch: expected " <> tmExpected e+                                                     <> ", got " <> tmActual e) |]+        }+    )+  , ( 'UndefinedVar+    , defaultSpec+        { specSourceField                    = Just 'crSrc+        , specLabelFields                    = [('crAt, "used here")]+        , specSecondaryLabelCollectionFields  = [('uvPrior, "shadowed here")]+        , specRelated                        = Just 'uvRelated+        , specCause                          = Just 'uvCause+        , specId                             = Just 'uvId+        , specMessage                        = Just [| \e -> pretty ("undefined variable " <> uvName e) |]+        }+    )+  ]+  ''CompileError++-- === Hand-written twin: identical fields, identical bodies =================++data CompileErrorManual+  = ParseFailureM { crmSrc :: NamedSource, crmAt :: Span, pemId :: DiagnosticId }+  | TypeMismatchM { crmSrc :: NamedSource, crmAt :: Span, tmmExpected :: Text, tmmActual :: Text }+  | UndefinedVarM { crmSrc :: NamedSource, crmAt :: Span, uvmName :: Text, uvmPrior :: [Span]+                  , uvmRelated :: [SomeDiagnostic], uvmCause :: Maybe SomeDiagnostic, uvmId :: Text }++instance Diagnostic CompileErrorManual where+  message ParseFailureM{}                        = pretty ("unexpected token" :: Text)+  message (TypeMismatchM { tmmExpected = ex, tmmActual = ac }) =+    pretty ("type mismatch: expected " <> ex <> ", got " <> ac)+  message (UndefinedVarM { uvmName = nm })       = pretty ("undefined variable " <> nm)++  code (ParseFailureM {}) = Just (rightOrErr (mkDiagnosticCode "tadka::E0101"))+  code _                  = Nothing++  severity (TypeMismatchM {}) = SevWarning+  severity _                  = SevError++  help (TypeMismatchM {}) = Just (pretty ("check the type annotation" :: Text))+  help _                  = Nothing++  context (ParseFailureM { crmSrc = s, crmAt = a }) = buildContext s [(a, Just "here")]+  context (TypeMismatchM { crmSrc = s, crmAt = a }) = buildContext s [(a, Just "here")]+  context (UndefinedVarM { crmSrc = s, crmAt = a, uvmPrior = prior }) =+    buildContextWith s+      (  [ (a, Primary, Just "used here") ]+      ++ [ (p, Secondary, Just "shadowed here") | p <- prior ] )++  related (UndefinedVarM { uvmRelated = r }) = r+  related _                                  = []++  diagnosticCause (UndefinedVarM { uvmCause = c }) = c+  diagnosticCause _                                = Nothing++  diagnosticId (ParseFailureM { pemId = i }) = Just i+  diagnosticId (UndefinedVarM { uvmId = i })  = Just (mkDiagnosticId i)+  diagnosticId _                              = Nothing++-- === Fixtures ===============================================================++srcV :: NamedSource+srcV = rightOrErr (mkNamedSource "f.hs" "let x = 1 in y")++spanX, spanY :: Span+spanX = rightOrErr (mkSpan 4 1)    -- "x"+spanY = rightOrErr (mkSpan 14 1)   -- "y"++priorD :: CompileError+priorD = ParseFailure srcV spanX (mkDiagnosticId "prior")++priorM :: CompileErrorManual+priorM = ParseFailureM srcV spanX (mkDiagnosticId "prior")++pfD :: CompileError+pfD = ParseFailure srcV spanX (mkDiagnosticId "pf-1")++pfM :: CompileErrorManual+pfM = ParseFailureM srcV spanX (mkDiagnosticId "pf-1")++tmD :: CompileError+tmD = TypeMismatch srcV spanX "Int" "Bool"++tmM :: CompileErrorManual+tmM = TypeMismatchM srcV spanX "Int" "Bool"++uvD :: CompileError+uvD = UndefinedVar srcV spanY "y" [spanX] [SomeDiagnostic priorD] (Just (SomeDiagnostic priorD)) "uv-1"++uvM :: CompileErrorManual+uvM = UndefinedVarM srcV spanY "y" [spanX] [SomeDiagnostic priorM] (Just (SomeDiagnostic priorM)) "uv-1"++-- === Renderers (identical to Phase 8's) =====================================++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++nar :: Diagnostic e => e -> Text+nar e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++jsn :: Diagnostic e => e -> Text+jsn e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++-- === Properties =============================================================++prop_parseFailure :: Property+prop_parseFailure = withTests 1 . property $ do+  gfx pfD === gfx pfM+  nar pfD === nar pfM+  jsn pfD === jsn pfM++prop_typeMismatch :: Property+prop_typeMismatch = withTests 1 . property $ do+  gfx tmD === gfx tmM+  nar tmD === nar tmM+  jsn tmD === jsn tmM++prop_undefinedVar :: Property+prop_undefinedVar = withTests 1 . property $ do+  gfx uvD === gfx uvM+  nar uvD === nar uvM+  jsn uvD === jsn uvM++group :: Group+group = Group "Phase 13 - deriveDiagnosticSum (derived == manual, per constructor)"+  [ ("ParseFailure: full property", prop_parseFailure)+  , ("TypeMismatch: full property", prop_typeMismatch)+  , ("UndefinedVar (secondary collection + related + cause): full property", prop_undefinedVar)+  ]
+ test/props/Phase2.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Phase 2 properties: span resolution and Context construction. The crux is+-- that 'mkContextDegrading' never changes the label count or ordering.+module Phase2 (group) where++import           Data.Either        (isLeft)+import           Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import           Data.Text          (Text)+import qualified Data.Text          as T+import           Prettyprinter      (Doc, pretty)++import           Hedgehog+                   (Gen, Group (..), Property, assert, failure, forAll,+                    property, success, withTests, (===))+import qualified Hedgehog.Gen       as Gen+import qualified Hedgehog.Range     as Range++import           Tadka+import           Tadka.Internal.Span  (spanLength, spanOffset)+import           Tadka.Internal.Types (unLength, unOffset)+import           Tadka.Internal     (buildContext)++group :: Group+group = Group "Phase 2 - span resolution & context"+  [ ("resolveSpan stays within source bounds",              prop_resolveInBounds)+  , ("resolveSpan handles overflowing span end",             prop_resolveOverflow)+  , ("mkContext is Left iff any span is out of bounds",     prop_mkContextStrict)+  , ("mkContextDegrading never changes label count/order",  prop_degradingCount)+  , ("buildContext [] = NoContext",                         prop_buildContextEmpty)+  , ("buildContext dispatches to mkContextDegrading",       prop_buildContextDispatch)+  ]++genSourceText :: Gen Text+genSourceText =+  Gen.text (Range.linear 0 40)+    (Gen.frequency [(6, Gen.alphaNum), (2, Gen.constant ' '), (2, Gen.constant '\n')])++genNamedSource :: Gen NamedSource+genNamedSource = do+  name <- Gen.text (Range.linear 1 8) Gen.alpha+  txt  <- genSourceText+  either (const Gen.discard) pure (mkNamedSource name txt)++-- Offsets/lengths in a range that straddles typical source lengths, so some+-- spans resolve and some are out of bounds.+genSpan :: Gen Span+genSpan = do+  o <- Gen.int (Range.linear 0 50)+  l <- Gen.int (Range.linear 0 50)+  either (const Gen.discard) pure (mkSpan o l)++genLabelText :: Gen (Maybe (Doc Ann))+genLabelText =+  Gen.choice [pure Nothing, Just . pretty <$> Gen.text (Range.linear 1 10) Gen.alpha]++genLabelKind :: Gen LabelKind+genLabelKind = Gen.element [Primary, Secondary]++genLabeledSpan :: Gen (Labeled Span)+genLabeledSpan = Labeled <$> genSpan <*> genLabelKind <*> genLabelText++genLabeledSpans :: Gen (NonEmpty (Labeled Span))+genLabeledSpans = do+  x  <- genLabeledSpan+  xs <- Gen.list (Range.linear 0 6) genLabeledSpan+  pure (x :| xs)++prop_resolveInBounds :: Property+prop_resolveInBounds = property $ do+  src <- forAll genNamedSource+  sp  <- forAll genSpan+  case resolveSpan src sp of+    Left _   -> success+    Right rs -> do+      let o = unOffset (spanOffset rs)+          l = unLength (spanLength rs)+      assert (o >= 0)+      assert (o + l <= T.length (sourceText src))++prop_resolveOverflow :: Property+prop_resolveOverflow = withTests 1 . property $ do+  src <- forAll genNamedSource+  sp  <- either (const failure) pure (mkSpan maxBound 1)+  case resolveSpan src sp of+    Left err -> do+      let expectedEnd = toInteger (maxBound :: Int) + 1+      spanErrorSpanEnd err === expectedEnd+    Right _ ->+      failure++prop_mkContextStrict :: Property+prop_mkContextStrict = property $ do+  src  <- forAll genNamedSource+  lbls <- forAll genLabeledSpans+  let anyOOB = any (\(Labeled sp _ _) -> isLeft (resolveSpan src sp)) (NE.toList lbls)+  isLeft (mkContext src lbls) === anyOOB++prop_degradingCount :: Property+prop_degradingCount = property $ do+  src  <- forAll genNamedSource+  lbls <- forAll genLabeledSpans+  let states = contextLabelStates (mkContextDegrading src lbls)+  -- 1. count preserved+  length states === NE.length lbls+  -- 2. LabelStale in exactly the positions whose span fails to resolve+  let expectedStale = map (\(Labeled sp _ _) -> isLeft (resolveSpan src sp)) (NE.toList lbls)+  map isStale states === expectedStale+  where+    isStale (LabelStale _) = True+    isStale (LabelOk _)    = False++prop_buildContextEmpty :: Property+prop_buildContextEmpty = withTests 1 . property $ do+  src <- forAll genNamedSource+  case buildContext src [] of+    NoContext -> success+    _         -> failure++prop_buildContextDispatch :: Property+prop_buildContextDispatch = property $ do+  src <- forAll genNamedSource+  neq <- forAll genLabeledSpans+  let items  = map (\(Labeled sp _ txt) -> (sp, txt)) (NE.toList neq)+      built  = buildContext src items+      viaDeg = mkContextDegrading src neq+  contextLabelStates built === contextLabelStates viaDeg
+ test/props/Phase3.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Phase 3 properties: the Diagnostic class and the shared related/cycle walk.+module Phase3 (group) where++import           Data.Text          (Text)+import qualified Data.Text+import           Numeric.Natural    (Natural)+import           Prettyprinter      (pretty)++import           Hedgehog+                   (Gen, Group (..), Property, assert, forAll, forAllWith, property,+                    withTests, (===))+import qualified Hedgehog.Gen       as Gen+import qualified Hedgehog.Range     as Range++import           Tadka+                   (Diagnostic (..), DiagnosticId, SomeDiagnostic (..),+                    mkDiagnosticId)+import           Tadka.Internal.Related+                   (RelatedTree (..), TerminationReason (..), defaultRelatedDepth,+                    flattenRelated, walkRelated)++group :: Group+group = Group "Phase 3 - diagnostic class & related walk"+  [ ("default related depth is 8",                         prop_defaultDepth)+  , ("cycle: shared id visited once, not descended",       prop_cycleVisitedOnce)+  , ("Nothing-only infinite chain terminates by depth",    prop_nothingInfiniteTerminates)+  , ("Nothing-only chains are depth-limited (v4 behavior)", prop_nothingDepthLimited)+  , ("walk is total & depth-bounded for any fuelled tree", prop_walkTotal)+  ]++-- | A minimal test diagnostic: only identity and related children matter for+-- the walk. Everything else is defaulted.+data TestDiag = TestDiag+  { tdId      :: Maybe DiagnosticId+  , tdRelated :: [SomeDiagnostic]+  }++instance Diagnostic TestDiag where+  message _    = pretty ("test" :: Text)+  diagnosticId = tdId+  related      = tdRelated++-- | Random finite tree with fresh (never shared) ids, bounded by fuel.+genFuelledDiag :: (Int -> Gen (Maybe DiagnosticId)) -> Int -> Gen SomeDiagnostic+genFuelledDiag genId fuel = do+  mId  <- genId fuel+  kids <- if fuel <= 0+            then pure []+            else Gen.list (Range.linear 0 3) (genFuelledDiag genId (fuel `div` 2))+  pure (SomeDiagnostic (TestDiag mId kids))++genNoId :: Int -> Gen (Maybe DiagnosticId)+genNoId _ = pure Nothing++genFreshId :: Int -> Gen (Maybe DiagnosticId)+genFreshId fuel =+  Gen.choice+    [ pure Nothing+    , Just . mkDiagnosticId <$> Gen.text (Range.linear 1 4) Gen.alpha+        -- salt with fuel so ids across levels rarely collide (fresh-ish)+    , pure (Just (mkDiagnosticId (pretty' fuel)))+    ]+  where+    pretty' n = "n" <> tshow n+    tshow = Data.Text.pack . show++treeDepth :: RelatedTree -> Int+treeDepth (RelatedTree _ []   _) = 1+treeDepth (RelatedTree _ kids _) = 1 + maximum (map treeDepth kids)++prop_defaultDepth :: Property+prop_defaultDepth = withTests 1 . property $ defaultRelatedDepth === (8 :: Natural)++-- Two nodes sharing ids in a cycle A -> B -> A: the second A is a CycleOmitted+-- leaf, reached once, never descended.+prop_cycleVisitedOnce :: Property+prop_cycleVisitedOnce = withTests 1 . property $ do+  let idA = mkDiagnosticId "A"+      idB = mkDiagnosticId "B"+      a   = TestDiag (Just idA) [SomeDiagnostic b]+      b   = TestDiag (Just idB) [SomeDiagnostic a]+      nodes = flattenRelated (walkRelated 8 (SomeDiagnostic a))+  -- exactly: A (root), B, A(cycle marker)+  length nodes === 3+  length (filter (\(_, t) -> t == CycleOmitted) nodes) === 1++-- A structurally infinite Nothing-only chain still terminates, bounded by depth.+prop_nothingInfiniteTerminates :: Property+prop_nothingInfiniteTerminates = withTests 1 . property $ do+  let loop  = TestDiag Nothing [SomeDiagnostic loop]+      nodes = flattenRelated (walkRelated 5 (SomeDiagnostic loop))+  length nodes === 6                                   -- root + 5 descents+  assert (any (\(_, t) -> t == DepthTruncated) nodes)+  assert (all (\(_, t) -> t /= CycleOmitted) nodes)    -- no ids => no cycle path++-- v4 fallback: Nothing-only trees are depth-limited, never cycle-omitted.+prop_nothingDepthLimited :: Property+prop_nothingDepthLimited = property $ do+  limit <- fromIntegral <$> forAll (Gen.int (Range.linear 0 6))+  fuel  <- forAll (Gen.int (Range.linear 0 24))+  root  <- forAllWith (const "<diag>") (genFuelledDiag genNoId fuel)+  let tree  = walkRelated limit root+      nodes = flattenRelated tree+  assert (length nodes >= 1)+  assert (all (\(_, t) -> t /= CycleOmitted) nodes)+  assert (treeDepth tree <= fromIntegral limit + 1)    -- root level + `limit` descents++-- The walk is total (finite result) and depth-bounded for any fuelled tree,+-- with or without ids.+prop_walkTotal :: Property+prop_walkTotal = property $ do+  limit <- fromIntegral <$> forAll (Gen.int (Range.linear 0 5))+  fuel  <- forAll (Gen.int (Range.linear 0 20))+  root  <- forAllWith (const "<diag>") (genFuelledDiag genFreshId fuel)+  let tree  = walkRelated limit root+      nodes = flattenRelated tree+  assert (length nodes >= 1)                           -- forces full evaluation+  assert (treeDepth tree <= fromIntegral limit + 1)
+ test/props/Phase4.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Phase 4 properties: the one path from Config to a renderer. The exit+-- criterion is that an explicit `withTarget` is never overridden by detection.+module Phase4 (group) where++import           Data.Aeson         (Value (Object))+import           Data.Text          (Text)+import qualified Data.Text          as T+import           Prettyprinter      (pretty)++import           Hedgehog+                   (Gen, Group (..), Property, assert, failure, forAll, property,+                    success, withTests, (===))+import qualified Hedgehog.Gen       as Gen++import           Tadka++group :: Group+group = Group "Phase 4 - renderer/config scaffolding"+  [ ("withTarget override is honoured by selectRenderer", prop_targetOverride)+  , ("override survives other setters",                   prop_overrideSurvivesSetters)+  , ("no explicit target defaults to graphical",          prop_defaultTarget)+  , ("render produces output for each target",            prop_renderSmoke)+  ]++-- A trivial diagnostic: only `message`, everything else defaulted.+data TrivialDiag = TrivialDiag++instance Diagnostic TrivialDiag where+  message _ = pretty ("trivial" :: Text)++targetOf :: SomeRenderer -> Target+targetOf (SomeRenderer (Graphical _))  = TGraphical+targetOf (SomeRenderer (Narratable _)) = TNarratable+targetOf (SomeRenderer (Json _))       = TJson++genTarget :: Gen Target+genTarget = Gen.enumBounded++prop_targetOverride :: Property+prop_targetOverride = property $ do+  t <- forAll genTarget+  targetOf (selectRenderer (withTarget t defaultConfig)) === t++prop_overrideSurvivesSetters :: Property+prop_overrideSurvivesSetters = property $ do+  t <- forAll genTarget+  let cfg = withColorMode ColorNever+          . withUnicodeMode UnicodeAscii+          . withRelatedDepthLimit 3+          . withTarget t+          $ defaultConfig+  targetOf (selectRenderer cfg) === t++prop_defaultTarget :: Property+prop_defaultTarget = withTests 1 . property $+  targetOf (selectRenderer defaultConfig) === TGraphical++-- Extract each target's output through a pure helper with a concrete return+-- type; matching the GADT existential directly inside the property monad would+-- leave the result type untouchable.+narratableOutput :: Diagnostic e => Config -> e -> Maybe Text+narratableOutput cfg e = case selectRenderer cfg of+  SomeRenderer r@(Narratable _) -> Just (render r e)+  _                             -> Nothing++jsonOutput :: Diagnostic e => Config -> e -> Maybe Value+jsonOutput cfg e = case selectRenderer cfg of+  SomeRenderer r@(Json _) -> Just (render r e)+  _                       -> Nothing++-- Smoke: each target's render path runs and carries the message through.+prop_renderSmoke :: Property+prop_renderSmoke = withTests 1 . property $ do+  case narratableOutput (withTarget TNarratable defaultConfig) TrivialDiag of+    Just t  -> assert ("trivial" `T.isInfixOf` t)+    Nothing -> failure+  case jsonOutput (withTarget TJson defaultConfig) TrivialDiag of+    Just (Object _) -> success+    _               -> failure
+ test/props/Phase5.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Phase 5 properties: width-aware caret layout, palette cycling, and a+-- totality smoke check for the graphical handler.+module Phase5 (group) where++import           Control.Exception             (SomeException, evaluate, try)+import           Control.Monad.IO.Class         (liftIO)+import qualified Data.List.NonEmpty             as NE+import           Data.Text                      (Text)+import qualified Data.Text                      as T+import           Prettyprinter                  (LayoutOptions (..),+                                                 PageWidth (Unbounded), layoutPretty)+import           Prettyprinter.Render.Terminal  (AnsiStyle, Color (..), color)+import           Prettyprinter.Render.Text      (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen                   as Gen+import qualified Hedgehog.Range                 as Range++import           Tadka+import           Tadka.Internal.Renderer.Graphical (caretGlyph, caretLayout, labelStyle)+import           Tadka.Internal.Width           (textWidth)++import           GenDiag                        (genGD, genLine, selfJust, selfNothing)++group :: Group+group = Group "Phase 5 - graphical handler"+  [ ("caret layout is non-negative and width-aware", prop_caretLayout)+  , ("caret glyph distinguishes primary/secondary",  prop_caretGlyph)+  , ("caret glyph cycles by per-kind rank",           prop_caretGlyphCyclesByRank)+  , ("label palette cycles as (i mod p)",             prop_paletteCycling)+  , ("graphical render is total (fuelled diagnostics)", prop_totality)+  , ("graphical render is total (pathological cycles)", prop_totalityCycles)+  ]++-- === caret layout =========================================================++prop_caretLayout :: Property+prop_caretLayout = property $ do+  line <- forAll genLine+  tabW <- forAll (Gen.int (Range.linear 1 8))+  let n = T.length line+  startCol <- forAll (Gen.int (Range.linear 1 (n + 1)))+  spanLen  <- forAll (Gen.int (Range.linear 0 (n + 5)))+  let (dispStart, caretWidth) = caretLayout tabW line startCol spanLen+  -- never negative, never collapses+  assert (dispStart >= 0)+  assert (caretWidth >= 1)+  -- width-aware: for tab-free text (genLine emits none) the display offset is+  -- exactly the prefix width; the tab-inclusive case is proved in the Tabs group+  dispStart === textWidth (T.take (startCol - 1) line)+  -- caret starts within (or at the end of) the line's display extent, so it+  -- can never intrude on the fixed line-number gutter to its left+  assert (dispStart <= textWidth line)++prop_caretGlyph :: Property+prop_caretGlyph = withTests 1 . property $ do+  caretGlyph ColorNever Primary   0 === '^'+  caretGlyph ColorNever Primary   1 === '~'+  caretGlyph ColorNever Secondary 0 === '-'+  caretGlyph ColorNever Secondary 1 === '~'+  caretGlyph ColorAlways Primary   5 === '^'+  caretGlyph ColorAlways Secondary 5 === '^'++-- | Rank cycles through a 3-character alphabet ('^'\/'-'  then '~' then '=')+-- for each kind under 'ColorNever'; any colour mode is always '^' regardless+-- of rank.+prop_caretGlyphCyclesByRank :: Property+prop_caretGlyphCyclesByRank = property $ do+  k <- forAll (Gen.element [Primary, Secondary])+  r <- forAll (Gen.int (Range.linear 0 20))+  caretGlyph ColorNever k r === caretGlyph ColorNever k (r + 3)++-- === palette cycling ======================================================++palColors :: [AnsiStyle]+palColors = map color [Red, Green, Yellow, Blue, Magenta, Cyan, White, Black]++prop_paletteCycling :: Property+prop_paletteCycling = property $ do+  p <- forAll (Gen.int (Range.linear 1 (length palColors)))+  i <- forAll (Gen.int (Range.linear 0 60))+  let palette = NE.fromList (take p palColors)+  labelStyle palette i === (NE.toList palette !! (i `mod` p))++-- === totality =============================================================++renderText :: Diagnostic e => e -> Text+renderText e = case selectRenderer (withColorMode ColorNever (withTarget TGraphical defaultConfig)) of+  SomeRenderer r@(Graphical _) ->+    renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _ -> ""++prop_totality :: Property+prop_totality = property $ do+  fuel <- forAll (Gen.int (Range.linear 0 3))+  d    <- forAllWith (const "<generated diagnostic>") (genGD fuel)+  res  <- liftIO (try (evaluate (T.length (renderText d))) :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure++prop_totalityCycles :: Property+prop_totalityCycles = withTests 1 . property $ do+  res <- liftIO (try (evaluate (sum (map (T.length . renderText) [selfNothing, selfJust])))+                   :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure
+ test/props/Phase6.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Phase 6 properties: prose-marker interpretation of 'Ann', and a totality+-- smoke check for the narratable handler over the shared generated set.+module Phase6 (group) where++import           Control.Exception          (SomeException, evaluate, try)+import           Control.Monad.IO.Class      (liftIO)+import           Data.Text                   (Text)+import qualified Data.Text                   as T+import qualified Prettyprinter               as PP++import           Hedgehog+import qualified Hedgehog.Gen                as Gen+import qualified Hedgehog.Range              as Range++import           GenDiag                     (genGD, selfJust, selfNothing)+import           Tadka++group :: Group+group = Group "Phase 6 - narratable handler"+  [ ("AnnCode renders quoted in prose",            prop_annCodeQuoted)+  , ("narratable render is total (fuelled)",       prop_totality)+  , ("narratable render is total (pathological)",  prop_totalityCycles)+  ]++-- A diagnostic whose message carries an AnnCode span, to exercise toProseMarker.+data Coded = Coded Text++instance Diagnostic Coded where+  message (Coded ident) = "undefined variable " <> PP.annotate AnnCode (PP.pretty ident)++renderText :: Diagnostic e => e -> Text+renderText e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++-- The narratable handler wraps AnnCode content in double quotes.+prop_annCodeQuoted :: Property+prop_annCodeQuoted = property $ do+  ident <- forAll (Gen.text (Range.linear 1 8) (Gen.enum 'a' 'z'))+  let out = renderText (Coded ident)+  assert (("\"" <> ident <> "\"") `T.isInfixOf` out)++prop_totality :: Property+prop_totality = property $ do+  fuel <- forAll (Gen.int (Range.linear 0 3))+  d    <- forAllWith (const "<generated diagnostic>") (genGD fuel)+  res  <- liftIO (try (evaluate (T.length (renderText d))) :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate' e++prop_totalityCycles :: Property+prop_totalityCycles = withTests 1 . property $ do+  res <- liftIO (try (evaluate (sum (map (T.length . renderText) [selfNothing, selfJust])))+                   :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate' e++annotate' :: SomeException -> PropertyT IO ()+annotate' e = annotate (show e) >> failure
+ test/props/Phase7.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Phase 7 properties: the @stale@ flag is derived from 'LabelState' (not+-- inferred from absence), and a totality smoke check for the JSON handler.+module Phase7 (group) where++import           Control.Exception          (SomeException, evaluate, try)+import           Control.Monad.IO.Class     (liftIO)+import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (pretty)++import           Hedgehog+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           GenDiag                    (GD (..), genGD, selfJust, selfNothing)+import           Tadka+import           Tadka.Internal             (buildContext)+import           Tadka.Internal.Related     (walkRelated)+import           Tadka.Internal.Renderer.Json (DiagnosticDTO (..), LabelDTO (..), toDTO)++group :: Group+group = Group "Phase 7 - JSON handler + DTO"+  [ ("ok label -> stale:false with position",   prop_okLabel)+  , ("stale label -> stale:true, null position", prop_staleLabel)+  , ("JSON render is total (fuelled)",           prop_totality)+  , ("JSON render is total (pathological)",      prop_totalityCycles)+  ]++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Build a one-label DTO for a diagnostic with the given span over "abcdef".+labelOf :: Int -> Int -> LabelDTO+labelOf off len =+  case dtoLabels (toDTO 8 (walkRelated 8 (SomeDiagnostic d))) of+    (l:_) -> l+    []    -> error "labelOf: expected exactly one label"+  where+    src = rightOrErr (mkNamedSource "f.hs" "abcdef")+    d   = GD "m" Nothing+             (buildContext src [(rightOrErr (mkSpan off len), Just (pretty ("x" :: Text)))])+             Nothing Nothing [] Nothing Nothing++prop_okLabel :: Property+prop_okLabel = property $ do+  len <- forAll (Gen.int (Range.linear 1 3))+  let l = labelOf 1 len       -- in bounds => LabelOk+  ldStale l  === False+  ldLine l   === Just 1+  ldLength l === Just len++prop_staleLabel :: Property+prop_staleLabel = withTests 1 . property $ do+  let l = labelOf 100 3       -- out of bounds => LabelStale+  ldStale l  === True+  ldLine l   === Nothing+  ldColumn l === Nothing+  ldLength l === Nothing++renderJsonText :: Diagnostic e => e -> Text+renderJsonText e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++prop_totality :: Property+prop_totality = property $ do+  fuel <- forAll (Gen.int (Range.linear 0 3))+  d    <- forAllWith (const "<generated diagnostic>") (genGD fuel)+  res  <- liftIO (try (evaluate (T.length (renderJsonText d))) :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure++prop_totalityCycles :: Property+prop_totalityCycles = withTests 1 . property $ do+  res <- liftIO (try (evaluate (sum (map (T.length . renderJsonText) [selfNothing, selfJust])))+                   :: IO (Either SomeException Int))+  case res of+    Right _ -> success+    Left e  -> annotate (show e) >> failure
+ test/props/Phase8.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Phase 8: the derive path and the manual path are two doors into the same+-- room. A @deriveDiagnostic@-generated instance and a hand-written instance for+-- a structurally identical type render byte-for-byte identically across all+-- three handlers.+module Phase8 (group) where++import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog                   (Group (..), Property, property, withTests, (===))++import           Tadka+import           Tadka.Internal             (buildContext)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Derived via the macro (specMessage keeps the message value-dependent, matching+-- the manual twin exactly rather than dumping the whole record via `show`).+data DErr = DErr { dSrc :: NamedSource, dAt :: Span, dGot :: Text }+  deriving (Show)++deriveDiagnostic defaultSpec+  { specCode        = Just "tadka::E0007"+  , specHelp        = Just "try renaming it"+  , specUrl         = Just "https://example.org/errors/E0007"+  , specSourceField = Just 'dSrc+  , specLabelFields = [('dAt, "here")]+  , specMessage     = Just [| \e -> pretty ("undefined variable " <> dGot e) |]+  }+  ''DErr++-- Hand-written twin: identical fields, identical bodies (calling the same+-- shared functions a manual author would use).+data MErr = MErr { mSrc :: NamedSource, mAt :: Span, mGot :: Text }++instance Diagnostic MErr where+  message e = pretty ("undefined variable " <> mGot e)+  code _    = Just (rightOrErr (mkDiagnosticCode "tadka::E0007"))+  severity _ = SevError+  help _    = Just (pretty ("try renaming it" :: Text))+  url _     = Just (rightOrErr (mkUrl "https://example.org/errors/E0007"))+  context e = buildContext (mSrc e) [(mAt e, Just (pretty ("here" :: Text)))]++srcV :: NamedSource+srcV = rightOrErr (mkNamedSource "f.hs" "x = foo")++spanV :: Span+spanV = rightOrErr (mkSpan 4 3)   -- "foo"++dVal :: DErr+dVal = DErr srcV spanV "foo"++mVal :: MErr+mVal = MErr srcV spanV "foo"++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++nar :: Diagnostic e => e -> Text+nar e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++jsn :: Diagnostic e => e -> Text+jsn e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++once :: (Text, Text) -> Property+once (a, b) = withTests 1 (property (a === b))++group :: Group+group = Group "Phase 8 - deriveDiagnostic (derived == manual)"+  [ ("graphical renders identically",  once (gfx dVal, gfx mVal))+  , ("narratable renders identically", once (nar dVal, nar mVal))+  , ("json renders identically",       once (jsn dVal, jsn mVal))+  ]
+ test/props/Phase9.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Phase 9: the generics path derives only 'context', identically to a+-- hand-written 'buildContext' call. @genericContext :: e -> Context@ can, by its+-- type, touch nothing else — code/severity/help/url/message/diagnosticId stay at+-- their class defaults here, exactly as in the manual twin.+module Phase9 (group) where++import qualified Data.Aeson                 as A+import           Data.Text                  (Text)+import qualified Data.Text.Lazy             as TL+import qualified Data.Text.Lazy.Encoding    as TLE+import           GHC.Generics               (Generic)+import           Prettyprinter              (LayoutOptions (..), PageWidth (Unbounded),+                                             layoutPretty, pretty)+import           Prettyprinter.Render.Text  (renderStrict)++import           Hedgehog                   (Group (..), Property, property, withTests, (===))++import           Tadka+import           Tadka.Internal             (buildContext)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Generics-wired: only message + context; context comes from genericContext,+-- which uses the Span field selector names ("gfrom", "gto") as label text.+data GErr = GErr { gsrc :: NamedSource, gfrom :: Span, gto :: Span }+  deriving (Generic)++instance Diagnostic GErr where+  message _ = "generic label wiring"+  context   = genericContext++-- Hand-written twin: same message, context via an explicit buildContext call+-- with the same label texts and order.+data MErr = MErr { msrc :: NamedSource, mfrom :: Span, mto :: Span }++instance Diagnostic MErr where+  message _ = "generic label wiring"+  context e = buildContext (msrc e)+    [ (mfrom e, Just (pretty ("gfrom" :: Text)))+    , (mto e,   Just (pretty ("gto"   :: Text)))+    ]++srcV :: NamedSource+srcV = rightOrErr (mkNamedSource "f.hs" "abcdefghij")++gVal :: GErr+gVal = GErr srcV (rightOrErr (mkSpan 0 3)) (rightOrErr (mkSpan 5 2))++mVal :: MErr+mVal = MErr srcV (rightOrErr (mkSpan 0 3)) (rightOrErr (mkSpan 5 2))++gfx :: Diagnostic e => e -> Text+gfx e = case selectRenderer (withColorMode ColorNever (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+  SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+  _                            -> ""++nar :: Diagnostic e => e -> Text+nar e = case selectRenderer (withTarget TNarratable defaultConfig) of+  SomeRenderer r@(Narratable _) -> render r e+  _                             -> ""++jsn :: Diagnostic e => e -> Text+jsn e = case selectRenderer (withTarget TJson defaultConfig) of+  SomeRenderer r@(Json _) -> TL.toStrict (TLE.decodeUtf8 (A.encode (render r e)))+  _                       -> ""++once :: (Text, Text) -> Property+once (a, b) = withTests 1 (property (a === b))++group :: Group+group = Group "Phase 9 - generics context-wiring (derived == manual)"+  [ ("graphical renders identically",  once (gfx gVal, gfx mVal))+  , ("narratable renders identically", once (nar gVal, nar mVal))+  , ("json renders identically",       once (jsn gVal, jsn mVal))+  ]
+ test/props/Source.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Phase I — the pluggable 'SourceCode' seam. The canonical 'NamedSource'+-- instance is total and its windowed reads agree, by definition, with a filter+-- of the full line enumeration.+module Source (group) where++import           Data.Text                  (Text)+import qualified Data.Text                  as T++import           Hedgehog+import qualified Hedgehog.Gen               as Gen+import qualified Hedgehog.Range             as Range++import           Tadka                      (NamedSource, mkNamedSource, sourceName,+                                             sourceText)+import           Tadka.Internal.SourceCode  (SourceCode (..))++group :: Group+group = Group "SourceCode (Phase I)"+  [ ("scName is the source name",            prop_name)+  , ("scLines (1, huge) enumerates all lines", prop_full)+  , ("scLines window == filtered enumeration", prop_window)+  ]++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++genSource :: Gen NamedSource+genSource = do+  name <- Gen.text (Range.linear 1 8) Gen.alpha+  segs <- Gen.list (Range.linear 0 6) (Gen.text (Range.linear 0 10) (Gen.filterT (/= '\n') Gen.ascii))+  pure (rightOrErr (mkNamedSource name (T.intercalate (T.singleton '\n') segs)))++allLines :: NamedSource -> [(Int, Text)]+allLines ns = zip [1 ..] (map dropCR (T.splitOn (T.singleton '\n') (sourceText ns)))+  where dropCR t = case T.stripSuffix (T.singleton '\r') t of+          Just t' -> t'+          Nothing -> t++prop_name :: Property+prop_name = property $ do+  ns <- forAll genSource+  scName ns === sourceName ns++prop_full :: Property+prop_full = property $ do+  ns <- forAll genSource+  scLines ns (1, 1000000) === allLines ns++-- The defining property, exercised over arbitrary (including negative/inverted)+-- ranges: a window is exactly the lines of the full enumeration within it.+prop_window :: Property+prop_window = property $ do+  ns <- forAll genSource+  lo <- forAll (Gen.int (Range.linear (-3) 12))+  hi <- forAll (Gen.int (Range.linear (-3) 12))+  scLines ns (lo, hi) === [ p | p@(n, _) <- allLines ns, n >= lo, n <= hi ]
+ test/props/Tabs.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Tab-stop expansion (post-v1 hardening): tabs in rendered source lines+-- expand to the next tab stop, and carets align under the /expanded/ source.+-- The alignment property is the mathematical statement of the fix: a caret's+-- leading-space count equals the display width of the tab-expanded source that+-- precedes the span.+module Tabs (group) where++import           Data.Text                          (Text)+import qualified Data.Text                          as T++import           Hedgehog+import qualified Hedgehog.Gen                       as Gen+import qualified Hedgehog.Range                     as Range++import           Tadka.Internal.Renderer.Graphical  (caretLayout)+import           Tadka.Internal.Width               (displayColumnAt, expandTabs, textWidth)++group :: Group+group = Group "Tab-aware source rendering"+  [ ("expandTabs leaves no tab characters",        prop_noTabs)+  , ("expanded width == displayColumnAt of line",  prop_widthConsistent)+  , ("displayColumnAt is monotonic",               prop_monotonic)+  , ("a tab always lands on a tab stop",           prop_tabStop)+  , ("caret aligns under the expanded source",     prop_alignment)+  , ("caret layout stays non-negative with tabs",  prop_nonNeg)+  ]++-- Unicode-hard text that also includes tabs.+genScalar :: Gen Char+genScalar = Gen.frequency+  [ (4, Gen.filterT (\c -> c /= '\n') (Gen.enum ' ' '~'))+  , (3, pure '\t')+  , (2, Gen.enum '\x0300' '\x036F')   -- combining marks (width 0)+  , (2, Gen.enum '\x4E00' '\x4E30')   -- CJK (width 2)+  , (1, Gen.enum '\x1F600' '\x1F610') -- emoji (width 2)+  ]++genLine :: Gen Text+genLine = Gen.text (Range.linear 0 40) genScalar++genTabW :: Gen Int+genTabW = Gen.int (Range.linear 1 8)++prop_noTabs :: Property+prop_noTabs = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  assert (not (T.any (== '\t') (expandTabs tw line)))++prop_widthConsistent :: Property+prop_widthConsistent = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  textWidth (expandTabs tw line) === displayColumnAt tw line (T.length line)++prop_monotonic :: Property+prop_monotonic = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  let n = T.length line+  a <- forAll (Gen.int (Range.linear 0 n))+  b <- forAll (Gen.int (Range.linear 0 n))+  let (lo, hi) = (min a b, max a b)+  assert (displayColumnAt tw line lo <= displayColumnAt tw line hi)++-- The defining property of a tab stop: the column immediately after a tab is a+-- multiple of the tab width.+prop_tabStop :: Property+prop_tabStop = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  let tabIdxs = [ i | (i, c) <- zip [0 ..] (T.unpack line), c == '\t' ]+  mapM_ (\i -> displayColumnAt tw line (i + 1) `mod` tw === 0) tabIdxs++-- THE alignment guarantee: the caret's display offset equals the width of the+-- tab-expanded source preceding the span, so the caret sits under it exactly.+prop_alignment :: Property+prop_alignment = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  let n = T.length line+  startCol <- forAll (Gen.int (Range.linear 1 (n + 1)))+  spanLen  <- forAll (Gen.int (Range.linear 0 (n + 5)))+  let (dispStart, _) = caretLayout tw line startCol spanLen+  dispStart === textWidth (expandTabs tw (T.take (startCol - 1) line))++prop_nonNeg :: Property+prop_nonNeg = property $ do+  tw   <- forAll genTabW+  line <- forAll genLine+  let n = T.length line+  startCol <- forAll (Gen.int (Range.linear 1 (n + 1)))+  spanLen  <- forAll (Gen.int (Range.linear 0 (n + 5)))+  let (dispStart, caretWidth) = caretLayout tw line startCol spanLen+  assert (dispStart >= 0)+  assert (caretWidth >= 1)
+ test/props/TermColor.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Terminal-capability resolution (pure) and ANSI colour application+-- (post-v1 hardening). The resolver proofs pin exactly how @Auto@ modes become+-- concrete; the colour proofs pin that colour adds only ANSI (and a uniform+-- caret glyph), never structural change — so plain output stays plain.+module TermColor (group) where++import           Data.Text                          (Text)+import qualified Data.Text                          as T+import           Prettyprinter                      (LayoutOptions (..),+                                                     PageWidth (Unbounded), layoutPretty)+import           Prettyprinter.Render.Text          (renderStrict)++import           Hedgehog+import qualified Hedgehog.Gen                       as Gen+import qualified Hedgehog.Range                     as Range++import           GenDiag                            (genGD)+import           Tadka+import           Tadka.Internal                     (buildContext)+import           Tadka.Internal.Config              (configPalette, configRelatedDepth,+                                                     configTabWidth, configTarget,+                                                     configColorMode, configUnicodeMode,+                                                     defaultPalette)+import           Tadka.Internal.Terminal            (TerminalCaps (..), resolveColor,+                                                     resolveConfig, resolveUnicode)++group :: Group+group = Group "Terminal detection & colour"+  [ ("explicit colour modes pass through",        prop_colorPassthrough)+  , ("explicit Unicode modes pass through",       prop_unicodePassthrough)+  , ("auto colour: NO_COLOR always wins",         prop_noColorWins)+  , ("auto colour: force beats tty",              prop_forceColor)+  , ("auto colour: else follows tty",             prop_ttyColor)+  , ("auto Unicode follows the locale",           prop_autoUnicode)+  , ("resolveConfig eliminates every Auto",       prop_noAutoAfter)+  , ("resolveConfig is idempotent",               prop_idempotent)+  , ("resolveConfig touches only the two modes",  prop_preservesRest)+  , ("ColorNever emits no ANSI",                  prop_neverNoEsc)+  , ("ColorAlways emits ANSI for labels",         prop_alwaysHasEsc)+  , ("colour changes only ANSI + caret glyph",    prop_structureInvariant)+  ]++-- === generators ===========================================================++genCaps :: Gen TerminalCaps+genCaps = TerminalCaps <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool++genColor :: Gen ColorMode+genColor = Gen.element [ColorAuto, ColorAlways, ColorNever]++genUnicode :: Gen UnicodeMode+genUnicode = Gen.element [UnicodeAuto, UnicodeAlways, UnicodeAscii]++-- === pure resolution proofs ===============================================++prop_colorPassthrough :: Property+prop_colorPassthrough = property $ do+  caps <- forAll genCaps+  resolveColor caps ColorAlways === ColorAlways+  resolveColor caps ColorNever  === ColorNever++prop_unicodePassthrough :: Property+prop_unicodePassthrough = property $ do+  caps <- forAll genCaps+  resolveUnicode caps UnicodeAlways === UnicodeAlways+  resolveUnicode caps UnicodeAscii  === UnicodeAscii++prop_noColorWins :: Property+prop_noColorWins = property $ do+  caps <- forAll (fmap (\c -> c { capNoColor = True }) genCaps)+  resolveColor caps ColorAuto === ColorNever++prop_forceColor :: Property+prop_forceColor = property $ do+  caps <- forAll (fmap (\c -> c { capNoColor = False, capForceColor = True }) genCaps)+  resolveColor caps ColorAuto === ColorAlways++prop_ttyColor :: Property+prop_ttyColor = property $ do+  caps0 <- forAll genCaps+  let caps = caps0 { capNoColor = False, capForceColor = False }+  resolveColor caps ColorAuto === (if capIsTerminal caps then ColorAlways else ColorNever)++prop_autoUnicode :: Property+prop_autoUnicode = property $ do+  caps <- forAll genCaps+  resolveUnicode caps UnicodeAuto === (if capUnicode caps then UnicodeAlways else UnicodeAscii)++cfgWith :: ColorMode -> UnicodeMode -> Config+cfgWith cm um =+  withRelatedDepthLimit 3 . withTabWidth 7 . withTarget TJson+    . withColorMode cm . withUnicodeMode um $ defaultConfig++prop_noAutoAfter :: Property+prop_noAutoAfter = property $ do+  caps <- forAll genCaps+  cm   <- forAll genColor+  um   <- forAll genUnicode+  let r = resolveConfig caps (cfgWith cm um)+  assert (configColorMode r `elem` [ColorAlways, ColorNever])+  assert (configUnicodeMode r `elem` [UnicodeAlways, UnicodeAscii])++prop_idempotent :: Property+prop_idempotent = property $ do+  caps <- forAll genCaps+  cm   <- forAll genColor+  um   <- forAll genUnicode+  let c1 = resolveConfig caps (cfgWith cm um)+      c2 = resolveConfig caps c1+  configColorMode c2   === configColorMode c1+  configUnicodeMode c2 === configUnicodeMode c1++prop_preservesRest :: Property+prop_preservesRest = property $ do+  caps <- forAll genCaps+  cm   <- forAll genColor+  um   <- forAll genUnicode+  let r = resolveConfig caps (cfgWith cm um)+  configRelatedDepth r === 3+  configTabWidth r     === 7+  configTarget r       === Just TJson+  assert (configPalette r == defaultPalette)++-- === colour application proofs =============================================++renderGfx :: Diagnostic e => ColorMode -> e -> Text+renderGfx cm e =+  case selectRenderer (withColorMode cm (withUnicodeMode UnicodeAlways (withTarget TGraphical defaultConfig))) of+    SomeRenderer r@(Graphical _) -> renderStrict (layoutPretty (LayoutOptions Unbounded) (render r e))+    _                            -> ""++esc :: Char+esc = '\ESC'++-- Drop ANSI CSI (…m) sequences.+stripEsc :: Text -> Text+stripEsc = T.pack . go . T.unpack+  where+    go [] = []+    go (c : '[' : rest)+      | c == esc  = go (drop 1 (dropWhile (/= 'm') rest))+    go (c : rest) = c : go rest++-- Normalise the cycling underline glyphs to '^' (safe only where content has no+-- '~'/'-'; the fixture below is chosen that way).+normHats :: Text -> Text+normHats = T.map (\c -> if c == '~' || c == '-' then '^' else c)++rightOrErr :: Show a => Either a b -> b+rightOrErr = either (error . show) id++-- Two labels on one line; label text/source deliberately free of '~'/'-'.+data ColorFix = ColorFix+instance Diagnostic ColorFix where+  message _ = "type mismatch"+  context _ = buildContext (rightOrErr (mkNamedSource "f.hs" "let a = bb"))+                [ (rightOrErr (mkSpan 4 1), Just "first thing")+                , (rightOrErr (mkSpan 8 2), Just "second thing")+                ]++prop_neverNoEsc :: Property+prop_neverNoEsc = property $ do+  d <- forAllWith (const "<generated diagnostic>") (genGD =<< Gen.int (Range.linear 0 3))+  assert (not (T.any (== esc) (renderGfx ColorNever d)))++prop_alwaysHasEsc :: Property+prop_alwaysHasEsc = withTests 1 . property $+  assert (T.any (== esc) (renderGfx ColorAlways ColorFix))++prop_structureInvariant :: Property+prop_structureInvariant = withTests 1 . property $+  stripEsc (renderGfx ColorAlways ColorFix) === normHats (renderGfx ColorNever ColorFix)