wireform-yaml (empty) → 0.1.0.0
raw patch · 38 files changed
+12882/−0 lines, 38 filesdep +HsYAMLdep +aesondep +base
Dependencies added: HsYAML, aeson, base, bytestring, containers, criterion, deepseq, directory, filepath, hashable, hedgehog, mtl, scientific, sydtest, sydtest-hedgehog, template-haskell, text, unordered-containers, vector, wireform-derive, wireform-yaml, yaml
Files
- CHANGELOG.md +18/−0
- LICENSE +26/−0
- README.md +340/−0
- bench-results/charts/yaml-decode-vs-hsyaml-dark.svg +62/−0
- bench-results/charts/yaml-decode-vs-hsyaml-light.svg +62/−0
- bench-results/charts/yaml-decode-vs-libyaml-dark.svg +62/−0
- bench-results/charts/yaml-decode-vs-libyaml-light.svg +62/−0
- bench-results/charts/yaml-extra-vs-libyaml-dark.svg +52/−0
- bench-results/charts/yaml-extra-vs-libyaml-light.svg +52/−0
- bench/Bench.hs +231/−0
- src/YAML.hs +44/−0
- src/YAML/Annotated.hs +625/−0
- src/YAML/Class.hs +719/−0
- src/YAML/Decode.hs +4544/−0
- src/YAML/Decode/Annotated.hs +676/−0
- src/YAML/Decode/Flow.hs +238/−0
- src/YAML/Derive.hs +562/−0
- src/YAML/Encode.hs +465/−0
- src/YAML/Encoding.hs +35/−0
- src/YAML/Internal.hs +37/−0
- src/YAML/JSON.hs +98/−0
- src/YAML/Pretty.hs +1235/−0
- src/YAML/Value.hs +168/−0
- test/Main.hs +33/−0
- test/Test/YAML/Annotated.hs +508/−0
- test/Test/YAML/Class.hs +65/−0
- test/Test/YAML/Conformance.hs +296/−0
- test/Test/YAML/Decode.hs +470/−0
- test/Test/YAML/Derive.hs +180/−0
- test/Test/YAML/Derive/Instances.hs +44/−0
- test/Test/YAML/Derive/Types.hs +177/−0
- test/Test/YAML/Encode.hs +130/−0
- test/Test/YAML/Helpers.hs +17/−0
- test/Test/YAML/JSON.hs +14/−0
- test/Test/YAML/Pretty.hs +110/−0
- test/Test/YAML/Roundtrip.hs +85/−0
- test/Test/YAML/Security.hs +196/−0
- wireform-yaml.cabal +144/−0
+ CHANGELOG.md view
@@ -0,0 +1,18 @@+# Changelog++## 0.1.0.0++Initial experimental release.++- YAML 1.2 encoding and decoding for dynamic values, documents, and streams.+- Block and flow collections; plain, quoted, literal, and folded scalars;+ tags, anchors, aliases, and merge keys.+- UTF-8, UTF-16, and UTF-32 input decoding.+- Generic and Template Haskell derivation of `ToYAML` and `FromYAML`, with+ the shared `wireform-derive` annotation vocabulary.+- Annotated syntax trees and source-preserving scalar edits, configurable+ pretty printing, and an `aeson` bridge.+- Nesting and alias-expansion limits, duplicate-key rejection, regression+ and property tests, and an optional upstream `yaml-test-suite` harness.+- Criterion comparisons with `HsYAML` and libyaml, including literal and+ escaped-string decoding.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 Ian Duncan++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,340 @@+# wireform-yaml++[](https://opensource.org/licenses/BSD-3-Clause)+++> [!CAUTION]+> This is an experimental, pre-1.0 package. APIs may change between releases.++[YAML 1.2](https://yaml.org/spec/1.2.2/) for Haskell. Encode and+decode the dynamic [`YAML.Value`](src/YAML/Value.hs), derive typeclass+instances generically or via Template Haskell, work with an annotated+AST that preserves source spans / comments / scalar style,+pretty-print back to YAML, bridge to JSON, and pass the official+[yaml-test-suite](https://github.com/yaml/yaml-test-suite) when you+point the test harness at a clone of it.++YAML 1.2 covers block-style and flow-style scalars, sequences, and+mappings; anchors and aliases (with merge-key semantics and a document-wide+expansion budget); explicit+tags; the four scalar styles (plain, single-quoted, double-quoted,+literal-folded); multi-document streams; and the JSON-compatible flow+subset. wireform-yaml implements the spec close enough to read and+write the corner cases that show up in Kubernetes manifests, CI+configs, and Ansible playbooks without surprising round-trip+behavior. It also exposes a separate annotated AST for tooling that+needs to preserve source positions and trivia (comments, blank+lines, scalar style) across a load / save cycle.++This package is part of the [wireform](https://github.com/iand675/wireform-)+monorepo and shares its allocation primitives, annotation deriver, and+testing discipline with every other format.++## Install++```cabal+build-depends:+ base,+ wireform-yaml ^>= 0.1.0.0,+ wireform-derive ^>= 0.2.0.0, -- if importing the shared modifier vocabulary+```++The package is part of the [wireform](https://github.com/iand675/wireform-)+monorepo and requires GHC 9.10 or later. Clone the repo and+`cabal build wireform-yaml` to compile locally. Compiling with the LLVM+backend (`-fllvm`) adds compile time+but measurably improves runtime performance.++## Hello world++```haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DerivingStrategies #-}++import GHC.Generics (Generic)+import Data.Text (Text)+import qualified Data.Text as T+import YAML.Class (ToYAML, FromYAML, encodeYAML, decodeYAML)++data Service = Service+ { name :: !Text+ , replicas :: !Int+ , image :: !Text+ } deriving stock (Show, Eq, Generic)+ deriving anyclass (ToYAML, FromYAML)++main :: IO ()+main = do+ let svc = Service "api" 3 "ghcr.io/example/api:1.4.2"+ text = encodeYAML svc+ putStrLn (T.unpack text)+ case decodeYAML text of+ Right (decoded :: Service) -> print decoded+ Left err -> putStrLn err+```++`encodeYAML svc` renders to:++```yaml+name: api+replicas: 3+image: ghcr.io/example/api:1.4.2+```++## What's in here++| Module | Role |+|------------------------|-----------------------------------------------------------|+| `YAML.Value` | Dynamic untyped `Value` ADT (scalars, sequences, mappings, tags, anchors) plus the `Document` and `Stream` wrappers for multi-document inputs |+| `YAML.Encode` | Emitter: `Value` / `Document` / `Stream` to YAML `Text` or `ByteString` |+| `YAML.Decode` | Loader: `ByteString` / `Text` to `Value` / `Document` / `Stream`, with anchor and alias resolution |+| `YAML.Encoding` | Builder used by `ToYAML` instances |+| `YAML.Pretty` | Render `Value` / `Document` / `Stream` back to YAML text with configurable scalar style, indent, and flow / block preference (`render`, `renderBS`, `renderDocument`, `renderStream`, `defaultOptions`, `compactOptions`) |+| `YAML.Class` | Public `ToYAML` / `FromYAML` typeclasses + `encodeYAML` / `encodeYAMLBS` / `decodeYAML` / `decodeYAMLBS` |+| `YAML.Derive` | `deriveYAML` / `deriveToYAML` / `deriveFromYAML` Template Haskell entry points |+| `YAML.Annotated` | Annotated AST (`AValue`, `ADocument`, `AStream`) that preserves source spans, comments, scalar style, and chomping indicators |+| `YAML.Decode.Annotated`| Loader for the annotated AST |+| `YAML.JSON` | Lossy bridge to and from `aeson`'s `Value` (mapping keys are stringified, tags and anchors are dropped) |++## Encode and decode++The typeclass entry points cover both `Text` and `ByteString` I/O:++```haskell+encodeYAML :: ToYAML a => a -> Text+encodeYAMLBS :: ToYAML a => a -> ByteString+decodeYAML :: FromYAML a => Text -> Either String a+decodeYAMLBS :: FromYAML a => ByteString -> Either String a+```++For dynamic values without a Haskell type to mirror them, work with+[`YAML.Value`](src/YAML/Value.hs) directly. The `Value` ADT carries+the explicit YAML tag on each node (`!!str`, `!!int`, `!!seq`,+custom tags), so type information that JSON would discard survives+the round-trip.++For multi-document YAML streams (`---` separated), use the `Document`+and `Stream` wrappers in `YAML.Value`, `decodeStream` / `decodeStreamBS`,+and `encodeStream`. Single-document entry points reject extra documents.++## Annotated AST++The annotated AST in `YAML.Annotated` is the surface to use when you+need to preserve more than the data model: source spans for error+reporting, scalar style for round-trip preservation, comments and+blank lines (trivia) for tooling that has to round-trip a file+without rewriting unrelated lines.++```haskell+import qualified YAML.Decode.Annotated as YDA+import qualified YAML.Pretty as YP++case YDA.decodeAnnotated input of+ Right (doc, original) -> putStrLn (T.unpack (YP.renderAnnotatedDocument YP.defaultOptions doc (Just original)))+ Left err -> putStrLn err+```++Edits preserve untouched flow-node tokens, quoting, and comments as well as+block-entry text. Changed flow collections may be laid out over multiple lines+to retain their comments. Parsed aliases keep their binding identities: changing+an anchor updates its live references, while deleting or moving a definition+materializes references that would otherwise become invalid. Editing through an+alias makes an independent copy.++Common consumers: language servers, schema-driven config editors,+formatters, and any tool that has to make a small change to a YAML+file without touching the rest.++## Annotation-driven deriving++`YAML.Derive` consumes the cross-format `Wireform.Derive.Modifier`+vocabulary from [`wireform-derive`](https://hackage.haskell.org/package/wireform-derive), so+the same annotated record can produce YAML, JSON, and any other+backend's instances:++```haskell+{-# LANGUAGE TemplateHaskell #-}++import qualified YAML.Derive as DYAML+import qualified Wireform.Derive.Aeson as DAeson+import Wireform.Derive (rename, renameStyle, KebabCase)++data DeploymentSpec = DeploymentSpec+ { deploymentReplicas :: !Int+ , deploymentImagePullPolicy :: !Text+ } deriving stock (Show, Eq, Generic)++{-# ANN type DeploymentSpec ("DeploymentSpec" :: String) #-}+{-# ANN deploymentReplicas (renameStyle KebabCase) #-}+{-# ANN deploymentImagePullPolicy (renameStyle KebabCase) #-}++DYAML.deriveYAML ''DeploymentSpec+DAeson.deriveJSON ''DeploymentSpec+```++Record constructors inside sums use a mapping for `contents`, so their field+renames, defaults, optional fields, and skipped fields work just like standalone+records. Positional constructors retain scalar or sequence `contents`.++## JSON bridge++`YAML.JSON` round-trips between `YAML.Value` and `Data.Aeson.Value`.+The bridge is intentionally lossy: YAML's data model is a strict+superset of JSON's, so non-string mapping keys are stringified, and+explicit tags and anchors are dropped. See the module haddock for the+exact mapping table. Non-finite YAML floats become JSON `null`.+YAML integers use arbitrary-precision `Integer`; bounded Haskell integer+decoders reject overflow, negative unsigned values, and fractional inputs.+ByteString decoder entry points detect UTF-8, UTF-16, and UTF-32 and reject+malformed encodings. Native records and maps reject ambiguous field names after+tag metadata is removed. The ByteString serialization instance uses a text scalar+for valid UTF-8 and a sequence of byte-valued integers for arbitrary binary data.++The parser bounds nesting and logical alias expansion (10 million nodes), rejects+cyclic/forward aliases, and limits tracked indentation to 1,048,574 spaces.++## Testing++The per-format Hedgehog suite lives in `test/`:++```bash+cabal test wireform-yaml:wireform-yaml-test+```++<!-- BEGIN_AUTOGEN tests -->+_No data yet. Run `cabal test wireform-yaml:all --test-show-details=streaming --xml=dist-stats/test-results/wireform-yaml.junit.xml` to populate._+<!-- END_AUTOGEN tests -->++It covers the parser, the emitter, the typeclass instances, the+annotated AST, security-relevant edge cases (billion-laughs anchor+expansion, deep nesting), and round-trip property tests against+`Value`.++### Conformance against `yaml-test-suite`++The test binary also runs an opt-in conformance harness against the+official [yaml/yaml-test-suite](https://github.com/yaml/yaml-test-suite).+Point `YAML_TEST_SUITE` at a local clone and the harness will walk+every case it finds:++```bash+git clone --branch data https://github.com/yaml/yaml-test-suite /tmp/yaml-test-suite+YAML_TEST_SUITE=/tmp/yaml-test-suite \+ cabal test wireform-yaml:wireform-yaml-test+```++The event-only upstream fixtures `X38W` and `2JQS` contain duplicate keys.+The harness asserts that value composition rejects them; it does not treat+valid parser events as permission to construct a mapping with duplicate keys.+All available JSON companions are compared across every document. Each accepted+fixture also round-trips structurally through the fast emitter, both pretty+layouts, and annotated normalization; collection-valued keys are checked directly.++When the env var is unset the harness reports a no-op skip group so+CI stays green out of the box. A built-in mini-suite drawn from the+YAML 1.2 spec examples always runs, so core compliance is exercised+even without the external clone.++## Benchmarks++A criterion harness in [`bench/Bench.hs`](bench/Bench.hs) compares+wireform-yaml's parser and emitter against the two established Haskell+YAML libraries:++- [`HsYAML`](https://hackage.haskell.org/package/HsYAML), pure+ Haskell, prioritises spec compliance.+- [`yaml`](https://hackage.haskell.org/package/yaml), bindings to+ libyaml.++```bash+cabal bench wireform-yaml:wireform-yaml-bench+```++<!-- BEGIN_AUTOGEN bench:yaml-decode-vs-libyaml -->+<picture>+ <source media="(prefers-color-scheme: dark)" srcset="bench-results/charts/yaml-decode-vs-libyaml-dark.svg">+ <img src="bench-results/charts/yaml-decode-vs-libyaml-light.svg" alt="wireform-yaml decode vs libyaml across input sizes">+</picture>++| Operation | wireform-yaml | yaml (libyaml) | ratio |+| :-------- | ------------: | -------------: | -----: |+| tiny | 0.44 µs | 6.14 µs | 13.95x |+| small | 6.73 µs | 34.6 µs | 5.15x |+| flow | 7.51 µs | 44.2 µs | 5.88x |+| literal | 4.71 µs | 11.2 µs | 2.38x |+| big | 37.5 µs | 122 µs | 3.26x |++<sub>Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.</sub>+<!-- END_AUTOGEN bench:yaml-decode-vs-libyaml -->++<!-- BEGIN_AUTOGEN bench:yaml-decode-vs-hsyaml -->+<picture>+ <source media="(prefers-color-scheme: dark)" srcset="bench-results/charts/yaml-decode-vs-hsyaml-dark.svg">+ <img src="bench-results/charts/yaml-decode-vs-hsyaml-light.svg" alt="wireform-yaml decode vs HsYAML (pure Haskell) across input sizes">+</picture>++| Operation | wireform-yaml | HsYAML | ratio |+| :-------- | ------------: | ------: | ------: |+| tiny | 0.44 µs | 119 µs | 270.86x |+| small | 6.73 µs | 1068 µs | 158.75x |+| flow | 7.51 µs | 1322 µs | 176.03x |+| literal | 4.71 µs | 1504 µs | 319.30x |+| big | 37.5 µs | 5027 µs | 133.95x |++<sub>Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.</sub>+<!-- END_AUTOGEN bench:yaml-decode-vs-hsyaml -->++### Escaped strings and derived records++<!-- BEGIN_AUTOGEN bench:yaml-extra-vs-libyaml -->+<picture>+ <source media="(prefers-color-scheme: dark)" srcset="bench-results/charts/yaml-extra-vs-libyaml-dark.svg">+ <img src="bench-results/charts/yaml-extra-vs-libyaml-light.svg" alt="Escaped strings and derived records vs libyaml">+</picture>++| Operation | wireform-yaml | yaml (libyaml) | ratio |+| :------------- | ------------: | -------------: | ----: |+| escaped decode | 7.12 µs | 13.6 µs | 1.91x |+| record decode | 1.85 µs | 11.9 µs | 6.43x |+| record encode | 1.25 µs | 5.36 µs | 4.29x |++<sub>Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.</sub>+<!-- END_AUTOGEN bench:yaml-extra-vs-libyaml -->++The record fixture uses the actual `deriveYAML` output. Every benchmark fixture+is checked for successful decoding before timing; the HsYAML comparison forces+the parsed contents as well as the outer document list.++ASCII validation scans eight bytes at a time and skips line normalization when+there are no carriage returns. Unicode and unusual controls retain lexical+validation. Literal scalars measure their final chomped length and copy their+UTF-8 lines into one exact buffer, so discarded trailing blank lines are neither+copied nor retained. Escaped scalars likewise write directly into a bounded+UTF-8 buffer. Optimized Core shows bulk byte copies, direct byte writes, and+unboxed offset loops without per-escape result allocation.++For cross-language comparisons:++- C: [libyaml](https://github.com/yaml/libyaml). The Hackage+ [`yaml`](https://hackage.haskell.org/package/yaml) package is a+ thin binding around it, so the Haskell-vs-Haskell number above is+ already partly cross-language.+- Rust: [`serde_yaml`](https://crates.io/crates/serde_yaml) (the+ established library) and [`saphyr`](https://crates.io/crates/saphyr)+ (a newer, faster alternative).++The committed tables above are generated from Criterion measurements. The harness+also exercises floating-point boundaries and the generated native-record codec.++## License++BSD-3-Clause.++## References++- [YAML 1.2.2 specification](https://yaml.org/spec/1.2.2/)+- [yaml/yaml-test-suite](https://github.com/yaml/yaml-test-suite) (the official conformance suite)+- [YAML 1.2 core schema](https://yaml.org/spec/1.2.2/#103-core-schema)
+ bench-results/charts/yaml-decode-vs-hsyaml-dark.svg view
@@ -0,0 +1,62 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#0d1117"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#e6edf3">wireform-yaml decode vs HsYAML (pure Haskell) across input sizes</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#7d8590">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#30363d" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#7d8590">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#7d8590">2500</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#7d8590">5000</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#7d8590">7500</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#7d8590">10000</text>+ </g>+ <g>+ <rect x="92.4" y="320.0" width="47.6" height="0.0" rx="2" fill="#58a6ff"/>+ <rect x="142" y="316.9" width="47.6" height="3.1" rx="2" fill="#ff7b72"/>+ <rect x="216.4" y="319.8" width="47.6" height="0.2" rx="2" fill="#58a6ff"/>+ <rect x="266" y="292.2" width="47.6" height="27.8" rx="2" fill="#ff7b72"/>+ <rect x="340.4" y="319.8" width="47.6" height="0.2" rx="2" fill="#58a6ff"/>+ <rect x="390" y="285.6" width="47.6" height="34.4" rx="2" fill="#ff7b72"/>+ <rect x="464.4" y="319.9" width="47.6" height="0.1" rx="2" fill="#58a6ff"/>+ <rect x="514" y="280.9" width="47.6" height="39.1" rx="2" fill="#ff7b72"/>+ <rect x="588.4" y="319.0" width="47.6" height="1.0" rx="2" fill="#58a6ff"/>+ <rect x="638" y="189.3" width="47.6" height="130.7" rx="2" fill="#ff7b72"/>+ </g>+ <g>+ <text x="116.2" y="316.0" text-anchor="middle" font-size="10" fill="#e6edf3">0.440</text>+ <text x="165.8" y="312.9" text-anchor="middle" font-size="10" fill="#e6edf3">119</text>+ <text x="240.2" y="315.8" text-anchor="middle" font-size="10" fill="#e6edf3">6.73</text>+ <text x="289.8" y="288.2" text-anchor="middle" font-size="10" fill="#e6edf3">1068</text>+ <text x="364.2" y="315.8" text-anchor="middle" font-size="10" fill="#e6edf3">7.51</text>+ <text x="413.8" y="281.6" text-anchor="middle" font-size="10" fill="#e6edf3">1322</text>+ <text x="488.2" y="315.9" text-anchor="middle" font-size="10" fill="#e6edf3">4.71</text>+ <text x="537.8" y="276.9" text-anchor="middle" font-size="10" fill="#e6edf3">1504</text>+ <text x="612.2" y="315.0" text-anchor="middle" font-size="10" fill="#e6edf3">37.5</text>+ <text x="661.8" y="185.3" text-anchor="middle" font-size="10" fill="#e6edf3">5027</text>+ </g>+ <g>+ <text x="142" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">tiny</text>+ <text x="266" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">small</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">flow</text>+ <text x="514" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">literal</text>+ <text x="638" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">big</text>+ </g>+ <g>+ <g transform="translate(267.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#58a6ff"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">wireform-yaml</text>+ </g>+ <g transform="translate(392.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#ff7b72"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">HsYAML</text>+ </g>+ </g>+</svg>
+ bench-results/charts/yaml-decode-vs-hsyaml-light.svg view
@@ -0,0 +1,62 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#ffffff"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#1f2328">wireform-yaml decode vs HsYAML (pure Haskell) across input sizes</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#656d76">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#d0d7de" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#656d76">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#656d76">2500</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#656d76">5000</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#656d76">7500</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#656d76">10000</text>+ </g>+ <g>+ <rect x="92.4" y="320.0" width="47.6" height="0.0" rx="2" fill="#0969da"/>+ <rect x="142" y="316.9" width="47.6" height="3.1" rx="2" fill="#cf222e"/>+ <rect x="216.4" y="319.8" width="47.6" height="0.2" rx="2" fill="#0969da"/>+ <rect x="266" y="292.2" width="47.6" height="27.8" rx="2" fill="#cf222e"/>+ <rect x="340.4" y="319.8" width="47.6" height="0.2" rx="2" fill="#0969da"/>+ <rect x="390" y="285.6" width="47.6" height="34.4" rx="2" fill="#cf222e"/>+ <rect x="464.4" y="319.9" width="47.6" height="0.1" rx="2" fill="#0969da"/>+ <rect x="514" y="280.9" width="47.6" height="39.1" rx="2" fill="#cf222e"/>+ <rect x="588.4" y="319.0" width="47.6" height="1.0" rx="2" fill="#0969da"/>+ <rect x="638" y="189.3" width="47.6" height="130.7" rx="2" fill="#cf222e"/>+ </g>+ <g>+ <text x="116.2" y="316.0" text-anchor="middle" font-size="10" fill="#1f2328">0.440</text>+ <text x="165.8" y="312.9" text-anchor="middle" font-size="10" fill="#1f2328">119</text>+ <text x="240.2" y="315.8" text-anchor="middle" font-size="10" fill="#1f2328">6.73</text>+ <text x="289.8" y="288.2" text-anchor="middle" font-size="10" fill="#1f2328">1068</text>+ <text x="364.2" y="315.8" text-anchor="middle" font-size="10" fill="#1f2328">7.51</text>+ <text x="413.8" y="281.6" text-anchor="middle" font-size="10" fill="#1f2328">1322</text>+ <text x="488.2" y="315.9" text-anchor="middle" font-size="10" fill="#1f2328">4.71</text>+ <text x="537.8" y="276.9" text-anchor="middle" font-size="10" fill="#1f2328">1504</text>+ <text x="612.2" y="315.0" text-anchor="middle" font-size="10" fill="#1f2328">37.5</text>+ <text x="661.8" y="185.3" text-anchor="middle" font-size="10" fill="#1f2328">5027</text>+ </g>+ <g>+ <text x="142" y="338" text-anchor="middle" font-size="11" fill="#1f2328">tiny</text>+ <text x="266" y="338" text-anchor="middle" font-size="11" fill="#1f2328">small</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#1f2328">flow</text>+ <text x="514" y="338" text-anchor="middle" font-size="11" fill="#1f2328">literal</text>+ <text x="638" y="338" text-anchor="middle" font-size="11" fill="#1f2328">big</text>+ </g>+ <g>+ <g transform="translate(267.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#0969da"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">wireform-yaml</text>+ </g>+ <g transform="translate(392.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#cf222e"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">HsYAML</text>+ </g>+ </g>+</svg>
+ bench-results/charts/yaml-decode-vs-libyaml-dark.svg view
@@ -0,0 +1,62 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#0d1117"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#e6edf3">wireform-yaml decode vs libyaml across input sizes</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#7d8590">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#30363d" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#7d8590">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#7d8590">50.0</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#7d8590">100</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#7d8590">150</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#7d8590">200</text>+ </g>+ <g>+ <rect x="92.4" y="319.4" width="47.6" height="0.6" rx="2" fill="#58a6ff"/>+ <rect x="142" y="312.0" width="47.6" height="8.0" rx="2" fill="#ff7b72"/>+ <rect x="216.4" y="311.3" width="47.6" height="8.7" rx="2" fill="#58a6ff"/>+ <rect x="266" y="275.0" width="47.6" height="45.0" rx="2" fill="#ff7b72"/>+ <rect x="340.4" y="310.2" width="47.6" height="9.8" rx="2" fill="#58a6ff"/>+ <rect x="390" y="262.6" width="47.6" height="57.4" rx="2" fill="#ff7b72"/>+ <rect x="464.4" y="313.9" width="47.6" height="6.1" rx="2" fill="#58a6ff"/>+ <rect x="514" y="305.4" width="47.6" height="14.6" rx="2" fill="#ff7b72"/>+ <rect x="588.4" y="271.2" width="47.6" height="48.8" rx="2" fill="#58a6ff"/>+ <rect x="638" y="161.1" width="47.6" height="158.9" rx="2" fill="#ff7b72"/>+ </g>+ <g>+ <text x="116.2" y="315.4" text-anchor="middle" font-size="10" fill="#e6edf3">0.440</text>+ <text x="165.8" y="308.0" text-anchor="middle" font-size="10" fill="#e6edf3">6.14</text>+ <text x="240.2" y="307.3" text-anchor="middle" font-size="10" fill="#e6edf3">6.73</text>+ <text x="289.8" y="271.0" text-anchor="middle" font-size="10" fill="#e6edf3">34.6</text>+ <text x="364.2" y="306.2" text-anchor="middle" font-size="10" fill="#e6edf3">7.51</text>+ <text x="413.8" y="258.6" text-anchor="middle" font-size="10" fill="#e6edf3">44.2</text>+ <text x="488.2" y="309.9" text-anchor="middle" font-size="10" fill="#e6edf3">4.71</text>+ <text x="537.8" y="301.4" text-anchor="middle" font-size="10" fill="#e6edf3">11.2</text>+ <text x="612.2" y="267.2" text-anchor="middle" font-size="10" fill="#e6edf3">37.5</text>+ <text x="661.8" y="157.1" text-anchor="middle" font-size="10" fill="#e6edf3">122</text>+ </g>+ <g>+ <text x="142" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">tiny</text>+ <text x="266" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">small</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">flow</text>+ <text x="514" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">literal</text>+ <text x="638" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">big</text>+ </g>+ <g>+ <g transform="translate(239.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#58a6ff"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">wireform-yaml</text>+ </g>+ <g transform="translate(364.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#ff7b72"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">yaml (libyaml)</text>+ </g>+ </g>+</svg>
+ bench-results/charts/yaml-decode-vs-libyaml-light.svg view
@@ -0,0 +1,62 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#ffffff"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#1f2328">wireform-yaml decode vs libyaml across input sizes</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#656d76">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#d0d7de" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#656d76">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#656d76">50.0</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#656d76">100</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#656d76">150</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#656d76">200</text>+ </g>+ <g>+ <rect x="92.4" y="319.4" width="47.6" height="0.6" rx="2" fill="#0969da"/>+ <rect x="142" y="312.0" width="47.6" height="8.0" rx="2" fill="#cf222e"/>+ <rect x="216.4" y="311.3" width="47.6" height="8.7" rx="2" fill="#0969da"/>+ <rect x="266" y="275.0" width="47.6" height="45.0" rx="2" fill="#cf222e"/>+ <rect x="340.4" y="310.2" width="47.6" height="9.8" rx="2" fill="#0969da"/>+ <rect x="390" y="262.6" width="47.6" height="57.4" rx="2" fill="#cf222e"/>+ <rect x="464.4" y="313.9" width="47.6" height="6.1" rx="2" fill="#0969da"/>+ <rect x="514" y="305.4" width="47.6" height="14.6" rx="2" fill="#cf222e"/>+ <rect x="588.4" y="271.2" width="47.6" height="48.8" rx="2" fill="#0969da"/>+ <rect x="638" y="161.1" width="47.6" height="158.9" rx="2" fill="#cf222e"/>+ </g>+ <g>+ <text x="116.2" y="315.4" text-anchor="middle" font-size="10" fill="#1f2328">0.440</text>+ <text x="165.8" y="308.0" text-anchor="middle" font-size="10" fill="#1f2328">6.14</text>+ <text x="240.2" y="307.3" text-anchor="middle" font-size="10" fill="#1f2328">6.73</text>+ <text x="289.8" y="271.0" text-anchor="middle" font-size="10" fill="#1f2328">34.6</text>+ <text x="364.2" y="306.2" text-anchor="middle" font-size="10" fill="#1f2328">7.51</text>+ <text x="413.8" y="258.6" text-anchor="middle" font-size="10" fill="#1f2328">44.2</text>+ <text x="488.2" y="309.9" text-anchor="middle" font-size="10" fill="#1f2328">4.71</text>+ <text x="537.8" y="301.4" text-anchor="middle" font-size="10" fill="#1f2328">11.2</text>+ <text x="612.2" y="267.2" text-anchor="middle" font-size="10" fill="#1f2328">37.5</text>+ <text x="661.8" y="157.1" text-anchor="middle" font-size="10" fill="#1f2328">122</text>+ </g>+ <g>+ <text x="142" y="338" text-anchor="middle" font-size="11" fill="#1f2328">tiny</text>+ <text x="266" y="338" text-anchor="middle" font-size="11" fill="#1f2328">small</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#1f2328">flow</text>+ <text x="514" y="338" text-anchor="middle" font-size="11" fill="#1f2328">literal</text>+ <text x="638" y="338" text-anchor="middle" font-size="11" fill="#1f2328">big</text>+ </g>+ <g>+ <g transform="translate(239.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#0969da"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">wireform-yaml</text>+ </g>+ <g transform="translate(364.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#cf222e"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">yaml (libyaml)</text>+ </g>+ </g>+</svg>
+ bench-results/charts/yaml-extra-vs-libyaml-dark.svg view
@@ -0,0 +1,52 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#0d1117"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#e6edf3">Escaped strings and derived records vs libyaml</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#7d8590">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#30363d" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#7d8590">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#7d8590">5.00</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#7d8590">10.0</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#7d8590">15.0</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#30363d" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#7d8590">20.0</text>+ </g>+ <g>+ <rect x="119.3" y="227.4" width="62" height="92.6" rx="2" fill="#58a6ff"/>+ <rect x="183.3" y="143.2" width="62" height="176.8" rx="2" fill="#ff7b72"/>+ <rect x="326.0" y="296.0" width="62" height="24.0" rx="2" fill="#58a6ff"/>+ <rect x="390.0" y="165.3" width="62" height="154.7" rx="2" fill="#ff7b72"/>+ <rect x="532.7" y="303.8" width="62" height="16.2" rx="2" fill="#58a6ff"/>+ <rect x="596.7" y="250.3" width="62" height="69.7" rx="2" fill="#ff7b72"/>+ </g>+ <g>+ <text x="150.3" y="223.4" text-anchor="middle" font-size="10" fill="#e6edf3">7.12</text>+ <text x="214.3" y="139.2" text-anchor="middle" font-size="10" fill="#e6edf3">13.6</text>+ <text x="357.0" y="292.0" text-anchor="middle" font-size="10" fill="#e6edf3">1.85</text>+ <text x="421.0" y="161.3" text-anchor="middle" font-size="10" fill="#e6edf3">11.9</text>+ <text x="563.7" y="299.8" text-anchor="middle" font-size="10" fill="#e6edf3">1.25</text>+ <text x="627.7" y="246.3" text-anchor="middle" font-size="10" fill="#e6edf3">5.36</text>+ </g>+ <g>+ <text x="183.3" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">escaped decode</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">record decode</text>+ <text x="596.7" y="338" text-anchor="middle" font-size="11" fill="#e6edf3">record encode</text>+ </g>+ <g>+ <g transform="translate(239.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#58a6ff"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">wireform-yaml</text>+ </g>+ <g transform="translate(364.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#ff7b72"/>+ <text x="18" y="1" font-size="11" fill="#e6edf3">yaml (libyaml)</text>+ </g>+ </g>+</svg>
+ bench-results/charts/yaml-extra-vs-libyaml-light.svg view
@@ -0,0 +1,52 @@+<?xml version="1.0" encoding="UTF-8"?><svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 720 400" width="720" height="400" font-family="ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif" font-size="12">+ <rect x="0" y="0" width="720" height="400" fill="#ffffff"/>+ <text x="360" y="26" text-anchor="middle" font-size="15" font-weight="600" fill="#1f2328">Escaped strings and derived records vs libyaml</text>+ <text x="360" y="44" text-anchor="middle" font-size="11" fill="#656d76">lower is better · µs · ghc-9.10.3 on darwin-aarch64, criterion 1.6.5</text>+ <g stroke="#d0d7de" stroke-width="1">+ <line x1="80" y1="320" x2="700" y2="320"/>+ <line x1="80" y1="60" x2="80" y2="320"/>+ </g>+ <g>+ <g/>+ <text x="72" y="324" text-anchor="end" font-size="10" fill="#656d76">0</text>+ <line x1="80" y1="255" x2="700" y2="255" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="259" text-anchor="end" font-size="10" fill="#656d76">5.00</text>+ <line x1="80" y1="190" x2="700" y2="190" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="194" text-anchor="end" font-size="10" fill="#656d76">10.0</text>+ <line x1="80" y1="125" x2="700" y2="125" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="129" text-anchor="end" font-size="10" fill="#656d76">15.0</text>+ <line x1="80" y1="60" x2="700" y2="60" stroke="#d0d7de" stroke-width="1" stroke-dasharray="2 3"/>+ <text x="72" y="64" text-anchor="end" font-size="10" fill="#656d76">20.0</text>+ </g>+ <g>+ <rect x="119.3" y="227.4" width="62" height="92.6" rx="2" fill="#0969da"/>+ <rect x="183.3" y="143.2" width="62" height="176.8" rx="2" fill="#cf222e"/>+ <rect x="326.0" y="296.0" width="62" height="24.0" rx="2" fill="#0969da"/>+ <rect x="390.0" y="165.3" width="62" height="154.7" rx="2" fill="#cf222e"/>+ <rect x="532.7" y="303.8" width="62" height="16.2" rx="2" fill="#0969da"/>+ <rect x="596.7" y="250.3" width="62" height="69.7" rx="2" fill="#cf222e"/>+ </g>+ <g>+ <text x="150.3" y="223.4" text-anchor="middle" font-size="10" fill="#1f2328">7.12</text>+ <text x="214.3" y="139.2" text-anchor="middle" font-size="10" fill="#1f2328">13.6</text>+ <text x="357.0" y="292.0" text-anchor="middle" font-size="10" fill="#1f2328">1.85</text>+ <text x="421.0" y="161.3" text-anchor="middle" font-size="10" fill="#1f2328">11.9</text>+ <text x="563.7" y="299.8" text-anchor="middle" font-size="10" fill="#1f2328">1.25</text>+ <text x="627.7" y="246.3" text-anchor="middle" font-size="10" fill="#1f2328">5.36</text>+ </g>+ <g>+ <text x="183.3" y="338" text-anchor="middle" font-size="11" fill="#1f2328">escaped decode</text>+ <text x="390" y="338" text-anchor="middle" font-size="11" fill="#1f2328">record decode</text>+ <text x="596.7" y="338" text-anchor="middle" font-size="11" fill="#1f2328">record encode</text>+ </g>+ <g>+ <g transform="translate(239.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#0969da"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">wireform-yaml</text>+ </g>+ <g transform="translate(364.5, 382)">+ <rect x="0" y="-9" width="12" height="12" rx="2" fill="#cf222e"/>+ <text x="18" y="1" font-size="11" fill="#1f2328">yaml (libyaml)</text>+ </g>+ </g>+</svg>
+ bench/Bench.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main (main) where++import Control.DeepSeq (NFData)+import Criterion.Main+import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as BB+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BSL+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Vector qualified as V+import Data.YAML qualified as HsYAML+import Data.Yaml qualified as Libyaml+import GHC.Generics (Generic)+import YAML.Class qualified as C+import YAML.Decode qualified as Y+import YAML.Derive (deriveYAML)+import YAML.Encode qualified as YE+import YAML.Value qualified as YV+++data Person = Person {name :: T.Text, age :: Int, active :: Bool}+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData, Aeson.FromJSON, Aeson.ToJSON)+++deriveYAML ''Person+++personBytes :: BS.ByteString+personBytes = "name: Alice\nage: 42\nactive: true\n"+++decodeRecord :: BS.ByteString -> Either String Person+decodeRecord = C.decodeYAMLBS+++decodeRecordLibyaml :: BS.ByteString -> Either String Person+decodeRecordLibyaml bytes = case Libyaml.decodeEither' bytes of+ Left err -> Left (show err)+ Right person -> Right person+++-- | A tiny mapping (~20 byte input).+tiny :: BS.ByteString+tiny = "key: value"+++-- | A mid-size nested document (a few hundred bytes).+small :: BS.ByteString+small =+ BS8.unlines+ [ "name: example"+ , "version: 1.2.3"+ , "tags:"+ , " - haskell"+ , " - yaml"+ , " - parser"+ , "owner:"+ , " name: Alice"+ , " email: alice@example.com"+ , "config:"+ , " threads: 8"+ , " timeout: 30"+ , " retry: true"+ , " endpoints:"+ , " - https://example.com"+ , " - https://example.org"+ ]+++-- | A flow-heavy mid-size document.+flowMid :: BS.ByteString+flowMid =+ BS8.unlines+ [ "matrix: [[1,2,3], [4,5,6], [7,8,9]]"+ , "tags: { a: 1, b: 2, c: 3, d: 4 }"+ , "items: [{x: 1, y: 2}, {x: 3, y: 4}, {x: 5, y: 6}]"+ ]+++-- | A scalar-heavy document (many quoted strings).+quoted :: BS.ByteString+quoted = BS8.unlines ("items:" : ((\n -> " - \"item " <> numberBytes n <> " with some quoted text\"") <$> [1 .. 50]))+++-- | A block scalar / literal text body.+literalBody :: BS.ByteString+literalBody = BS8.unlines ("code: |" : ((\n -> " line " <> numberBytes n <> " of body text") <$> [1 .. 50]))+++numberBytes :: Int -> BS.ByteString+numberBytes = BSL.toStrict . BB.toLazyByteString . BB.intDec+++-- | Finite floats including precision and exponent boundaries.+floating :: BS.ByteString+floating = "[" <> BS.intercalate ", " (replicate 25 "0.1, 1.1930203655234305e70, 5e-324, -2.2250738585072014e-308, 1.7976931348623157e308") <> "]"+++-- | Escaped controls and supplementary Unicode on the quoted slow path.+escaped :: BS.ByteString+escaped = "{text: \"" <> BS.concat (replicate 100 "a\\nb\\u00a0\\U0001f600") <> "\"}"+++-- | A larger doc (~2 KB) of mixed content.+big :: BS.ByteString+big = BS.concat (section <$> ["doc1", "doc2", "doc3", "doc4"])+ where+ section name = name <> ":\n" <> BS8.unlines ((" " <>) <$> BS8.lines small)+++decodeBytes :: BS.ByteString -> Either String YV.Stream+decodeBytes = Y.decodeStreamBS+++decodeHsYAML :: BS.ByteString -> Either String ()+decodeHsYAML bs = case HsYAML.decodeNode (BSL.fromStrict bs) of+ Right ns -> Right (foldr (\doc rest -> forceHsNode (HsYAML.docRoot doc) `seq` rest) () ns)+ Left (_, e) -> Left e+++-- Force the parsed data, not just the outer document list. HsYAML keeps+-- source locations too; those presentation details aren't part of this result.+forceHsNode :: HsYAML.Node location -> ()+forceHsNode node = case node of+ HsYAML.Anchor _ _ inner -> forceHsNode inner+ HsYAML.Sequence _ _ values -> foldr (\value rest -> forceHsNode value `seq` rest) () values+ HsYAML.Mapping _ _ values -> Map.foldrWithKey (\key value rest -> forceHsNode key `seq` forceHsNode value `seq` rest) () values+ HsYAML.Scalar _ scalar -> case scalar of+ HsYAML.SNull -> ()+ HsYAML.SBool value -> value `seq` ()+ HsYAML.SInt value -> value `seq` ()+ HsYAML.SFloat value -> value `seq` ()+ HsYAML.SStr value -> value `seq` ()+ HsYAML.SUnknown tag value -> tag `seq` value `seq` ()+++decodeLibyaml :: BS.ByteString -> Either String Aeson.Value+decodeLibyaml bs = case Libyaml.decodeEither' bs of+ Right v -> Right v+ Left e -> Left (show e)+++main :: IO ()+main = do+ mapM_ validateFixture [("tiny", tiny), ("small", small), ("flow", flowMid), ("quoted", quoted), ("literal", literalBody), ("big", big), ("floating", floating), ("escaped", escaped)]+ let expected = Right (Person "Alice" 42 True)+ if decodeRecord personBytes == expected && decodeRecordLibyaml personBytes == expected then pure () else fail "invalid native-record benchmark fixture"+ defaultMain+ [ bgroup+ "decode"+ [ bench "tiny" $ nf decodeBytes tiny+ , bench "small" $ nf decodeBytes small+ , bench "flowMid" $ nf decodeBytes flowMid+ , bench "quoted50" $ nf decodeBytes quoted+ , bench "literal50" $ nf decodeBytes literalBody+ , bench "big" $ nf decodeBytes big+ , bench "floating" $ nf decodeBytes floating+ , bench "escaped" $ nf decodeBytes escaped+ ]+ , bgroup+ "decode-hsyaml"+ [ bench "tiny" $ nf decodeHsYAML tiny+ , bench "small" $ nf decodeHsYAML small+ , bench "flowMid" $ nf decodeHsYAML flowMid+ , bench "quoted50" $ nf decodeHsYAML quoted+ , bench "literal50" $ nf decodeHsYAML literalBody+ , bench "big" $ nf decodeHsYAML big+ , bench "floating" $ nf decodeHsYAML floating+ , bench "escaped" $ nf decodeHsYAML escaped+ ]+ , bgroup+ "decode-libyaml"+ [ bench "tiny" $ nf decodeLibyaml tiny+ , bench "small" $ nf decodeLibyaml small+ , bench "flowMid" $ nf decodeLibyaml flowMid+ , bench "quoted50" $ nf decodeLibyaml quoted+ , bench "literal50" $ nf decodeLibyaml literalBody+ , bench "big" $ nf decodeLibyaml big+ , bench "floating" $ nf decodeLibyaml floating+ , bench "escaped" $ nf decodeLibyaml escaped+ ]+ , bgroup+ "preprocess"+ [ bench "small" $ nf (length . Y.preprocess) (decodeText small)+ , bench "big" $ nf (length . Y.preprocess) (decodeText big)+ ]+ , bgroup+ "decode-record"+ [ bench "wireform-yaml" $ nf decodeRecord personBytes+ , bench "libyaml" $ nf decodeRecordLibyaml personBytes+ ]+ , bgroup+ "encode-record"+ [ bench "wireform-yaml" $ nf C.encodeYAMLBS (Person "Alice" 42 True)+ , bench "libyaml" $ nf Libyaml.encode (Person "Alice" 42 True)+ ]+ , bgroup+ "encode"+ [ env (pure (decodeBody small)) $ \v ->+ bench "small" $+ nf YE.encode v+ , env (pure (decodeBody flowMid)) $ \v ->+ bench "flowMid" $+ nf YE.encode v+ ]+ ]+ where+ decodeBody bs = case decodeBytes bs of+ Right s -> YV.docBody (V.head (YV.unStream s))+ Left e -> error e++ decodeText = TE.decodeUtf8+++-- Fail setup if a codec rejects a fixture, rather than timing its error path.+validateFixture :: (String, BS.ByteString) -> IO ()+validateFixture (name, bytes) = do+ accepted "wireform-yaml" (decodeBytes bytes)+ accepted "HsYAML" (decodeHsYAML bytes)+ accepted "libyaml" (decodeLibyaml bytes)+ where+ accepted codec result = case result of+ Left err -> fail (codec <> "/" <> name <> ": " <> err)+ Right _ -> pure ()
+ src/YAML.hs view
@@ -0,0 +1,44 @@+{- | Convenience re-export module for the common wireform-yaml surface.++Import this module to get the YAML codec — encoding, decoding, the+dynamic value model, the typeclasses, and the deriver — in one go.++@+import YAML++let bs = encode (YString "hello")+case decode bs of+ Right val -> pure val+ Left err -> fail err+@++Specialized surfaces that are deliberately *not* re-exported here — opt into+them directly when you need them: "YAML.JSON" (the YAML ↔ JSON bridge),+"YAML.Annotated" and "YAML.Decode.Annotated" (the position-annotated value+model and decoder), and "YAML.Pretty" (the pretty-printer).+-}+module YAML (+ -- * Encoding+ module YAML.Encode,+ module YAML.Encoding,++ -- * Decoding+ module YAML.Decode,++ -- * Dynamic values+ module YAML.Value,++ -- * Typeclass-based codec + deriving+ module YAML.Class,+ module YAML.Derive,+) where++import YAML.Class+import YAML.Decode+import YAML.Derive+import YAML.Encode+import YAML.Encoding+import YAML.Value+++-- Keep optional JSON and presentation APIs in their dedicated modules.
+ src/YAML/Annotated.hs view
@@ -0,0 +1,625 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Annotated YAML representation that preserves enough source-level+information to round-trip a parsed document /verbatim/, while still+allowing programmatic modification.++The intended workflow is:++@+Right (adoc, original) <- 'YAML.Decode.Annotated.decodeAnnotated' yamlText+let adoc' = adoc { 'adBody' = 'updateAt' [\"server\", \"port\"] ('aInt' 8081) ('adBody' adoc) }+let yamlText' = 'YAML.Pretty.renderAnnotatedDocument' 'YAML.Pretty.defaultOptions' adoc' (Just original)+@++The renderer copies original source bytes for sub-trees that haven't+been modified (preserving comments, blank lines, quote style,+block-vs-flow choice, indentation, etc.) and falls back to the+pretty-printer's settings for fresh content.+-}+module YAML.Annotated (+ -- * Annotated value+ AValue (..),+ ABody (..),+ AMapEntry (..),+ Trivia (..),+ Comment (..),+ SrcSpan (..),++ -- * Style+ ScalarStyle (..),+ Chomping (..),+ SeqStyle (..),+ MapStyle (..),++ -- * Document / stream+ ADocument (..),+ AStream (..),++ -- * Construction (un-annotated, ready for fresh emission)+ aNull,+ aBool,+ aInt,+ aFloat,+ aString,+ aStringStyled,+ aSeq,+ aMap,+ aTagged,+ aAnchored,++ -- * Querying+ abody,+ astripAnnotations,+ isDirty,+ markDirty,+ prepareForRendering,++ -- * Modification helpers+ setKey,+ updateKey,+ deleteKey,+ appendKey,+ updateAt,+ setIndex,+ appendItem,+ deleteIndex,+) where++import Control.DeepSeq (NFData)+import Control.Monad.State.Strict (State, evalState, get, modify')+import Data.HashMap.Strict qualified as HM+import Data.HashSet qualified as HS+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Generics (Generic)+import YAML.Value (Anchor (..), Tag (..))+import YAML.Value qualified as YV+++-- ---------------------------------------------------------------------------+-- Source spans + trivia+-- ---------------------------------------------------------------------------++{- | A half-open byte range @[start, end)@ in the original source+'Text' (encoded as UTF-8 and indexed by byte position so the+offsets are stable across text-encoding boundaries).+-}+data SrcSpan = SrcSpan+ { srcStart :: {-# UNPACK #-} !Int+ , srcEnd :: {-# UNPACK #-} !Int+ }+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (NFData)+++{- | A single comment token: a leading @#@ on its own line, or an+end-of-line comment trailing a value.+-}+data Comment = Comment+ { commentText :: !Text+ {- ^ The text after the @#@, without the @#@ itself or any+ indenting whitespace. May contain trailing whitespace.+ -}+ , commentColumn :: {-# UNPACK #-} !Int+ {- ^ Column where the @#@ sat in the source, useful for+ preserving indentation when re-emitting fresh content+ around the comment.+ -}+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | Whitespace / comments / blank-lines that decorate a value.+data Trivia = Trivia+ { triviaLeading :: ![Comment]+ {- ^ Stand-alone comments on lines /before/ this value+ (between the previous structural token and this one).+ -}+ , triviaBlankLines :: {-# UNPACK #-} !Int+ {- ^ Number of blank lines immediately preceding the value+ (after any leading comments).+ -}+ , triviaTrailing :: !(Maybe Comment)+ {- ^ End-of-line comment on the same line as the value, if+ any.+ -}+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | Trivia with no comments and no blank lines.+emptyTrivia :: Trivia+emptyTrivia = Trivia [] 0 Nothing+++-- ---------------------------------------------------------------------------+-- Style+-- ---------------------------------------------------------------------------++-- | How a scalar was (or should be) emitted.+data ScalarStyle+ = -- | @value@ — unquoted plain scalar.+ SSPlain+ | -- | @\"value\"@ — double-quoted; supports YAML escapes.+ SSDoubleQuoted+ | -- | @\'value\'@ — single-quoted.+ SSSingleQuoted+ | -- | @|@ — literal block scalar.+ SSLiteral !Chomping+ | -- | @>@ — folded block scalar.+ SSFolded !Chomping+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | Chomping indicator for block scalars.+data Chomping = Clip | Strip | Keep+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | How a sequence was (or should be) emitted.+data SeqStyle = SeqBlock | SeqFlow+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | How a mapping was (or should be) emitted.+data MapStyle = MapBlock | MapFlow+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- ---------------------------------------------------------------------------+-- The annotated tree+-- ---------------------------------------------------------------------------++{- | Annotated YAML value.++Carries enough information for the renderer to reproduce the+original source byte-for-byte when nothing has been modified+('avSpan' present and 'avDirty' False) and to fall back to the+'YAML.Pretty.RenderOptions' pretty-printer otherwise.+-}+data AValue = AValue+ { avBody :: !ABody+ , avTrivia :: !Trivia+ , avSpan :: !(Maybe SrcSpan)+ {- ^ The half-open byte range in the original source that+ produced this value, if any. 'Nothing' means the value+ was constructed fresh and has no original-source backing.+ -}+ , avNodeSpan :: !(Maybe SrcSpan)+ -- ^ Exact flow-node token range, excluding its surrounding entry and trivia.+ , avTrailingText :: !Text+ -- ^ Container-ending trivia retained when children are edited.+ , avAnchorId :: {-# UNPACK #-} !Int+ -- ^ Original binding identity on an anchor definition; negative for fresh nodes.+ , avDirty :: !Bool+ {- ^ Set to 'True' when a sub-tree has been modified; the+ renderer falls back to fresh emission for any node with+ @'avDirty' == True@ even if 'avSpan' is present.+ -}+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | The actual structural body of an 'AValue'.+data ABody+ = ANull+ | ABool !Bool+ | AInt !Integer+ | AFloat !Double+ | AString !Text !ScalarStyle+ | ASeq !(Vector AValue) !SeqStyle+ | AMap !(Vector AMapEntry) !MapStyle+ | ATagged !Tag !AValue+ | AAnchored !Anchor !AValue+ | {- | A @*alias@ reference. The annotated layer keeps it+ explicit; projection to 'YAML.Value.Value' preserves the+ reference as 'YAML.Value.YAlias'.+ -}+ AAlias !Anchor+ | {- | An original alias with its immutable binding identity and resolved+ target. The target permits safe materialization if its definition is deleted+ or moved after this reference during an edit.+ -}+ AResolvedAlias {-# UNPACK #-} !Int !Anchor !AValue+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++{- | A mapping entry.++The @amTrailing@ comment is the eol comment on the value line+(if any); per-entry trivia for blank lines and stand-alone+comments lives on the @amKey@'s 'avTrivia'.+-}+data AMapEntry = AMapEntry+ { amKey :: !AValue+ , amValue :: !AValue+ , amTrailing :: !(Maybe Comment)+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- ---------------------------------------------------------------------------+-- Documents / streams+-- ---------------------------------------------------------------------------++-- | An annotated document.+data ADocument = ADocument+ { adDirectivesEnd :: !Bool+ , adExplicitEnd :: !Bool+ , adBody :: !AValue+ , adLeading :: ![Comment]+ {- ^ Comments before the document body (after any preceding+ @---@ marker).+ -}+ , adOriginalSpan :: !(Maybe SrcSpan)+ -- ^ Original document bytes, including framing and trailing trivia.+ , adTrailing :: ![Comment]+ {- ^ Comments after the body (before any @...@ marker or the+ next document).+ -}+ , adDirectives :: ![Text]+ -- ^ Original directive lines, retained when edited content is re-emitted.+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | An annotated multi-document stream.+newtype AStream = AStream {aStreamDocs :: Vector ADocument}+ deriving stock (Show, Eq, Generic)+ deriving newtype (NFData)+++-- ---------------------------------------------------------------------------+-- Construction (fresh, un-annotated)+-- ---------------------------------------------------------------------------++freshAValue :: ABody -> AValue+freshAValue b = AValue b emptyTrivia Nothing Nothing "" (-1) False+++aNull :: AValue+aNull = freshAValue ANull+++aBool :: Bool -> AValue+aBool b = freshAValue (ABool b)+++aInt :: Integer -> AValue+aInt n = freshAValue (AInt n)+++aFloat :: Double -> AValue+aFloat d = freshAValue (AFloat d)+++{- | Construct a string in the renderer's default scalar style+(typically plain unless the body would parse back as some other+core-schema literal, in which case the renderer will quote it).+-}+aString :: Text -> AValue+aString t = freshAValue (AString t SSPlain)+++-- | Construct a string with an explicit scalar style.+aStringStyled :: Text -> ScalarStyle -> AValue+aStringStyled t s = freshAValue (AString t s)+++aSeq :: [AValue] -> AValue+aSeq xs = freshAValue (ASeq (V.fromList xs) SeqBlock)+++aMap :: [(AValue, AValue)] -> AValue+aMap kvs =+ freshAValue+ (AMap (V.fromList ((\(k, v) -> AMapEntry k v Nothing) <$> kvs)) MapBlock)+++aTagged :: Tag -> AValue -> AValue+aTagged t v = freshAValue (ATagged t v)+++aAnchored :: Anchor -> AValue -> AValue+aAnchored a v = freshAValue (AAnchored a v)+++-- ---------------------------------------------------------------------------+-- Querying+-- ---------------------------------------------------------------------------++abody :: AValue -> ABody+abody = avBody+++isDirty :: AValue -> Bool+isDirty = avDirty+++{- | Mark a value as dirty so the renderer will re-emit it from+scratch (using 'YAML.Pretty.RenderOptions') instead of copying+the original source bytes.+-}+markDirty :: AValue -> AValue+markDirty v = v {avDirty = True}+{-# INLINE markDirty #-}+++{- | Preserve references to definitions that still precede them. References to+deleted or displaced definitions become independent copies of their targets;+immutable identities keep legal anchor-name rebinding unambiguous.+-}+prepareForRendering :: AValue -> AValue+prepareForRendering root+ | not (hasAliases root) = root+ | otherwise = evalState (go root) HM.empty+ where+ definitions = collect Nothing HM.empty root+ hasAliases value = case avBody value of+ AResolvedAlias _ _ _ -> True+ ATagged _ inner -> hasAliases inner+ AAnchored _ inner -> hasAliases inner+ ASeq items _ -> V.any hasAliases items+ AMap entries _ -> V.any (\entry -> hasAliases (amKey entry) || hasAliases (amValue entry)) entries+ _ -> False+ collect outerTag found value = case avBody value of+ AAnchored _ inner ->+ let target = maybe inner (`aTagged` inner) outerTag+ updated = if avAnchorId value < 0 then found else HM.insert (avAnchorId value) target found+ in collect Nothing updated inner+ ATagged tag inner -> collect (Just tag) found inner+ ASeq items _ -> V.foldl' (collect Nothing) found items+ AMap entries _ -> V.foldl' (\acc entry -> collect Nothing (collect Nothing acc (amKey entry)) (amValue entry)) found entries+ _ -> found+ go :: AValue -> State (HM.HashMap Text Int) AValue+ go value = case avBody value of+ AResolvedAlias identity anchor snapshot -> do+ active <- get+ if HM.lookup (unAnchor anchor) active == Just identity+ then pure value+ else pure (materialize HS.empty (HM.lookupDefault snapshot identity definitions)) {avTrivia = avTrivia value}+ AAnchored anchor inner -> do+ modify' (HM.insert (unAnchor anchor) (avAnchorId value))+ updated <- go inner+ pure value {avBody = AAnchored anchor updated, avDirty = avDirty value || avDirty updated}+ ATagged tag inner -> do+ updated <- go inner+ pure value {avBody = ATagged tag updated, avDirty = avDirty value || avDirty updated}+ ASeq items style -> do+ updated <- V.mapM go items+ pure value {avBody = ASeq updated style, avDirty = avDirty value || V.any avDirty updated}+ AMap entries style -> do+ updated <- V.mapM (\entry -> do key <- go (amKey entry); item <- go (amValue entry); pure entry {amKey = key, amValue = item}) entries+ pure value {avBody = AMap updated style, avDirty = avDirty value || V.any (\entry -> avDirty (amKey entry) || avDirty (amValue entry)) updated}+ _ -> pure value+ materialize visited value = case avBody value of+ AAnchored _ inner -> materialize visited inner+ AResolvedAlias identity _ snapshot ->+ let target = if HS.member identity visited then snapshot else HM.lookupDefault snapshot identity definitions+ in materialize (HS.insert identity visited) target+ body ->+ value+ { avSpan = Nothing+ , avDirty = True+ , avAnchorId = -1+ , avBody = case body of+ ATagged tag inner -> ATagged tag (materialize visited inner)+ ASeq items style -> ASeq (materialize visited <$> items) style+ AMap entries style -> AMap ((\entry -> entry {amKey = materialize visited (amKey entry), amValue = materialize visited (amValue entry)}) <$> entries) style+ other -> other+ }+++{- | Project an 'AValue' down to the unannotated 'YAML.Value.Value'+representation. Explicit aliases project to 'YAML.Value.YAlias'.+-}+astripAnnotations :: AValue -> YV.Value+astripAnnotations a = case avBody a of+ ANull -> YV.YNull+ ABool b -> YV.YBool b+ AInt n -> YV.YInt n+ AFloat d -> YV.YFloat d+ AString t _ -> YV.YString t+ ASeq xs _ -> YV.YSeq (V.map astripAnnotations xs)+ AMap es _ ->+ YV.YMap+ ( V.map+ ( \(AMapEntry k v _) ->+ (astripAnnotations k, astripAnnotations v)+ )+ es+ )+ ATagged tg v -> YV.YTagged tg (astripAnnotations v)+ AAnchored an v -> YV.YAnchored an (astripAnnotations v)+ AAlias anchor -> YV.YAlias anchor+ AResolvedAlias _ anchor _ -> YV.YAlias anchor+++-- ---------------------------------------------------------------------------+-- Modification helpers+-- ---------------------------------------------------------------------------++{- | Replace the value at the given mapping key. If the key isn't+present the original mapping is returned unchanged. Marks the+mapping (and only the mapping) as dirty.+-}+setKey :: Text -> AValue -> AValue -> AValue+setKey k newV m = updateKey k (const (Just newV)) m+++{- | Update the value at the given mapping key. Returning 'Nothing'+from the function deletes the entry; returning 'Just' replaces+it. If the key isn't present the original mapping is returned.+-}+updateKey :: Text -> (AValue -> Maybe AValue) -> AValue -> AValue+updateKey k f m = case avBody m of+ AMap entries style ->+ if V.any (matchesKey k . amKey) entries+ then markDirty m {avBody = AMap (V.mapMaybe updateEntry entries) style}+ else m+ ATagged tag inner -> modifyInner (ATagged tag) (updateKey k f) m inner+ AAnchored anchor inner -> modifyInner (AAnchored anchor) (updateKey k f) m inner+ AResolvedAlias _ _ target -> editAlias (updateKey k f) m target+ _ -> m+ where+ updateEntry entry+ | matchesKey k (amKey entry) = (\value -> entry {amValue = preserveStyle (amValue entry) value}) <$> f (amValue entry)+ | otherwise = Just entry+++matchesKey :: Text -> AValue -> Bool+matchesKey key value = case avBody value of+ AString text _ -> text == key+ ATagged _ inner -> matchesKey key inner+ AAnchored _ inner -> matchesKey key inner+ AResolvedAlias _ _ target -> matchesKey key target+ _ -> False+++modifyInner :: (AValue -> ABody) -> (AValue -> AValue) -> AValue -> AValue -> AValue+modifyInner wrap f outer inner =+ let changed = f inner+ in if avDirty changed then markDirty outer {avBody = wrap changed} else outer+++editAlias :: (AValue -> AValue) -> AValue -> AValue -> AValue+editAlias change reference target =+ let updated = change target+ in if avDirty updated then markDirty updated {avTrivia = avTrivia reference, avSpan = Nothing} else reference+++preserveStyle :: AValue -> AValue -> AValue+preserveStyle old new =+ let styled = case (avBody old, avBody new) of+ (AString _ style, AString text SSPlain) -> new {avBody = AString text style}+ (AAnchored anchor inner, _) | not (hasAnchor new) -> (aAnchored anchor (preserveStyle inner (detachSelf (avAnchorId old) new))) {avAnchorId = avAnchorId old}+ (AAnchored anchor _, _) -> inheritIdentity anchor (avAnchorId old) new+ (ATagged _ inner, _) -> preserveStyle inner new+ _ -> new+ in markDirty styled {avTrivia = avTrivia old, avTrailingText = avTrailingText old}+ where+ hasAnchor value = case avBody value of+ AAnchored _ _ -> True+ ATagged _ inner -> hasAnchor inner+ _ -> False+ inheritIdentity anchor identity value = case avBody value of+ AAnchored name _ | name == anchor -> value {avAnchorId = identity}+ ATagged tag inner -> value {avBody = ATagged tag (inheritIdentity anchor identity inner)}+ _ -> value+ detachSelf identity value+ | not (dependsOn identity value) = value+ | otherwise = case avBody value of+ AResolvedAlias _ _ target -> detachSelf identity target+ ATagged tag inner -> markDirty value {avBody = ATagged tag (detachSelf identity inner)}+ AAnchored anchor inner -> markDirty value {avBody = AAnchored anchor (detachSelf identity inner)}+ ASeq items style -> markDirty value {avBody = ASeq (detachSelf identity <$> items) style}+ AMap entries style -> markDirty value {avBody = AMap ((\entry -> entry {amKey = detachSelf identity (amKey entry), amValue = detachSelf identity (amValue entry)}) <$> entries) style}+ _ -> value+ dependsOn identity value = case avBody value of+ AResolvedAlias original _ target -> original == identity || dependsOn identity target+ ATagged _ inner -> dependsOn identity inner+ AAnchored _ inner -> dependsOn identity inner+ ASeq items _ -> V.any (dependsOn identity) items+ AMap entries _ -> V.any (\entry -> dependsOn identity (amKey entry) || dependsOn identity (amValue entry)) entries+ _ -> False+++-- | Delete a key from a mapping. No-op if absent.+deleteKey :: Text -> AValue -> AValue+deleteKey k m = updateKey k (const Nothing) m+++{- | Append a key-value pair to the end of a mapping. If the key+already exists the existing value is left in place; use+'setKey' to replace.+-}+appendKey :: Text -> AValue -> AValue -> AValue+appendKey k v m = case avBody m of+ AMap entries style+ | V.any (matchesKey k . amKey) entries -> m+ | otherwise ->+ let entry =+ AMapEntry+ (markDirty (aString k))+ (markDirty v)+ Nothing+ in markDirty+ m+ { avBody = AMap (V.snoc entries entry) style+ }+ ATagged tag inner -> modifyInner (ATagged tag) (appendKey k v) m inner+ AAnchored anchor inner -> modifyInner (AAnchored anchor) (appendKey k v) m inner+ AResolvedAlias _ _ target -> editAlias (appendKey k v) m target+ _ -> m+++{- | Walk a path of mapping keys and apply 'setKey' at the leaf.+The intermediate mappings are also marked dirty so the renderer+knows their layout might need re-flowing.+-}+updateAt :: [Text] -> AValue -> AValue -> AValue+updateAt [] _ m = m+updateAt [k] v m = setKey k v m+updateAt (k : ks) v m = updateKey k (Just . updateAt ks v) m+++{- | Replace an item in a sequence. If the index is out of bounds+the sequence is returned unchanged.+-}+setIndex :: Int -> AValue -> AValue -> AValue+setIndex i x s = case avBody s of+ ASeq items style+ | i >= 0+ , i < V.length items ->+ markDirty+ s+ { avBody = ASeq (items V.// [(i, preserveStyle (items V.! i) x)]) style+ }+ ATagged tag inner -> modifyInner (ATagged tag) (setIndex i x) s inner+ AAnchored anchor inner -> modifyInner (AAnchored anchor) (setIndex i x) s inner+ AResolvedAlias _ _ target -> editAlias (setIndex i x) s target+ _ -> s+++-- | Append an item to the end of a sequence.+appendItem :: AValue -> AValue -> AValue+appendItem x s = case avBody s of+ ASeq items style ->+ markDirty+ s+ { avBody = ASeq (V.snoc items (markDirty x)) style+ }+ ATagged tag inner -> modifyInner (ATagged tag) (appendItem x) s inner+ AAnchored anchor inner -> modifyInner (AAnchored anchor) (appendItem x) s inner+ AResolvedAlias _ _ target -> editAlias (appendItem x) s target+ _ -> s+++-- | Remove an item from a sequence.+deleteIndex :: Int -> AValue -> AValue+deleteIndex i s = case avBody s of+ ASeq items style+ | i >= 0+ , i < V.length items ->+ let items' = V.ifilter (\j _ -> j /= i) items+ in markDirty s {avBody = ASeq items' style}+ ATagged tag inner -> modifyInner (ATagged tag) (deleteIndex i) s inner+ AAnchored anchor inner -> modifyInner (AAnchored anchor) (deleteIndex i) s inner+ AResolvedAlias _ _ target -> editAlias (deleteIndex i) s target+ _ -> s
+ src/YAML/Class.hs view
@@ -0,0 +1,719 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Typeclass-based YAML serialization with GHC Generics support.+module YAML.Class (+ ToYAML (..),+ FromYAML (..),+ encodeYAML,+ encodeYAMLBS,+ decodeYAML,+ decodeYAMLBS,+ GToYAML (..),+ GFromYAML (..),+ validateFieldNames,+) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Functor.Compose (Compose (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product qualified as FProduct+import Data.Functor.Sum qualified as FSum+import Data.HashSet qualified as HS+import Data.Int (Int16, Int32, Int64, Int8)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet (IntSet)+import Data.IntSet qualified as IntSet+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Monoid qualified as Mon+import Data.Ord (Down (..))+import Data.Ratio (Ratio, denominator, numerator, (%))+import Data.Semigroup qualified as Semi+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TEnc+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Int qualified as BI+import Data.Text.Lazy.Builder.RealFloat qualified as BF+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Version (Version, makeVersion, versionBranch)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Float (double2Float, float2Double)+import GHC.Generics+import Numeric.Natural (Natural)+import YAML.Decode qualified as YD+import YAML.Encode qualified as YE+import YAML.Value qualified as YV+++-- ---------------------------------------------------------------------------+-- Class+-- ---------------------------------------------------------------------------++class ToYAML a where+ toYAML :: a -> YV.Value+ default toYAML :: (Generic a, GToYAML (Rep a)) => a -> YV.Value+ toYAML = gToYAML . from+++class FromYAML a where+ fromYAML :: YV.Value -> Either String a+ default fromYAML :: (Generic a, GFromYAML (Rep a)) => YV.Value -> Either String a+ fromYAML v = to <$> gFromYAML v+++encodeYAML :: ToYAML a => a -> Text+encodeYAML = YE.encode . toYAML+++encodeYAMLBS :: ToYAML a => a -> ByteString+encodeYAMLBS = YE.encodeBS . toYAML+++decodeYAML :: FromYAML a => Text -> Either String a+decodeYAML t = YD.decode t >>= fromYAML+++decodeYAMLBS :: FromYAML a => ByteString -> Either String a+decodeYAMLBS b = YD.decodeBS b >>= fromYAML+++-- ---------------------------------------------------------------------------+-- Scalar instances+-- ---------------------------------------------------------------------------++instance ToYAML YV.Value where toYAML = id+++instance FromYAML YV.Value where fromYAML = Right+++instance ToYAML Text where+ toYAML = YV.YString+++instance FromYAML Text where+ fromYAML v = case YV.unwrap v of+ YV.YString t -> Right t+ YV.YInt n -> Right (TL.toStrict (TB.toLazyText (BI.decimal n)))+ YV.YFloat d -> Right (TL.toStrict (TB.toLazyText (BF.realFloat d)))+ YV.YBool b -> Right (if b then "true" else "false")+ YV.YNull -> Right T.empty+ _ -> Left "FromYAML Text: expected scalar"+++instance ToYAML Bool where toYAML = YV.YBool+++instance FromYAML Bool where+ fromYAML v = case YV.unwrap v of+ YV.YBool b -> Right b+ _ -> Left "FromYAML Bool: expected YBool"+++intToYAML :: Integral a => a -> YV.Value+intToYAML = YV.YInt . fromIntegral+++intFrom :: forall a. (Integral a, Bounded a) => YV.Value -> Either String a+intFrom v = case YV.unwrap v of+ YV.YInt n+ | n >= toInteger (minBound :: a), n <= toInteger (maxBound :: a) -> Right (fromInteger n)+ | otherwise -> Left "FromYAML Int: integer out of range"+ _ -> Left "FromYAML Int: expected YInt"+++instance ToYAML Int where toYAML = intToYAML+++instance FromYAML Int where fromYAML = intFrom+++instance ToYAML Int8 where toYAML = intToYAML+++instance FromYAML Int8 where fromYAML = intFrom+++instance ToYAML Int16 where toYAML = intToYAML+++instance FromYAML Int16 where fromYAML = intFrom+++instance ToYAML Int32 where toYAML = intToYAML+++instance FromYAML Int32 where fromYAML = intFrom+++instance ToYAML Int64 where toYAML = intToYAML+++instance FromYAML Int64 where fromYAML = intFrom+++instance ToYAML Word where toYAML = intToYAML+++instance FromYAML Word where fromYAML = intFrom+++instance ToYAML Word8 where toYAML = intToYAML+++instance FromYAML Word8 where fromYAML = intFrom+++instance ToYAML Word16 where toYAML = intToYAML+++instance FromYAML Word16 where fromYAML = intFrom+++instance ToYAML Word32 where toYAML = intToYAML+++instance FromYAML Word32 where fromYAML = intFrom+++instance ToYAML Word64 where toYAML = intToYAML+++instance FromYAML Word64 where fromYAML = intFrom+++instance ToYAML Integer where toYAML = YV.YInt+++instance FromYAML Integer where+ fromYAML v = case YV.unwrap v of+ YV.YInt n -> Right n+ _ -> Left "FromYAML Integer: expected YInt"+++instance ToYAML Natural where toYAML = YV.YInt . fromIntegral+++instance FromYAML Natural where+ fromYAML v = case YV.unwrap v of+ YV.YInt n | n >= 0 -> Right (fromIntegral n)+ _ -> Left "FromYAML Natural: expected non-negative YInt"+++instance ToYAML Double where toYAML = YV.YFloat+++instance FromYAML Double where+ fromYAML v = case YV.unwrap v of+ YV.YFloat d -> Right d+ YV.YInt n -> Right (fromIntegral n)+ _ -> Left "FromYAML Double: expected YFloat"+++instance ToYAML Float where toYAML = YV.YFloat . float2Double+++instance FromYAML Float where+ fromYAML v = case YV.unwrap v of+ YV.YFloat d -> Right (double2Float d)+ YV.YInt n -> Right (fromIntegral n)+ _ -> Left "FromYAML Float: expected YFloat"+++instance ToYAML Char where+ toYAML c = YV.YString (T.singleton c)+++instance FromYAML Char where+ fromYAML v = case YV.unwrap v of+ YV.YString t | T.length t == 1 -> Right (T.head t)+ _ -> Left "FromYAML Char: expected single-character YString"+++instance ToYAML TL.Text where+ toYAML = YV.YString . TL.toStrict+++instance FromYAML TL.Text where+ fromYAML v = TL.fromStrict <$> fromYAML v+++{- | Valid UTF-8 bytes use a text scalar. Arbitrary binary data uses a sequence+of byte-valued integers, so this pure instance is total and round-trippable.+-}+instance ToYAML ByteString where+ toYAML bytes = case TEnc.decodeUtf8' bytes of+ Right text -> YV.YString text+ Left _ -> YV.YSeq (V.generate (BS.length bytes) (YV.YInt . toInteger . BS.index bytes))+++instance FromYAML ByteString where+ fromYAML v = case YV.unwrap v of+ YV.YString t -> Right (TEnc.encodeUtf8 t)+ YV.YSeq bytes -> BS.pack . V.toList <$> V.mapM (intFrom @Word8) bytes+ _ -> Left "FromYAML ByteString: expected text or a byte sequence"+++instance ToYAML BSL.ByteString where+ toYAML = toYAML . BSL.toStrict+++instance FromYAML BSL.ByteString where+ fromYAML v = BSL.fromStrict <$> fromYAML v+++instance ToYAML () where+ toYAML () = YV.YSeq V.empty+++instance FromYAML () where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs | V.null xs -> Right ()+ _ -> Left "FromYAML (): expected empty YSeq"+++-- ---------------------------------------------------------------------------+-- Container instances+-- ---------------------------------------------------------------------------++instance ToYAML a => ToYAML [a] where+ toYAML xs = YV.YSeq (V.fromList (map toYAML xs))+++instance FromYAML a => FromYAML [a] where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs -> traverse fromYAML (V.toList xs)+ _ -> Left "FromYAML [a]: expected YSeq"+++instance ToYAML a => ToYAML (Vector a) where+ toYAML xs = YV.YSeq (V.map toYAML xs)+++instance FromYAML a => FromYAML (Vector a) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs -> V.mapM fromYAML xs+ _ -> Left "FromYAML Vector: expected YSeq"+++instance ToYAML a => ToYAML (Maybe a) where+ toYAML Nothing = YV.YNull+ toYAML (Just x) = toYAML x+++instance FromYAML a => FromYAML (Maybe a) where+ fromYAML v = case YV.unwrap v of+ YV.YNull -> Right Nothing+ _ -> Just <$> fromYAML v+++instance ToYAML a => ToYAML (NonEmpty a) where+ toYAML = toYAML . NE.toList+++instance FromYAML a => FromYAML (NonEmpty a) where+ fromYAML v = do+ xs <- fromYAML v+ case xs of+ [] -> Left "FromYAML NonEmpty: empty list"+ (y : ys) -> Right (y :| ys)+++instance (ToYAML a, ToYAML b) => ToYAML (Either a b) where+ toYAML (Left x) = YV.YMap (V.singleton (YV.YString "Left", toYAML x))+ toYAML (Right x) = YV.YMap (V.singleton (YV.YString "Right", toYAML x))+++instance (FromYAML a, FromYAML b) => FromYAML (Either a b) where+ fromYAML v = case YV.unwrap v of+ YV.YMap kvs | V.length kvs == 1 -> case V.head kvs of+ (k, vv) -> case YV.unwrap k of+ YV.YString "Left" -> Left <$> fromYAML vv+ YV.YString "Right" -> Right <$> fromYAML vv+ _ -> Left "FromYAML Either: expected Left/Right key"+ _ -> Left "FromYAML Either: expected single-key YMap"+++instance ToYAML a => ToYAML (Set a) where+ toYAML = YV.YSeq . V.fromList . fmap toYAML . Set.toList+++instance (Ord a, FromYAML a) => FromYAML (Set a) where+ fromYAML v = Set.fromList <$> fromYAML v+++instance ToYAML a => ToYAML (Seq a) where+ toYAML s = YV.YSeq (V.fromList (fmap toYAML (foldr (:) [] s)))+++instance FromYAML a => FromYAML (Seq a) where+ fromYAML v = Seq.fromList <$> fromYAML v+++instance ToYAML v => ToYAML (Map Text v) where+ toYAML m = YV.YMap (V.fromList (fmap mkPair (Map.toList m)))+ where+ mkPair (k, val) = (YV.YString k, toYAML val)+++instance FromYAML v => FromYAML (Map Text v) where+ fromYAML v = case YV.unwrap v of+ YV.YMap kvs -> do+ V.foldM decodePair Map.empty kvs+ where+ decodePair values (k, val) = case YV.unwrap k of+ YV.YString s -> Map.alterF (\case Nothing -> Just <$> fromYAML val; Just _ -> Left "FromYAML Map: duplicate text key after unwrapping tags") s values+ _ -> Left "FromYAML (Map Text v): non-string key"+ _ -> Left "FromYAML (Map Text v): expected YMap"+++instance ToYAML v => ToYAML (IntMap v) where+ toYAML m = YV.YMap (V.fromList (fmap mkPair (IntMap.toList m)))+ where+ mkPair (k, val) = (YV.YInt (fromIntegral k), toYAML val)+++instance FromYAML v => FromYAML (IntMap v) where+ fromYAML v = case YV.unwrap v of+ YV.YMap kvs -> do+ V.foldM decodePair IntMap.empty kvs+ where+ decodePair values (k, val) = case YV.unwrap k of+ YV.YInt _ -> do+ key <- fromYAML k :: Either String Int+ IntMap.alterF (\case Nothing -> Just <$> fromYAML val; Just _ -> Left "FromYAML IntMap: duplicate integer key") key values+ _ -> Left "FromYAML IntMap: non-integer key"+ _ -> Left "FromYAML IntMap: expected YMap"+++instance ToYAML IntSet where+ toYAML = YV.YSeq . V.fromList . fmap toYAML . IntSet.toList+++instance FromYAML IntSet where+ fromYAML v = IntSet.fromList <$> fromYAML v+++-- ---------------------------------------------------------------------------+-- Tuples+-- ---------------------------------------------------------------------------++instance (ToYAML a, ToYAML b) => ToYAML (a, b) where+ toYAML (a, b) = YV.YSeq (V.fromList [toYAML a, toYAML b])+++instance (FromYAML a, FromYAML b) => FromYAML (a, b) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs+ | V.length xs == 2 ->+ (,) <$> fromYAML (xs V.! 0) <*> fromYAML (xs V.! 1)+ _ -> Left "FromYAML (a,b): expected YSeq of length 2"+++instance (ToYAML a, ToYAML b, ToYAML c) => ToYAML (a, b, c) where+ toYAML (a, b, c) = YV.YSeq (V.fromList [toYAML a, toYAML b, toYAML c])+++instance (FromYAML a, FromYAML b, FromYAML c) => FromYAML (a, b, c) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs+ | V.length xs == 3 ->+ (,,) <$> fromYAML (xs V.! 0) <*> fromYAML (xs V.! 1) <*> fromYAML (xs V.! 2)+ _ -> Left "FromYAML (a,b,c): expected YSeq of length 3"+++instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d) => ToYAML (a, b, c, d) where+ toYAML (a, b, c, d) =+ YV.YSeq (V.fromList [toYAML a, toYAML b, toYAML c, toYAML d])+++instance (FromYAML a, FromYAML b, FromYAML c, FromYAML d) => FromYAML (a, b, c, d) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs+ | V.length xs == 4 ->+ (,,,)+ <$> fromYAML (xs V.! 0)+ <*> fromYAML (xs V.! 1)+ <*> fromYAML (xs V.! 2)+ <*> fromYAML (xs V.! 3)+ _ -> Left "FromYAML (a,b,c,d): expected YSeq of length 4"+++-- ---------------------------------------------------------------------------+-- Functor / monoid newtypes+-- ---------------------------------------------------------------------------++instance ToYAML a => ToYAML (Identity a) where toYAML (Identity x) = toYAML x+++instance FromYAML a => FromYAML (Identity a) where+ fromYAML v = Identity <$> fromYAML v+++instance ToYAML a => ToYAML (Const a b) where toYAML (Const x) = toYAML x+++instance FromYAML a => FromYAML (Const a b) where+ fromYAML v = Const <$> fromYAML v+++instance ToYAML a => ToYAML (Down a) where toYAML (Down x) = toYAML x+++instance FromYAML a => FromYAML (Down a) where+ fromYAML v = Down <$> fromYAML v+++instance ToYAML Version where toYAML = toYAML . versionBranch+++instance FromYAML Version where fromYAML v = makeVersion <$> fromYAML v+++instance ToYAML a => ToYAML (Ratio a) where+ toYAML r = YV.YSeq (V.fromList [toYAML (numerator r), toYAML (denominator r)])+++instance (Integral a, FromYAML a) => FromYAML (Ratio a) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs | V.length xs == 2 -> do+ n <- fromYAML (xs V.! 0)+ d <- fromYAML (xs V.! 1)+ if d == 0+ then Left "FromYAML Ratio: zero denominator"+ else Right (n % d)+ _ -> Left "FromYAML Ratio: expected YSeq of length 2"+++instance ToYAML a => ToYAML (Mon.Sum a) where toYAML = toYAML . Mon.getSum+++instance FromYAML a => FromYAML (Mon.Sum a) where+ fromYAML v = Mon.Sum <$> fromYAML v+++instance ToYAML a => ToYAML (Mon.Product a) where toYAML = toYAML . Mon.getProduct+++instance FromYAML a => FromYAML (Mon.Product a) where+ fromYAML v = Mon.Product <$> fromYAML v+++instance ToYAML a => ToYAML (Mon.Dual a) where toYAML = toYAML . Mon.getDual+++instance FromYAML a => FromYAML (Mon.Dual a) where+ fromYAML v = Mon.Dual <$> fromYAML v+++instance ToYAML Mon.All where toYAML = toYAML . Mon.getAll+++instance FromYAML Mon.All where fromYAML v = Mon.All <$> fromYAML v+++instance ToYAML Mon.Any where toYAML = toYAML . Mon.getAny+++instance FromYAML Mon.Any where fromYAML v = Mon.Any <$> fromYAML v+++instance ToYAML a => ToYAML (Mon.First a) where toYAML = toYAML . Mon.getFirst+++instance FromYAML a => FromYAML (Mon.First a) where+ fromYAML v = Mon.First <$> fromYAML v+++instance ToYAML a => ToYAML (Mon.Last a) where toYAML = toYAML . Mon.getLast+++instance FromYAML a => FromYAML (Mon.Last a) where+ fromYAML v = Mon.Last <$> fromYAML v+++instance ToYAML a => ToYAML (Semi.Min a) where toYAML = toYAML . Semi.getMin+++instance FromYAML a => FromYAML (Semi.Min a) where+ fromYAML v = Semi.Min <$> fromYAML v+++instance ToYAML a => ToYAML (Semi.Max a) where toYAML = toYAML . Semi.getMax+++instance FromYAML a => FromYAML (Semi.Max a) where+ fromYAML v = Semi.Max <$> fromYAML v+++instance ToYAML a => ToYAML (Semi.First a) where toYAML = toYAML . Semi.getFirst+++instance FromYAML a => FromYAML (Semi.First a) where+ fromYAML v = Semi.First <$> fromYAML v+++instance ToYAML a => ToYAML (Semi.Last a) where toYAML = toYAML . Semi.getLast+++instance FromYAML a => FromYAML (Semi.Last a) where+ fromYAML v = Semi.Last <$> fromYAML v+++instance ToYAML a => ToYAML (Semi.WrappedMonoid a) where+ toYAML = toYAML . Semi.unwrapMonoid+++instance FromYAML a => FromYAML (Semi.WrappedMonoid a) where+ fromYAML v = Semi.WrapMonoid <$> fromYAML v+++instance (ToYAML a, ToYAML b) => ToYAML (Semi.Arg a b) where+ toYAML (Semi.Arg a b) = YV.YSeq (V.fromList [toYAML a, toYAML b])+++instance (FromYAML a, FromYAML b) => FromYAML (Semi.Arg a b) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs+ | V.length xs == 2 ->+ Semi.Arg <$> fromYAML (xs V.! 0) <*> fromYAML (xs V.! 1)+ _ -> Left "FromYAML Arg: expected YSeq of length 2"+++instance ToYAML (f (g a)) => ToYAML (Compose f g a) where+ toYAML = toYAML . getCompose+++instance FromYAML (f (g a)) => FromYAML (Compose f g a) where+ fromYAML v = Compose <$> fromYAML v+++instance (ToYAML (f a), ToYAML (g a)) => ToYAML (FProduct.Product f g a) where+ toYAML (FProduct.Pair x y) = YV.YSeq (V.fromList [toYAML x, toYAML y])+++instance (FromYAML (f a), FromYAML (g a)) => FromYAML (FProduct.Product f g a) where+ fromYAML v = case YV.unwrap v of+ YV.YSeq xs+ | V.length xs == 2 ->+ FProduct.Pair <$> fromYAML (xs V.! 0) <*> fromYAML (xs V.! 1)+ _ -> Left "FromYAML Functor.Product: expected YSeq of length 2"+++instance (ToYAML (f a), ToYAML (g a)) => ToYAML (FSum.Sum f g a) where+ toYAML (FSum.InL x) = YV.YMap (V.singleton (YV.YString "InL", toYAML x))+ toYAML (FSum.InR x) = YV.YMap (V.singleton (YV.YString "InR", toYAML x))+++instance (FromYAML (f a), FromYAML (g a)) => FromYAML (FSum.Sum f g a) where+ fromYAML v = case YV.unwrap v of+ YV.YMap kvs | V.length kvs == 1 -> case V.head kvs of+ (k, val) -> case YV.unwrap k of+ YV.YString "InL" -> FSum.InL <$> fromYAML val+ YV.YString "InR" -> FSum.InR <$> fromYAML val+ _ -> Left "FromYAML Functor.Sum: expected InL/InR key"+ _ -> Left "FromYAML Functor.Sum: expected single-key YMap"+++-- ---------------------------------------------------------------------------+-- GHC.Generics support+-- ---------------------------------------------------------------------------++class GToYAML f where+ gToYAML :: f p -> YV.Value+++class GFromYAML f where+ gFromYAML :: YV.Value -> Either String (f p)+++instance GToYAML f => GToYAML (M1 D c f) where+ gToYAML (M1 x) = gToYAML x+++instance GFromYAML f => GFromYAML (M1 D c f) where+ gFromYAML v = M1 <$> gFromYAML v+++instance GToYAMLFields f => GToYAML (M1 C c f) where+ gToYAML (M1 x) = YV.YMap (V.fromList (gToYAMLFields x))+++instance GFromYAMLFields f => GFromYAML (M1 C c f) where+ gFromYAML v = case YV.unwrap v of+ YV.YMap kvs -> do+ validateFieldNames kvs+ let lkup nm = lookupField nm kvs+ M1 <$> gFromYAMLFields lkup+ _ -> Left "GFromYAML: expected YMap for record type"+++{- | Tags can distinguish YAML mapping keys whose native Text field names are+equal. Reject that ambiguity before a record decoder chooses a field.+-}+validateFieldNames :: Vector (YV.Value, YV.Value) -> Either String ()+validateFieldNames fields = () <$ V.foldM add HS.empty fields+ where+ add names (key, _) = case YV.unwrap key of+ YV.YString name+ | HS.member name names -> Left "FromYAML: duplicate field name after unwrapping tags"+ | otherwise -> Right (HS.insert name names)+ _ -> Right names+++lookupField :: Text -> Vector (YV.Value, YV.Value) -> Maybe YV.Value+lookupField nm kvs = go 0+ where+ !len = V.length kvs+ go !i+ | i >= len = Nothing+ | otherwise = case kvs V.! i of+ (k, val) -> case YV.unwrap k of+ YV.YString s | s == nm -> Just val+ _ -> go (i + 1)+++class GToYAMLFields f where+ gToYAMLFields :: f p -> [(YV.Value, YV.Value)]+++class GFromYAMLFields f where+ gFromYAMLFields :: (Text -> Maybe YV.Value) -> Either String (f p)+++instance (GToYAMLFields a, GToYAMLFields b) => GToYAMLFields (a :*: b) where+ gToYAMLFields (a :*: b) = gToYAMLFields a ++ gToYAMLFields b+++instance (GFromYAMLFields a, GFromYAMLFields b) => GFromYAMLFields (a :*: b) where+ gFromYAMLFields lkup = (:*:) <$> gFromYAMLFields lkup <*> gFromYAMLFields lkup+++instance (Selector s, ToYAML a) => GToYAMLFields (M1 S s (K1 i a)) where+ gToYAMLFields m@(M1 (K1 x)) = [(YV.YString (T.pack (selName m)), toYAML x)]+++instance (Selector s, FromYAML a) => GFromYAMLFields (M1 S s (K1 i a)) where+ gFromYAMLFields lkup =+ let nm = T.pack (selName (undefined :: M1 S s (K1 i a) p))+ in case lkup nm of+ Nothing -> Left $ "GFromYAML: missing field " ++ T.unpack nm+ Just v -> M1 . K1 <$> fromYAML v
+ src/YAML/Decode.hs view
@@ -0,0 +1,4544 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++{- | YAML 1.2 decoder.++Parses a YAML stream into a 'YAML.Value.Stream' / 'Document' /+'Value' according to the YAML 1.2 specification, applying the+/core schema/ for plain-scalar resolution. Supports:++* Block-style mappings and sequences (with flexible indentation).+* Flow-style mappings (@{a: b}@) and sequences (@[a, b]@), nested.+* Plain, single-quoted, and double-quoted scalars (with all+ YAML 1.2 escapes for the latter, including @\\xNN@, @\\uNNNN@,+ @\\UNNNNNNNN@).+* Block literal (@|@) and block folded (@>@) scalars with all three+ chomping indicators (@-@, @+@, default-clip) and optional+ indentation indicators.+* Anchors (@&name@) and aliases (@*name@). Aliases are expanded+ inline so that downstream code can treat the result as a tree.+* Explicit tags (@!!str@, @!!int@, @!\<tag:yaml.org,2002:bool\>@,+ etc.) with the standard short-hand expansions for the+ @tag:yaml.org,2002:@ family.+* Comments, blank lines, the @---@ document-start and @...@+ document-end markers, and multi-document streams.+-}+module YAML.Decode (+ decode,+ decodeBS,+ decodeStream,+ decodeStreamBS,+ decodeDocuments,+ LocatedDocument (..),+ decodeLocatedDocuments,+ resolveExplicitTag,+ preprocess,+ splitMappingLine,+) where++import Control.Monad (unless, when)+import Control.Monad.State.Strict (StateT, evalStateT, get, lift, modify')+import Data.Bits qualified as Bits+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Char (chr, digitToInt, isDigit, isHexDigit)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HM+import Data.HashSet qualified as HS+import Data.Hashable (Hashable)+import Data.List (sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Scientific qualified as Sci+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Array qualified as TA+import Data.Text.Encoding qualified as TE+import Data.Text.Internal qualified as TI+import Data.Text.Internal.Unsafe.Char qualified as TU+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Int qualified as BI+import Data.Vector qualified as V+import Data.Word (Word64, Word8)+import GHC.ByteOrder (ByteOrder (..), targetByteOrder)+import GHC.Exts (+ ByteArray#,+ Int (..),+ Int#,+ clz#,+ ctz#,+ indexWord8ArrayAsWord64#,+ uncheckedIShiftRL#,+ word2Int#,+ word64ToWord#,+ )+import GHC.Float (castDoubleToWord64)+import GHC.Generics (Generic)+import GHC.Word (Word64 (..))+import YAML.Annotated qualified as A+import YAML.Internal (stripYaml, stripYamlEnd, stripYamlStart, wordsYaml)+import YAML.Value+++-- ---------------------------------------------------------------------------+-- Fast byte-indexed Text access. The flow parser walks a buffer+-- one byte at a time looking for ASCII control characters+-- ('[', ']', '{', '}', ',', ':', '#', '\\1', '\\2'); doing that+-- through 'T.index' / 'T.length' is O(p) / O(N) per call because+-- Text positions are character indices and the implementation has+-- to walk UTF-8 bytes to convert. Operating on the underlying+-- byte array directly gives O(1) access without changing the+-- semantics for ASCII-only control bytes (multi-byte UTF-8+-- sequences in scalar content all start with a leading byte ≥+-- 0x80 that never matches our ASCII stoppers).+-- ---------------------------------------------------------------------------++-- | Byte length of a 'Text' (O(1)).+bLen :: Text -> Int+bLen (TI.Text _ _ l) = l+{-# INLINE bLen #-}+++{- | Byte at position @p@ inside a 'Text' (O(1)). The caller is+responsible for keeping @p@ in @[0, bLen t)@.+-}+bAt :: Text -> Int -> Word8+bAt (TI.Text arr off _) p = TA.unsafeIndex arr (off + p)+{-# INLINE bAt #-}+++{- | Slice @t@ to the bytes @[s, e)@ (O(1)). The caller must+ensure both ends sit on UTF-8 character boundaries.+-}+bSlice :: Text -> Int -> Int -> Text+bSlice (TI.Text arr off _) s e = TI.text arr (off + s) (max 0 (e - s))+{-# INLINE bSlice #-}+++{- | Drop the first @p@ bytes of @t@ (O(1)). Caller must ensure+@p@ lies on a UTF-8 character boundary.+-}+bDrop :: Int -> Text -> Text+bDrop p (TI.Text arr off l) =+ let !p' = min p l+ in TI.text arr (off + p') (l - p')+{-# INLINE bDrop #-}+++{- | Take the first @p@ bytes of @t@ (O(1)). Caller must ensure+@p@ lies on a UTF-8 character boundary.+-}+bTake :: Int -> Text -> Text+bTake p (TI.Text arr off l) =+ let !p' = max 0 (min p l)+ in TI.text arr off p'+{-# INLINE bTake #-}+++-- ---------------------------------------------------------------------------+-- SWAR (SIMD-Within-A-Register) byte scanners.+--+-- Most of the parser's hot inner loops are looking for a single+-- ASCII byte (e.g. '#', '\\1', '\"') in a 'Text' body. The+-- Data.Text 'T.any' / 'T.findIndex' walk one /character/ at a+-- time via the UTF-8 stream interface; we can do much better by+-- treating the underlying byte array as 64-bit words and using+-- the classic "has-zero-byte" bit trick:+--+-- hasZeroByte x = ((x - 0x0101010101010101) & ~x & 0x8080808080808080) /= 0+--+-- After XOR-ing the input word with a broadcast of the target+-- byte, any byte equal to the target becomes zero, so a single+-- 64-bit operation tells us whether the eight bytes contain it.+-- ---------------------------------------------------------------------------++bcast64 :: Word8 -> Word64+bcast64 b = fromIntegral b * 0x0101010101010101+{-# INLINE bcast64 #-}+++{- | True iff @x@ contains any zero byte. False-positive-free for+the boolean answer (the standard 'has-zero-byte' trick is+reliable for the binary "any zero?" question even though its+per-byte mask is not).+-}+hasZeroByte :: Word64 -> Bool+hasZeroByte x =+ ( (x - 0x0101010101010101)+ Bits..&. Bits.complement x+ Bits..&. 0x8080808080808080+ )+ /= 0+{-# INLINE hasZeroByte #-}+++{- | Per-byte mask: returns @0x80@ in every byte position where+the input byte was @0x00@ and @0x00@ everywhere else. Robust+against the borrow-propagation false positives of the simpler+@(x-ones)&~x&hi@ formula (Hacker's Delight §6-1, "find a+specific byte").+-}+zeroByteMask :: Word64 -> Word64+zeroByteMask x =+ let !lo7 = 0x7F7F7F7F7F7F7F7F :: Word64+ !his = 0x8080808080808080 :: Word64+ !t = ((x Bits..&. lo7) + lo7) Bits..|. x+ in -- 'hi-bit set' iff one of:+ -- * x had bit 7 set (so byte was >= 0x80, i.e. not 0x00)+ -- * (low 7 bits of x) + 0x7F had bit 7 set (i.e. low 7+ -- bits weren't all zero, i.e. byte was non-zero in 1..127)+ -- Either way 'hi-bit set' means "non-zero". Inverting and+ -- ANDing with 'his' picks out the zero bytes only.+ Bits.complement t Bits..&. his+{-# INLINE zeroByteMask #-}+++{- | Read 8 unaligned bytes from a byte array starting at byte+index @i@ as a single 'Word64'.+-}+indexWord64Unaligned :: ByteArray# -> Int -> Word64+indexWord64Unaligned ba# (I# i#) = W64# (indexWord8ArrayAsWord64# ba# i#)+{-# INLINE indexWord64Unaligned #-}+++{- | True when @t@ contains the byte @c@. Pure byte-level scan+(no UTF-8 decoding) using a Word64-at-a-time loop.+-}+bAnyByte :: Word8 -> Text -> Bool+bAnyByte !c (TI.Text (TA.ByteArray ba#) off len) =+ let !pat = bcast64 c+ !endB = off + len+ goWord !i+ | i + 8 > endB = goByte i+ | otherwise =+ let !w = indexWord64Unaligned ba# i+ !xored = w `Bits.xor` pat+ in if hasZeroByte xored+ then True+ else goWord (i + 8)+ goByte !i+ | i >= endB = False+ | TA.unsafeIndex (TA.ByteArray ba#) i == c = True+ | otherwise = goByte (i + 1)+ in goWord off+{-# INLINE bAnyByte #-}+++-- 0: printable ASCII with no CR; 1: the same with CR line breaks;+-- 2: Unicode or a potentially invalid control, requiring lexical validation.+-- The word loop avoids decoding ASCII as Unicode twice on ordinary documents.+asciiSourceStatus :: Text -> Int#+asciiSourceStatus (TI.Text array@(TA.ByteArray bytes#) offset size) =+ case wordLoop offset 0 of I# result -> result+ where+ end = offset + size+ wordLoop !position !status+ | position + 8 > end = byteLoop position end status+ | otherwise =+ let word = indexWord64Unaligned bytes# position+ in if word Bits..&. 0x8080808080808080 /= 0+ then 2+ else+ if hasZeroByte (word Bits..&. 0xE0E0E0E0E0E0E0E0) || hasZeroByte (word `Bits.xor` 0x7F7F7F7F7F7F7F7F)+ then case byteLoop position (position + 8) status of+ 2 -> 2+ nextStatus -> wordLoop (position + 8) nextStatus+ else wordLoop (position + 8) status+ byteLoop !position !limit !status+ | position >= limit = status+ | otherwise = case TA.unsafeIndex array position of+ 13 -> byteLoop (position + 1) limit 1+ 9 -> byteLoop (position + 1) limit status+ 10 -> byteLoop (position + 1) limit status+ byte+ | byte >= 32 && byte < 127 -> byteLoop (position + 1) limit status+ | otherwise -> 2+{-# INLINE asciiSourceStatus #-}+++{- | First matching byte in memory order. A native word load places the+first byte at opposite ends on little- and big-endian hosts. The target+byte order is a compile-time constant, so the unused branch disappears.+-}+wordFirstMatchByte :: Word64 -> Int+wordFirstMatchByte (W64# word#) = case targetByteOrder of+ LittleEndian -> I# (uncheckedIShiftRL# (word2Int# (ctz# (word64ToWord# word#))) 3#)+ BigEndian -> I# (uncheckedIShiftRL# (word2Int# (clz# (word64ToWord# word#))) 3#)+{-# INLINE wordFirstMatchByte #-}+++{- | First index of /any/ of three bytes in @t@, or @-1@ when+none is present. Three robust SWAR scans run on the same+Word64 per iteration; the OR-combined per-byte mask is then+'ctz'-ed for the in-word offset of the first match.+-}+bFindAnyOf3 :: Word8 -> Word8 -> Word8 -> Text -> Int+bFindAnyOf3 !a !b !c (TI.Text (TA.ByteArray ba#) off len) =+ let !pa = bcast64 a+ !pb = bcast64 b+ !pc = bcast64 c+ !endB = off + len+ goWord !i+ | i + 8 > endB = goByte i+ | otherwise =+ let !w = indexWord64Unaligned ba# i+ !m =+ zeroByteMask (w `Bits.xor` pa)+ Bits..|. zeroByteMask (w `Bits.xor` pb)+ Bits..|. zeroByteMask (w `Bits.xor` pc)+ in if m == 0+ then goWord (i + 8)+ else i + wordFirstMatchByte m - off+ goByte !i+ | i >= endB = -1+ | otherwise =+ let !x = TA.unsafeIndex (TA.ByteArray ba#) i+ in if x == a || x == b || x == c+ then i - off+ else goByte (i + 1)+ in goWord off+{-# INLINE bFindAnyOf3 #-}+++-- | First index of either of two bytes. See 'bFindAnyOf3'.+bFindAnyOf2 :: Word8 -> Word8 -> Text -> Int+bFindAnyOf2 !a !b (TI.Text (TA.ByteArray ba#) off len) =+ let !pa = bcast64 a+ !pb = bcast64 b+ !endB = off + len+ goWord !i+ | i + 8 > endB = goByte i+ | otherwise =+ let !w = indexWord64Unaligned ba# i+ !m =+ zeroByteMask (w `Bits.xor` pa)+ Bits..|. zeroByteMask (w `Bits.xor` pb)+ in if m == 0+ then goWord (i + 8)+ else i + wordFirstMatchByte m - off+ goByte !i+ | i >= endB = -1+ | otherwise =+ let !x = TA.unsafeIndex (TA.ByteArray ba#) i+ in if x == a || x == b+ then i - off+ else goByte (i + 1)+ in goWord off+{-# INLINE bFindAnyOf2 #-}+++-- | Word8 character literals of common ASCII control bytes.+w8Comma+ , w8Colon+ , w8LBrack+ , w8RBrack+ , w8LBrace+ , w8RBrace+ , w8DQuote+ , w8SQuote+ , w8Hash+ , w8Space+ , w8Tab+ , w8Quest+ , w8SOH+ , w8STX+ , w8Backslash+ :: Word8+w8Comma = 44+w8Colon = 58+w8LBrack = 91+w8RBrack = 93+w8LBrace = 123+w8RBrace = 125+w8DQuote = 34+w8SQuote = 39+w8Hash = 35+w8Space = 32+w8Tab = 9+w8Quest = 63+w8SOH = 1 -- '\\1'+w8STX = 2 -- '\\2'+w8Backslash = 92+++-- ---------------------------------------------------------------------------+-- Public entry points+-- ---------------------------------------------------------------------------++decode :: Text -> Either String Value+decode t = case decodeDocuments t of+ Left err -> Left err+ Right [] -> Right YNull+ Right [d] -> Right (docBody d)+ Right _ -> Left "YAML: source contains multiple documents; use decodeStream"+++decodeBS :: ByteString -> Either String Value+decodeBS bs = decodeSourceBS bs >>= decode+++decodeStream :: Text -> Either String Stream+decodeStream t = (Stream . V.fromList) <$> decodeDocuments t+++decodeStreamBS :: ByteString -> Either String Stream+decodeStreamBS bs = decodeSourceBS bs >>= decodeStream+++-- The first bytes distinguish UTF-8, UTF-16 and UTF-32 even without a BOM.+-- Validate wide encodings before using text's partial decoding functions.+decodeSourceBS :: ByteString -> Either String Text+decodeSourceBS bytes+ | prefix [0, 0, 254, 255] || (len >= 4 && byte 0 == 0 && byte 1 == 0 && byte 2 == 0) = wide32 False+ | prefix [255, 254, 0, 0] || (len >= 4 && byte 1 == 0 && byte 2 == 0 && byte 3 == 0) = wide32 True+ | prefix [254, 255] || (len >= 2 && byte 0 == 0) = wide16 False+ | prefix [255, 254] || (len >= 2 && byte 1 == 0) = wide16 True+ | otherwise = either (Left . show) Right (TE.decodeUtf8' bytes)+ where+ len = BS.length bytes+ byte = BS.index bytes+ prefix = (`BS.isPrefixOf` bytes) . BS.pack+ unit :: Bool -> Int -> Int+ unit little i =+ let a = fromIntegral (byte i)+ b = fromIntegral (byte (i + 1))+ in if little then a + b * 256 else a * 256 + b+ wide16 little+ | len `rem` 2 /= 0 || not (valid16 0) = Left "YAML: invalid UTF-16 input"+ | otherwise = Right ((if little then TE.decodeUtf16LE else TE.decodeUtf16BE) bytes)+ where+ valid16 i+ | i >= len = True+ | u >= 0xD800 && u <= 0xDBFF = i + 3 < len && let low = unit little (i + 2) in low >= 0xDC00 && low <= 0xDFFF && valid16 (i + 4)+ | u >= 0xDC00 && u <= 0xDFFF = False+ | otherwise = valid16 (i + 2)+ where+ u = unit little i :: Int+ wide32 little+ | len `rem` 4 /= 0 || not (valid32 0) = Left "YAML: invalid UTF-32 input"+ | otherwise = Right ((if little then TE.decodeUtf32LE else TE.decodeUtf32BE) bytes)+ where+ valid32 i+ | i >= len = True+ | otherwise =+ let a = unit little i :: Int+ b = unit little (i + 2)+ cp = if little then a + b * 65536 else a * 65536 + b+ in cp <= 0x10FFFF && (cp < 0xD800 || cp > 0xDFFF) && valid32 (i + 4)+++decodeDocuments :: Text -> Either String [Document]+decodeDocuments src = prepareSource src >>= parseStream . preprocess+++prepareSource :: Text -> Either String Text+prepareSource src = case asciiSourceStatus src of+ 0# -> Right src+ 1# -> Right (normalizeLineBreaks src)+ _+ | T.any suspicious src && not (validRawCharacters (RawOutside True True) src) -> Left "YAML: invalid unescaped character in input"+ | otherwise -> Right (normalizeLineBreaks src)+ where+ suspicious c = invalidC0 c || c >= '\x7F' && c < '\xA0' && c /= '\x85' || c == '\xFFFE' || c == '\xFFFF'+++invalidC0 :: Char -> Bool+invalidC0 c = c < ' ' && c /= '\t' && c /= '\n' && c /= '\r'+++data RawContext = RawOutside !Bool !Bool | RawComment | RawSingle | RawDouble | RawEscape+++-- Only needed when the source contains a non-printable code point. YAML's+-- JSON-compatible quoted scalars allow non-C0 code points that comments and+-- plain/block scalars forbid. The structural parser validates the latter too.+validRawCharacters :: RawContext -> Text -> Bool+validRawCharacters context source = case T.uncons source of+ Nothing -> True+ Just (c, rest)+ | invalidC0 c -> False+ | otherwise -> case context of+ RawDouble -> go (case c of '"' -> RawOutside False False; '\\' -> RawEscape; _ -> RawDouble) rest+ RawEscape -> go RawDouble rest+ RawSingle+ | c == '\'' -> case T.uncons rest of+ Just ('\'', after) -> go RawSingle after+ _ -> go (RawOutside False False) rest+ | otherwise -> go RawSingle rest+ RawComment -> printable c && go (if c == '\n' then RawOutside True True else RawComment) rest+ RawOutside canStart separated+ | not (printable c) -> False+ | c == '\n' || c == '\r' -> go (RawOutside True True) rest+ | canStart && c == '\xFEFF' -> go (RawOutside True separated) rest+ | c == ' ' || c == '\t' -> go (RawOutside canStart True) rest+ | canStart && c == '"' -> go RawDouble rest+ | canStart && c == '\'' -> go RawSingle rest+ | separated && c == '#' -> go RawComment rest+ | canStart && (c == '!' || c == '&') ->+ let (token, after) = T.break (\char -> char == ' ' || char == '\t' || char == '\n' || char == '\r') rest+ in T.all printable token && go (RawOutside True True) after+ | c `T.elem` "[,{" -> go (RawOutside True False) rest+ | canStart && c == '-', Just after <- T.stripPrefix "--" rest, followsSeparator after -> go (RawOutside True False) after+ | c == ':' && followsSeparator rest -> go (RawOutside True False) rest+ | canStart && c `T.elem` "-?" && followsSeparator rest -> go (RawOutside True False) rest+ | otherwise -> go (RawOutside False False) rest+ where+ go = validRawCharacters+ printable c = c == '\n' || c == '\r' || c == '\xFEFF' || validNonBreak c+ followsSeparator text = case T.uncons text of+ Nothing -> True+ Just (c, _) -> c `T.elem` " \t\n\r,]}"+++validNonBreak :: Char -> Bool+validNonBreak c = (c == '\t' || c >= ' ' && c <= '\x7E' || c == '\x85' || c >= '\xA0' && c <= '\xFFFD' || c >= '\x10000') && c /= '\xFEFF'+++normalizeLineBreaks :: Text -> Text+normalizeLineBreaks src+ | T.any (== '\r') src = T.replace "\r" "\n" (T.replace "\r\n" "\n" src)+ | otherwise = src+++-- | A document and its original source slice, with a UTF-8 byte offset in the stream.+data LocatedDocument = LocatedDocument+ { locatedDocument :: !Document+ , locatedSource :: !Text+ , locatedOffset :: {-# UNPACK #-} !Int+ , locatedAnnotatedBody :: A.AValue+ -- ^ Presentation tree retaining immutable alias references for editing.+ }+++data ParsedDocument = ParsedDocument+ { parsedDocument :: !Document+ , parsedStartLine :: {-# UNPACK #-} !Int+ , parsedAnnotated :: ~(Either String A.AValue)+ }+++{- | Source slices come from the same parse as the document structure. Concatenating+the slices recovers the original stream, including comments and directives.+-}+decodeLocatedDocuments :: Text -> Either String [LocatedDocument]+decodeLocatedDocuments src = do+ prepared <- prepareSource src+ parsed <- parseStreamLocated (preprocess prepared)+ let bytes = TE.encodeUtf8 src+ starts = V.fromList (0 : lineStarts bytes 0)+ offset line = if line <= 1 then 0 else starts V.! (line - 1)+ locate [] = Right []+ locate (d : ds) = do+ annotations <- parsedAnnotated d+ others <- locate ds+ let begin = offset (parsedStartLine d)+ end = case ds of next : _ -> offset (parsedStartLine next); [] -> BS.length bytes+ pure (LocatedDocument (parsedDocument d) (TE.decodeUtf8 (BS.take (end - begin) (BS.drop begin bytes))) begin annotations : others)+ locate parsed+ where+ lineStarts bytes = go+ where+ len = BS.length bytes+ go i+ | i >= len = []+ | BS.index bytes i == 13 =+ let next = if i + 1 < len && BS.index bytes (i + 1) == 10 then i + 2 else i + 1+ in next : go next+ | BS.index bytes i == 10 = (i + 1) : go (i + 1)+ | otherwise = go (i + 1)+++-- ---------------------------------------------------------------------------+-- Pre-processing: split into structured lines+-- ---------------------------------------------------------------------------++data PLine = PLine+ { lineNo :: {-# UNPACK #-} !Int+ , lineIndent :: {-# UNPACK #-} !Int+ , lineKind :: !LineKind+ , lineBody :: !Text+ {- ^ content after stripping indent+ AND trailing whitespace (the form+ most parser paths want)+ -}+ , lineRawBody :: !Text+ {- ^ content after stripping indent+ only — trailing whitespace kept,+ for block-scalar collection+ -}+ }+ deriving (Show)+++data LineKind+ = LBlank+ | LComment+ | -- | @---@+ LDocStart+ | -- | @...@+ LDocEnd+ | -- | @%YAML 1.2@ etc.+ LDirective+ | LContent+ | LByteOrderMark+ deriving (Eq, Show)+++preprocess :: Text -> [PLine]+preprocess (TI.Text arr@(TA.ByteArray ba#) off blen) =+ goLine 1 off+ where+ !endByte = off + blen++ -- A single line scan: SWAR-find the next '\\n', then dispatch+ -- to 'mkLine' which does the indent / strip-trailing-WS+ -- analysis as a small backward + forward pass on the line+ -- slice. Splitting "find newline" from "analyse line" lets+ -- the bulk content scan run 8 bytes at a time.+ goLine :: Int -> Int -> [PLine]+ goLine !lno !lineStart+ | lineStart >= endByte = []+ | otherwise =+ let !nlAbs = scanNewline lineStart+ -- 'nlAbs' is endByte if the trailing line has no+ -- terminating '\\n'. Either way 'mkLine' builds+ -- the PLine for [lineStart, nlAbs).+ !line = mkLine lno lineStart nlAbs+ !next = if nlAbs < endByte then nlAbs + 1 else endByte+ in line : goLine (lno + 1) next++ -- SWAR scan for byte 0x0A starting at @i@. Returns the+ -- absolute byte index of the first newline, or @endByte@+ -- when none is found in [i, endByte). Uses the robust+ -- 'zeroByteMask' so the per-byte position from 'ctz' is+ -- exact.+ scanNewline :: Int -> Int+ scanNewline !i+ | i + 8 > endByte = scanNewlineByte i+ | otherwise =+ let !w = indexWord64Unaligned ba# i+ !m = zeroByteMask (w `Bits.xor` 0x0A0A0A0A0A0A0A0A)+ in if m == 0+ then scanNewline (i + 8)+ else+ let !off' = wordFirstMatchByte m+ !cand = i + off'+ in if cand < endByte then cand else endByte++ scanNewlineByte :: Int -> Int+ scanNewlineByte !i+ | i >= endByte = endByte+ | TA.unsafeIndex arr i == 10 = i+ | otherwise = scanNewlineByte (i + 1)++ -- Build a 'PLine' for the byte range [lineStart, lineEnd)+ -- (lineEnd points at the terminating '\\n' or 'endByte').+ -- Indentation is purely leading SPACE characters; tabs+ -- never count. Trailing '\\r', spaces and tabs are stripped+ -- from 'lineBody' but retained in 'lineRawBody'.+ mkLine :: Int -> Int -> Int -> PLine+ mkLine !lno !lineStart !lineEnd =+ let !endNoCR =+ if lineEnd > lineStart+ && TA.unsafeIndex arr (lineEnd - 1) == 13+ then lineEnd - 1+ else lineEnd+ !leadSp = countLeadingSpaces lineStart endNoCR+ !contentStart = lineStart + leadSp+ in if contentStart >= endNoCR+ then+ let !restLen = endNoCR - contentStart+ !lineRawB =+ if restLen == 0+ then T.empty+ else TI.text arr contentStart restLen+ in PLine lno leadSp LBlank T.empty lineRawB+ else+ let !rawEnd = stripTrailingWS endNoCR contentStart+ !rawLen = endNoCR - contentStart+ !bodyLen = rawEnd - contentStart+ !lineRawB = TI.text arr contentStart rawLen+ !lineB+ | bodyLen == 0 = T.empty+ | bodyLen == rawLen = lineRawB+ | otherwise = TI.text arr contentStart bodyLen+ !kind = if leadSp == 0 && T.isPrefixOf "\xFEFF" lineB then LByteOrderMark else classify lineB+ in PLine lno leadSp kind lineB lineRawB++ countLeadingSpaces :: Int -> Int -> Int+ countLeadingSpaces !s !e = go s+ where+ go !i+ | i >= e = i - s+ | TA.unsafeIndex arr i == 32 = go (i + 1)+ | otherwise = i - s++ -- Walk backward from @e@ down to @low@, returning the byte+ -- index just past the last non-(space|tab) byte. Used to+ -- strip trailing whitespace from 'lineBody' without the+ -- per-byte 'lastNonWS' tracking the previous code did+ -- during the forward scan.+ stripTrailingWS :: Int -> Int -> Int+ stripTrailingWS !e !low+ | e <= low = low+ | otherwise =+ let !c = TA.unsafeIndex arr (e - 1)+ in if c == 32 || c == 9+ then stripTrailingWS (e - 1) low+ else e+++-- Top-level CAFs so 'classify' doesn't repack literals on every line.+dashesText, dashesSpace, dashesTab :: Text+dashesText = T.pack "---"+dashesSpace = T.pack "--- "+dashesTab = T.pack "---\t"+++dotsText, dotsSpace, dotsTab :: Text+dotsText = T.pack "..."+dotsSpace = T.pack "... "+dotsTab = T.pack "...\t"+++classify :: Text -> LineKind+classify t = case T.uncons t of+ Nothing -> LBlank+ Just (h, _)+ | h == '#' -> LComment+ | h == '-'+ , t == dashesText+ || T.isPrefixOf dashesSpace t+ || T.isPrefixOf dashesTab t ->+ LDocStart+ | h == '.'+ , t == dotsText+ || T.isPrefixOf dotsSpace t+ || T.isPrefixOf dotsTab t ->+ LDocEnd+ | h == '%' -> LDirective+ | otherwise -> LContent+{-# INLINE classify #-}+++isSkippable :: PLine -> Bool+isSkippable l = case lineKind l of+ LBlank -> True+ LComment -> True+ LDirective -> True+ _ -> False+{-# INLINE isSkippable #-}+++isSkippableNonDirective :: PLine -> Bool+isSkippableNonDirective l = case lineKind l of+ LBlank -> True+ LComment -> True+ _ -> False+{-# INLINE isSkippableNonDirective #-}+++-- ---------------------------------------------------------------------------+-- Parser monad: pure ([PLine], Map Text Value) -> Either String (a, ...)+-- ---------------------------------------------------------------------------++{- | Result of one parse step. Avoids the @Either String (a, PS)@+/pair-of-pair/ shape used previously, which allocated two+cells (the 'Either' constructor plus the @(a, PS)@ tuple) on+every successful @>>=@. 'Result' uses a single constructor+carrying both the value and the next state, halving the per-+bind allocation on the success path. ('Err' carries a 'String'+which is rarely allocated since failure stops the chain.)+-}+data Result a+ = Ok !a !PS+ | Err !String+++newtype P a = P {unP :: PS -> Result a}+++{- | Mode flags packed into a single 'Int' so that 'modifyS'+doesn't have to copy individual 'Int' / 'Bool' fields when+entering / leaving a scope.++* bits 0..19: 'parentInd' (biased by 'parentBias' so the+ @-1@ sentinel fits in the unsigned slot, range+ @[-1, 0xFFFFE]@; YAML lines wider than ~1 M chars are+ not a real-world case).+* bits 20..29: 'parserDepth' (10 bits, range @[0, 1023]@).+* bit 30: 'inMapValue'+* bit 31: 'flowSpannedNewline'+-}+data PS = PS+ { psLines :: ![PLine]+ , psAnchors :: !(HashMap Text Text)+ {- ^ Source names point at immutable binding identities, so rebinding a name+ cannot change the size or value of an earlier alias.+ -}+ , psBindings :: !(HashMap Text AnchorBinding)+ , psNextBinding :: {-# UNPACK #-} !Int+ , psShortcuts :: !(Map Text Text)+ {- ^ %TAG shorthand prefixes ('!handle!' → expansion).+ Reset between documents.+ -}+ , psFlags :: {-# UNPACK #-} !Int+ }+++{- | Hard-coded recursion depth limit. YAML documents legitimately+nesting more than 'maxParserDepth' containers are vanishingly+rare; the limit exists to prevent a deeply-nested adversarial+input from blowing the Haskell stack.+-}+maxParserDepth :: Int+maxParserDepth = 1024+{-# INLINE maxParserDepth #-}+++{- | Hard-coded ceiling on the logical node count of any anchor+value or document body. Prevents adversarial alias-DAG inputs+(the YAML 'billion laughs' attack) from producing a 'Value'+whose naive traversal would never finish: the per-anchor+check in 'recordAnchor' fails before such a value is even+constructed.+-}+maxParseNodes :: Int+maxParseNodes = 10_000_000+{-# INLINE maxParseNodes #-}+++parentBias :: Int+parentBias = 1+++parentMask, depthMask, depthShift :: Int+parentMask = 0xFFFFF -- 20 bits, [0, 1 048 575]+depthShift = 20+depthMask = Bits.shiftL 0x3FF depthShift -- bits 20..29 (10 bits)+++inMapValueBit, flowSpannedBit :: Int+inMapValueBit = 30+flowSpannedBit = 31+++packFlags :: Int -> Bool -> Bool -> Int+packFlags pInd inMV fSpan =+ let !p = (pInd + parentBias) Bits..&. parentMask+ !mv = if inMV then Bits.bit inMapValueBit else 0+ !fs = if fSpan then Bits.bit flowSpannedBit else 0+ in p Bits..|. mv Bits..|. fs+{-# INLINE packFlags #-}+++psParentInd :: PS -> Int+psParentInd s = (psFlags s Bits..&. parentMask) - parentBias+{-# INLINE psParentInd #-}+++psInMapValue :: PS -> Bool+psInMapValue s = Bits.testBit (psFlags s) inMapValueBit+{-# INLINE psInMapValue #-}+++psFlowSpannedNewline :: PS -> Bool+psFlowSpannedNewline s = Bits.testBit (psFlags s) flowSpannedBit+{-# INLINE psFlowSpannedNewline #-}+++psDepth :: PS -> Int+psDepth s = Bits.shiftR (psFlags s) depthShift Bits..&. 0x3FF+{-# INLINE psDepth #-}+++setParentInd :: Int -> PS -> PS+setParentInd !i s =+ s+ { psFlags =+ (psFlags s Bits..&. Bits.complement parentMask)+ Bits..|. ((i + parentBias) Bits..&. parentMask)+ }+{-# INLINE setParentInd #-}+++setInMapValue :: Bool -> PS -> PS+setInMapValue True s = s {psFlags = Bits.setBit (psFlags s) inMapValueBit}+setInMapValue False s = s {psFlags = Bits.clearBit (psFlags s) inMapValueBit}+{-# INLINE setInMapValue #-}+++setFlowSpanned :: Bool -> PS -> PS+setFlowSpanned True s = s {psFlags = Bits.setBit (psFlags s) flowSpannedBit}+setFlowSpanned False s = s {psFlags = Bits.clearBit (psFlags s) flowSpannedBit}+{-# INLINE setFlowSpanned #-}+++setDepth :: Int -> PS -> PS+setDepth !d s =+ s+ { psFlags =+ (psFlags s Bits..&. Bits.complement depthMask)+ Bits..|. Bits.shiftL (d Bits..&. 0x3FF) depthShift+ }+{-# INLINE setDepth #-}+++runP :: P a -> PS -> Either String (a, PS)+runP (P f) s = case f s of+ Ok a s' -> Right (a, s')+ Err e -> Left e+{-# INLINE runP #-}+++instance Functor P where+ fmap f (P g) =+ P+ ( \s -> case g s of+ Ok a s' -> Ok (f a) s'+ Err e -> Err e+ )+ {-# INLINE fmap #-}+++instance Applicative P where+ pure x = P (\s -> Ok x s)+ {-# INLINE pure #-}+ P pf <*> P px =+ P+ ( \s -> case pf s of+ Err e -> Err e+ Ok f s' -> case px s' of+ Err e -> Err e+ Ok x s'' -> Ok (f x) s''+ )+ {-# INLINE (<*>) #-}+ P g *> P h =+ P+ ( \s -> case g s of+ Err e -> Err e+ Ok _ s' -> h s'+ )+ {-# INLINE (*>) #-}+++instance Monad P where+ P g >>= k =+ P+ ( \s -> case g s of+ Err e -> Err e+ Ok a s' -> unP (k a) s'+ )+ {-# INLINE (>>=) #-}+++instance MonadFail P where+ fail = failP+ {-# INLINE fail #-}+++failP :: String -> P a+failP msg = P (\_ -> Err msg)+{-# INLINE failP #-}+++getS :: P PS+getS = P (\s -> Ok s s)+{-# INLINE getS #-}+++modifyS :: (PS -> PS) -> P ()+modifyS f = P (\s -> Ok () (f s))+{-# INLINE modifyS #-}+++getLines :: P [PLine]+getLines = P (\s -> Ok (psLines s) s)+{-# INLINE getLines #-}+++setLines :: [PLine] -> P ()+setLines ls = P (\s -> Ok () (s {psLines = ls}))+{-# INLINE setLines #-}+++popLine :: P (Maybe PLine)+popLine = P $ \s ->+ let go [] = (Nothing, [])+ go (x : rest)+ | isSkippable x = go rest+ | otherwise = (Just x, rest)+ (mx, ls') = go (psLines s)+ in Ok mx (s {psLines = ls'})+{-# INLINE popLine #-}+++{- | Drop the next non-skippable line without allocating a+'Maybe' wrapper. Used at sites that have already peeked /+pattern-matched the head and only need to advance the cursor.+-}+dropLine :: P ()+dropLine = P $ \s ->+ let go [] = []+ go (x : rest)+ | isSkippable x = go rest+ | otherwise = rest+ in Ok () (s {psLines = go (psLines s)})+{-# INLINE dropLine #-}+++peekLine :: P (Maybe PLine)+peekLine = P $ \s ->+ let go [] = Nothing+ go (x : xs)+ | isSkippable x = go xs+ | otherwise = Just x+ in Ok (go (psLines s)) s+{-# INLINE peekLine #-}+++pushLine :: PLine -> P ()+pushLine l = P (\s -> Ok () (s {psLines = l : psLines s}))+{-# INLINE pushLine #-}+++-- ---------------------------------------------------------------------------+-- Resource bounds+--+-- Defences against two well-known adversarial-input classes:+--+-- 1. /Stack overflow via deep nesting./ A '[[[[…]]]]'-style+-- input with hundreds of thousands of opening brackets+-- would blow the runtime stack. 'withDepth' bumps a counter+-- on every recursive descent and refuses to continue past+-- 'maxParserDepth' (default 1024).+--+-- 2. /Alias-DAG \"billion laughs\"./ A small input+--+-- @+-- a: &a [1,1,1,1,1,1,1,1,1]+-- b: &b [*a,*a,*a,*a,*a,*a,*a,*a,*a]+-- …+-- i: &i [*h,*h,*h,*h,*h,*h,*h,*h,*h]+-- @+--+-- yields a 'Value' whose physical representation is small+-- (sharing) but whose naive traversal walks 9^9 ~ 4×10^8+-- nodes. Pure Haskell sharing protects the parser itself+-- but downstream consumers (e.g. JSON projection) blow up.+-- 'recordAnchor' computes the /logical/ expanded size of+-- every anchor at registration time using a memoised walk+-- seeded from previously-recorded anchors and refuses any+-- anchor whose expansion exceeds 'maxParseNodes'.+-- ---------------------------------------------------------------------------++{- | Run @action@ at one greater nesting depth. Fails before+entering when the depth would exceed 'maxParserDepth'.+The depth lives in the high bits of the packed 'psFlags' so+the bump / pop are bit-twiddles on a single 'Int' field, not+record updates of a separate strict 'Int' slot.+-}+withDepth :: P a -> P a+withDepth (P action) = P $ \s ->+ let !d0 = psDepth s+ !d = d0 + 1+ in if d >= maxParserDepth -- guard before the 10-bit depth slot wraps+ then Err "YAML: maximum nesting depth exceeded"+ else case action (setDepth d s) of+ Err e -> Err e+ Ok x s' -> Ok x (setDepth d0 s')+{-# INLINE withDepth #-}+++-- Binding identities never occur in the source grammar. Internal references+-- use the distinct YAlias node, not scalar text or a mutable anchor name.+data AnchorBinding = AnchorBinding+ { bindingIdentity :: {-# UNPACK #-} !Int+ , bindingName :: !Anchor+ , bindingValue :: !Value+ , bindingSize :: {-# UNPACK #-} !Int+ }+++sizeWithMemo :: HashMap Text AnchorBinding -> Value -> Int+sizeWithMemo bindings = go+ where+ add a b = min (maxParseNodes + 1) (a + b)+ go (YAlias identity) = maybe (maxParseNodes + 1) ((1 +) . bindingSize) (HM.lookup (unAnchor identity) bindings)+ go (YAnchored _ inner) = add 1 (go inner)+ go (YTagged _ inner) = add 1 (go inner)+ go (YSeq xs) = V.foldl' (\n v -> if n > maxParseNodes then n else add n (go v)) 1 xs+ go (YMap kvs) = V.foldl' (\n (k, v) -> if n > maxParseNodes then n else add n (add (go k) (go v))) 1 kvs+ go _ = 1+++validAnchorName :: Text -> Bool+validAnchorName name = not (T.null name) && T.all (\c -> c > ' ' && validNonBreak c && not (c `T.elem` "[],{}")) name+++recordAnchor :: Text -> Value -> P Anchor+recordAnchor name value = do+ unless (validAnchorName name) (failP "YAML: invalid or empty anchor name")+ when (hasAnchor value) (failP "YAML: node has more than one anchor")+ st <- getS+ let inner = value+ !size = sizeWithMemo (psBindings st) inner+ identity = "\0binding:" <> TL.toStrict (TB.toLazyText (BI.decimal (psNextBinding st)))+ binding = AnchorBinding (psNextBinding st) (Anchor name) inner size+ when (size > maxParseNodes) (failP "YAML: anchor expansion exceeds the node budget (possible billion-laughs alias DAG)")+ modifyS+ ( \state ->+ state+ { psAnchors = HM.insert name identity (psAnchors state)+ , psBindings = HM.insert identity binding (psBindings state)+ , psNextBinding = psNextBinding state + 1+ }+ )+ pure (Anchor identity)+ where+ hasAnchor (YAnchored _ _) = True+ hasAnchor (YAlias _) = True+ hasAnchor (YTagged _ inner) = hasAnchor inner+ hasAnchor _ = False+++resolveAnchor :: Text -> P Value+resolveAnchor name = do+ unless (validAnchorName name) (failP "YAML: invalid or empty alias name")+ state <- getS+ case HM.lookup name (psAnchors state) of+ Just identity -> pure (YAlias (Anchor identity))+ Nothing -> failP ("YAML: alias *" ++ T.unpack name ++ " has no anchor")+++resetAnchors :: P ()+resetAnchors = modifyS (\state -> state {psAnchors = HM.empty, psBindings = HM.empty, psNextBinding = 0})+++-- Canonical keys distinguish scalar tags, normalize NaN/negative zero, and+-- ignore insertion order inside mapping-valued keys.+data Key+ = KNull+ | KBool !Bool+ | KInt !Integer+ | KFloat !Word64+ | KString !Text+ | KSeq ![Key]+ | KMap ![KeyEntry]+ | KTagged !Text !Key+ deriving stock (Eq, Ord, Generic)+ deriving anyclass (Hashable)+++data KeyEntry = KeyEntry !Key !Key+ deriving stock (Eq, Ord, Generic)+ deriving anyclass (Hashable)+++keyOf :: Value -> Key+keyOf = \case+ YNull -> KNull+ YBool b -> KBool b+ YInt n -> KInt n+ YFloat d -> KFloat (if isNaN d then 0x7ff8000000000000 else if d == 0 then 0 else castDoubleToWord64 d)+ YString t -> KString t+ YSeq xs -> KSeq (keyOf <$> V.toList xs)+ YMap kvs -> KMap (sort ((\(k, v) -> KeyEntry (keyOf k) (keyOf v)) <$> V.toList kvs))+ YAnchored _ v -> keyOf v+ YTagged (Tag t) v+ | t == "!" || t `elem` ["tag:yaml.org,2002:str", "tag:yaml.org,2002:int", "tag:yaml.org,2002:float", "tag:yaml.org,2002:bool", "tag:yaml.org,2002:null", "tag:yaml.org,2002:map", "tag:yaml.org,2002:seq"] -> keyOf v+ | otherwise -> KTagged t (keyOf v)+ YAlias a -> KTagged "unresolved-alias" (KString (unAnchor a))+++-- Resolve each immutable binding at most once. Validation and merge expansion+-- run before exposing a value to downstream consumers.+finishDocument :: HashMap Text AnchorBinding -> Value -> Either String Value+finishDocument bindings body+ | sizeWithMemo bindings body > maxParseNodes = Left "YAML: document alias expansion exceeds the node budget"+ | otherwise = evalStateT (go body) HM.empty+ where+ go :: Value -> StateT (HashMap Text Value) (Either String) Value+ go value = case value of+ YAlias (Anchor identity) -> do+ cache <- get+ case HM.lookup identity cache of+ Just v -> pure v+ Nothing -> case HM.lookup identity bindings of+ Nothing -> lift (Left "YAML: unresolved alias")+ Just binding -> do+ inner <- go (bindingValue binding)+ let resolved = YAnchored (bindingName binding) inner+ modify' (HM.insert identity resolved)+ pure resolved+ YAnchored identity v -> case HM.lookup (unAnchor identity) bindings of+ Nothing -> lift (Left "YAML: unresolved anchor binding")+ Just binding -> YAnchored (bindingName binding) <$> go v+ YTagged t v -> YTagged t <$> go v+ YSeq xs -> YSeq <$> traverse go xs+ YMap kvs -> do+ entries <- traverse (\(k, v) -> (,) <$> go k <*> go v) kvs+ lift (finishMap entries)+ v -> pure v+++-- Build the editable presentation graph only when source annotations are+-- requested. Alias targets share a memo, rather than expanding a DAG per use.+annotatePresentation :: HashMap Text AnchorBinding -> Value -> Either String A.AValue+annotatePresentation bindings body = evalStateT (go body) HM.empty+ where+ binding identity = maybe (lift (Left "YAML: unresolved presentation binding")) pure (HM.lookup (unAnchor identity) bindings)+ go :: Value -> StateT (HashMap Text A.AValue) (Either String) A.AValue+ go = \case+ YNull -> pure A.aNull+ YBool value -> pure (A.aBool value)+ YInt value -> pure (A.aInt value)+ YFloat value -> pure (A.aFloat value)+ YString value -> pure (A.aString value)+ YSeq values -> do+ items <- V.mapM go values+ pure A.aNull {A.avBody = A.ASeq items A.SeqBlock}+ YMap values -> do+ entries <- V.mapM (\(key, value) -> do k <- go key; v <- go value; pure (A.AMapEntry k v Nothing)) values+ pure A.aNull {A.avBody = A.AMap entries A.MapBlock}+ YTagged tag inner -> A.aTagged tag <$> go inner+ YAnchored identity inner -> do+ definition <- binding identity+ value <- go inner+ pure (A.aAnchored (bindingName definition) value) {A.avAnchorId = bindingIdentity definition}+ YAlias identity -> do+ definition <- binding identity+ memo <- get+ target <- case HM.lookup (unAnchor identity) memo of+ Just value -> pure value+ Nothing -> do+ value <- go (bindingValue definition)+ modify' (HM.insert (unAnchor identity) value)+ pure value+ pure A.aNull {A.avBody = A.AResolvedAlias (bindingIdentity definition) (bindingName definition) target}+++finishMap :: V.Vector (Value, Value) -> Either String Value+finishMap entries = do+ seen <- V.foldM checkUnique HS.empty entries+ if not (V.any (isMerge . fst) entries)+ then pure (YMap entries)+ else do+ inherited <- concat <$> traverse mergeSource (V.toList (V.filter (isMerge . fst) entries))+ let explicit = V.filter (not . isMerge . fst) entries+ initial = HS.delete (KTagged "tag:yaml.org,2002:merge" (KString "<<")) seen+ append (known, acc) pair@(key, _)+ | HS.member (keyOf key) known = (known, acc)+ | otherwise = (HS.insert (keyOf key) known, pair : acc)+ (_, extra) = foldl' append (initial, []) inherited+ pure (YMap (explicit V.++ V.fromList (reverse extra)))+ where+ checkUnique seen (key, _)+ | HS.member (keyOf key) seen = Left "YAML: duplicate mapping key"+ | otherwise = Right (HS.insert (keyOf key) seen)+ isMerge (YAnchored _ key) = isMerge key+ isMerge (YTagged (Tag tag) _) = tag == "tag:yaml.org,2002:merge"+ isMerge _ = False+ mergeSource (_, value) = case unwrap value of+ YMap kvs -> Right (V.toList kvs)+ YSeq maps ->+ concat+ <$> traverse+ ( \v -> case unwrap v of+ YMap kvs -> Right (V.toList kvs)+ _ -> Left "YAML: merge sequence must contain mappings"+ )+ (V.toList maps)+ _ -> Left "YAML: merge value must be a mapping or sequence of mappings"+++resetShortcuts :: P ()+resetShortcuts = modifyS (\s -> s {psShortcuts = Map.empty})+++recordShortcut :: Text -> Text -> P ()+recordShortcut handle prefix =+ modifyS (\s -> s {psShortcuts = Map.insert handle prefix (psShortcuts s)})+++{- | Run an action with 'psParentInd' temporarily set to @i@,+restoring the previous value afterwards.+-}+withParentInd :: Int -> P a -> P a+withParentInd !i action = do+ when (i < -1 || i >= parentMask) (failP "YAML: indentation exceeds the supported range")+ saved <- psParentInd <$> getS+ modifyS (setParentInd i)+ x <- action+ modifyS (setParentInd saved)+ pure x+++-- Bit 32 is scoped to the direct scalar under an explicit tag. Containers+-- clear it before parsing their children; node properties retain it.+withRawScalar :: Bool -> P a -> P a+withRawScalar raw action = do+ saved <- psFlags <$> getS+ modifyS (\st -> st {psFlags = if raw then Bits.setBit (psFlags st) 32 else Bits.clearBit (psFlags st) 32})+ x <- action+ modifyS (\st -> st {psFlags = if Bits.testBit saved 32 then Bits.setBit (psFlags st) 32 else Bits.clearBit (psFlags st) 32})+ pure x+++withSequenceItem :: Bool -> P a -> P a+withSequenceItem enabled action = do+ saved <- psFlags <$> getS+ modifyS (\s -> s {psFlags = (if enabled then Bits.setBit else Bits.clearBit) (psFlags s) 33})+ result <- action+ modifyS (\s -> s {psFlags = (if Bits.testBit saved 33 then Bits.setBit else Bits.clearBit) (psFlags s) 33})+ pure result+++resolvePlainP :: Text -> P Value+resolvePlainP raw = do+ unless (T.null raw || plainStartAllowed False raw) (failP "YAML: invalid plain scalar indicator")+ unless (T.all (\c -> c == '\n' || validNonBreak c) raw) (failP "YAML: invalid character in plain scalar")+ flags <- psFlags <$> getS+ pure (if Bits.testBit flags 32 then YString raw else resolvePlain raw)+++getParentInd :: P Int+getParentInd = psParentInd <$> getS+++withInMapValue :: Bool -> P a -> P a+withInMapValue !b action = do+ saved <- psInMapValue <$> getS+ modifyS (setInMapValue b)+ x <- action+ modifyS (setInMapValue saved)+ pure x+++getInMapValue :: P Bool+getInMapValue = psInMapValue <$> getS+++lookupShortcut :: Text -> P (Maybe Text)+lookupShortcut handle = do+ s <- getS+ pure (Map.lookup handle (psShortcuts s))+++-- ---------------------------------------------------------------------------+-- Stream / document+-- ---------------------------------------------------------------------------++parseStream :: [PLine] -> Either String [Document]+parseStream lns = fmap parsedDocument <$> parseStreamLocated lns+++parseStreamLocated :: [PLine] -> Either String [ParsedDocument]+parseStreamLocated lns =+ case runP+ (loop True True)+ ( PS+ lns+ HM.empty+ HM.empty+ 0+ Map.empty+ (packFlags 0 False False)+ ) of+ Left err -> Left err+ Right (ds, _) -> Right ds+ where+ loop !first !prevExplicitEnd = do+ ls <- getLines+ case dropWhile isSkippableNonDirective ls of+ [] -> pure []+ (l : rest) | lineKind l == LByteOrderMark -> do+ let raw = T.drop 1 (lineRawBody l)+ spaces = T.length (T.takeWhile (== ' ') raw)+ body = T.drop spaces raw+ setLines (l {lineIndent = spaces, lineBody = stripYamlEnd body, lineRawBody = body, lineKind = classify (stripYamlEnd body)} : rest)+ loop first prevExplicitEnd+ (l : _) -> do+ let canBeBare = first || prevExplicitEnd+ isExplicitStart = lineKind l == LDocStart+ isDirective = lineKind l == LDirective+ when (isDirective && not first && not prevExplicitEnd) $+ failP $+ "directive without preceding '...' marker (line "+ ++ show (lineNo l)+ ++ ")"+ unless (canBeBare || isExplicitStart || isDirective) $+ failP $+ "second document without '---' marker (line "+ ++ show (lineNo l)+ ++ ")"+ parsed <- parseDocument+ let d = parsedDocument parsed+ progress <- checkProgress (lineNo l)+ if progress+ then do+ ds <- loop (first && lineKind l == LDocEnd) (docExplicitEnd d)+ pure (if lineKind l == LDocEnd then ds else parsed {parsedStartLine = if first then 1 else case ls of { raw : _ -> lineNo raw; [] -> lineNo l }} : ds)+ else+ failP $ "stray content (line " ++ show (lineNo l) ++ ")"++ checkProgress prevLine = do+ ls <- getLines+ pure $ case dropWhile isSkippable ls of+ [] -> True+ (l : _) -> lineNo l /= prevLine+++{- | Consume any leading directives ('%YAML ...', '%TAG ...') from+the line stream. Returns whether at least one directive was+present. Validates the directive syntax: '%YAML' takes a single+version token, '%TAG' takes exactly two arguments, and '%YAML'+can appear at most once per document.+-}+consumeDirectives :: P Bool+consumeDirectives = go False False+ where+ go !sawAny !sawYaml = do+ ls <- getLines+ case dropWhile isSkippableNonDirective ls of+ (l : rest) | lineKind l == LDirective -> do+ setLines rest+ let body = stripInlineComment (lineBody l)+ args = wordsYaml (T.drop 1 body) -- drop leading '%'+ case args of+ ("YAML" : ver : extra) -> do+ when sawYaml $+ failP+ ( "duplicate %YAML directive (line "+ ++ show (lineNo l)+ ++ ")"+ )+ when (not (null extra)) $+ failP+ ( "extra words on %YAML directive (line "+ ++ show (lineNo l)+ ++ ")"+ )+ when (not (validYamlVersion ver)) $+ failP+ ( "invalid %YAML version "+ ++ T.unpack ver+ ++ " (line "+ ++ show (lineNo l)+ ++ ")"+ )+ go True True+ ("TAG" : handle : prefix : []) -> do+ unless (validTagHandle handle && validURIText prefix) (failP "YAML: invalid TAG directive handle or prefix")+ shortcuts <- psShortcuts <$> getS+ when (Map.member handle shortcuts) (failP "YAML: duplicate TAG directive handle")+ recordShortcut handle prefix+ go True sawYaml+ ("TAG" : _) ->+ failP+ ( "malformed %TAG directive (line "+ ++ show (lineNo l)+ ++ ")"+ )+ ("YAML" : _) ->+ failP+ ( "malformed %YAML directive (line "+ ++ show (lineNo l)+ ++ ")"+ )+ _ -> go True sawYaml -- unknown / reserved directive+ _ -> pure sawAny+++validYamlVersion :: Text -> Bool+validYamlVersion t = case T.splitOn (T.pack ".") t of+ [maj, min_]+ | T.dropWhile (== '0') maj == "1" && T.all isDigit_ min_+ , not (T.null maj) && not (T.null min_) ->+ True+ _ -> False+ where+ isDigit_ c = c >= '0' && c <= '9'+++parseDocument :: P ParsedDocument+parseDocument = do+ -- %TAG shortcuts are scoped to a single document — clear any+ -- left over from the previous one before we parse the new+ -- prologue (spec §6.8.2).+ resetShortcuts+ hadDirective <- consumeDirectives+ ls0' <- getLines+ let nextSig = dropWhile isSkippableNonDirective ls0'+ (directives, ls1) <- case nextSig of+ (l : rest) | lineKind l == LDocStart -> do+ let body = lineBody l+ tail_ = let content = stripYamlStart (T.drop 3 body) in if T.isPrefixOf "#" content then T.empty else content+ isInlineBlockScalar = case T.uncons tail_ of+ Just ('|', _) -> True+ Just ('>', _) -> True+ _ -> False+ virtInd+ | isInlineBlockScalar = -1+ | otherwise = lineIndent l+ -- '--- &anchor a: b' (an anchor immediately followed by a+ -- mapping pair on the same line as '---') is invalid per+ -- the test suite (CXX2 / mapping-with-anchor-on-document-+ -- start-line).+ case T.uncons tail_ of+ Just ('&', restA) ->+ let (_anchor, afterAnchor) = takeAnchorName restA+ afterStripped = stripYamlStart afterAnchor+ in case findKeyValueSplit afterStripped of+ Just _ ->+ failP $+ "anchor immediately followed by mapping on '---' line (line "+ ++ show (lineNo l)+ ++ ")"+ Nothing -> pure ()+ _ -> pure ()+ pure $+ if T.null tail_+ then (True, rest)+ else+ ( True+ , PLine+ (lineNo l)+ virtInd+ LContent+ tail_+ tail_+ : rest+ )+ (l : _)+ | hadDirective ->+ failP+ ( "missing '---' after directive (line "+ ++ show (lineNo l)+ ++ ")"+ )+ []+ | hadDirective ->+ failP "directive without document"+ _ -> pure (False, ls0')+ setLines ls1+ resetAnchors+ rawBody <- parseDocBody+ bindings <- psBindings <$> getS+ body <- either failP pure (finishDocument bindings rawBody)+ ls2 <- getLines+ (explicitEnd, ls3) <- case dropWhile isSkippable ls2 of+ (l : rest) | lineKind l == LDocEnd -> do+ let extra = stripYamlStart (T.drop 3 (lineBody l))+ -- Strip an inline comment if any.+ extra' = stripYamlEnd $ case T.uncons extra of+ Just ('#', _) -> T.empty+ _ -> stripInlineComment extra+ unless (T.null extra') $+ failP $+ "trailing content after '...' marker: "+ ++ show extra+ ++ " (line "+ ++ show (lineNo l)+ ++ ")"+ pure (True, rest)+ _ -> pure (False, ls2)+ setLines ls3+ pure (ParsedDocument (Document directives explicitEnd body) 0 (annotatePresentation bindings rawBody))+++parseDocBody :: P Value+parseDocBody = do+ mNext <- peekLine+ case mNext of+ Nothing -> pure YNull+ Just l+ | lineKind l == LDocStart -> pure YNull+ | lineKind l == LDocEnd -> pure YNull+ -- A bare top-level '|' / '>' block scalar at column 0 is+ -- the same as '--- |' / '--- >' for indent purposes — body+ -- lines may live at column 0 (parent < 0).+ | lineIndent l == 0+ , isBlockScalarStart (lineBody l) -> do+ modifyS+ ( \s -> case psLines s of+ (h : rs) -> s {psLines = h {lineIndent = -1} : rs}+ [] -> s+ )+ parseNode (-1)+ | otherwise -> parseNode (min 0 (lineIndent l))+ where+ isBlockScalarStart t = case T.uncons t of+ Just ('|', _) -> True+ Just ('>', _) -> True+ _ -> False+++-- ---------------------------------------------------------------------------+-- Node dispatch+-- ---------------------------------------------------------------------------++-- | Parse a node whose left margin is at least @minInd@.+parseNode :: Int -> P Value+parseNode !minInd = withDepth $ do+ mNext <- peekLine+ case mNext of+ Nothing -> pure YNull+ Just l+ | lineKind l == LDocStart -> pure YNull+ | lineKind l == LDocEnd -> pure YNull+ | lineIndent l < minInd -> pure YNull+ | otherwise -> dispatch l+++dispatch :: PLine -> P Value+dispatch l0 = do+ -- Strip leading TAB characters. They're not allowed as block+ -- indentation per spec §6.1 but real-world inputs use them as+ -- 'separation' whitespace between a structural marker and the+ -- following node — '\\t{}', '\\t- x', '\\t"…"' all parse OK+ -- in libfyaml etc.+ let body0 = lineBody l0+ case T.uncons body0 of+ Just ('\t', _) -> do+ let l =+ l0+ { lineBody = T.dropWhile (== '\t') body0+ , lineRawBody = T.dropWhile (== '\t') (lineRawBody l0)+ }+ modifyS+ ( \s -> case psLines s of+ (top : rs)+ | lineNo top == lineNo l0 ->+ s {psLines = l : rs}+ _ -> s+ )+ dispatchOn l+ _ -> dispatchOn l0+ where+ dispatchOn l+ | let body = lineBody l+ , isSeqItem body || isExplicitKey body || case findKeyValueSplit body of Just _ -> True; Nothing -> False =+ withSequenceItem False (withRawScalar False (dispatchRaw l))+ | otherwise = dispatchRaw l+ dispatchRaw l = case T.uncons (lineBody l) of+ Just (h, _) -> case h of+ '!' -> parseTagged+ '&' -> parseAnchored+ '*' -> case findAliasKeySplit (lineBody l) of+ Just (aliasName, vRest) ->+ parseBlockMapAliasFirst+ (lineIndent l)+ aliasName+ vRest+ Nothing -> parseAlias+ '|' -> parseBlockScalar Literal+ '>' -> parseBlockScalar Folded+ '[' -> consumeFlowFromHead >>= maybeFlowAsBlockKey (lineIndent l)+ '{' -> consumeFlowFromHead >>= maybeFlowAsBlockKey (lineIndent l)+ '"' -> parseQuotedScalarLine '"' l+ '\'' -> parseQuotedScalarLine '\'' l+ _ -> parseBlockOrPlain l+ Nothing -> parseBlockOrPlain l+++{- | Quoted scalars can be the entire node body, or the start of a+@key: \"…\"@ pair when the closing quote is followed by a colon. We+look ahead for a top-level @:@ after the closing quote and dispatch+to 'parseBlockMap' if found, otherwise consume the quoted scalar.++Quoted scalars may span multiple lines per YAML 1.2; if the close+quote is not on the same line we splice continuation lines into+the buffer until it is.+-}+parseQuotedScalarLine :: Char -> PLine -> P Value+parseQuotedScalarLine q l =+ -- A quoted key and quoted value also end with a quote. Only the+ -- absence of a colon can rule out a mapping without scanning it.+ let body = lineBody l+ in if not (bAnyByte w8Colon body)+ then doQuoted+ else case findKeyValueSplit body of+ Just (k, vRest) -> parseBlockMap (lineIndent l) k vRest+ Nothing -> doQuoted+ where+ doQuoted = do+ dropLine+ consumeQuotedAt+ q+ (lineIndent l)+ (preserveTrailingEscape (lineBody l) (lineRawBody l))+++{- | If the trimmed line body ends in @\\@ that's not itself+escaped, take the next character /verbatim/ from the raw body+(so an escape argument like @\\<TAB>@ survives the trailing-WS+strip done by 'preprocess'). Any whitespace /after/ that escape+argument is still stripped.+-}+preserveTrailingEscape :: Text -> Text -> Text+preserveTrailingEscape stripped raw = case T.unsnoc stripped of+ Just (_, '\\')+ | not (endsEvenBackslashes stripped) ->+ -- Reach into raw at the position right after the trailing '\'.+ let idx = T.length stripped+ in if idx < T.length raw+ then stripped <> T.singleton (T.index raw idx)+ else stripped+ _ -> stripped+ where+ endsEvenBackslashes t =+ even (T.length (T.takeWhileEnd (== '\\') t))+++{- | Like 'consumeQuoted' but the caller knows the indent of the+line that opened the quote; continuation lines must be at strictly+greater indent.+-}+consumeQuotedAt :: Char -> Int -> Text -> P Value+consumeQuotedAt q !openInd = go0 False+ where+ parser = case q of '"' -> parseDQ; _ -> parseSQ++ -- The very first attempt; no fold prefix has been emitted yet.+ go0 !multi !buf = case parser 0 buf of+ Just (v, p) -> finish multi v (bDrop p buf)+ Nothing -> readMore multi buf 0++ -- @blanks@ counts consecutive empty continuation lines we've+ -- absorbed since the last non-empty (or the opening) line.+ -- We pop the raw next line (not 'popLine', which would skip+ -- blank / comment lines — those are significant inside a+ -- multi-line quoted scalar).+ readMore _multi !buf !blanks = do+ ls <- getLines+ case ls of+ [] -> failP "YAML: unterminated quoted scalar"+ (l' : _)+ | lineKind l' == LDocStart || lineKind l' == LDocEnd ->+ failP $+ "document marker inside quoted scalar (line "+ ++ show (lineNo l')+ ++ ")"+ -- Continuations must be at /at least/ the same indent as+ -- the line that opened the quote. A line at lower indent+ -- belongs to the surrounding scope.+ (l' : _)+ | openInd > 0+ , lineKind l' == LContent+ , lineIndent l' < openInd ->+ failP $+ "wrong-indented quoted-scalar continuation (line "+ ++ show (lineNo l')+ ++ ")"+ (l' : rest) -> do+ setLines rest+ let body0 = lineBody l'+ raw = lineRawBody l'+ -- Use the raw body when the trimmed line body ends+ -- in '\\' so that '\\<TAB>' survives.+ body = preserveTrailingEscape body0 raw+ isBlank = T.null (stripYaml body)+ body' = T.dropWhile (\c -> c == ' ' || c == '\t') body+ -- DQ-only: a bare trailing backslash on the previous+ -- line eats the newline plus any leading whitespace+ -- on the next line (YAML 1.2 §5.7 / §7.5).+ endsWithEscape =+ q == '"'+ && case T.unsnoc buf of+ Just (_, '\\') -> not (endsEvenBackslashes buf)+ _ -> False+ if isBlank+ then readMore True buf (blanks + 1)+ else+ let (buf', joined)+ | endsWithEscape =+ (T.init buf <> body', True)+ | otherwise =+ let joinSep+ | blanks == 0 = tSpace+ | otherwise = T.replicate blanks tNL+ in (buf <> joinSep <> body', True)+ in joined `seq` case parser 0 buf' of+ Just (v, p) -> finish True v (bDrop p buf')+ Nothing -> readMore True buf' 0++ -- A run of trailing backslashes counts as "even" when it+ -- pairs up to "\\\\…", which means no escape at end.+ endsEvenBackslashes t = even (T.length (T.takeWhileEnd (== '\\') t))++ finish multi v rest =+ let trimmed = stripYamlStart rest+ -- Was there at least one whitespace char between the+ -- closing quote and 'rest'?+ hadSeparator = bLen trimmed < bLen rest+ stripped = case T.uncons trimmed of+ -- A '#' may only start a comment when preceded by+ -- whitespace; without one it's malformed.+ Just ('#', _)+ | hadSeparator -> T.empty+ | otherwise -> trimmed+ _ -> stripYamlEnd (stripInlineComment trimmed)+ in if T.null stripped+ then pure v+ else case T.uncons stripped of+ Just (c, _)+ | c == ':' && multi ->+ failP "multi-line quoted scalar used as implicit key"+ -- A ':' trailing after the close quote means+ -- the scalar is acting as a key. That's only+ -- valid when this consumeQuoted call wasn't+ -- already inside a value position (openInd > 0+ -- means we're inside a parent block context's+ -- value). Otherwise treat the ':' as malformed+ -- (e.g. ZL4Z's "a: 'b': c").+ | c == ':' && openInd > 0 ->+ failP $ "nested mapping after quoted scalar value"+ | c == ',' -> pushBack stripped+ | c == ':' -> pushBack stripped+ | c == ']' -> pushBack stripped+ | c == '}' -> pushBack stripped+ | otherwise ->+ failP $+ "trailing content after quoted scalar: "+ ++ show stripped+ Nothing -> pure v+ where+ pushBack s = do+ pushLine (PLine 0 0 LContent s s)+ pure v+++parseTagged :: P Value+parseTagged = do+ inValue <- getInMapValue+ inSequence <- (\s -> Bits.testBit (psFlags s) 33) <$> getS+ Just l <- popLine+ let (tg, rest) = breakOnSpace (lineBody l)+ after0 = stripYamlStart rest+ after = case T.uncons after0 of+ Just ('#', _) -> T.empty+ _ -> after0+ tag <- expandTagP (lineNo l) tg+ -- Tag tokens can contain URI characters (incl. ',') /inside/+ -- a verbatim '!<...>' wrapper, but a bare tag ('!!str' /+ -- '!foo') may not include ',' or flow indicators. Reject the+ -- bare-tag form when it contains them.+ let isVerbatim = case T.uncons (T.drop 1 tg) of+ Just ('<', _) -> True+ _ -> False+ unless isVerbatim $+ case T.find+ ( \c ->+ c == ','+ || c == '['+ || c == ']'+ || c == '{'+ || c == '}'+ )+ tg of+ Just c ->+ failP $+ "invalid tag character "+ ++ show c+ ++ " in tag "+ ++ show tg+ ++ " (line "+ ++ show (lineNo l)+ ++ ")"+ Nothing -> pure ()+ case findKeyValueSplit after of+ Just (keyText, valueRest) -> do+ key <- parsePropertyKey tag keyText+ pushLine l {lineBody = after, lineRawBody = after}+ parseBlockMapWithKey (lineIndent l) key valueRest+ Nothing ->+ if T.null after+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > lineIndent l+ || (lineIndent l2 == lineIndent l && not inValue)+ || (not inSequence && lineIndent l2 == lineIndent l && isSeqItem (lineBody l2) && tag == Tag "tag:yaml.org,2002:seq") -> do+ v <- withRawScalar True $ parseNode (lineIndent l2)+ tagValue tag v+ Just l2+ | lineKind l2 == LContent+ , let body2 = lineBody l2+ , isBlockScalarHeadOrProp body2 -> do+ -- Adjust the body line's stored indent to 0 so a+ -- following block-scalar's auto-baseline picks up+ -- content at any column > 0 (spec example 8.21).+ modifyS+ ( \s -> case psLines s of+ (h : rs) -> s {psLines = h {lineIndent = 0} : rs}+ _ -> s+ )+ v <- withRawScalar True $ parseNode 0+ tagValue tag v+ _ -> tagValue tag YNull+ else do+ -- Update both 'lineBody' and 'lineRawBody' so that+ -- consumeQuoted's preserveTrailingEscape works on the+ -- right slice of the line.+ pushLine l {lineBody = after, lineRawBody = after}+ v <- withRawScalar True $ parseNode (lineIndent l)+ tagValue tag v+++parsePropertyKey :: Tag -> Text -> P Value+parsePropertyKey tag text = do+ key <- parseRawKey text >>= recordAndResolveFlow+ tagValue tag key+++parseRawKey :: Text -> P Value+parseRawKey text+ | T.null text = pure YNull+ | otherwise = case parseFlowValueWith True 0 0 text of+ Just (v, end) | T.null (stripYaml (bDrop end text)) -> pure v+ _ -> failP "YAML: invalid mapping key properties"+++parseAnchored :: P Value+parseAnchored = do+ inMapValue <- getInMapValue+ -- Once we descend below the immediate mapping-value dispatch,+ -- further parseNode calls are NOT in mapping-value position.+ withInMapValue False (parseAnchoredImpl inMapValue)+++parseAnchoredImpl :: Bool -> P Value+parseAnchoredImpl !inMapValue = do+ inSequence <- (\s -> Bits.testBit (psFlags s) 33) <$> getS+ parentIndent <- getParentInd+ Just l <- popLine+ let body = lineBody l+ (name, rest) = takeAnchorName (T.drop 1 body)+ after0 = stripYamlStart rest+ after = case T.uncons after0 of+ Just ('#', _) -> T.empty+ _ -> after0+ -- '&anchor - foo' / '&anchor ? key' / '&anchor : value' are+ -- invalid: an anchor cannot label a block-sequence / explicit+ -- mapping marker on the same line (the marker introduces its+ -- own nested structure with its own indentation requirements).+ case T.uncons after of+ Just ('-', rest1)+ | startsWithSeparator rest1 ->+ failP $+ "anchor immediately followed by block indicator '-' (line "+ ++ show (lineNo l)+ ++ ")"+ Just ('?', rest1)+ | startsWithSeparator rest1 ->+ failP $+ "anchor immediately followed by explicit-key marker (line "+ ++ show (lineNo l)+ ++ ")"+ -- '&anchor *alias' is invalid: an alias is itself a node+ -- reference and can't be re-labelled with a new anchor.+ Just ('*', _) ->+ failP $+ "anchor immediately followed by alias (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ -- If the rest of the line introduces a mapping (i.e. there's a+ -- top-level @": "@ in the remainder), the anchor only binds to+ -- the /key/, not to the surrounding mapping. This matches the+ -- YAML 1.2 node-anchoring model where the anchor precedes the+ -- specific node it labels.+ case findKeyValueSplit after of+ Just (k, vRest) -> do+ keyVal <- parseRawKey k >>= recordAndResolveFlow+ identity <- recordAnchor name keyVal+ pushLine l {lineBody = after, lineRawBody = after}+ parseBlockMapWithKey (lineIndent l) (YAnchored identity keyVal) vRest+ Nothing -> do+ v <-+ if T.null after+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > lineIndent l+ , isJustAnchorScalar (lineBody l2) -> do+ -- '&outer' followed by '&inner scalar'+ -- (no ':'/structural marker) is invalid:+ -- two anchors on the same scalar node+ -- (4JVG / scalar-value-with-two-anchors).+ failP $+ "node has two consecutive anchors (line "+ ++ show (lineNo l2)+ ++ ")"+ Just l2+ | lineIndent l2 > lineIndent l ->+ parseNode (lineIndent l2)+ -- A bare anchor at the same column as a following+ -- block sequence binds to that sequence.+ Just l2+ | lineIndent l2 == lineIndent l+ , not inSequence+ , isSeqItem (lineBody l2) ->+ parseBlockSeq (lineIndent l2)+ -- A bare anchor whose next line at the same+ -- column is another node-property line chains+ -- into that property; the whole stack labels+ -- the eventual node. EXCEPT when the anchor is+ -- itself the value of a mapping entry: a+ -- same-column property line then is a sibling+ -- (not a chained property), so the anchor refers+ -- to Null. See H7J7 (node-anchor-not-indented).+ Just l2+ | lineIndent l2 == lineIndent l+ , isNodePropertyLine (lineBody l2)+ , not inMapValue ->+ parseNode (lineIndent l2)+ -- A bare anchor on its own line at column > 0+ -- binds to the next same-column content line.+ Just l2+ | lineIndent l2 == lineIndent l+ , lineIndent l > 0+ , lineKind l2 == LContent ->+ parseNode (lineIndent l2)+ -- An anchor whose line is more-indented than the+ -- following block sequence binds to that+ -- sequence (e.g. 'seq:\\n &anchor\\n- a\\n- b').+ Just l2+ | lineKind l2 == LContent+ , lineIndent l2 < lineIndent l+ , lineIndent l2 >= parentIndent+ , isSeqItem (lineBody l2) ->+ parseBlockSeq (lineIndent l2)+ -- At column 0 we only chain into a same-column+ -- /plain scalar/. In mapping-value position the+ -- same-column line is the next sibling.+ Just l2+ | lineIndent l2 == lineIndent l+ , lineIndent l == 0+ , lineKind l2 == LContent+ , not inMapValue ->+ parseNode (lineIndent l2)+ _ -> pure YNull+ else do+ pushLine l {lineBody = after, lineRawBody = after}+ parseNode (lineIndent l)+ identity <- recordAnchor name v+ pure (YAnchored identity v)+++{- | True when the line is shaped like '&anchor scalar' — i.e.+starts with an anchor whose remainder is a plain scalar (no+':' / sequence marker).+-}+isJustAnchorScalar :: Text -> Bool+isJustAnchorScalar t = case T.uncons t of+ Just ('&', rest) ->+ let (_name, after) = takeAnchorName rest+ body = stripYamlStart after+ in not (T.null body)+ && case findKeyValueSplit body of+ Just _ -> False+ Nothing ->+ not (isSeqItem body)+ && not (isExplicitKey body)+ _ -> False+++{- | True when the line begins with a node-property indicator+('!' tag or '&' anchor) followed by separator / EOL.+-}+isNodePropertyLine :: Text -> Bool+isNodePropertyLine t = case T.uncons t of+ Just ('!', _) -> True+ Just ('&', _) -> True+ _ -> False+++{- | True when the line begins with a block-scalar header indicator+('|' / '>') or a node-property indicator.+-}+isBlockScalarHeadOrProp :: Text -> Bool+isBlockScalarHeadOrProp t = case T.uncons t of+ Just ('|', _) -> True+ Just ('>', _) -> True+ Just ('!', _) -> True+ Just ('&', _) -> True+ _ -> False+++parseAlias :: P Value+parseAlias = do+ Just l <- popLine+ let body = lineBody l+ (name, rest) = takeAnchorName (T.drop 1 body)+ after0 = stripYamlStart rest+ after = case T.uncons after0 of+ Just ('#', _) -> T.empty+ _ -> after0+ if T.null after+ then resolveAnchor name+ else do+ pushLine (PLine (lineNo l) (lineIndent l) LContent after after)+ resolveAnchor name+++{- | Read an anchor / alias name. Colons are valid name characters;+a mapping delimiter after an anchor therefore needs separation+(@&name : value@).+-}+takeAnchorName :: Text -> (Text, Text)+takeAnchorName t = goT 0+ where+ !len = bLen t+ goT !i+ | i >= len = (t, T.empty)+ | otherwise =+ let !b = bAt t i+ in if isAnchorByte b+ then goT (i + 1)+ else (bTake i t, bDrop i t)+++isAnchorByte :: Word8 -> Bool+isAnchorByte b =+ -- ASCII byte: reject the same chars as 'isAnchorChar'.+ -- Non-ASCII bytes (≥ 0x80, including UTF-8 leading and+ -- continuation bytes) are always part of the name.+ case b of+ 44 -> False -- ','+ 91 -> False -- '['+ 93 -> False -- ']'+ 123 -> False -- '{'+ 125 -> False -- '}'+ 32 -> False -- ' '+ 9 -> False -- '\t'+ 10 -> False -- '\n'+ 13 -> False -- '\r'+ _ -> True+{-# INLINE isAnchorByte #-}+++breakOnSpace :: Text -> (Text, Text)+breakOnSpace = T.break (\c -> c == ' ' || c == '\t')+++-- ---------------------------------------------------------------------------+-- Flow style+-- ---------------------------------------------------------------------------++consumeFlowFromHead :: P Value+consumeFlowFromHead = do+ Just l <- popLine+ modifyS (setFlowSpanned False)+ inMV <- getInMapValue+ parent <- getParentInd+ -- Inside any block container (mapping value or non-zero+ -- parent ind), use the parent-+-1 column as the lower bound+ -- for flow continuations so we can detect tab-as-indent+ -- (Y79Y/003).+ let openInd+ | inMV = max 1 (parent + 1)+ | parent >= 0 && parent < ourInd = parent + 1+ | otherwise = -1+ ourInd = lineIndent l+ value <- consumeFlowAt openInd (lineBody l)+ modifyS+ ( \state ->+ state+ { psLines = case psLines state of+ next : rest | lineNo next == 0 -> next {lineIndent = ourInd} : rest+ other -> other+ }+ )+ pure value+++{- | After a flow node has been consumed, see if there's a virtual+':' line waiting in the stream — if so, the flow node is the+/key/ of a block mapping. Continue parsing as a block mapping+with this flow value as the first key.+-}+maybeFlowAsBlockKey :: Int -> Value -> P Value+maybeFlowAsBlockKey !ind k = do+ mNext <- peekLine+ case mNext of+ Just l+ | lineIndent l == ind+ , let body = lineBody l+ , body == tColonStr+ || T.isPrefixOf tColonSpace body+ || T.isPrefixOf tColonTab body -> do+ spanned <- psFlowSpannedNewline <$> getS+ longKey <- (\s -> Bits.testBit (psFlags s) 34) <$> getS+ when longKey (failP "YAML: implicit mapping key exceeds 1024 characters")+ when spanned $+ failP $+ "flow node spanning newline used as block-mapping key (line "+ ++ show (lineNo l)+ ++ ")"+ dropLine+ let after =+ if body == tColonStr+ then T.empty+ else T.drop 2 body+ v <- parseImplicitMapValue ind after+ rest <- collectFlowMapEntries ind+ pure (YMap (V.fromList ((k, v) : rest)))+ _ -> pure k+++{- | Collect more block-mapping entries after a flow-as-key entry.+Mirrors 'parseBlockMap.collect' but specialized to start from+an arbitrary state.+-}+collectFlowMapEntries :: Int -> P [(Value, Value)]+collectFlowMapEntries !ind = go []+ where+ go acc = do+ mPL <- peekLine+ case mPL of+ Nothing -> pure (reverse acc)+ Just l+ | lineIndent l /= ind -> pure (reverse acc)+ | isSeqItem (lineBody l) -> pure (reverse acc)+ | startsWithTab (lineBody l) ->+ failP $+ "tab character used as indentation (line "+ ++ show (lineNo l)+ ++ ")"+ | isExplicitKey (lineBody l) -> do+ k <- readEntryKey+ v <- readEntryValue+ go ((k, v) : acc)+ | otherwise -> case findAliasKeySplit (lineBody l) of+ Just (aliasName, vRest) -> do+ dropLine+ k <- resolveAnchor aliasName+ v <- parseImplicitMapValue ind vRest+ go ((k, v) : acc)+ Nothing -> case findKeyValueSplit (lineBody l) of+ Just (k, vRest) -> do+ dropLine+ kv <- parseBlockKey k+ v <- parseImplicitMapValue ind vRest+ go ((kv, v) : acc)+ Nothing -> pure (reverse acc)++ -- (cheap inline of parseExplicitMap.readExplicitPart "?")+ readEntryKey = do+ Just l <- popLine+ let body = lineBody l+ afterMarker =+ if body == tQuestStr+ then T.empty+ else T.drop 1 body+ rest = stripYamlStart (T.drop 1 afterMarker)+ if T.null rest+ then do+ mNext <- peekLine+ case mNext of+ Just l2 | lineIndent l2 > lineIndent l -> parseNode (lineIndent l2)+ _ -> pure YNull+ else do+ pushLine (PLine (lineNo l) (lineIndent l + 2) LContent rest rest)+ parseNode (lineIndent l + 2)++ readEntryValue = do+ mPL <- peekLine+ case mPL of+ Just l+ | lineIndent l == ind+ , ( lineBody l == tColonStr+ || T.isPrefixOf tColonSpace (lineBody l)+ || T.isPrefixOf tColonTab (lineBody l)+ ) -> do+ Just l' <- popLine+ let body = lineBody l'+ afterMarker =+ if body == tColonStr+ then T.empty+ else T.drop 1 body+ rest = stripYamlStart (T.drop 1 afterMarker)+ if T.null rest+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > lineIndent l' ->+ parseNode (lineIndent l2)+ _ -> pure YNull+ else do+ pushLine+ ( PLine+ (lineNo l')+ (lineIndent l' + 2)+ LContent+ rest+ rest+ )+ withParentInd (lineIndent l') (parseNode (lineIndent l' + 2))+ _ -> pure YNull+++{- | Single-pass walk over a parsed flow value that both+/registers/ each embedded 'YAnchored' anchor and /resolves/+the alias nodes left by 'parseFlowAlias'.++The pass is bottom-up: when we encounter @&n inner@ we+resolve @inner@ first and only then call 'recordAnchor', so+the stored value is itself fully resolved. References to+@*name@ are then just looked up — no recursive walk into the+resolved value is needed, which both avoids the+alias-DAG-of-DAGs exponential blow-up that a separate+record-then-resolve approach would incur and naturally+detects forward / self-cycles (the anchor isn't in the+environment when we try to resolve into its own definition).+-}+recordAndResolveFlow :: Value -> P Value+recordAndResolveFlow = go+ where+ go v = case v of+ YAlias (Anchor name) -> resolveAnchor name+ YAnchored (Anchor n) inner -> do+ inner' <- go inner+ identity <- recordAnchor n inner'+ pure (YAnchored identity inner')+ YTagged (Tag spelling) inner -> do+ tag <- expandTagP 0 spelling+ normalized <- case resolveExplicitTag tag inner of+ Just value -> pure value+ Nothing -> failP "YAML: scalar or collection does not match its explicit tag"+ resolved <- go normalized+ recordTaggedAnchors tag resolved+ pure (YTagged tag resolved)+ YSeq xs -> YSeq <$> V.mapM go xs+ YMap kvs ->+ YMap+ <$> V.mapM+ (\(k, x) -> (,) <$> go k <*> go x)+ kvs+ _ -> pure v+++consumeFlowAt :: Int -> Text -> P Value+consumeFlowAt !openInd = go+ where+ -- Strip end-of-line comments before adding a new chunk to the+ -- buffer. Flow nodes may contain comments between elements,+ -- per the YAML 1.2 grammar.+ stripFlowComment t = stripYamlEnd (stripComment True t)++ go buf0 = do+ state <- getS+ let buf = stripFlowComment buf0+ case scanFlow (psDepth state) buf of+ ScanComplete v rest -> do+ let longKey = T.length buf - T.length rest > 1024+ modifyS (\s -> s {psFlags = (if longKey then Bits.setBit else Bits.clearBit) (psFlags s) 34})+ v' <- recordAndResolveFlow v+ let !s = bDrop (skipFlowWS 0 rest) rest+ case T.uncons s of+ Nothing -> pure v'+ -- Trailing block-context indicators ('- ', ': ', '? ',+ -- bare '-' / ':' / '?') immediately after a flow node+ -- close are malformed (P2EQ /+ -- invalid-block-mapping-key-on-same-line-as-previous-key).+ Just (c, _)+ -- Trailing block indicators or bare text on the same+ -- line after a flow node close are malformed. Only a+ -- ':' / ',' / ']' / '}' terminator (the surrounding+ -- flow context's own punctuation) is acceptable here.+ | c == ',' || c == ':' || c == ']' || c == '}' -> do+ pushLine (PLine 0 0 LContent s s)+ pure v'+ | otherwise ->+ failP $ "trailing content after flow node: " ++ show s+ ScanIncomplete -> do+ ls <- getLines+ case ls of+ [] -> failP "YAML: unterminated flow node"+ (l' : _)+ | lineKind l' == LDocStart || lineKind l' == LDocEnd ->+ failP $+ "document marker inside flow node (line "+ ++ show (lineNo l')+ ++ ")"+ (l' : _)+ | openInd > 0+ , lineKind l' == LContent+ , lineIndent l' < openInd ->+ failP $+ "wrong-indented flow continuation (line "+ ++ show (lineNo l')+ ++ ")"+ (l' : _)+ | openInd > 0+ , lineKind l' == LContent+ , lineIndent l' == 0+ , case T.uncons (lineBody l') of+ Just ('\t', _) -> True+ _ -> False ->+ failP $+ "tab as indentation in flow continuation (line "+ ++ show (lineNo l')+ ++ ")"+ (l' : rs) -> do+ setLines rs+ modifyS (setFlowSpanned True)+ -- Join with a sentinel character (\\1) instead of a+ -- plain space so downstream parsers can detect that+ -- a structural element spanned a newline (used for+ -- the implicit-key-followed-by-newline check).+ go (buf <> tSOH <> lineBody l')+++data ScanResult+ = ScanComplete !Value !Text+ | ScanIncomplete+++scanFlow :: Int -> Text -> ScanResult+scanFlow depth buf = case parseFlowValue depth 0 buf of+ Just (v, p) -> ScanComplete v (bDrop p buf)+ Nothing -> ScanIncomplete+++parseFlowValue :: Int -> Int -> Text -> Maybe (Value, Int)+parseFlowValue = parseFlowValueWith False+++parseFlowValueWith :: Bool -> Int -> Int -> Text -> Maybe (Value, Int)+parseFlowValueWith !raw !depth !p0 t =+ let !len = bLen t+ p = skipFlowWS p0 t+ in if depth >= maxParserDepth || p >= len+ then Nothing+ else case bAt t p of+ 91 -> parseFlowSeq (depth + 1) (p + 1) t -- '['+ 123 -> parseFlowMap (depth + 1) (p + 1) t -- '{'+ 34 -> parseDQ p t -- '"'+ 39 -> parseSQ p t -- '\''+ 33 -> parseFlowTagged (depth + 1) p t -- '!'+ 38 -> parseFlowAnchored raw (depth + 1) p t -- '&'+ 42 -> parseFlowAlias p t -- '*'+ _ -> parseFlowPlainWith (if raw then YString else resolvePlain) p t+++{- | Tagged node in flow context. Reads the tag token (everything+up to whitespace / flow stopper) and then optionally parses a+following node; @!!str@ alone is allowed and means "tagged+null".+-}+parseFlowTagged :: Int -> Int -> Text -> Maybe (Value, Int)+parseFlowTagged !depth !p t =+ let !len = bLen t+ goT !i+ | i >= len = i+ | otherwise =+ let !c = bAt t i+ in if c == w8Space+ || c == w8Tab+ || c == w8SOH+ || c == w8Comma+ || c == w8RBrack+ || c == w8RBrace+ then i+ else goT (i + 1)+ !p1 = if p + 1 < len && bAt t (p + 1) == 60 then verbatim (p + 2) else goT p+ verbatim i+ | i >= len = i+ | bAt t i == 62 = i + 1+ | otherwise = verbatim (i + 1)+ tagText = bSlice t p p1+ tag = Tag tagText+ p2 = skipFlowWS p1 t+ in if p2 >= len+ then taggedFlow tag YNull p2+ else case bAt t p2 of+ 44 -> taggedFlow tag YNull p1 -- ','+ 93 -> taggedFlow tag YNull p1 -- ']'+ 125 -> taggedFlow tag YNull p1 -- '}'+ 58+ | colonIsSeparator (p2 + 1) t -> -- ':'+ taggedFlow tag YNull p1+ _ -> case parseFlowValueWith True depth p2 t of+ Just (v, p3) -> taggedFlow tag v p3+ Nothing -> taggedFlow tag YNull p2+++{- | Anchor in flow context: read the anchor name and parse the+labelled value, wrapping it in 'YAnchored' so the post-pass+'recordFlowAnchors' picks it up and registers it with the+enclosing parser state.+-}+parseFlowAnchored :: Bool -> Int -> Int -> Text -> Maybe (Value, Int)+parseFlowAnchored !raw !depth !p t =+ let !len = bLen t+ goN !i+ | i >= len = i+ | otherwise =+ let !c = bAt t i+ in if c == w8Space+ || c == w8Tab+ || c == w8SOH+ || c == w8Comma+ || c == w8RBrack+ || c == w8RBrace+ then i+ else goN (i + 1)+ !endName = goN (p + 1)+ name = bSlice t (p + 1) endName+ p2 = skipFlowWS endName t+ in if p2 >= len+ then Just (YAnchored (Anchor name) YNull, p2)+ else case bAt t p2 of+ 44 -> Just (YAnchored (Anchor name) YNull, endName)+ 93 -> Just (YAnchored (Anchor name) YNull, endName)+ 125 -> Just (YAnchored (Anchor name) YNull, endName)+ 58+ | colonIsSeparator (p2 + 1) t ->+ Just (YAnchored (Anchor name) YNull, endName)+ _ -> case parseFlowValueWith raw depth p2 t of+ Just (v, p3) -> Just (YAnchored (Anchor name) v, p3)+ Nothing -> Just (YAnchored (Anchor name) YNull, p2)+++{- | Alias in flow context. A distinct constructor keeps user strings opaque+to the resolution pass, even when they contain escaped control characters.+-}+parseFlowAlias :: Int -> Text -> Maybe (Value, Int)+parseFlowAlias !p t =+ let !len = bLen t+ goN !i+ | i >= len = i+ | otherwise =+ let !c = bAt t i+ in if c == w8Space+ || c == w8Tab+ || c == w8SOH+ || c == w8Comma+ || c == w8RBrack+ || c == w8RBrace+ then i+ else goN (i + 1)+ !p1 = goN (p + 1)+ name = bSlice t (p + 1) p1+ in Just (YAlias (Anchor name), p1)+++parseFlowSeq :: Int -> Int -> Text -> Maybe (Value, Int)+parseFlowSeq !depth !p0 t =+ let !len = bLen t+ goV !p acc+ | p >= len = Nothing+ | bAt t p == w8RBrack = Just (YSeq (V.fromList (reverse acc)), p + 1)+ | bAt t p == w8Hash = Nothing+ | bAt t p == w8STX = Nothing+ | otherwise = case parseFlowEntry depth p t of+ Nothing -> Nothing+ Just (v, p1) ->+ -- Skip any '\\2' comment-break sentinels before+ -- looking for the next separator.+ let p2 = skipFlowWSAndCB p1 t+ in if p2 >= len+ then Nothing+ else case bAt t p2 of+ 44 ->+ -- ','+ let p3 = p2 + 1+ in if p3 < len && bAt t p3 == w8Hash+ then Nothing+ else goV (skipFlowWS p3 t) (v : acc)+ 93 ->+ -- ']'+ Just (YSeq (V.fromList (reverse (v : acc))), p2 + 1)+ _ -> Nothing+ in goV (skipFlowWS p0 t) []+++{- | Skip whitespace and comment-break sentinels ('\\2'). Used+between flow elements where a comment may sit just before the+separator.+-}+skipFlowWSAndCB :: Int -> Text -> Int+skipFlowWSAndCB !p t =+ let !len = bLen t+ go !i+ | i >= len = i+ | otherwise = case bAt t i of+ 32 -> go (i + 1)+ 9 -> go (i + 1)+ 1 -> go (i + 1)+ 2 -> go (i + 1)+ _ -> i+ in go p+{-# INLINE skipFlowWSAndCB #-}+++{- | A flow-sequence entry can be a single value or a one-pair+mapping (with @key: value@ syntax, or just @: value@ for an empty+key).+-}+parseFlowEntry :: Int -> Int -> Text -> Maybe (Value, Int)+parseFlowEntry depth = parseFlowEntry' depth False+++{- | When the @explicit@ flag is set, the entry is being parsed+under a leading @?@ marker (explicit key); the+implicit-key-spans-newline check is skipped.+-}+parseFlowEntry' :: Int -> Bool -> Int -> Text -> Maybe (Value, Int)+parseFlowEntry' !depth !explicit !p0 t =+ let !len = bLen t+ p = skipFlowWS p0 t+ in if p >= len+ then Nothing+ else+ if bAt t p == w8Quest+ && p + 1 < len+ && ( bAt t (p + 1) == w8Space+ || bAt t (p + 1) == w8Tab+ || bAt t (p + 1) == w8SOH+ )+ then parseFlowEntry' depth True (skipFlowWS (p + 1) t) t+ else+ if bAt t p == w8Colon && colonIsSeparator (p + 1) t+ then+ let p1 = skipFlowWS (p + 1) t+ in if p1 >= len+ then Nothing+ else case bAt t p1 of+ 44 -> Just (YMap (V.singleton (YNull, YNull)), p1)+ 93 -> Just (YMap (V.singleton (YNull, YNull)), p1)+ _ -> case parseFlowValue depth p1 t of+ Nothing -> Just (YMap (V.singleton (YNull, YNull)), p1)+ Just (v, p2) ->+ Just (YMap (V.singleton (YNull, v)), p2)+ else+ let !flowOpener = case bAt t p of+ 34 -> True -- '"'+ 39 -> True -- '\''+ 91 -> True -- '['+ 123 -> True -- '{'+ _ -> False+ in case parseFlowValue depth p t of+ Nothing -> Nothing+ Just (k, p1) ->+ let p2 = skipFlowWS p1 t+ in if p2 < len+ && bAt t p2 == w8Colon+ && ( flowOpener+ || colonIsSeparator (p2 + 1) t+ )+ then+ -- For flow /sequences/, an implicit+ -- key->value pair appearing inline+ -- must have key and ':' on the same+ -- line (spec §7.4.1).+ let span_ = bSlice t p p2+ in if not explicit+ && (bAnyByte w8SOH span_ || T.length span_ > 1024)+ then Nothing+ else case parseFlowValue depth (skipFlowWS (p2 + 1) t) t of+ Nothing -> Just (YMap (V.singleton (k, YNull)), p2 + 1)+ Just (v, p3) -> Just (YMap (V.singleton (k, v)), p3)+ else Just (if explicit then YMap (V.singleton (k, YNull)) else k, p1)+++{- | Whether a colon at position @p@ acts as a key/value separator+in flow context: only when the very next character is a flow+stopper or whitespace.+-}+colonIsSeparator :: Int -> Text -> Bool+colonIsSeparator !p t+ | p >= bLen t = True+ | otherwise = flowColonFollower (bAt t p)+{-# INLINE colonIsSeparator #-}+++parseFlowMap :: Int -> Int -> Text -> Maybe (Value, Int)+parseFlowMap !depth !p0 t =+ let !len = bLen t+ goV !p acc+ | p >= len = Nothing+ | bAt t p == w8RBrace = Just (YMap (V.fromList (reverse acc)), p + 1)+ | bAt t p == w8Comma = Nothing+ | otherwise = do+ let explicit = bAt t p == w8Quest && colonIsSeparator (p + 1) t+ start = if explicit then skipFlowWS (p + 1) t else p+ (key, end) <-+ if start < len && (bAt t start == w8Colon || explicit && bAt t start `elem` [w8Comma, w8RBrace])+ then Just (YNull, start)+ else parseFlowValue depth start t+ let separator = skipFlowWS end t+ if separator < len && bAt t separator == w8Colon+ then+ let valueStart = skipFlowWS (separator + 1) t+ in if valueStart < len && bAt t valueStart `elem` [w8Comma, w8RBrace]+ then finish valueStart key YNull acc+ else do+ (value, next) <- parseFlowValue depth valueStart t+ finish next key value acc+ else finish separator key YNull acc+ finish !p key value acc =+ let next = skipFlowWS p t+ in if next >= len+ then Nothing+ else case bAt t next of+ 44 -> goV (skipFlowWS (next + 1) t) ((key, value) : acc)+ 125 -> Just (YMap (V.fromList (reverse ((key, value) : acc))), next + 1)+ _ -> Nothing+ in goV (skipFlowWS p0 t) []+++parseDQ :: Int -> Text -> Maybe (Value, Int)+parseDQ !p0 t =+ let !len = bLen t+ -- Fast path: SWAR-scan for the first occurrence of '\"',+ -- '\\\\', or '\\1'. If the closing quote comes first+ -- (i.e. no escape or newline-sentinel before it) we slice+ -- the body out without further work.+ !startSlice = p0 + 1+ !rest = bSlice t startSlice len+ !idx = bFindAnyOf3 w8DQuote w8Backslash w8SOH rest+ in if idx < 0+ then Nothing -- no terminator at all+ else+ let !absIdx = startSlice + idx+ !c = bAt t absIdx+ in if c == w8DQuote+ then+ Just+ ( YString (bSlice t startSlice absIdx)+ , absIdx + 1+ )+ else decodeQuoted True p0 absIdx t+++parseSQ :: Int -> Text -> Maybe (Value, Int)+parseSQ !p0 t =+ let !len = bLen t+ !startSlice = p0 + 1+ !rest = bSlice t startSlice len+ -- SWAR-scan for the first '\\'' or '\\1' sentinel. A bare+ -- '\\'' is a closing quote; a doubled '\\'\\'' is the+ -- single-quoted escape and forces the slow path.+ !idx = bFindAnyOf2 w8SQuote w8SOH rest+ in if idx < 0+ then Nothing+ else+ let !absIdx = startSlice + idx+ !c = bAt t absIdx+ in if c == w8SQuote+ then+ if absIdx + 1 < len && bAt t (absIdx + 1) == w8SQuote+ then decodeQuoted False p0 absIdx t -- '\\'\\'' escape+ else+ Just+ ( YString (bSlice t startSlice absIdx)+ , absIdx + 1+ )+ else decodeQuoted False p0 absIdx t+++-- Decode escapes into one UTF-8 buffer, copying ordinary runs in bulk. The+-- preliminary scan bounds allocation by this scalar, not the remaining flow+-- document; escaped strings in a long sequence therefore stay linear in size.+decodeQuoted :: Bool -> Int -> Int -> Text -> Maybe (Value, Int)+decodeQuoted double opening firstSpecial source@(TI.Text input inputOffset inputLength) = do+ closing <- findClosing firstSpecial+ let start = opening + 1+ rawLength = closing - start+ -- The largest expansion is \L or \P: two input bytes become three.+ extra = rawLength `quot` 2 + 1+ if rawLength > maxBound - extra+ then Nothing+ else+ let (array, result) = TA.run2 $ do+ output <- TA.new (rawLength + extra)+ TA.copyI (firstSpecial - start) output 0 input (inputOffset + start)+ let done size = TA.shrinkM output size >> pure (output, Just size)+ go !cursor !written+ | cursor == closing = done written+ | otherwise =+ let index =+ if double+ then bFindAnyOf3 w8DQuote w8Backslash w8SOH (bSlice source cursor (closing + 1))+ else bFindAnyOf2 w8SQuote w8SOH (bSlice source cursor (closing + 1))+ position = cursor + index+ runLength = position - cursor+ next = written + runLength+ in do+ TA.copyI runLength output written input (inputOffset + cursor)+ if position == closing+ then done next+ else case bAt source position of+ 92+ | double ->+ decodeDQEscape+ source+ (position + 1)+ (pure (output, Nothing))+ ( \char following -> do+ width <- TU.unsafeWrite output next char+ go following (next + width)+ )+ 39 | not double -> do+ TA.unsafeWrite output next w8SQuote+ go (position + 2) (next + 1)+ _ -> do+ TA.unsafeWrite output next w8Space+ go (position + 1) (next + 1)+ go firstSpecial (firstSpecial - start)+ in case result of+ Nothing -> Nothing+ Just size -> Just (YString (TI.text array 0 size), closing + 1)+ where+ findClosing !cursor+ | cursor >= inputLength = Nothing+ | otherwise =+ let quote = if double then w8DQuote else w8SQuote+ index = bFindAnyOf2 quote quote (bDrop cursor source)+ position = cursor + index+ in if index < 0+ then Nothing+ else+ if double && escapedQuote (position - 1) False+ then findClosing (position + 1)+ else+ if not double && position + 1 < inputLength && bAt source (position + 1) == w8SQuote+ then findClosing (position + 2)+ else Just position+ -- Only quote candidates need escape parity. Scanning every backslash here+ -- repeats work that the decoding pass already performs for each escape.+ escapedQuote !position !oddRun+ | position >= 0 && bAt source position == w8Backslash = escapedQuote (position - 1) (not oddRun)+ | otherwise = oddRun+++plainStartAllowed :: Bool -> Text -> Bool+plainStartAllowed flow text = case T.uncons text of+ Nothing -> False+ Just (first, rest)+ | first `T.elem` ",[]{}#&*!|>'\"%@`" -> False+ | first `T.elem` "-?:" -> case T.uncons rest of+ Nothing -> False+ Just (next, _) -> next /= ' ' && next /= '\t' && next /= '\n' && next /= '\1' && (not flow || not (next `T.elem` ",[]{}"))+ | otherwise -> True+++parseFlowPlainWith :: (Text -> Value) -> Int -> Text -> Maybe (Value, Int)+parseFlowPlainWith resolve !p t =+ let !len = bLen t+ -- Walk the body looking for a stopper. Track in 'sawSOH'+ -- whether we crossed any '\\1' newline sentinel, so we+ -- can skip the (allocating) 'T.replace' fold below in+ -- the common case.+ scan !i !crossedNewline+ | i >= len = (i, crossedNewline)+ | otherwise =+ let !c = bAt t i+ in if isFlowStopByte c+ || (c == w8Colon && colonStopByte i)+ then (i, crossedNewline)+ else scan (i + 1) (crossedNewline || c == w8SOH)+ colonStopByte !i =+ let i1 = i + 1+ in i1 >= len || flowColonFollower (bAt t i1)+ (!p', !sawSOH) = scan p False+ raw = bSlice t p p'+ folded+ | sawSOH = T.replace tSOH tSpace raw+ | otherwise = raw+ stripped = stripYamlEnd folded+ in if T.null stripped || not (plainStartAllowed True stripped) || not (T.all validNonBreak stripped)+ then Nothing+ else+ if stripped == tDashStr+ then Nothing+ else Just (resolve stripped, p')+++-- ---------------------------------------------------------------------------+-- Constant-string CAFs.+--+-- 'T.pack \"…\"' is /not/ free even for a static literal — it+-- allocates the result 'Text' on every call unless GHC happens+-- to lift it. Hoisting frequently-used literals to top-level+-- saves a re-pack on every hot-loop iteration.+-- ---------------------------------------------------------------------------++tSOH, tSTX, tSpace, tNL :: Text+tSOH = T.singleton '\1'+tSTX = T.singleton '\2'+tSpace = T.singleton ' '+tNL = T.singleton '\n'+++tDashStr :: Text+tDashStr = T.pack "-"+++tQuestStr :: Text+tQuestStr = T.pack "?"+++tColonStr, tColonSpace, tColonTab :: Text+tColonStr = T.pack ":"+tColonSpace = T.pack ": "+tColonTab = T.pack ":\t"+++tYamlTagPrefix :: Text+tYamlTagPrefix = T.pack "tag:yaml.org,2002:"+++{- | Bytes that terminate a flow-context plain scalar+(excluding the colon-with-follower case which is handled by+the caller).+-}+isFlowStopByte :: Word8 -> Bool+isFlowStopByte c =+ c == w8Comma+ || c == w8LBrack+ || c == w8RBrack+ || c == w8LBrace+ || c == w8RBrace+ || c == w8STX+{-# INLINE isFlowStopByte #-}+++{- | A byte that, when it follows a ':' in flow context, makes+that ':' a key/value separator (and therefore a stop point+for a flow plain scalar).+-}+flowColonFollower :: Word8 -> Bool+flowColonFollower c =+ c == w8Space+ || c == w8Tab+ || c == w8SOH+ || c == w8Comma+ || c == w8RBrack+ || c == w8RBrace+{-# INLINE flowColonFollower #-}+++skipFlowWS :: Int -> Text -> Int+skipFlowWS !p t =+ let !len = bLen t+ go !i+ | i >= len = i+ | otherwise = case bAt t i of+ 32 -> go (i + 1) -- ' '+ 9 -> go (i + 1) -- '\t'+ 1 -> go (i + 1) -- '\1'+ 2 -> go (i + 1) -- comment break+ _ -> i+ in go p+{-# INLINE skipFlowWS #-}+++-- ---------------------------------------------------------------------------+-- Block style: dispatch from a line we haven't consumed yet.+-- ---------------------------------------------------------------------------++{- | A line starts a block-sequence entry if its body is exactly+@-@ or starts with @- @ / @-<TAB>@.+-}+isSeqItem :: Text -> Bool+isSeqItem b =+ case bLen b of+ 0 -> False+ 1 -> bAt b 0 == 45 -- '-'+ _ ->+ bAt b 0 == 45+ && let !c1 = bAt b 1+ in c1 == w8Space || c1 == w8Tab+{-# INLINE isSeqItem #-}+++-- | Same shape for the explicit-key marker @?@.+isExplicitKey :: Text -> Bool+isExplicitKey b =+ case bLen b of+ 0 -> False+ 1 -> bAt b 0 == w8Quest+ _ ->+ bAt b 0 == w8Quest+ && let !c1 = bAt b 1+ in c1 == w8Space || c1 == w8Tab+{-# INLINE isExplicitKey #-}+++{- | True when @b@ is exactly @\":\"@ or starts with @\": \"@ /+@\":\\t\"@. Used to recognise the value-continuation marker+after an explicit @?@ key.+-}+isColonMarker :: Text -> Bool+isColonMarker b =+ case bLen b of+ 0 -> False+ 1 -> bAt b 0 == w8Colon+ _ ->+ bAt b 0 == w8Colon+ && let !c1 = bAt b 1+ in c1 == w8Space || c1 == w8Tab+{-# INLINE isColonMarker #-}+++parseBlockOrPlain :: PLine -> P Value+parseBlockOrPlain l+ | isSeqItem body = parseBlockSeq (lineIndent l)+ | isExplicitKey body = parseExplicitMap (lineIndent l)+ | otherwise = case findAliasKeySplit body of+ Just (aliasName, vRest) ->+ parseBlockMapAliasFirst+ (lineIndent l)+ aliasName+ vRest+ Nothing -> case findKeyValueSplit body of+ Just (k, vRest) -> parseBlockMap (lineIndent l) k vRest+ Nothing -> parsePlainScalar (lineIndent l) body+ where+ body = lineBody l+++{- | Block mapping whose first key is an alias node (parsed via+'findAliasKeySplit'). Same shape as 'parseBlockMap' otherwise.+-}+parseBlockMapAliasFirst :: Int -> Text -> Text -> P Value+parseBlockMapAliasFirst !ind aliasName firstRest = do+ dropLine+ k0 <- resolveAnchor aliasName+ v0 <- parseImplicitMapValue ind firstRest+ rest <- collect [(k0, v0)]+ pure (YMap (V.fromList (reverse rest)))+ where+ collect acc = do+ mPL <- peekLine+ case mPL of+ Nothing -> pure acc+ Just l+ | lineIndent l /= ind -> pure acc+ | isSeqItem (lineBody l) -> pure acc+ | isExplicitKey (lineBody l) -> pure acc+ | startsWithTab (lineBody l) ->+ failP $+ "tab character used as indentation (line "+ ++ show (lineNo l)+ ++ ")"+ | otherwise -> case findAliasKeySplit (lineBody l) of+ Just (a, vRest) -> do+ dropLine+ k <- resolveAnchor a+ v <- parseImplicitMapValue ind vRest+ collect ((k, v) : acc)+ Nothing -> case findKeyValueSplit (lineBody l) of+ Just (k, vRest) -> do+ dropLine+ v <- parseImplicitMapValue ind vRest+ key <- parseBlockKey k+ collect ((key, v) : acc)+ Nothing -> pure acc+++-- ---------------------------------------------------------------------------+-- Block sequence+-- ---------------------------------------------------------------------------++parseBlockSeq :: Int -> P Value+parseBlockSeq !ind = collect [] >>= \xs -> pure (YSeq (V.fromList (reverse xs)))+ where+ collect acc = do+ mPL <- peekLine+ case mPL of+ Nothing -> pure acc+ Just l+ | lineIndent l /= ind -> pure acc+ | not (isSeqItem (lineBody l)) ->+ pure acc+ | otherwise -> do+ v <- parseSeqItem ind+ collect (v : acc)+++parseSeqItem :: Int -> P Value+parseSeqItem !ind = do+ Just l <- popLine+ let body = lineBody l+ after+ | body == "-" = T.empty+ | otherwise = T.drop 2 body+ after' = stripYamlStart after+ -- '-<TAB><INDICATOR>' or '- <TAB><INDICATOR>' (nested block+ -- marker reached via a tab in the indent column) is 'tab as+ -- indentation' per spec §6.1. The plain-scalar form+ -- '-<TAB>x' is fine because no further indent calculation+ -- happens; but '-\\t-' / '- \\t-' / '-\\t?' / etc. would set+ -- the nested block's indent to a tab-containing column.+ let separatorHasTab =+ T.any+ (== '\t')+ ( T.takeWhile+ (\c -> c == ' ' || c == '\t')+ (T.drop 1 body)+ )+ when (separatorHasTab && startsWithBlockIndicator after') $+ failP $+ "tab character used as indentation before nested block marker (line "+ ++ show (lineNo l)+ ++ ")"+ let isCommentOnly = case T.uncons after' of+ Just ('#', _) -> True+ _ -> False+ if isCommentOnly || T.null after'+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > ind ->+ withParentInd ind (parseNode (lineIndent l2))+ _ -> pure YNull+ else do+ let isCarrier = case T.uncons after' of+ Just ('|', _) -> True+ Just ('>', _) -> True+ Just ('!', _) -> True+ Just ('&', _) -> True+ _ -> False+ isNestedBlock = case T.uncons after' of+ Just ('-', rest) -> startsWithSeparator rest+ Just ('?', rest) -> startsWithSeparator rest+ _ -> False+ extraWS = T.length after - T.length after'+ virtInd+ | isCarrier = ind+ -- For nested block constructs the actual+ -- column of the next dash / explicit-key marker+ -- is past the outer dash AND any extra+ -- separator spaces. Use it so collectors at+ -- that level match real-world inputs (A2M4).+ | isNestedBlock = ind + 2 + extraWS+ | otherwise = ind + 2+ virt = PLine (lineNo l) virtInd LContent after' after'+ pushLine virt+ withParentInd ind $+ withSequenceItem True $+ if T.isPrefixOf "!" after' || T.isPrefixOf "&" after'+ then withInMapValue True (parseNode virtInd)+ else parseNode virtInd+++-- ---------------------------------------------------------------------------+-- Block mapping+-- ---------------------------------------------------------------------------++parseBlockMap :: Int -> Text -> Text -> P Value+parseBlockMap ind firstKey firstRest = do+ key <- parseBlockKey firstKey+ parseBlockMapWithKey ind key firstRest+++parseBlockKey :: Text -> P Value+parseBlockKey raw+ | T.length raw > 1024 = failP "YAML: implicit mapping key exceeds 1024 characters"+ | T.null raw = pure YNull+ | otherwise = case T.uncons raw of+ Just ('"', _) -> quoted parseDQ+ Just ('\'', _) -> quoted parseSQ+ Just (c, _) | c == '!' || c == '&' || c == '*' || c == '[' || c == '{' -> parseRawKey raw >>= recordAndResolveFlow+ _ -> do+ unless ((plainStartAllowed False raw || raw `elem` ["-", "?", ":"]) && T.all validNonBreak raw) (failP "YAML: invalid plain mapping key")+ pure (resolvePlain raw)+ where+ quoted parser = case parser 0 raw of+ Just (key, end) | T.null (stripYaml (bDrop end raw)) -> pure key+ _ -> failP "YAML: invalid quoted mapping key"+++parseBlockMapWithKey :: Int -> Value -> Text -> P Value+parseBlockMapWithKey !ind firstKey firstRest = do+ dropLine+ v0 <- parseImplicitMapValue ind firstRest+ rest <- collect [(firstKey, v0)]+ pure (YMap (V.fromList (reverse rest)))+ where+ collect acc = do+ mPL <- peekLine+ case mPL of+ Nothing -> pure acc+ Just l+ | lineIndent l /= ind -> pure acc+ | otherwise ->+ let body = lineBody l+ in case T.uncons body of+ Nothing -> pure acc+ Just (h, _)+ | h == '\t' ->+ failP $+ "tab character used as indentation (line "+ ++ show (lineNo l)+ ++ ")"+ | h == '-'+ , isSeqItem body ->+ pure acc+ | h == '?'+ , isExplicitKey body -> do+ k <- readExplicitPart "?"+ v <- readExplicitValue+ collect ((k, v) : acc)+ | h == '*'+ , Just (aliasName, vRest) <- findAliasKeySplit body -> do+ dropLine+ k <- resolveAnchor aliasName+ v <- parseImplicitMapValue ind vRest+ collect ((k, v) : acc)+ | otherwise -> case findKeyValueSplit body of+ Just (k, vRest) -> do+ dropLine+ let (anchors, k') = stripKeyProperties k+ case T.uncons k' of+ Just ('*', _)+ | not (null anchors) ->+ failP $+ "anchor immediately followed by alias key (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ kv <- parseBlockKey k+ v <- parseImplicitMapValue ind vRest+ collect ((kv, v) : acc)+ Nothing -> pure acc++ readExplicitPart marker = do+ Just l <- popLine+ let body = lineBody l+ afterMarker =+ if body == marker+ then T.empty+ else T.drop 1 body+ rest0 = stripYamlStart (T.drop 1 afterMarker)+ rest = case T.uncons rest0 of+ Just ('#', _) -> T.empty+ _ -> rest0+ case T.uncons afterMarker of+ Just ('\t', _) ->+ failP $+ "tab character after explicit-key marker (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ if T.null rest+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > lineIndent l ->+ parseNode (lineIndent l2)+ Just l2+ | lineIndent l2 == lineIndent l+ , isSeqItem (lineBody l2) ->+ parseBlockSeq (lineIndent l2)+ _ -> pure YNull+ else do+ let isBlockScalarHead = case T.uncons rest of+ Just ('|', _) -> True+ Just ('>', _) -> True+ _ -> False+ virtInd+ | isBlockScalarHead = lineIndent l+ | otherwise = lineIndent l + 2+ pushLine+ ( PLine+ (lineNo l)+ virtInd+ LContent+ rest+ rest+ )+ withParentInd (lineIndent l) (parseNode virtInd)++ readExplicitValue = do+ mPL <- peekLine+ case mPL of+ Just l+ | lineIndent l == ind+ && isColonMarker (lineBody l) ->+ readExplicitPart ":"+ _ -> pure YNull+++startsWithTab :: Text -> Bool+startsWithTab t = case T.uncons t of+ Just ('\t', _) -> True+ _ -> False+++-- | True when @t@ is empty or starts with a space / tab.+startsWithSeparator :: Text -> Bool+startsWithSeparator t = case T.uncons t of+ Nothing -> True+ Just (' ', _) -> True+ Just ('\t', _) -> True+ _ -> False+++{- | True when @t@ begins with a block-context structural marker+('-' or '?' followed by space / tab / EOL).+-}+startsWithBlockIndicator :: Text -> Bool+startsWithBlockIndicator t = case T.uncons t of+ Just ('-', rest) -> isBlockSep rest+ Just ('?', rest) -> isBlockSep rest+ _ -> False+ where+ isBlockSep r = case T.uncons r of+ Nothing -> True+ Just (' ', _) -> True+ Just ('\t', _) -> True+ _ -> False+++{- | Strip leading anchor / tag tokens (separated by spaces) from+a block-mapping key string. Returns the list of anchor names+encountered and the remainder text. Tags are dropped silently+(they don't change the key projection).+-}+stripKeyProperties :: Text -> ([Text], Text)+stripKeyProperties = go []+ where+ go acc t = case T.uncons (stripYamlStart t) of+ Just ('&', rest) ->+ let (name, after) = takeAnchorName rest+ in go (name : acc) after+ Just ('!', rest) ->+ let (_tg, after) = T.span (\c -> not (c == ' ' || c == '\t')) rest+ in go acc after+ _ -> (reverse acc, stripYamlStart t)+++{- | Recognise @*alias : value@ style mapping entries where the key+is an alias node. Returns the alias name (without the @*@) and+the value text after the colon, or 'Nothing' when the line+doesn't have this shape.+-}+findAliasKeySplit :: Text -> Maybe (Text, Text)+findAliasKeySplit t = case T.uncons t of+ Just ('*', rest) ->+ let (name, after) = takeAnchorName rest+ afterTrim = stripYamlStart after+ in case T.uncons afterTrim of+ Just (':', tail_)+ | T.null tail_ || T.head tail_ == ' ' || T.head tail_ == '\t' ->+ Just (name, T.drop 1 afterTrim)+ _ -> Nothing+ _ -> Nothing+++parseImplicitMapValue :: Int -> Text -> P Value+parseImplicitMapValue ind rest = withParentInd ind (withInMapValue True (withSequenceItem False (parseImplicitMapValueBody ind rest)))+++parseImplicitMapValueBody :: Int -> Text -> P Value+parseImplicitMapValueBody !ind vRest =+ if T.null after+ then do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > ind -> do+ -- Strip leading tabs from the body, which YAML+ -- treats as additional whitespace (not part of+ -- the scalar text).+ let body' = T.dropWhile (== '\t') (lineBody l2)+ modifyS+ ( \s ->+ s+ { psLines = case psLines s of+ (h : rs) -> h {lineBody = body'} : rs+ [] -> []+ }+ )+ parseNode (lineIndent l2)+ | lineIndent l2 == ind+ && (isSeqItem (lineBody l2)) ->+ parseBlockSeq ind+ _ -> pure YNull+ else case T.uncons after of+ Just (h, _)+ | h == '|' -> do+ pushLine (PLine 0 ind LContent after after)+ parseBlockScalar Literal+ | h == '>' -> do+ pushLine (PLine 0 ind LContent after after)+ parseBlockScalar Folded+ | h == '[' -> do+ pushLine (PLine 0 (ind + 2) LContent after after)+ Just l <- popLine+ consumeFlowAt (ind + 1) (lineBody l)+ | h == '{' -> do+ pushLine (PLine 0 (ind + 2) LContent after after)+ Just l <- popLine+ consumeFlowAt (ind + 1) (lineBody l)+ | h == '&' -> do+ pushLine (PLine 0 ind LContent after after)+ withInMapValue True parseAnchored+ | h == '*' -> do+ pushLine (PLine 0 (ind + 2) LContent after after)+ parseAlias+ | h == '!' -> do+ pushLine (PLine 0 ind LContent after after)+ parseTagged+ | h == '"' -> consumeQuotedAt '"' (ind + 1) after+ | h == '\'' -> consumeQuotedAt '\'' (ind + 1) after+ | h == '#' -> parseImplicitMapValueEmpty ind+ | otherwise -> goPlain+ Nothing -> goPlain+ where+ goPlain :: P Value+ goPlain = do+ -- Fast path: if the next physical line in the stream+ -- can't extend this plain scalar (lower indent than+ -- the value column, OR no next line at all), we can+ -- resolve directly without 'parsePlainScalar'.+ ls <- getLines+ let canExtend = case ls of+ (n : _) ->+ lineKind n == LContent+ && lineIndent n > ind+ _ -> False+ sclean = stripYamlEnd (stripInlineComment after)+ isUnambiguous =+ not canExtend+ && case findKeyValueSplit sclean of+ Just _ -> False+ Nothing -> True+ if isUnambiguous+ then resolvePlainP sclean+ else do+ pushLine (PLine 0 (ind + 1) LContent after after)+ withInMapValue True (parsePlainScalar (ind + 1) after)+ after = stripYamlStart vRest+++parseImplicitMapValueEmpty :: Int -> P Value+parseImplicitMapValueEmpty !ind = do+ mNext <- peekLine+ case mNext of+ Just l2+ | lineIndent l2 > ind -> do+ let body' = T.dropWhile (== '\t') (lineBody l2)+ modifyS+ ( \s ->+ s+ { psLines = case psLines s of+ (h : rs) -> h {lineBody = body'} : rs+ [] -> []+ }+ )+ parseNode (lineIndent l2)+ | lineIndent l2 == ind && isSeqItem (lineBody l2) ->+ parseBlockSeq ind+ _ -> pure YNull+++-- ---------------------------------------------------------------------------+-- Explicit-key mapping (?-form)+-- ---------------------------------------------------------------------------++parseExplicitMap :: Int -> P Value+parseExplicitMap !ind = collect [] >>= \kvs -> pure (YMap (V.fromList (reverse kvs)))+ where+ collect acc = do+ mPL <- peekLine+ case mPL of+ Nothing -> pure acc+ Just l+ | lineIndent l /= ind -> pure acc+ | isExplicitKey (lineBody l) -> do+ k <- readExplicitPart "?"+ v <- readExplicitValue+ collect ((k, v) : acc)+ -- A bare ':' or ': value' / ':<TAB>value' line at the+ -- mapping indent is an entry with an implicit (null)+ -- key. Per spec §8.18, omitting the '?' is permitted.+ | isColonMarker (lineBody l) -> do+ v <- readExplicitPart ":"+ collect ((YNull, v) : acc)+ -- An ordinary 'key: value' implicit pair after a ?-form+ -- entry continues the same mapping (spec §8.18).+ | otherwise -> case findKeyValueSplit (lineBody l) of+ Just (k, vRest) -> do+ dropLine+ kv <- parseBlockKey k+ v <- parseImplicitMapValue ind vRest+ collect ((kv, v) : acc)+ Nothing -> pure acc++ readExplicitPart marker = do+ Just l <- popLine+ let body = lineBody l+ afterMarker =+ if body == marker+ then T.empty+ else T.drop 1 body+ rest0 = stripYamlStart (T.drop 1 afterMarker)+ -- '#' immediately after the explicit-key marker+ -- starts a comment; the value comes from the next+ -- continuation line.+ rest = case T.uncons rest0 of+ Just ('#', _) -> T.empty+ _ -> rest0+ case T.uncons afterMarker of+ Just ('\t', _) ->+ failP $+ "tab character after explicit-key marker (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ if T.null rest+ then do+ mNext <- peekLine+ case mNext of+ Just l2 | lineIndent l2 > lineIndent l -> parseNode (lineIndent l2)+ Just l2+ | lineIndent l2 == lineIndent l+ , isSeqItem (lineBody l2) ->+ parseBlockSeq (lineIndent l2)+ _ -> pure YNull+ else do+ let isBlockScalarHead = case T.uncons rest of+ Just ('|', _) -> True+ Just ('>', _) -> True+ _ -> False+ virtInd+ | isBlockScalarHead = lineIndent l+ | otherwise = lineIndent l + 2+ pushLine (PLine (lineNo l) virtInd LContent rest rest)+ withParentInd (lineIndent l) (parseNode virtInd)++ readExplicitValue = do+ mPL <- peekLine+ case mPL of+ Just l+ | lineIndent l == ind+ && isColonMarker (lineBody l) ->+ readExplicitPart ":"+ _ -> pure YNull+++-- ---------------------------------------------------------------------------+-- Plain scalars (multi-line)+-- ---------------------------------------------------------------------------++parsePlainScalar :: Int -> Text -> P Value+parsePlainScalar !ind firstBody = do+ parentInd <- getParentInd+ inMapValue <- getInMapValue+ parsePlainScalarAt parentInd inMapValue ind firstBody+++{- | Like 'parsePlainScalar' but with explicit parent indent and+"are we in a mapping-value position" flag.+-}+parsePlainScalarAt :: Int -> Bool -> Int -> Text -> P Value+parsePlainScalarAt !parentInd !inMapValue !baseIndArg firstBody = do+ unless (plainStartAllowed False firstBody) (failP "YAML: invalid plain scalar indicator")+ let !ind = baseIndArg+ !_p = parentInd+ !_m = inMapValue+ dropLine+ -- Fast path: a body with no '#' at all has no comment, so we+ -- skip the comparison probe entirely.+ let !hasHash = bAnyByte w8Hash firstBody+ !stripped =+ if hasHash+ then stripInlineComment firstBody+ else firstBody+ !first = stripYamlEnd stripped+ !hadComment =+ hasHash+ && bLen stripped < bLen (stripYamlEnd firstBody)+ -- A plain scalar may not contain ': ' (colon-space) in block+ -- context — that would form a nested mapping (spec §7.3.3).+ case findKeyValueSplit first of+ Just _ -> failP $ "nested mapping in plain scalar: " ++ show first+ _ -> pure ()+ -- A trailing comment on the first line of a plain scalar+ -- followed by a continuation line is malformed (the comment+ -- would silently break the scalar).+ when hadComment $ do+ ls' <- getLines+ case ls' of+ (l2 : _)+ | lineIndent l2 >= ind+ , lineKind l2 == LContent+ , not (isSeqItem (lineBody l2))+ , not (isExplicitKey (lineBody l2))+ , case findKeyValueSplit (lineBody l2) of+ Just _ -> False+ Nothing -> True ->+ failP $+ "comment between plain-scalar lines (line "+ ++ show (lineNo l2 - 1)+ ++ ")"+ _ -> pure ()+ rest <- collectFolds ind 0 []+ let !final = joinPlain (first : rest)+ resolvePlainP final+ where+ -- @blanks@ counts the run of consecutive blank lines we've+ -- absorbed since the last non-blank continuation line. The+ -- collected list interleaves non-blank line bodies with marker+ -- entries representing blank-line runs (encoded as the empty+ -- string preceded by a special sentinel, see joinPlain).+ --+ -- A continuation line is accepted when its indent is /strictly+ -- greater/ than the scalar's base indent and it doesn't look+ -- like a new collection entry (mapping key, seq item, explicit+ -- '?' key).+ collectFolds baseInd blanks acc = do+ ls <- getLines+ case ls of+ [] -> pure (reverse acc)+ (l : _)+ | lineKind l == LBlank ->+ do consumeOne; collectFolds baseInd (blanks + 1) acc+ | lineKind l == LComment+ && lineIndent l > baseInd ->+ do consumeOne; collectFolds baseInd blanks acc+ | (lineKind l == LContent || lineKind l == LDirective)+ -- Standard continuation: indent >= baseInd.+ -- Shallow continuation rules:+ -- * indent in (parentInd .. baseInd) range is OK+ -- for plain scalar content (UV7Q).+ -- * a '- ' shallow line (looks like nested seq) at+ -- the OUTERMOST seq (parentInd == 0, NOT inside+ -- a mapping value) also folds into the plain+ -- scalar (AB8U).+ && ( lineIndent l >= baseInd+ || ( lineIndent l > parentInd+ && not (isExplicitKey (lineBody l))+ && ( not (isSeqItem (lineBody l))+ || (parentInd == 0 && not inMapValue)+ )+ )+ )+ && not+ ( isSeqItem (lineBody l)+ && lineIndent l >= baseInd+ )+ && not+ ( isExplicitKey (lineBody l)+ && lineIndent l >= baseInd+ )+ && case findKeyValueSplit (lineBody l) of+ Just _ -> False+ Nothing -> True ->+ do+ -- For an LDirective line (begins with '%'), only+ -- accept it as scalar content if there's no later+ -- '---' / '...' marker that would make it a real+ -- directive for a subsequent document.+ accept <- case lineKind l of+ LDirective -> do+ ls' <- getLines+ pure (not (any isMarker ls'))+ _ -> pure True+ if not accept+ then pure (reverse acc)+ else do+ consumeOne+ let raw = lineBody l+ s0 = stripYamlEnd (stripInlineComment raw)+ s = T.dropWhile (\c -> c == ' ' || c == '\t') s0+ hadComment = bLen s0 < bLen (stripYamlEnd raw)+ prefix+ | blanks == 0 = s+ | otherwise = T.replicate blanks tNL <> s+ when hadComment $ do+ ls' <- getLines+ case ls' of+ (l2 : _)+ | lineIndent l2 >= baseInd+ , lineKind l2 == LContent+ , not (isSeqItem (lineBody l2))+ , not (isExplicitKey (lineBody l2))+ , case findKeyValueSplit (lineBody l2) of+ Just _ -> False+ Nothing -> True ->+ failP $+ "comment between plain-scalar lines (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ collectFolds baseInd 0 (prefix : acc)+ | otherwise -> pure (reverse acc)+ where+ isMarker l = lineKind l == LDocStart || lineKind l == LDocEnd++ consumeOne = do+ ls <- getLines+ case ls of+ (_ : xs) -> setLines xs+ [] -> pure ()++ -- Join the collected pieces; pieces that already start with a+ -- newline marker are joined with no separator.+ -- Most plain scalars are a single line; short-circuit+ -- those without building any intermediate list. For the+ -- multi-line case build the result in one 'T.concat'+ -- allocation rather than chaining '<>' (which is O(N^2) on+ -- the result text).+ joinPlain [] = T.empty+ joinPlain [x] = x+ joinPlain xs = T.concat (interleave xs)+ where+ interleave [] = []+ interleave [x] = [x]+ interleave (x : y : zs)+ | T.isPrefixOf tNL y = x : interleave (y : zs)+ | otherwise = x : tSpace : interleave (y : zs)+++-- ---------------------------------------------------------------------------+-- Block scalars+-- ---------------------------------------------------------------------------++data Chomp = Strip | Clip | Keep deriving (Eq, Show)+++data BlockKind = Literal | Folded deriving (Eq, Show)+++parseBlockScalar :: BlockKind -> P Value+parseBlockScalar k = do+ Just l <- popLine+ let header = T.drop 1 (lineBody l) -- drop '|' or '>'+ (chomp, hint) <- case parseHeader header of+ Right h -> pure h+ Left err ->+ failP $+ "invalid block scalar header: "+ ++ err+ ++ " (line "+ ++ show (lineNo l)+ ++ ")"+ let explicitBase = (max 0 (lineIndent l) +) <$> hint+ body <- collectScalarLines (lineIndent l) explicitBase+ -- Per spec §8.1.1: a /leading/ blank line whose indent is+ -- greater than the first content line's indent is invalid+ -- (the missing indent indicator can't be recovered from+ -- blank lines alone).+ case explicitBase of+ Nothing ->+ let leadingBlanks = takeWhile (\(_, b) -> T.null b) body+ afterBlanks = dropWhile (\(_, b) -> T.null b) body+ in case afterBlanks of+ ((firstC, _) : _)+ | firstC >= 0+ , any (\(i, _) -> i > firstC) leadingBlanks ->+ failP $+ "block scalar baseline below earlier blank-line indent (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ _ -> pure ()+ let bodyAdj = case nonEmptyContent explicitBase body of+ True -> body+ False -> map (\(i, b) -> if i < 0 then (i, b) else (-1, b)) body+ txt = case k of+ Literal -> joinLiteralAt explicitBase chomp bodyAdj+ Folded -> joinFoldedAt explicitBase chomp bodyAdj+ unless (case asciiSourceStatus txt of 0# -> True; _ -> T.all (\c -> c == '\n' || validNonBreak c) txt) (failP "YAML: invalid character in block scalar")+ pure (YString txt)+ where+ nonEmptyContent baseline = any (\(i, b) -> i >= 0 && (not (T.null b) || maybe False (i >) baseline))++ parseHeader :: Text -> Either String (Chomp, Maybe Int)+ parseHeader h0 =+ let+ -- Anything on the header line after a single '#' (with+ -- preceding whitespace) is a comment.+ h = stripInlineComment h0+ rest = T.unpack (stripYaml h)+ chompOf '-' = Strip+ chompOf '+' = Keep+ chompOf _ = Clip+ mkHint c+ | c >= '1' && c <= '9' = Right (Just (digitToInt c))+ -- '|0' is invalid (indent indicator must be 1..9).+ | c == '0' = Left "indent indicator must be 1..9"+ | otherwise = Left ("unexpected character " ++ [c])+ in+ case rest of+ [] -> Right (Clip, Nothing)+ [c]+ | c == '-' || c == '+' -> Right (chompOf c, Nothing)+ | isDigit c -> (\h_ -> (Clip, h_)) <$> mkHint c+ | otherwise -> Left ("unexpected character " ++ [c])+ [a, b]+ | (a == '-' || a == '+') && isDigit b ->+ (\h_ -> (chompOf a, h_)) <$> mkHint b+ | isDigit a && (b == '-' || b == '+') ->+ (\h_ -> (chompOf b, h_)) <$> mkHint a+ | otherwise -> Left ("unexpected header " ++ rest)+ _ -> Left ("unexpected header " ++ rest)+++{- | Collect the body lines of a block scalar.++The semantics: blank / more-indented blank lines belong to the+scalar regardless of their column. Once we've seen a content+line, that line's indent /is/ the "base indent" of the scalar;+the scalar terminates on the first subsequent line whose indent+falls /at or below/ that base. Lines whose source classified as+@LComment@ but sit at indent > base are treated as scalar+content (the '#' is data); comments at base or shallower+terminate.+-}+collectScalarLines :: Int -> Maybe Int -> P [(Int, Text)]+collectScalarLines !parent !mExplicit = collect mExplicit []+ where+ -- @mBase@ is the established base indent (after the first+ -- content line, or pre-seeded by an explicit indent+ -- indicator). @acc@ is the reverse-accumulated body.+ collect mBase acc = do+ ls <- getLines+ case ls of+ [] -> pure (reverse acc)+ (l : _)+ | lineKind l == LBlank ->+ do+ let ind = lineIndent l+ raw = lineRawBody l+ hasTabs = not (T.null raw)+ -- A 'blank' line whose only content is a TAB+ -- and that sits at or below 'parent' before any+ -- content line establishes a baseline is using+ -- a tab as block-scalar indentation: invalid+ -- per spec §6.1 (Y79Y/000).+ case mBase of+ Nothing+ | hasTabs+ , ind <= parent+ , parent >= 0 ->+ failP $+ "tab character used as block-scalar indentation (line "+ ++ show (lineNo l)+ ++ ")"+ _ -> pure ()+ _ <- consumeOne+ let isMoreIndented = case mBase of+ Just b -> ind > b+ Nothing -> ind > parent+ if isMoreIndented+ then collect mBase ((ind, raw) : acc)+ else+ if hasTabs+ then case mBase of+ Just b+ | ind >= b ->+ collect mBase ((ind, raw) : acc)+ _ -> collect mBase ((-1, T.empty) : acc)+ else collect mBase ((-1, T.empty) : acc)+ | lineKind l == LDocStart || lineKind l == LDocEnd ->+ pure (reverse acc)+ | otherwise ->+ let ind = lineIndent l+ inside = case mBase of+ Just b -> ind >= b+ Nothing -> ind > parent+ in if not inside+ then pure (reverse acc)+ else do+ _ <- consumeOne+ let mBase' = case mBase of+ Just _ -> mBase+ Nothing -> Just ind+ collect mBase' ((ind, lineRawBody l) : acc)++ consumeOne = do+ ls <- getLines+ case ls of+ (_ : xs) -> setLines xs >> pure ()+ [] -> pure ()+++-- Track the last content byte separately from trailing blank-line bytes, so+-- stripped/clipped scalars neither allocate nor retain the discarded suffix.+data LiteralExtent = LiteralExtent+ { literalBytes :: {-# UNPACK #-} !Int+ , literalContentEnd :: {-# UNPACK #-} !Int+ }+++joinLiteralAt :: Maybe Int -> Chomp -> [(Int, Text)] -> Text+joinLiteralAt mExpl chomp xs =+ let baseInd = case mExpl of Just base -> base; Nothing -> minNonNegative xs+ measure !total !contentEnd [] = LiteralExtent total contentEnd+ measure !total !contentEnd ((indent, body) : rest) =+ let width = if indent < 0 then 0 else max 0 (indent - baseInd) + bLen body+ next = total + width + 1+ in measure next (if width == 0 then contentEnd else next - 1) rest+ extent = measure 0 0 xs+ size = case chomp of+ Keep -> literalBytes extent+ Strip -> literalContentEnd extent+ Clip -> if literalContentEnd extent == 0 then 0 else literalContentEnd extent + 1+ array = TA.run $ do+ output <- TA.new size+ let spacesAt !position !count+ | count <= 0 = pure ()+ | otherwise = TA.unsafeWrite output position w8Space >> spacesAt (position + 1) (count - 1)+ writeLines !_ [] = pure output+ writeLines !position _ | position >= size = pure output+ writeLines !position ((indent, body) : rest)+ | indent < 0 = TA.unsafeWrite output position 10 >> writeLines (position + 1) rest+ | otherwise = case body of+ TI.Text input offset length_ -> do+ let padding = max 0 (indent - baseInd)+ content = position + padding+ newline = content + length_+ spacesAt position padding+ TA.copyI length_ output content input offset+ when (newline < size) (TA.unsafeWrite output newline 10)+ writeLines (newline + 1) rest+ writeLines 0 xs+ in if size == 0 then T.empty else TI.text array 0 size+++joinFoldedAt :: Maybe Int -> Chomp -> [(Int, Text)] -> Text+joinFoldedAt mExpl chomp xs =+ let baseInd = case mExpl of+ Just b -> b+ Nothing -> minNonNegative xs+ raw+ | null xs = T.empty+ | otherwise = T.concat (foldFirst xs baseInd) <> tNL+ in chompText chomp raw+ where+ isBlank (i, b) = i < 0 || T.null b++ -- A line is "more-indented" if its source column is past the+ -- base indent OR its body starts with whitespace (a leading+ -- tab counts).+ isMoreIndented bi (i, b) =+ i > bi+ || case T.uncons b of+ Just (' ', _) -> True+ Just ('\t', _) -> True+ _ -> False++ foldFirst [] _ = []+ foldFirst ((i, b) : rest) bi+ | isBlank (i, b) = tNL : foldAfterFirstBlank rest bi+ | otherwise =+ let txt = T.replicate (max 0 (i - bi)) tSpace <> b+ more = isMoreIndented bi (i, b)+ in txt : foldNext rest bi more++ -- Same as 'foldAfterBlank' but used when no content line has+ -- yet been seen — there's no "previous more-indented marker"+ -- to subtract, so a more-indented first content line gets+ -- /no/ extra preserved newline.+ foldAfterFirstBlank [] _ = []+ foldAfterFirstBlank ((i, b) : rest) bi+ | isBlank (i, b) = tNL : foldAfterFirstBlank rest bi+ | otherwise =+ let txt = T.replicate (max 0 (i - bi)) tSpace <> b+ nowMore = isMoreIndented bi (i, b)+ in txt : foldNext rest bi nowMore++ foldNext [] _ _ = []+ foldNext ((i, b) : rest) bi prevMore+ | isBlank (i, b) =+ -- A break right after a more-indented line is preserved+ -- as a literal newline; the upcoming blank emits another+ -- on top of that.+ let pre = if prevMore then [tNL] else []+ in pre ++ tNL : foldAfterBlank rest bi prevMore+ | otherwise =+ let txt = T.replicate (max 0 (i - bi)) tSpace <> b+ nowMore = isMoreIndented bi (i, b)+ joinSep+ | prevMore || nowMore = tNL+ | otherwise = tSpace+ in joinSep : txt : foldNext rest bi nowMore++ -- @prevMore@ here refers to whether the line that opened the+ -- blank run was more-indented; when leaving a blank run we+ -- need to emit one more break if either side is more-indented.+ foldAfterBlank [] _ _ = []+ foldAfterBlank ((i, b) : rest) bi prevMore+ | isBlank (i, b) = tNL : foldAfterBlank rest bi prevMore+ | otherwise =+ let txt = T.replicate (max 0 (i - bi)) tSpace <> b+ nowMore = isMoreIndented bi (i, b)+ -- If we're leaving a blank-run into a more-indented+ -- line and the previous content line was /not/+ -- itself more-indented, the spec requires an extra+ -- preserved break.+ extra =+ if nowMore && not prevMore+ then [tNL]+ else []+ in extra ++ txt : foldNext rest bi nowMore+++{- | Smallest indent from a non-blank line in the collected list,+or 0 if there are no non-blank lines. Blank lines (including+"more-indented blanks" we keep around for spacing) do not+contribute, since the spec defines the body indent as the indent+of the first non-empty line.+-}+minNonNegative :: [(Int, Text)] -> Int+minNonNegative = go Nothing+ where+ go acc [] = case acc of+ Nothing -> 0+ Just !n -> n+ go acc ((i, b) : rest)+ | i < 0 || T.null b = go acc rest+ | otherwise = case acc of+ Nothing -> go (Just i) rest+ Just !n+ | i < n -> go (Just i) rest+ | otherwise -> go (Just n) rest+++chompText :: Chomp -> Text -> Text+chompText Strip = T.dropWhileEnd (== '\n')+chompText Keep = id+chompText Clip = \text ->+ let stripped = T.dropWhileEnd (== '\n') text+ in if T.null stripped then T.empty else stripped <> tNL+++-- ---------------------------------------------------------------------------+-- Plain-scalar resolution per the YAML 1.2 core schema+-- ---------------------------------------------------------------------------++resolvePlain :: Text -> Value+resolvePlain raw+ | raw == "<<" = YTagged (Tag "tag:yaml.org,2002:merge") (YString "<<")+ | otherwise = case T.uncons raw of+ Nothing -> YString T.empty+ Just (h, _)+ | recognizedFirst h -> resolvePlain' raw+ | otherwise -> YString raw+++{- | First-character check: filter for chars that could possibly+begin a YAML core-schema literal (null, bool, inf/nan, signed+digit, '+/-/.' or '~'). Skips the costly comparison cascade+for the common case of unquoted plain strings.+-}+recognizedFirst :: Char -> Bool+recognizedFirst c =+ c == 'n'+ || c == 'N'+ || c == 't'+ || c == 'T'+ || c == 'f'+ || c == 'F'+ || c == '~'+ || c == '.'+ || c == '+'+ || c == '-'+ || (c >= '0' && c <= '9')+{-# INLINE recognizedFirst #-}+++resolvePlain' :: Text -> Value+resolvePlain' raw+ | raw == "null" || raw == "~" || raw == "Null" || raw == "NULL" = YNull+ | raw == "true" || raw == "True" || raw == "TRUE" = YBool True+ | raw == "false" || raw == "False" || raw == "FALSE" = YBool False+ | raw == ".inf"+ || raw == ".Inf"+ || raw == ".INF"+ || raw == "+.inf"+ || raw == "+.Inf"+ || raw == "+.INF" =+ YFloat (1 / 0)+ | raw == "-.inf" || raw == "-.Inf" || raw == "-.INF" = YFloat (-1 / 0)+ | raw == ".nan" || raw == ".NaN" || raw == ".NAN" = YFloat (0 / 0)+ | otherwise = case parseIntCore raw of+ Just n -> YInt n+ Nothing -> case parseFloatCore raw of+ Just d -> YFloat d+ Nothing -> YString raw+++parseIntCore :: Text -> Maybe Integer+parseIntCore raw+ | Just body <- T.stripPrefix "0x" raw = digits 16 body+ | Just body <- T.stripPrefix "0o" raw = digits 8 body+ | otherwise = case T.uncons raw of+ Just ('+', rest) -> digits 10 rest+ Just ('-', rest) -> negate <$> digits 10 rest+ _ -> digits 10 raw+ where+ digits :: Word64 -> Text -> Maybe Integer+ digits base body+ | bLen body == 0 = Nothing+ | otherwise = small 0 0+ where+ !len = bLen body+ (!limit, !lastDigit) = maxBound `quotRem` base+ digitAt i =+ let byte = bAt body i+ in if byte >= 48 && byte <= 57+ then fromIntegral (byte - 48)+ else+ if byte >= 65 && byte <= 70+ then fromIntegral (byte - 55)+ else+ if byte >= 97 && byte <= 102+ then fromIntegral (byte - 87)+ else 255+ -- Inline the digit reader so its Word64 result is never heap-boxed per digit.+ {-# INLINE digitAt #-}+ small :: Word64 -> Int -> Maybe Integer+ small !acc !i+ | i == len = Just (toInteger acc)+ | otherwise =+ let !digit = digitAt i+ in if digit >= base+ then Nothing+ else+ if acc > limit || (acc == limit && digit > lastDigit)+ then big (toInteger acc) i+ else small (acc * base + digit) (i + 1)+ big !acc !i+ | i == len = Just acc+ | otherwise =+ let !digit = digitAt i+ in if digit >= base+ then Nothing+ else big (acc * toInteger base + toInteger digit) (i + 1)+{-# INLINE parseIntCore #-}+++parseFloatCore :: Text -> Maybe Double+parseFloatCore raw =+ let (sign, body) = case T.uncons raw of+ Just ('+', rest) -> (1, rest)+ Just ('-', rest) -> (-1, rest)+ _ -> (1, raw)+ (mantissa, exponentPart) = T.break (\c -> c == 'e' || c == 'E') body+ (whole, fraction) = T.break (== '.') mantissa+ digit c = c >= '0' && c <= '9'+ allDigits t = not (T.null t) && T.all digit t+ validMantissa =+ if T.null fraction+ then allDigits whole+ else+ T.all digit whole+ && T.all digit (T.drop 1 fraction)+ && (not (T.null whole) || T.length fraction > 1)+ exponentDigits = case T.uncons (T.drop 1 exponentPart) of+ Just ('+', rest) -> rest+ Just ('-', rest) -> rest+ _ -> T.drop 1 exponentPart+ validExponent = T.null exponentPart || allDigits exponentDigits+ digits = whole <> T.drop 1 fraction+ in if validMantissa && validExponent+ then do+ explicitExponent <- if T.null exponentPart then Just 0 else parseIntCore (T.drop 1 exponentPart)+ let decimalExponent = explicitExponent - toInteger (max 0 (bLen fraction - 1))+ if T.all (== '0') digits+ then Just (sign * 0)+ else+ if decimalExponent > 400+ then Just (sign * (1 / 0))+ else+ if decimalExponent < negate (toInteger (bLen digits) + 400)+ then Just (sign * 0)+ else do+ coefficient <- parseIntCore digits+ Just (sign * Sci.toRealFloat (Sci.scientific coefficient (fromInteger decimalExponent)))+ else Nothing+++-- ---------------------------------------------------------------------------+-- Tags+-- ---------------------------------------------------------------------------++-- Apply a standard tag before downstream consumers unwrap its metadata.+resolveExplicitTag :: Tag -> Value -> Maybe Value+resolveExplicitTag tag (YAnchored anchor inner) = YAnchored anchor <$> resolveExplicitTag tag inner+resolveExplicitTag _ (YTagged _ _) = Nothing+resolveExplicitTag _ (YAlias _) = Nothing+resolveExplicitTag (Tag tag) v = case (tag, v) of+ ("!", YNull) -> Just (YString T.empty)+ ("!", _) -> Just v+ ("tag:yaml.org,2002:str", YNull) -> Just (YString T.empty)+ ("tag:yaml.org,2002:str", YString _) -> Just v+ ("tag:yaml.org,2002:merge", YString "<<") -> Just v+ ("tag:yaml.org,2002:int", YString raw) -> YInt <$> parseIntCore raw+ ("tag:yaml.org,2002:int", YInt _) -> Just v+ ("tag:yaml.org,2002:float", YString raw) -> case parseFloatCore raw of+ Just value -> Just (YFloat value)+ Nothing -> case resolvePlain raw of+ YFloat value -> Just (YFloat value)+ _ -> Nothing+ ("tag:yaml.org,2002:float", YFloat _) -> Just v+ ("tag:yaml.org,2002:float", YInt n) -> Just (YFloat (fromInteger n))+ ("tag:yaml.org,2002:bool", YString raw) -> case resolvePlain raw of+ YBool b -> Just (YBool b)+ _ -> Nothing+ ("tag:yaml.org,2002:bool", YBool _) -> Just v+ ("tag:yaml.org,2002:null", YNull) -> Just YNull+ ("tag:yaml.org,2002:null", YString raw)+ | T.null raw || resolvePlain raw == YNull -> Just YNull+ ("tag:yaml.org,2002:seq", YSeq _) -> Just v+ ("tag:yaml.org,2002:map", YMap _) -> Just v+ _+ | tag `elem` ["tag:yaml.org,2002:str", "tag:yaml.org,2002:int", "tag:yaml.org,2002:float", "tag:yaml.org,2002:bool", "tag:yaml.org,2002:null", "tag:yaml.org,2002:seq", "tag:yaml.org,2002:map", "tag:yaml.org,2002:merge"] -> Nothing+ | otherwise -> Just (case v of YNull -> YString T.empty; _ -> v)+++tagValue :: Tag -> Value -> P Value+tagValue tag v = case resolveExplicitTag tag v of+ Just inner -> do+ recordTaggedAnchors tag inner+ pure (YTagged tag inner)+ Nothing -> failP "YAML: scalar or collection does not match its explicit tag"+++-- A tag before an anchor labels the same node. Refresh its binding after+-- scalar resolution, so aliases inherit the resolved type and explicit tag.+recordTaggedAnchors :: Tag -> Value -> P ()+recordTaggedAnchors tag = go+ where+ go (YAnchored identity inner) = do+ state <- getS+ case HM.lookup (unAnchor identity) (psBindings state) of+ Nothing -> failP "YAML: unresolved tagged anchor"+ Just definition -> do+ let value = YTagged tag inner+ size = sizeWithMemo (psBindings state) value+ when (size > maxParseNodes) (failP "YAML: anchor expansion exceeds the node budget")+ modifyS (\s -> s {psBindings = HM.insert (unAnchor identity) definition {bindingValue = value, bindingSize = size} (psBindings s)})+ go _ = pure ()+++taggedFlow :: Tag -> Value -> Int -> Maybe (Value, Int)+taggedFlow tag v offset = Just (YTagged tag v, offset)+++expandTag :: Text -> Tag+expandTag t+ | T.isPrefixOf "!!" t =+ Tag (tYamlTagPrefix <> T.drop 2 t)+ | T.isPrefixOf "!<" t && T.isSuffixOf ">" t =+ Tag (T.init (T.drop 2 t))+ | otherwise = Tag t+++{- | Resolve a tag token against the current %TAG shortcut map.+Refuses references to undefined shortcuts (spec §6.8.2).+-}+expandTagP :: Int -> Text -> P Tag+expandTagP lno token = do+ unless (validTagToken token) (failP "YAML: invalid tag spelling")+ tag@(Tag resolved) <- expandTagUncheckedP lno token+ unless (resolved == "!" || validResolvedTag resolved) (failP "YAML: tag must be a local tag or an absolute URI")+ pure tag+++validTagHandle :: Text -> Bool+validTagHandle handle =+ handle == "!"+ || handle == "!!"+ || (T.length handle > 2 && T.head handle == '!' && T.last handle == '!' && T.all wordChar (T.init (T.tail handle)))+ where+ wordChar c = asciiLetter c || c >= '0' && c <= '9' || c == '-'+++asciiLetter :: Char -> Bool+asciiLetter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'+++-- Percent escapes are URI spelling, not scalar escapes. YAML 1.2.2 §5.6+-- requires that applications receive and compare these spellings unchanged.+validURIText :: Text -> Bool+validURIText text = not (T.null text) && go text+ where+ go rest = case T.uncons rest of+ Nothing -> True+ Just ('%', suffix) -> case T.uncons suffix of+ Just (a, more) -> case T.uncons more of+ Just (b, after) -> isHexDigit a && isHexDigit b && go after+ Nothing -> False+ Nothing -> False+ Just (c, suffix) -> (asciiLetter c || c >= '0' && c <= '9' || c `T.elem` "-#;/?:@&=+$,_.!~*'()[]") && go suffix+++validResolvedTag :: Text -> Bool+validResolvedTag text+ | Just local <- T.stripPrefix "!" text = not (T.null local) && validURIText text+ | otherwise =+ let (scheme, rest) = T.break (== ':') text+ in not (T.null scheme) && asciiLetter (T.head scheme) && T.all (\c -> asciiLetter c || c >= '0' && c <= '9' || c `T.elem` "+-.") scheme && not (T.null rest) && validURIText text+++validTagToken :: Text -> Bool+validTagToken token+ | token == "!" = True+ | Just body <- T.stripPrefix "!<" token = maybe False validResolvedTag (T.stripSuffix ">" body)+ | Just rest <- T.stripPrefix "!" token =+ let (handleBody, suffix) = T.break (== '!') rest+ (handle, name) = if T.null suffix then ("!", rest) else ("!" <> handleBody <> "!", T.drop 1 suffix)+ in validTagHandle handle && validURIText name && not (T.any (`T.elem` "!,[]{}") name)+ | otherwise = False+++expandTagUncheckedP :: Int -> Text -> P Tag+expandTagUncheckedP lno t+ | T.isPrefixOf "!<" t && not (T.isSuffixOf ">" t) = failP "YAML: unterminated verbatim tag"+ -- '!!something' uses the implicit secondary handle '!!'.+ | T.isPrefixOf "!!" t = do+ shortcut <- lookupShortcut "!!"+ pure (maybe (expandTag t) (\prefix -> Tag (prefix <> T.drop 2 t)) shortcut)+ -- '!<verbatim>' is a verbatim tag.+ | T.isPrefixOf "!<" t && T.isSuffixOf ">" t = pure (expandTag t)+ -- '!handle!suffix' uses a primary or named shortcut.+ | T.isPrefixOf "!" t+ , let rest = T.drop 1 t+ , (handleBody, sfx) <- T.break (== '!') rest+ , not (T.null sfx)+ , let handle = T.cons '!' (T.snoc handleBody '!') =+ do+ ms <- lookupShortcut handle+ case ms of+ Just prefix -> pure (Tag (prefix <> T.drop 1 sfx))+ Nothing ->+ failP $+ "undefined %TAG shortcut "+ ++ show handle+ ++ " (line "+ ++ show lno+ ++ ")"+ | T.isPrefixOf "!" t+ , t /= "!" = do+ shortcut <- lookupShortcut "!"+ pure (maybe (expandTag t) (\prefix -> Tag (prefix <> T.drop 1 t)) shortcut)+ | otherwise = pure (expandTag t)+++-- ---------------------------------------------------------------------------+-- @key: value@ split (top-level, respects quotes / brackets)+-- ---------------------------------------------------------------------------++{- | Walks the line in O(n) by reading the underlying UTF-8+bytes directly. Returns @Just (key, rest)@ when a top-level+@':'@ separator is found. The key/rest split is byte-position+based, which coincides with the character split when the line+is ASCII (the overwhelmingly common case for YAML keys).++For lines that contain non-ASCII multi-byte characters before+the separator, we fall back to the slower char-based split so+that 'T.take' / 'T.drop' produce correctly aligned slices.+-}++-- | Split a mapping header without discarding its quoted key spelling.+splitMappingLine :: Text -> Maybe (Text, Text)+splitMappingLine = findKeyValueSplit+++findKeyValueSplit :: Text -> Maybe (Text, Text)+findKeyValueSplit (TI.Text arr off blen)+ | blen == 0 = Nothing+ | otherwise = goByte off 0 0 0 32+ where+ !endByte = off + blen+ -- 'goByte' uses byte indices into the underlying TA.Array.+ -- 'p' is the previous byte's code for atTokenStart.+ goByte+ :: Int+ -> Int+ -> Int+ -> Int+ -> Int+ -> Maybe (Text, Text)+ goByte !i !d !b !s !p+ | i >= endByte = Nothing+ | otherwise =+ let !w = TA.unsafeIndex arr i+ !c = toEnum (fromIntegral w) :: Char+ wi = fromIntegral w :: Int+ in case s of+ 1 -> case c of+ '"' -> goByte (i + 1) d b 0 wi+ '\\'+ | i + 1 < endByte ->+ goByte (i + 2) d b 1 wi+ _ -> goByte (i + 1) d b 1 wi+ 2 -> case c of+ '\'' -> goByte (i + 1) d b 0 wi+ _ -> goByte (i + 1) d b 2 wi+ _ -> case c of+ '"' | ts -> goByte (i + 1) d b 1 wi+ '\'' | ts -> goByte (i + 1) d b 2 wi+ '['+ | ts || d > 0 || b > 0 ->+ goByte (i + 1) (d + 1) b s wi+ ']'+ | d > 0 ->+ goByte (i + 1) (d - 1) b s wi+ '{'+ | ts || d > 0 || b > 0 ->+ goByte (i + 1) d (b + 1) s wi+ '}'+ | b > 0 ->+ goByte (i + 1) d (b - 1) s wi+ '#' | ts && d == 0 && b == 0 -> Nothing+ ':'+ | d == 0+ , b == 0 ->+ if i + 1 >= endByte+ then Just (sliceKey i, T.empty)+ else+ let n = TA.unsafeIndex arr (i + 1)+ in if n == 32 || n == 9+ then+ Just+ ( sliceKey i+ , sliceTail (i + 1)+ )+ else goByte (i + 1) d b s wi+ _ -> goByte (i + 1) d b s wi+ where+ ts = p == 32 || p == 9++ -- Slice [off, i) from the underlying array (a zero-copy+ -- Text), strip trailing ASCII whitespace, then unquote.+ sliceKey i = stripYamlEnd (TI.text arr off (i - off))++ sliceTail i = TI.text arr i (endByte - i)+{-# INLINEABLE findKeyValueSplit #-}+++-- ---------------------------------------------------------------------------+-- Inline-comment stripping (respects quotes)+-- ---------------------------------------------------------------------------++stripInlineComment :: Text -> Text+stripInlineComment = stripComment False+++-- Flow buffers contain physical line sentinels. A comment ends a scalar but+-- must not discard the later lines already accumulated in that buffer.+stripComment :: Bool -> Text -> Text+stripComment flow t+ -- Fast path: if there's no '#' anywhere, return the input+ -- untouched (the common case for typical mapping values).+ | not (bAnyByte w8Hash t) = t+ | otherwise =+ -- Walk the underlying bytes, finding the first+ -- column-stopping '#' (preceded by ' ', '\\t', or '\\1' and+ -- not inside a quoted span). For an outer-context match,+ -- we either truncate at the preceding whitespace or, for+ -- a '\\1' match, splice in a '\\2' sentinel and skip the+ -- comment body.+ let !len = bLen t+ go !i !st+ | i >= len = bSlice t 0 i+ | otherwise = case st of+ Outer ->+ let !c = bAt t i+ in case c of+ 34 -> go (i + 1) InDQ -- '"'+ 39 -> go (i + 1) InSQ -- '\''+ 35+ | (i == 0 && flow) || (i > 0 && let previous = bAt t (i - 1) in previous == w8Space || previous == w8Tab || previous == w8SOH) ->+ if flow then spliceAt i else bSlice t 0 (max 0 (i - 1))+ | otherwise -> go (i + 1) Outer+ _ -> go (i + 1) Outer+ InDQ -> case bAt t i of+ 92+ | i + 1 < len -> -- '\\' escape+ go (i + 2) InDQ+ 34 -> go (i + 1) Outer+ _ -> go (i + 1) InDQ+ InSQ ->+ let !c = bAt t i+ in if c == w8SQuote+ then+ if i + 1 < len && bAt t (i + 1) == w8SQuote+ then go (i + 2) InSQ+ else go (i + 1) Outer+ else go (i + 1) InSQ+ spliceAt !commentStart =+ let prefix = bSlice t 0 commentStart+ afterComment = T.dropWhile (/= '\1') (bDrop (commentStart + 1) t)+ in prefix <> tSTX <> stripComment True afterComment+ in go 0 Outer+++{-# INLINEABLE stripInlineComment #-}+++data QState = Outer | InDQ | InSQ+++-- ---------------------------------------------------------------------------+-- Double-quoted escape decoding+-- ---------------------------------------------------------------------------++decodeDQEscape :: Text -> Int -> r -> (Char -> Int -> r) -> r+decodeDQEscape source !position failure success+ | position >= bLen source = failure+ | otherwise = case bAt source position of+ 48 -> done '\0'+ 97 -> done '\a'+ 98 -> done '\b'+ 116 -> done '\t'+ 9 -> done '\t'+ 110 -> done '\n'+ 118 -> done '\v'+ 102 -> done '\f'+ 114 -> done '\r'+ 101 -> done '\x1B'+ 32 -> done ' '+ 34 -> done '"'+ 47 -> done '/'+ 92 -> done '\\'+ 78 -> done '\x85'+ 95 -> done '\xA0'+ 76 -> done '\x2028'+ 80 -> done '\x2029'+ 120 -> readHex 2+ 117 -> readHex 4+ 85 -> readHex 8+ _ -> failure+ where+ done char = success char (position + 1)+ readHex width+ | position + 1 + width > bLen source = failure+ | otherwise = go (position + 1) 0+ where+ end = position + 1 + width+ go !offset !codepoint+ | codepoint > 0x10FFFF = failure+ | offset == end =+ if codepoint <= 0x10FFFF && not (codepoint >= 0xD800 && codepoint <= 0xDFFF)+ then success (chr codepoint) end+ else failure+ | otherwise =+ let byte = bAt source offset+ digit+ | byte >= 48 && byte <= 57 = fromIntegral (byte - 48)+ | byte >= 65 && byte <= 70 = fromIntegral (byte - 55)+ | byte >= 97 && byte <= 102 = fromIntegral (byte - 87)+ | otherwise = 16+ in if digit == 16 then failure else go (offset + 1) (codepoint * 16 + digit)+{-# INLINE decodeDQEscape #-}
+ src/YAML/Decode/Annotated.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Annotation-preserving YAML decoder.++Parses YAML to 'AStream' / 'ADocument' / 'AValue' carrying:++* Source-byte spans for each top-level mapping entry / sequence+ item, so unmodified entries can be copied verbatim during+ re-emission.+* Comments and blank-line trivia attached to the entry that+ follows them.+* The original scalar style (plain / quoted / literal block /+ folded block) so that fresh edits keep the surrounding+ document's stylistic choices.++The structural parse delegates to "YAML.Decode" so spec+conformance stays in one place; this module layers a second+pass that walks the source text with a small line scanner.+-}+module YAML.Decode.Annotated (+ decodeAnnotated,+ decodeAnnotatedStream,+ decodeAnnotatedDocument,+) where++import Data.ByteString qualified as BS+import Data.Char (isDigit)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Vector qualified as V+import YAML.Annotated (+ ABody (..),+ ADocument (..),+ AMapEntry (..),+ AStream (..),+ AValue (..),+ Chomping (..),+ Comment (..),+ MapStyle (..),+ ScalarStyle (..),+ SeqStyle (..),+ SrcSpan (..),+ Trivia (..),+ )+import YAML.Annotated qualified+import YAML.Decode qualified as YD+import YAML.Decode.Flow (annotateFlow)+import YAML.Internal (isYamlSpace, stripYaml, stripYamlStart, wordsYaml)+import YAML.Value (Document (..), Value (..))+import YAML.Value qualified+++-- ---------------------------------------------------------------------------+-- Public entry points+-- ---------------------------------------------------------------------------++{- | Decode a single-document YAML source into an annotated tree.+The original source 'Text' is returned alongside; the renderer+needs it to copy unchanged sub-trees verbatim.+-}+decodeAnnotated :: Text -> Either String (ADocument, Text)+decodeAnnotated src = do+ (AStream docs, original) <- decodeAnnotatedStream src+ case V.toList docs of+ [d] -> pure (d, original)+ [] -> pure (ADocument False False (annotatePlain YNull) [] (Just (SrcSpan 0 (BS.length (TE.encodeUtf8 src)))) [] [], src)+ _ -> Left "decodeAnnotated: source contains multiple documents; use decodeAnnotatedStream"+++-- | Decode documents with spans relative to the original stream.+decodeAnnotatedStream :: Text -> Either String (AStream, Text)+decodeAnnotatedStream src = do+ docs <- YD.decodeLocatedDocuments src+ pure (AStream (V.fromList (fmap annotateLocated docs)), src)+ where+ annotateLocated located =+ let offset = YD.locatedOffset located+ doc = annotateDocument (YD.locatedSource located) (YD.locatedDocument located) (YD.locatedAnnotatedBody located)+ shift (SrcSpan a b) = SrcSpan (a + offset) (b + offset)+ shiftValue av =+ av+ { avSpan = shift <$> avSpan av+ , avNodeSpan = shift <$> avNodeSpan av+ , avBody = case avBody av of+ ASeq xs style -> ASeq (V.map shiftValue xs) style+ AMap es style -> AMap (V.map (\e -> e {amKey = shiftValue (amKey e), amValue = shiftValue (amValue e)}) es) style+ ATagged tag inner -> ATagged tag (shiftValue inner)+ AAnchored anchor inner -> AAnchored anchor (shiftValue inner)+ body -> body+ }+ in doc {adBody = shiftValue (adBody doc), adOriginalSpan = shift <$> adOriginalSpan doc}+++decodeAnnotatedDocument :: Text -> Either String ADocument+decodeAnnotatedDocument src = fst <$> decodeAnnotated src+++-- ---------------------------------------------------------------------------+-- Annotation pass+-- ---------------------------------------------------------------------------++-- | Wrap a parsed 'Document' with annotations.+annotateDocument :: Text -> Document -> AValue -> ADocument+annotateDocument src (Document start end body) presentation =+ let !srcLen = BS.length (TE.encodeUtf8 src)+ !lineIdx = buildLineIndex src+ !av = annotateBody src lineIdx presentation+ !av' = av {avSpan = Just (SrcSpan 0 srcLen)}+ in ADocument+ { adDirectivesEnd = start+ , adExplicitEnd = end+ , adBody = av'+ , adLeading = []+ , adOriginalSpan = Just (SrcSpan 0 srcLen)+ , adTrailing = trailingComments body src+ , adDirectives = filter (T.isPrefixOf "%") (takeWhile (\line -> T.null (stripYaml line) || T.isPrefixOf "#" line || T.isPrefixOf "%" line) (logicalLines src))+ }+++-- Keep trailing standalone comments when an edit disables whole-document copying.+trailingComments :: Value -> Text -> [Comment]+trailingComments value src+ | isBlockScalar value = []+ | otherwise = reverse (go (reverse (logicalLines src)))+ where+ -- A root block scalar may contain comment-looking lines at column zero.+ -- Its header is the first content line, possibly preceded by properties.+ isBlockScalar (YTagged _ inner) = isBlockScalar inner+ isBlockScalar (YAnchored _ inner) = isBlockScalar inner+ isBlockScalar (YString _) = case dropWhile isPrologue (logicalLines src) of+ line : _ -> case dropWhile isProperty (wordsYaml line) of+ header : _ -> T.isPrefixOf "|" header || T.isPrefixOf ">" header+ [] -> False+ [] -> False+ isBlockScalar _ = False+ isProperty word = T.isPrefixOf "!" word || T.isPrefixOf "&" word+ isPrologue line =+ let stripped = stripYaml line+ in T.null stripped || T.isPrefixOf "#" stripped || T.isPrefixOf "%" stripped || stripped == "---"+ go [] = []+ go (line : rest)+ | T.null (stripYaml line) = go rest+ | stripYaml line == "..." = go rest+ | Just body <- T.stripPrefix "#" line =+ Comment (T.dropWhile (== ' ') body) 0 : go rest+ | otherwise = []+++-- | Wrap top-level structures with per-entry spans + trivia.+annotateBody :: Text -> LineIndex -> AValue -> AValue+annotateBody src lineIdx value+ | Just annotated <- annotateFlow src value = annotated+ | otherwise = case avBody value of+ AMap pairs _+ | not (V.null pairs)+ , Just entries <- locateMapEntries src lineIdx ((\entry -> (amKey entry, amValue entry)) <$> V.toList pairs) ->+ value {avBody = AMap (V.fromList entries) MapBlock}+ ASeq items _+ | not (V.null items)+ , Just entries <- locateSeqItems src lineIdx (V.toList items) ->+ value {avBody = ASeq (V.fromList entries) SeqBlock}+ ATagged tag inner -> value {avBody = ATagged tag (annotateBody src lineIdx inner)}+ AAnchored anchor inner -> value {avBody = AAnchored anchor (annotateBody src lineIdx inner)}+ _ -> styleNode src value+++-- ---------------------------------------------------------------------------+-- Trivial annotation (no source spans, default styles)+-- ---------------------------------------------------------------------------++annotatePlain :: Value -> AValue+annotatePlain v = AValue (bodyOf v) emptyTrivia Nothing Nothing "" (-1) False+ where+ bodyOf = \case+ YNull -> ANull+ YBool b -> ABool b+ YInt n -> AInt n+ YFloat d -> AFloat d+ YString t -> AString t (defaultScalarStyle t)+ YSeq xs -> ASeq (V.map annotatePlain xs) SeqBlock+ YMap kvs ->+ AMap+ ( V.map+ ( \(k, vv) ->+ AMapEntry+ (annotatePlain k)+ (annotatePlain vv)+ Nothing+ )+ kvs+ )+ MapBlock+ YTagged tg inner -> ATagged tg (annotatePlain inner)+ YAnchored a inner -> AAnchored a (annotatePlain inner)+ YAlias a -> AAlias a+++emptyTrivia :: Trivia+emptyTrivia = Trivia [] 0 Nothing+++defaultScalarStyle :: Text -> ScalarStyle+defaultScalarStyle t+ | T.any (\c -> c == '\n' || c == '\r') t = SSDoubleQuoted+ | otherwise = SSPlain+++logicalLines :: Text -> [Text]+logicalLines = T.lines . T.replace "\r" "\n" . T.replace "\r\n" "\n"+++propertyOnly :: Text -> Bool+propertyOnly source =+ let strip text+ | T.isPrefixOf "!" text || T.isPrefixOf "&" text = strip (stripYamlStart (T.dropWhile (\c -> c /= ' ' && c /= '\t') text))+ | otherwise = T.null text || T.isPrefixOf "#" text+ in (T.isPrefixOf "!" source || T.isPrefixOf "&" source) && strip source+++-- ---------------------------------------------------------------------------+-- Line-byte index+-- ---------------------------------------------------------------------------++{- | A 'LineIndex' is a vector mapping 1-based line numbers to+their UTF-8 byte offsets in the source. Index 0 is unused; the+final element is the byte length of the source so that line+@i@ runs from @lineByte i@ inclusive to @lineByte (i + 1)@+exclusive.+-}+data LineIndex = LineIndex !(V.Vector Int)+ deriving (Show)+++buildLineIndex :: Text -> LineIndex+buildLineIndex src =+ let bytes = TE.encodeUtf8 src+ size = BS.length bytes+ starts position+ | position >= size = []+ | BS.index bytes position == 13 =+ let next = if position + 1 < size && BS.index bytes (position + 1) == 10 then position + 2 else position + 1+ in next : starts next+ | BS.index bytes position == 10 = (position + 1) : starts (position + 1)+ | otherwise = starts (position + 1)+ in LineIndex (V.fromList (0 : starts 0 <> [size]))+{-# INLINE buildLineIndex #-}+++lineRange :: LineIndex -> Int -> Maybe (Int, Int)+lineRange (LineIndex v) lno+ | lno < 1 || lno >= V.length v = Nothing+ | otherwise = Just (V.unsafeIndex v (lno - 1), V.unsafeIndex v lno)+++-- ---------------------------------------------------------------------------+-- Top-level mapping entry locator+-- ---------------------------------------------------------------------------++{- | Walk the source in line order, matching each top-level+mapping key from the parsed structure to a line beginning at+column 0 with that key followed by @:@. For each entry we+record the byte span covering the key line + any continuation+lines (lines indented past column 0). Stand-alone comments and+blank lines that immediately precede the key are attached as+'triviaLeading' / 'triviaBlankLines'.++Returns 'Nothing' if the parsed structure can't be aligned with+the source on a 1:1 basis (e.g. mappings nested under @---@,+multi-document streams). The caller falls back to whole-doc+verbatim in that case.+-}+locateMapEntries+ :: Text+ -> LineIndex+ -> [(AValue, AValue)]+ -> Maybe [AMapEntry]+locateMapEntries src lineIdx kvs = go 1 [] 0 kvs+ where+ LineIndex starts = lineIdx+ !lineCount = V.length starts - 1++ -- 'pendingComments' / 'pendingBlanks' accumulate trivia+ -- waiting to attach to the next key line.+ go !lno !pendingComments !pendingBlanks remaining+ | lno > lineCount =+ if null remaining then Just [] else Nothing+ | otherwise =+ case lineSliceUtf8 src lineIdx lno of+ Nothing -> Nothing+ Just lt ->+ let stripped = stripYamlStart lt+ indent = T.length lt - T.length stripped+ in -- Skip directive / doc-marker lines.+ case T.uncons stripped of+ _+ | T.null stripped ->+ go+ (lno + 1)+ pendingComments+ (pendingBlanks + 1)+ remaining+ Just ('#', rest) ->+ let cmt = Comment (stripCommentBody rest) indent+ in go+ (lno + 1)+ (pendingComments ++ [cmt])+ pendingBlanks+ remaining+ _ | propertyOnly stripped -> go (lno + 1) pendingComments pendingBlanks remaining+ Just ('%', _) ->+ go (lno + 1) pendingComments pendingBlanks remaining+ Just ('-', rest)+ | T.isPrefixOf "--" rest ->+ go (lno + 1) pendingComments pendingBlanks remaining+ Just ('.', rest)+ | T.isPrefixOf ".." rest ->+ go (lno + 1) pendingComments pendingBlanks remaining+ _+ | indent /= 0 ->+ -- A continuation line outside any entry: bail.+ Nothing+ _ ->+ case remaining of+ [] -> Nothing -- extra content past the parsed entries+ ((kv, vv) : rest) ->+ case matchKeyOnLine stripped kv of+ Nothing -> Nothing+ Just _ ->+ -- Find the entry's span: from start+ -- of key line through last non-blank+ -- continuation line.+ let !entryStartByte = V.unsafeIndex starts (lno - 1)+ (endLine, _eolCmt) =+ scanEntryLines src lineIdx (lno + 1)+ !entryEndByte =+ -- Line @endLine@ is the first+ -- line that does NOT belong to+ -- this entry (or @lineCount + 1@+ -- when none follows). Bytes+ -- BEFORE that line make up the+ -- entry.+ V.unsafeIndex+ starts+ (min (endLine - 1) (V.length starts - 1))+ trailingCmt =+ parseEolComment src lineIdx lno+ trivia =+ Trivia+ pendingComments+ pendingBlanks+ Nothing+ keyAv =+ (styleNode (maybe stripped fst (YD.splitMappingLine stripped)) kv)+ { avTrivia = trivia+ }+ valAv =+ annotateContainedValue+ src+ lineIdx+ vv+ ( Just+ ( SrcSpan+ entryStartByte+ entryEndByte+ )+ )+ entry =+ AMapEntry+ keyAv+ valAv+ { avSpan =+ Just+ ( SrcSpan+ entryStartByte+ entryEndByte+ )+ }+ trailingCmt+ in (entry :)+ <$> go endLine [] 0 rest+++-- ---------------------------------------------------------------------------+-- Top-level sequence item locator+-- ---------------------------------------------------------------------------++locateSeqItems+ :: Text -> LineIndex -> [AValue] -> Maybe [AValue]+locateSeqItems src lineIdx items = go 1 [] 0 items+ where+ LineIndex starts = lineIdx+ !lineCount = V.length starts - 1++ go !lno !pendingComments !pendingBlanks remaining+ | lno > lineCount =+ if null remaining then Just [] else Nothing+ | otherwise =+ case lineSliceUtf8 src lineIdx lno of+ Nothing -> Nothing+ Just lt ->+ let stripped = stripYamlStart lt+ indent = T.length lt - T.length stripped+ in case T.uncons stripped of+ _+ | T.null stripped ->+ go+ (lno + 1)+ pendingComments+ (pendingBlanks + 1)+ remaining+ Just ('#', rest) ->+ let cmt = Comment (stripCommentBody rest) indent+ in go+ (lno + 1)+ (pendingComments ++ [cmt])+ pendingBlanks+ remaining+ _ | propertyOnly stripped -> go (lno + 1) pendingComments pendingBlanks remaining+ Just ('%', _) ->+ go (lno + 1) pendingComments pendingBlanks remaining+ _ | stripped == "---" || stripped == "..." -> go (lno + 1) pendingComments pendingBlanks remaining+ Just ('-', after) | T.null after || T.head after == ' ' ->+ case remaining of+ [] -> Nothing+ (vv : rest) ->+ let !entryStartByte = V.unsafeIndex starts (lno - 1)+ (endLine, _) =+ scanEntryLines src lineIdx (lno + 1)+ !entryEndByte =+ V.unsafeIndex+ starts+ (min (endLine - 1) (V.length starts - 1))+ av =+ annotateContainedValue+ src+ lineIdx+ vv+ ( Just+ ( SrcSpan+ entryStartByte+ entryEndByte+ )+ )+ av' =+ av+ { avTrivia =+ Trivia+ pendingComments+ pendingBlanks+ (case avBody vv of AMap _ _ -> Nothing; ASeq _ _ -> Nothing; _ -> parseEolComment src lineIdx lno)+ , avSpan =+ Just+ ( SrcSpan+ entryStartByte+ entryEndByte+ )+ }+ in (av' :) <$> go endLine [] 0 rest+ _ -> Nothing+ where+ !_ = indent -- silence unused+++{- | An entry's body extends until the next non-indented line.+Blank lines and stand-alone comments belong to the NEXT entry's+trivia, not this one.+-}+scanEntryLines :: Text -> LineIndex -> Int -> (Int, Maybe Comment)+scanEntryLines src lineIdx@(LineIndex starts) start = go start+ where+ !lineCount = V.length starts - 1+ scalarEntry = maybe False isScalarHeader (lineSliceUtf8 src lineIdx (start - 1))+ isScalarHeader source =+ let row = stripYamlStart source+ item = if T.isPrefixOf "- " row then T.drop 2 row else row+ value = maybe item snd (YD.splitMappingLine item)+ stripProps text = if T.isPrefixOf "!" text || T.isPrefixOf "&" text then stripProps (stripYamlStart (T.dropWhile (\c -> c /= ' ' && c /= '\t') text)) else text+ in case T.uncons (stripProps (stripYamlStart value)) of Just (c, _) -> c == '|' || c == '>'; Nothing -> False+ go !lno+ | lno > lineCount = (lineCount + 1, Nothing)+ | otherwise =+ case lineSliceUtf8 src lineIdx lno of+ Nothing -> (lno, Nothing)+ Just lt ->+ let stripped = stripYamlStart lt+ indent = T.length lt - T.length stripped+ laterIndented = lookAhead (lno + 1)+ in if (not (T.null stripped) && indent > 0) || (T.null stripped && (scalarEntry || laterIndented))+ then go (lno + 1)+ else (lno, Nothing)+ lookAhead line+ | line > lineCount = False+ | otherwise = case lineSliceUtf8 src lineIdx line of+ Just text+ | T.null (stripYaml text) -> lookAhead (line + 1)+ | otherwise -> T.length text > T.length (stripYamlStart text)+ Nothing -> False+++-- Recursively annotate each entry using a dedented source view, then translate+-- its byte spans back into the original document. This preserves comments and+-- quoting at every block level, including compact sequence-of-mapping items.+annotateContainedValue :: Text -> LineIndex -> AValue -> Maybe SrcSpan -> AValue+annotateContainedValue src _ value Nothing = styleNode src value+annotateContainedValue src _ value span_@(Just (SrcSpan begin end)) =+ let chunk = TE.decodeUtf8 (BS.take (end - begin) (BS.drop begin (TE.encodeUtf8 src)))+ chunkIndex@(LineIndex originalStarts) = buildLineIndex chunk+ rows = (\line -> maybe "" id (lineSliceUtf8 chunk chunkIndex line)) <$> [1 .. V.length originalStarts - 1]+ first = case rows of line : _ -> line; [] -> ""+ stripped = stripYamlStart first+ isItem = stripped == "-" || T.isPrefixOf "- " stripped+ payload =+ if isItem+ then stripYamlStart (T.drop 1 stripped)+ else maybe stripped (stripYamlStart . snd) (YD.splitMappingLine stripped)+ firstRemoved = BS.length (TE.encodeUtf8 first) - BS.length (TE.encodeUtf8 payload)+ remainder = drop 1 rows+ significant = filter (\line -> not (T.null (stripYaml line)) && not (T.isPrefixOf "#" (stripYamlStart line))) remainder+ base = case significant of line : _ -> T.length line - T.length (stripYamlStart line); [] -> 0+ inline = not (T.null payload) && not (T.isPrefixOf "#" payload)+ -- A compact map starts immediately after a sequence dash. Otherwise+ -- inline content is a scalar/flow node; block children start next line.+ compact = isItem && inline && case avBody value of AMap _ _ -> True; _ -> False+ useFirst = inline || compact+ removed line = min base (T.length (T.takeWhile (== ' ') line))+ normalizedRows = (if useFirst then [payload] else []) <> ((\line -> T.drop (removed line) line) <$> remainder)+ rowNumbers = (if useFirst then [0] else []) <> [1 .. length rows - 1]+ prefixes = (if useFirst then [firstRemoved] else []) <> (removed <$> remainder)+ view = T.intercalate "\n" normalizedRows+ viewStarts = V.fromList (scanl (\offset line -> offset + BS.length (TE.encodeUtf8 line) + 1) 0 normalizedRows)+ sourceStarts = V.fromList ((begin +) . (originalStarts V.!) <$> rowNumbers)+ prefixBytes = V.fromList prefixes+ translate isEnd offset+ | V.null sourceStarts = begin+ | otherwise =+ let row = min (V.length sourceStarts - 1) (findRow offset 0 (V.length viewStarts - 1))+ column = offset - viewStarts V.! row+ prefix = if isEnd && column == 0 && row > 0 then 0 else prefixBytes V.! row+ in sourceStarts V.! row + prefix + column+ findRow offset low high+ | low >= high = low+ | otherwise =+ let middle = (low + high + 1) `quot` 2+ in if viewStarts V.! middle <= offset then findRow offset middle high else findRow offset low (middle - 1)+ shift (SrcSpan a b) = SrcSpan (translate False a) (translate True b)+ relocate av =+ av+ { avSpan = shift <$> avSpan av+ , avNodeSpan = shift <$> avNodeSpan av+ , avBody = case avBody av of+ AMap entries style -> AMap (V.map (\entry -> entry {amKey = relocate (amKey entry), amValue = relocate (amValue entry)}) entries) style+ ASeq items style -> ASeq (V.map relocate items) style+ ATagged tag inner -> ATagged tag (relocate inner)+ AAnchored anchor inner -> AAnchored anchor (relocate inner)+ body -> body+ }+ annotated = annotateBody view (buildLineIndex view) value+ childEnds = case avBody annotated of+ AMap entries _ -> srcEnd <$> V.toList (V.mapMaybe (avSpan . amValue) entries)+ ASeq items _ -> srcEnd <$> V.toList (V.mapMaybe avSpan items)+ _ -> []+ suffix = case childEnds of+ [] -> ""+ positions -> TE.decodeUtf8 (BS.drop (maximum positions) (TE.encodeUtf8 view))+ in (relocate annotated) {avSpan = span_, avTrailingText = if isFlow annotated then avTrailingText annotated else suffix}+ where+ isFlow av = case avBody av of+ AMap _ MapFlow -> True+ ASeq _ SeqFlow -> True+ ATagged _ inner -> isFlow inner+ AAnchored _ inner -> isFlow inner+ _ -> False+++styleNode :: Text -> AValue -> AValue+styleNode source av = av {avBody = apply (avBody av)}+ where+ line = case filter (\text -> let t = stripYaml text in not (T.null t) && not (T.isPrefixOf "#" t) && not (T.isPrefixOf "%" t) && t /= "---") (logicalLines source) of+ first : _ -> stripYamlStart first+ [] -> ""+ content = stripProperties line+ stripProperties text+ | T.isPrefixOf "!" text || T.isPrefixOf "&" text = stripProperties (stripYamlStart (T.dropWhile (\c -> c /= ' ' && c /= '\t') text))+ | otherwise = text+ chomp+ | T.isInfixOf "-" content = Strip+ | T.isInfixOf "+" content = Keep+ | otherwise = Clip+ apply (AString text _) =+ AString+ text+ ( case T.uncons content of+ Just ('\'', _) -> SSSingleQuoted+ Just ('"', _) -> SSDoubleQuoted+ Just ('|', _) -> SSLiteral chomp+ Just ('>', _) -> SSFolded chomp+ _ -> defaultScalarStyle text+ )+ apply (AMap entries _) | T.isPrefixOf "{" content = AMap entries MapFlow+ apply (ASeq items _) | T.isPrefixOf "[" content = ASeq items SeqFlow+ apply (ATagged tag inner) = ATagged tag (styleNode content inner)+ apply (AAnchored anchor inner) = AAnchored anchor (styleNode content inner)+ apply body = body+++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++lineSliceUtf8 :: Text -> LineIndex -> Int -> Maybe Text+lineSliceUtf8 src lineIdx lno = do+ (s, e) <- lineRange lineIdx lno+ let bs = TE.encodeUtf8 src+ let raw = BS.take (max 0 (e - s)) (BS.drop s bs)+ bs' = case BS.unsnoc raw of+ Just (init', 0x0A) -> init'+ _ -> raw+ bs'' = case BS.unsnoc bs' of+ Just (init', 0x0D) -> init'+ _ -> bs'+ Right t <- pure (TE.decodeUtf8' bs'')+ pure t+++{- | Match a top-level key name against the start of a stripped+line. Recognises plain / single-quoted / double-quoted scalar+keys; bails out for anything more exotic.+-}+matchKeyOnLine :: Text -> AValue -> Maybe Text+matchKeyOnLine line key = do+ (raw, _) <- YD.splitMappingLine line+ case avBody key of+ AResolvedAlias _ (YAML.Value.Anchor name) _ | raw == "*" <> name -> Just line+ _ -> do+ parsed <- either (const Nothing) Just (YD.decode raw)+ if unwrapKey parsed == unwrapKey (YAML.Annotated.astripAnnotations key) then Just line else Nothing+ where+ unwrapKey (YTagged _ value) = unwrapKey value+ unwrapKey (YAnchored _ value) = unwrapKey value+ unwrapKey value = value+++stripCommentBody :: Text -> Text+stripCommentBody t = T.dropWhile (== ' ') t+++parseEolComment :: Text -> LineIndex -> Int -> Maybe Comment+parseEolComment src lineIdx lno = do+ lt <- lineSliceUtf8 src lineIdx lno+ -- Find an unquoted '#' preceded by whitespace.+ let go !i !inSq !inDq+ | i >= T.length lt = Nothing+ | otherwise =+ let c = T.index lt i+ in case c of+ '\'' | not inDq -> go (i + 1) (not inSq) inDq+ '"' | not inSq -> go (i + 1) inSq (not inDq)+ '#'+ | not inSq+ , not inDq+ , i > 0+ , isYamlSpace (T.index lt (i - 1)) ->+ Just+ ( Comment+ (stripCommentBody (T.drop (i + 1) lt))+ i+ )+ _ -> go (i + 1) inSq inDq+ go 0 False False+++_isDigit :: Char -> Bool+_isDigit = isDigit
+ src/YAML/Decode/Flow.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Align an already validated flow tree with its presentation tokens. This+pass never decides YAML semantics; an alignment failure leaves the normal+annotation fallback in charge.+-}+module YAML.Decode.Flow (annotateFlow) where++import Control.Monad (guard)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Vector qualified as V+import Data.Word (Word8)+import YAML.Annotated+++data Token = Token !Int !Int !Kind+++data Kind = Atom | Quoted !Word8 | Property | Punct !Word8 | Note !Comment+++annotateFlow :: Text -> AValue -> Maybe AValue+annotateFlow source original = do+ let bytes = TE.encodeUtf8 source+ body = dropPrologue 0 bytes+ tokens = lexFlow bytes body+ content = dropWhile isProperty tokens+ case content of+ Token _ _ (Punct c) : _ -> guard (c == 91 || c == 123)+ _ -> Nothing+ (result, rest) <- node tokens original+ let before = TE.decodeUtf8 (BS.take body bytes)+ comments = foldMap (\line -> case T.stripPrefix "#" (T.dropWhile (== ' ') line) of Just text -> [Comment (T.dropWhile (== ' ') text) 0]; Nothing -> []) (T.lines (T.replace "\r" "\n" before))+ trailing = case (avNodeSpan result, rest) of+ (Just (SrcSpan _ end), Token start _ (Note comment) : _)+ | not (BS.any (\byte -> byte == 10 || byte == 13) (BS.take (start - end) (BS.drop end bytes))) -> Just comment+ _ -> Nothing+ pure (leading comments result) {avTrivia = (avTrivia (leading comments result)) {triviaTrailing = trailing}}+ where+ isProperty (Token _ _ Property) = True+ isProperty (Token _ _ (Note _)) = True+ isProperty _ = False+++dropPrologue :: Int -> BS.ByteString -> Int+dropPrologue !offset bytes+ | offset >= BS.length bytes = offset+ | space (BS.index bytes offset) = dropPrologue (offset + 1) bytes+ | BS.index bytes offset == 35 || BS.index bytes offset == 37 =+ dropPrologue (offset + BS.length (BS.takeWhile (\c -> c /= 10 && c /= 13) (BS.drop offset bytes))) bytes+ | BS.take 3 (BS.drop offset bytes) == "---" = dropPrologue (offset + 3) bytes+ | BS.take 3 (BS.drop offset bytes) == BS.pack [239, 187, 191] = dropPrologue (offset + 3) bytes+ | otherwise = offset+++space :: Word8 -> Bool+space c = c == 32 || c == 9 || c == 10 || c == 13+++lexFlow :: BS.ByteString -> Int -> [Token]+lexFlow bytes = go+ where+ size = BS.length bytes+ at = BS.index bytes+ slice a b = TE.decodeUtf8 (BS.take (b - a) (BS.drop a bytes))+ go !i+ | i >= size = []+ | space c = go (i + 1)+ | c == 35 =+ let end = untilByte (\b -> b == 10 || b == 13) (i + 1)+ comment = Comment (T.dropWhile (== ' ') (slice (i + 1) end)) 0+ in Token i end (Note comment) : go end+ | c == 34 || c == 39 =+ let end = quoted c (i + 1)+ in Token i end (Quoted c) : go end+ | c == 33 || c == 38 =+ let end =+ if c == 33 && i + 1 < size && at (i + 1) == 60+ then min size (untilByte (== 62) (i + 2) + 1)+ else untilByte (\b -> space b || delimiter b) (i + 1)+ in Token i end Property : go end+ | delimiter c || (c == 58 && colon i) || (c == 63 && (i + 1 == size || space (at (i + 1)))) = Token i (i + 1) (Punct c) : go (i + 1)+ | otherwise =+ let end = plain (i + 1)+ trimmed = trimEnd end+ in Token i trimmed Atom : go end+ where+ c = at i+ delimiter b = b == 91 || b == 93 || b == 123 || b == 125 || b == 44+ colon i = i + 1 == size || space (at (i + 1)) || delimiter (at (i + 1)) || previous (i - 1) `elem` [34, 39, 93, 125]+ previous i+ | i < 0 = 0+ | space (at i) = previous (i - 1)+ | otherwise = at i+ untilByte stop !i+ | i >= size || stop (at i) = i+ | otherwise = untilByte stop (i + 1)+ trimEnd !i+ | i > 0 && space (at (i - 1)) = trimEnd (i - 1)+ | otherwise = i+ plain !i+ | i >= size = i+ | delimiter (at i) = i+ | at i == 35 && space (at (i - 1)) = i+ | at i == 58 && (i + 1 == size || space (at (i + 1)) || delimiter (at (i + 1))) = i+ | otherwise = plain (i + 1)+ quoted q !i+ | i >= size = size+ | q == 34 && at i == 92 = quoted q (min size (i + 2))+ | at i == q = if q == 39 && i + 1 < size && at (i + 1) == q then quoted q (i + 2) else i + 1+ | otherwise = quoted q (i + 1)+++node :: [Token] -> AValue -> Maybe (AValue, [Token])+node tokens original = do+ let (properties, content) = span property tokens+ bare = unwrap original+ (parsed, rest) <- bareNode content bare+ let notes = foldMap (\token -> case token of Token _ _ (Note comment) -> [comment]; _ -> []) properties+ result = leading notes (rewrap original parsed)+ start = case properties of Token a _ _ : _ -> a; [] -> maybe 0 srcStart (avNodeSpan parsed)+ propertyEnd = foldl (\end (Token _ next _) -> max end next) start properties+ -- Include the physical break after a property-only comment. Copying a+ -- span that ends inside that comment would swallow a fresh separator.+ emptyEnd = case (notes, rest) of (_ : _, Token offset _ _ : _) -> offset; _ -> propertyEnd+ finish = maybe emptyEnd srcEnd (avNodeSpan parsed)+ pure (result {avNodeSpan = if null properties then avNodeSpan parsed else Just (SrcSpan start finish)}, rest)+ where+ property (Token _ _ Property) = True+ property (Token _ _ (Note _)) = True+ property _ = False+ unwrap av = case avBody av of ATagged _ x -> unwrap x; AAnchored _ x -> unwrap x; _ -> av+ rewrap av inner = case avBody av of+ ATagged tag x -> av {avBody = ATagged tag (rewrap x inner), avNodeSpan = Nothing}+ AAnchored anchor x -> av {avBody = AAnchored anchor (rewrap x inner), avNodeSpan = Nothing}+ _ -> inner+++bareNode :: [Token] -> AValue -> Maybe (AValue, [Token])+bareNode tokens original = case (tokens, avBody original) of+ (Token start _ (Punct 91) : rest, ASeq items _) -> do+ (values, trailing, ending) <- sequenceNodes rest (V.toList items)+ case ending of+ Token _ end (Punct 93) : more -> pure (original {avBody = ASeq (V.fromList values) SeqFlow, avNodeSpan = Just (SrcSpan start end), avTrailingText = notesText trailing}, more)+ _ -> Nothing+ (Token start _ (Punct 123) : rest, AMap entries _) -> do+ (values, trailing, ending) <- mappingNodes rest (V.toList entries)+ case ending of+ Token _ end (Punct 125) : more -> pure (original {avBody = AMap (V.fromList values) MapFlow, avNodeSpan = Just (SrcSpan start end), avTrailingText = notesText trailing}, more)+ _ -> Nothing+ (_, AMap entries _) | V.length entries == 1 -> do+ (entry, rest) <- pair tokens (V.head entries)+ let start = case tokens of Token offset _ _ : _ -> offset; [] -> 0+ end = case rest of Token offset _ _ : _ -> offset; [] -> maybe start srcEnd (avNodeSpan (amValue entry))+ pure (original {avBody = AMap (V.singleton entry) MapFlow, avNodeSpan = Just (SrcSpan start end)}, rest)+ (_, ANull) | boundary tokens -> pure (original {avNodeSpan = Nothing}, tokens)+ (_, AString text _) | T.null text, boundary tokens -> pure (original {avNodeSpan = Nothing}, tokens)+ (Token start end kind : rest, _)+ | scalar kind ->+ let body = case (avBody original, kind) of+ (AString text _, Quoted 34) -> AString text SSDoubleQuoted+ (AString text _, Quoted 39) -> AString text SSSingleQuoted+ (AString text _, _) -> AString text SSPlain+ (other, _) -> other+ in pure (original {avBody = body, avNodeSpan = Just (SrcSpan start end)}, rest)+ _ -> Nothing+ where+ scalar Atom = True+ scalar (Quoted _) = True+ scalar _ = False+++boundary :: [Token] -> Bool+boundary [] = True+boundary (Token _ _ (Punct c) : _) = c == 44 || c == 93 || c == 125 || c == 58+boundary _ = False+++takeNotes :: [Token] -> ([Comment], [Token])+takeNotes (Token _ _ (Note comment) : rest) = let (comments, more) = takeNotes rest in (comment : comments, more)+takeNotes tokens = ([], tokens)+++notesText :: [Comment] -> Text+notesText = foldMap (\comment -> "# " <> commentText comment <> "\n")+++leading :: [Comment] -> AValue -> AValue+leading comments av = av {avTrivia = (avTrivia av) {triviaLeading = comments <> triviaLeading (avTrivia av)}}+++sequenceNodes :: [Token] -> [AValue] -> Maybe ([AValue], [Comment], [Token])+sequenceNodes tokens [] = let (comments, rest) = takeNotes tokens in pure ([], comments, rest)+sequenceNodes tokens (value : values) = do+ let (before, start) = takeNotes tokens+ (parsed, after) <- node start value+ let (trailing, separator) = takeNotes after+ decorated = leading (before <> trailing) parsed+ case separator of+ Token _ _ (Punct 44) : rest -> do+ (next, ending, more) <- sequenceNodes rest values+ pure (decorated : next, ending, more)+ _ -> do+ guard (null values)+ pure ([decorated], [], separator)+++pair :: [Token] -> AMapEntry -> Maybe (AMapEntry, [Token])+pair tokens original = do+ let (before, content) = takeNotes tokens+ start = case content of Token _ _ (Punct 63) : rest -> rest; _ -> content+ (key, afterKey) <- node start (amKey original)+ let (middle, colon) = takeNotes afterKey+ (value, rest) <- case colon of+ Token _ _ (Punct 58) : afterColon -> do+ let (comments, valueStart) = takeNotes afterColon+ (result, more) <- node valueStart (amValue original)+ pure (leading comments result, more)+ _ -> case avBody (amValue original) of ANull -> pure (amValue original, colon); _ -> Nothing+ let (trailing, ending) = takeNotes rest+ pure (original {amKey = leading (before <> middle <> trailing) key, amValue = value, amTrailing = Nothing}, ending)+++mappingNodes :: [Token] -> [AMapEntry] -> Maybe ([AMapEntry], [Comment], [Token])+mappingNodes tokens [] = let (comments, rest) = takeNotes tokens in pure ([], comments, rest)+mappingNodes tokens (entry : entries) = do+ (parsed, after) <- pair tokens entry+ case after of+ Token _ _ (Punct 44) : rest -> do+ (next, ending, more) <- mappingNodes rest entries+ pure (parsed : next, ending, more)+ _ -> do+ guard (null entries)+ pure ([parsed], [], after)
+ src/YAML/Derive.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Annotation-driven Template Haskell deriver for YAML+'YAML.Class.ToYAML' / 'YAML.Class.FromYAML' instances.++Encoding shape:++* 'TypeShapeNewtype' — pass-through to the inner field's instance.+* 'TypeShapeRecord' — YAML mapping with text-string keys.+* 'TypeShapeEnum' — YAML scalar 'YV.YString' carrying the+ (possibly renamed) constructor name.+* 'TypeShapeSum' — YAML mapping+ @{ tag: \"Ctor\", contents: ... }@; nullary constructors omit+ the @contents@ key entirely (mirroring the TOML / EDN derivers).++Modifiers honoured: 'rename', 'renameStyle', 'renameWith', 'skip',+'defaults', 'optional', 'coerced'.+-}+module YAML.Derive (+ deriveYAML,+ deriveToYAML,+ deriveFromYAML,+) where++import Data.Coerce (Coercible, coerce)+import Data.Foldable (foldlM)+import Data.List (nub)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Language.Haskell.TH+import Wireform.Derive.Backend+import Wireform.Derive.ModifierInfo+import Wireform.Derive.TypeInfo+import YAML.Class qualified as Y+import YAML.Value qualified as YV+++-- ---------------------------------------------------------------------------+-- Public entry points+-- ---------------------------------------------------------------------------++deriveYAML :: Name -> Q [Dec]+deriveYAML nm = (++) <$> deriveToYAML nm <*> deriveFromYAML nm+++deriveToYAML :: Name -> Q [Dec]+deriveToYAML nm = do+ ti <- reifyTypeInfo nm+ context <- instanceContext ''Y.ToYAML ti+ body <- toYAMLBody ti+ let typ = applyTypeArgs (ConT (typeInfoName ti)) (typeInfoVarTypes ti)+ decl =+ InstanceD+ Nothing+ context+ (AppT (ConT ''Y.ToYAML) typ)+ [FunD 'Y.toYAML [Clause [] (NormalB body) []]]+ pure [decl]+++deriveFromYAML :: Name -> Q [Dec]+deriveFromYAML nm = do+ ti <- reifyTypeInfo nm+ context <- instanceContext ''Y.FromYAML ti+ body <- fromYAMLBody ti+ let typ = applyTypeArgs (ConT (typeInfoName ti)) (typeInfoVarTypes ti)+ decl =+ InstanceD+ Nothing+ context+ (AppT (ConT ''Y.FromYAML) typ)+ [FunD 'Y.fromYAML [Clause [] (NormalB body) []]]+ pure [decl]+++-- Constrain the variables used by serialized fields. An applied type variable+-- (f a) needs a constraint on the application, rather than the higher-kinded f.+instanceContext :: Name -> TypeInfo -> Q Cxt+instanceContext cls ti = do+ constraints <- case typeInfoShape ti of+ TypeShapeNewtype constructor -> pure (concatMap ordinary (conInfoFields constructor))+ TypeShapeRecord constructor -> concat <$> traverse fieldConstraints (conInfoFields constructor)+ TypeShapeEnum _ -> pure []+ TypeShapeSum constructors -> concat <$> traverse (\constructor -> if conInfoIsRecord constructor then concat <$> traverse fieldConstraints (conInfoFields constructor) else pure (concatMap ordinary (conInfoFields constructor))) constructors+ pure (nub (typeInfoContext ti <> constraints))+ where+ ordinary = (AppT (ConT cls) <$>) . variables . fieldInfoType+ fieldConstraints field@(FieldInfo selector typ) = case selector of+ Nothing -> pure (ordinary field)+ Just name -> do+ modifier <- reifyModifierInfoFor backendYAML name+ pure $+ if miSkip modifier+ then []+ else case miCoerce modifier of+ Nothing -> ordinary field+ Just target+ | null (variables typ) -> []+ | otherwise ->+ let wireType = if miRequired modifier == Just False then AppT (ConT ''Maybe) (ConT target) else ConT target+ in [AppT (AppT (ConT ''Coercible) typ) wireType]+ variables typ+ | variableHead typ = [typ]+ variables (AppT left right) = variables left <> variables right+ variables (SigT typ _) = variables typ+ variables (ParensT typ) = variables typ+ variables _ = []+ variableHead (VarT _) = True+ variableHead (AppT typ _) = variableHead typ+ variableHead _ = False+++-- ---------------------------------------------------------------------------+-- ToYAML+-- ---------------------------------------------------------------------------++toYAMLBody :: TypeInfo -> Q Exp+toYAMLBody ti = case typeInfoShape ti of+ TypeShapeNewtype c -> toYAMLNewtype c+ TypeShapeRecord c -> toYAMLRecord c+ TypeShapeEnum cs -> toYAMLEnum cs+ TypeShapeSum cs -> toYAMLSum cs+++toYAMLNewtype :: ConInfo -> Q Exp+toYAMLNewtype c = case conInfoFields c of+ [FieldInfo (Just sel) _] -> do+ x <- newName "x"+ lamE [varP x] [|Y.toYAML ($(varE sel) $(varE x))|]+ [FieldInfo Nothing _] -> do+ x <- newName "x"+ lamE [conP (conInfoName c) [varP x]] [|Y.toYAML $(varE x)|]+ _ -> fail "YAML.Derive: newtype must have exactly one field"+++toYAMLRecord :: ConInfo -> Q Exp+toYAMLRecord c = do+ x <- newName "x"+ pairs <- recordToYAMLPairs (varE x) c+ lamE [varP x] [|YV.YMap (V.fromList $(pure pairs))|]+++recordToYAMLPairs :: Q Exp -> ConInfo -> Q Exp+recordToYAMLPairs varExp c = do+ pairExpss <- mapM (toYAMLField varExp) (conInfoFields c)+ pure (ListE (concat pairExpss))+++toYAMLField :: Q Exp -> FieldInfo -> Q [Exp]+toYAMLField varExp (FieldInfo mSel _) = do+ selName <- requireSelector mSel+ mi <- reifyModifierInfoFor backendYAML selName+ if miSkip mi+ then pure []+ else do+ let selBase = Text.pack (nameBase selName)+ keyExp <- renderWireKey mi selBase+ let getter = appE (varE selName) varExp+ encoded = case miCoerce mi of+ Nothing -> [|Y.toYAML $getter|]+ Just target -> [|Y.toYAML $(sigE [|coerce $getter|] (pure (if miRequired mi == Just False then AppT (ConT ''Maybe) (ConT target) else ConT target)))|]+ pair <- [|(YV.YString $(pure keyExp), $encoded)|]+ pure [pair]+++toYAMLEnum :: [ConInfo] -> Q Exp+toYAMLEnum cs = do+ v <- newName "v"+ matches <- mapM enumToYAMLMatch cs+ body <- caseE (varE v) (map pure matches)+ lamE [varP v] (pure body)+++enumToYAMLMatch :: ConInfo -> Q Match+enumToYAMLMatch c = do+ mi <- reifyModifierInfoFor backendYAML (conInfoName c)+ keyExp <- renderWireKey mi (Text.pack (nameBase (conInfoName c)))+ body <- [|YV.YString $(pure keyExp)|]+ pure (Match (ConP (conInfoName c) [] []) (NormalB body) [])+++toYAMLSum :: [ConInfo] -> Q Exp+toYAMLSum cs = do+ v <- newName "v"+ matches <- mapM sumCtorToYAML cs+ body <- caseE (varE v) (map pure matches)+ lamE [varP v] (pure body)+++sumCtorToYAML :: ConInfo -> Q Match+sumCtorToYAML c+ | conInfoIsRecord c+ , not (null (conInfoFields c)) = do+ modifier <- reifyModifierInfoFor backendYAML (conInfoName c)+ tag <- renderWireKey modifier (Text.pack (nameBase (conInfoName c)))+ record <- newName "record"+ pairs <- recordToYAMLPairs (varE record) c+ body <- [|YV.YMap (V.fromList [(YV.YString "tag", YV.YString $(pure tag)), (YV.YString "contents", YV.YMap (V.fromList $(pure pairs)))])|]+ let pattern_ = AsP record (ConP (conInfoName c) [] (replicate (length (conInfoFields c)) WildP))+ pure (Match pattern_ (NormalB body) [])+ | otherwise = sumCtorToYAMLPositional c+++sumCtorToYAMLPositional :: ConInfo -> Q Match+sumCtorToYAMLPositional c = do+ mi <- reifyModifierInfoFor backendYAML (conInfoName c)+ keyExp <- renderWireKey mi (Text.pack (nameBase (conInfoName c)))+ fieldNames <- mapM (\_ -> newName "f") (conInfoFields c)+ let pat = ConP (conInfoName c) [] (map VarP fieldNames)+ body <- case fieldNames of+ [] ->+ [|+ YV.YMap+ ( V.fromList+ [ (YV.YString (Text.pack "tag"), YV.YString $(pure keyExp))+ ]+ )+ |]+ [n] ->+ [|+ YV.YMap+ ( V.fromList+ [ (YV.YString (Text.pack "tag"), YV.YString $(pure keyExp))+ , (YV.YString (Text.pack "contents"), Y.toYAML $(varE n))+ ]+ )+ |]+ ns ->+ [|+ YV.YMap+ ( V.fromList+ [ (YV.YString (Text.pack "tag"), YV.YString $(pure keyExp))+ ,+ ( YV.YString (Text.pack "contents")+ , YV.YSeq+ ( V.fromList+ $(pure (ListE (map (AppE (VarE 'Y.toYAML) . VarE) ns)))+ )+ )+ ]+ )+ |]+ pure (Match pat (NormalB body) [])+++-- ---------------------------------------------------------------------------+-- FromYAML+-- ---------------------------------------------------------------------------++fromYAMLBody :: TypeInfo -> Q Exp+fromYAMLBody ti = case typeInfoShape ti of+ TypeShapeNewtype c -> fromYAMLNewtype c+ TypeShapeRecord c -> fromYAMLRecord c+ TypeShapeEnum cs -> fromYAMLEnum cs+ TypeShapeSum cs -> fromYAMLSum cs+++fromYAMLNewtype :: ConInfo -> Q Exp+fromYAMLNewtype c = case conInfoFields c of+ [FieldInfo _ _] -> [|fmap $(conE (conInfoName c)) . Y.fromYAML|]+ _ -> fail "YAML.Derive: newtype must have exactly one field"+++fromYAMLRecord :: ConInfo -> Q Exp+fromYAMLRecord c = do+ v <- newName "v"+ kvs <- newName "kvs"+ bodyE <- recordParser kvs c+ let unwrapped = AppE (VarE 'YV.unwrap) (VarE v)+ lamE+ [varP v]+ ( caseE+ (pure unwrapped)+ [ match+ (conP 'YV.YMap [varP kvs])+ (normalB [|Y.validateFieldNames $(varE kvs) >> $(pure bodyE)|])+ []+ , match+ wildP+ ( normalB+ [|Left "YAML.Derive: expected YMap for record type"|]+ )+ []+ ]+ )+++recordParser :: Name -> ConInfo -> Q Exp+recordParser kvs c = do+ let conName = conInfoName c+ fields = conInfoFields c+ case fields of+ [] -> [|Right $(conE conName)|]+ (f0 : fs) -> do+ e0 <- fieldParser kvs f0+ hd <- [|$(conE conName) <$> $(pure e0)|]+ foldlM+ ( \acc f -> do+ ef <- fieldParser kvs f+ [|$(pure acc) <*> $(pure ef)|]+ )+ hd+ fs+++fieldParser :: Name -> FieldInfo -> Q Exp+fieldParser kvs (FieldInfo mSel _) = do+ selName <- requireSelector mSel+ mi <- reifyModifierInfoFor backendYAML selName+ if miSkip mi+ then case miDefaults mi of+ Just defNm -> [|Right $(varE defNm)|]+ Nothing ->+ [|+ Left+ ( "YAML.Derive: missing 'defaults' for skipped field "+ ++ $(litE (stringL (nameBase selName)))+ )+ |]+ else do+ let selBase = Text.pack (nameBase selName)+ keyExp <- renderWireKey mi selBase+ let isOptional = miRequired mi == Just False+ targetType target = if isOptional then AppT (ConT ''Maybe) (ConT target) else ConT target+ missing <- case miDefaults mi of+ Just def -> [|Right $(varE def)|]+ Nothing | isOptional -> [|Right Nothing|]+ Nothing -> [|Left ("YAML.Derive: missing field " ++ Text.unpack $(pure keyExp))|]+ input <- newName "input"+ present <- case miCoerce mi of+ Nothing -> [|Y.fromYAML $(varE input)|]+ Just target -> [|coerce <$> $(sigE [|Y.fromYAML $(varE input)|] (pure (AppT (AppT (ConT ''Either) (ConT ''String)) (targetType target))))|]+ [|+ case lookupYAMLField $(pure keyExp) $(varE kvs) of+ Nothing -> $(pure missing)+ Just $(varP input) -> $(pure present)+ |]+++-- | Linear scan for a key in a 'YV.YMap'.+lookupYAMLField+ :: Text.Text+ -> V.Vector (YV.Value, YV.Value)+ -> Maybe YV.Value+lookupYAMLField nm kvs = V.foldr step Nothing kvs+ where+ step (k, val) acc = case YV.unwrap k of+ YV.YString s | s == nm -> Just val+ _ -> acc+++fromYAMLEnum :: [ConInfo] -> Q Exp+fromYAMLEnum cs = do+ v <- newName "v"+ s <- newName "s"+ branches <- mapM (enumDispatch s) cs+ let fallback =+ ( NormalG (ConE 'True)+ , AppE+ ( AppE+ (VarE 'mappend)+ (LitE (StringL "YAML.Derive: unknown enum value "))+ )+ (AppE (VarE 'show) (VarE s))+ )+ multi =+ MultiIfE+ ( map (\(g, e) -> (g, AppE (ConE 'Right) e)) branches+ ++ [(NormalG (ConE 'True), AppE (ConE 'Left) (snd fallback))]+ )+ unwrapped = AppE (VarE 'YV.unwrap) (VarE v)+ lamE+ [varP v]+ ( caseE+ (pure unwrapped)+ [ match+ (conP 'YV.YString [varP s])+ (normalB (pure multi))+ []+ , match+ wildP+ (normalB [|Left "YAML.Derive: enum expected YString"|])+ []+ ]+ )+++enumDispatch :: Name -> ConInfo -> Q (Guard, Exp)+enumDispatch sVar c = do+ mi <- reifyModifierInfoFor backendYAML (conInfoName c)+ keyExp <- renderWireKey mi (Text.pack (nameBase (conInfoName c)))+ let guardExp = InfixE (Just (VarE sVar)) (VarE '(==)) (Just keyExp)+ bodyExp = ConE (conInfoName c)+ pure (NormalG guardExp, bodyExp)+++fromYAMLSum :: [ConInfo] -> Q Exp+fromYAMLSum cs = do+ v <- newName "v"+ kvs <- newName "kvs"+ tagVar <- newName "tag"+ cVar <- newName "c"+ branches <- mapM (sumDispatch tagVar cVar) cs+ let fallback =+ ( NormalG (ConE 'True)+ , AppE+ (ConE 'Left)+ ( AppE+ ( AppE+ (VarE 'mappend)+ (LitE (StringL "YAML.Derive: unknown sum tag "))+ )+ (AppE (VarE 'show) (VarE tagVar))+ )+ )+ multi = MultiIfE (branches ++ [fallback])+ unwrapped = AppE (VarE 'YV.unwrap) (VarE v)+ lamE+ [varP v]+ ( caseE+ (pure unwrapped)+ [ match+ (conP 'YV.YMap [varP kvs])+ ( normalB+ [|+ do+ Y.validateFieldNames $(varE kvs)+ $(varP tagVar) <-+ case lookupYAMLField (Text.pack "tag") $(varE kvs) of+ Just t -> case YV.unwrap t of+ YV.YString s -> Right s+ _ -> Left "YAML.Derive: sum 'tag' not a string"+ _ -> Left "YAML.Derive: sum missing 'tag'"+ let $(varP cVar) =+ lookupYAMLField (Text.pack "contents") $(varE kvs)+ $(pure multi)+ |]+ )+ []+ , match+ wildP+ (normalB [|Left "YAML.Derive: sum expected YMap"|])+ []+ ]+ )+++sumDispatch :: Name -> Name -> ConInfo -> Q (Guard, Exp)+sumDispatch tagVar cVar c = do+ mi <- reifyModifierInfoFor backendYAML (conInfoName c)+ keyExp <- renderWireKey mi (Text.pack (nameBase (conInfoName c)))+ let guardExp = InfixE (Just (VarE tagVar)) (VarE '(==)) (Just keyExp)+ body <-+ if conInfoIsRecord c && not (null (conInfoFields c))+ then recordSumParser cVar c+ else case conInfoFields c of+ [] ->+ let conNameStr = nameBase (conInfoName c)+ in [|+ case $(varE cVar) of+ Nothing -> Right $(conE (conInfoName c))+ Just _ ->+ Left+ ( "YAML.Derive: "+ ++ conNameStr+ ++ " is nullary; unexpected 'contents'"+ )+ |]+ [_one] ->+ let conNameStr = nameBase (conInfoName c)+ in [|+ case $(varE cVar) of+ Just inner -> fmap $(conE (conInfoName c)) (Y.fromYAML inner)+ Nothing ->+ Left+ ( "YAML.Derive: "+ ++ conNameStr+ ++ " missing 'contents'"+ )+ |]+ many -> sumNAry cVar (conInfoName c) (length many)+ pure (NormalG guardExp, body)+++recordSumParser :: Name -> ConInfo -> Q Exp+recordSumParser contents constructor = do+ fields <- newName "fields"+ parser <- recordParser fields constructor+ [|+ do+ $(varP fields) <- case $(varE contents) of+ Nothing -> Right V.empty+ Just inner -> case YV.unwrap inner of+ YV.YMap entries -> Right entries+ _ -> Left "YAML.Derive: record constructor contents must be a mapping"+ Y.validateFieldNames $(varE fields)+ $(pure parser)+ |]+++sumNAry :: Name -> Name -> Int -> Q Exp+sumNAry cVar conName arity = do+ arr <- newName "arr"+ let parseI :: Int -> Q Exp+ parseI i = [|Y.fromYAML ($(varE arr) V.! $(litE (integerL (fromIntegral i))))|]+ hd <- do+ e0 <- parseI 0+ [|$(conE conName) <$> $(pure e0)|]+ body <-+ foldlM+ ( \acc i -> do+ ei <- parseI i+ [|$(pure acc) <*> $(pure ei)|]+ )+ hd+ [1 .. arity - 1]+ let conNameStr = nameBase conName+ arityStr = show arity+ [|+ case $(varE cVar) of+ Just inner -> case YV.unwrap inner of+ YV.YSeq $(varP arr)+ | V.length $(varE arr) == $(litE (integerL (fromIntegral arity))) ->+ $(pure body)+ | otherwise ->+ Left+ ( "YAML.Derive: "+ ++ conNameStr+ ++ " expected "+ ++ arityStr+ ++ " contents, got "+ ++ show (V.length $(varE arr))+ )+ _ ->+ Left+ ( "YAML.Derive: "+ ++ conNameStr+ ++ " expected YSeq contents"+ )+ Nothing ->+ Left+ ( "YAML.Derive: "+ ++ conNameStr+ ++ " missing 'contents'"+ )+ |]+++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++requireSelector :: Maybe Name -> Q Name+requireSelector (Just n) = pure n+requireSelector Nothing =+ fail "YAML.Derive: cannot derive YAML for non-record positional field"+++applyTypeArgs :: Type -> [Type] -> Type+applyTypeArgs = foldl AppT
+ src/YAML/Encode.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE BangPatterns #-}++{- | YAML 1.2 emitter.++Renders a 'YAML.Value.Value' (or a 'Document' / 'Stream') to its+block-style YAML representation, choosing flow style only for+empty containers and as a fallback. The output is /round-trippable/:+well-formed acyclic values with unique mapping keys retain their data through+'encode' and 'YAML.Decode.decode'. Decoding expands alias references; the+annotated surface retains their presentation identities for editing.++The emitter follows the YAML 1.2 core schema (so plain scalars that+happen to look like a bool / null / int / float are quoted to keep+their string identity).+-}+module YAML.Encode (+ encode,+ encodeBS,+ encodeDocument,+ encodeStream,+ safePlain,+ plainSyntaxSafe,+ buildTag,+ mustEscape,+ explicitKey,+) where++import Data.ByteString (ByteString)+import Data.Char (isControl, isDigit, ord)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder (+ Builder,+ fromText,+ singleton,+ toLazyText,+ )+import Data.Text.Lazy.Builder.Int qualified as BI+import Data.Text.Lazy.Builder.RealFloat qualified as BF+import Data.Vector qualified as V+import YAML.Value+++-- ---------------------------------------------------------------------------+-- Public entry points+-- ---------------------------------------------------------------------------++-- | Encode a single document body.+encode :: Value -> Text+encode v = TL.toStrict (toLazyText (buildDoc (Document False False v)))+++encodeBS :: Value -> ByteString+encodeBS = TE.encodeUtf8 . encode+++encodeDocument :: Document -> Text+encodeDocument = TL.toStrict . toLazyText . buildDoc+++encodeStream :: Stream -> Text+encodeStream (Stream docs) =+ TL.toStrict (toLazyText (V.ifoldl' (\acc i d -> acc <> buildDoc (d {docDirectivesEnd = i > 0 || docDirectivesEnd d})) mempty docs))+++-- ---------------------------------------------------------------------------+-- Document framing+-- ---------------------------------------------------------------------------++buildDoc :: Document -> Builder+buildDoc (Document directives explicitEnd body) =+ let !head_ = if directives then fromText "---\n" else mempty+ !body_ = buildTopLevel body+ !end_ = if explicitEnd then fromText "...\n" else mempty+ in head_ <> body_ <> end_+++buildTopLevel :: Value -> Builder+buildTopLevel v = case v of+ YMap kvs+ | V.null kvs -> fromText "{}\n"+ | otherwise -> buildBlockMap 0 kvs+ YSeq xs+ | V.null xs -> fromText "[]\n"+ | otherwise -> buildBlockSeq 0 xs+ scalar -> buildScalar scalar <> singleton '\n'+++-- ---------------------------------------------------------------------------+-- Block style+-- ---------------------------------------------------------------------------++buildBlockMap :: Int -> V.Vector (Value, Value) -> Builder+buildBlockMap !ind kvs = V.foldl' step mempty kvs+ where+ step !acc (k, v) = acc <> indent ind <> kvLine ind k v+++kvLine :: Int -> Value -> Value -> Builder+kvLine !ind k v =+ let !keyB = buildKey ind k+ !inner = v+ in case inner of+ YMap kvs+ | V.null kvs -> keyB <> fromText ": {}\n"+ | otherwise ->+ keyB <> fromText ":\n" <> buildBlockMap (ind + 2) kvs+ YSeq xs+ | V.null xs -> keyB <> fromText ": []\n"+ | otherwise ->+ keyB <> fromText ":\n" <> buildBlockSeq ind xs+ _ ->+ keyB <> fromText ": " <> buildScalar inner <> singleton '\n'+++buildBlockSeq :: Int -> V.Vector Value -> Builder+buildBlockSeq !ind xs = V.foldl' step mempty xs+ where+ step !acc x = acc <> indent ind <> seqLine ind x+++seqLine :: Int -> Value -> Builder+seqLine !ind v =+ let !inner = v+ in case inner of+ YMap kvs+ | V.null kvs -> fromText "- {}\n"+ | otherwise -> fromText "- " <> firstKvLine (ind + 2) kvs+ YSeq ys+ | V.null ys -> fromText "- []\n"+ | otherwise ->+ -- Nested block sequences inside a block sequence are+ -- emitted in flow style. The compact "- - x" form is+ -- valid YAML but round-trips ambiguously through+ -- plain-scalar resolution.+ fromText "- ["+ <> commaSep (V.map buildFlow ys)+ <> fromText "]\n"+ _ ->+ fromText "- " <> buildScalar inner <> singleton '\n'+++{- | Emit the first key-value pair on the same line as @-@, then the+rest at the deeper indent.+-}+firstKvLine :: Int -> V.Vector (Value, Value) -> Builder+firstKvLine !ind kvs+ | V.null kvs = mempty+ | otherwise =+ let (k, v) = V.head kvs+ rest = V.tail kvs+ in kvLine ind k v <> V.foldl' (\acc (k', v') -> acc <> indent ind <> kvLine ind k' v') mempty rest+++indent :: Int -> Builder+indent !n+ | n <= 0 = mempty+ | otherwise = fromText (T.replicate n " ")+++-- ---------------------------------------------------------------------------+-- Keys+-- ---------------------------------------------------------------------------++{- | Keys are rendered as scalars; complex (sequence / mapping) keys+are folded through the flow-style emitter inside an explicit-key+@?@ marker.+-}+buildKey :: Int -> Value -> Builder+buildKey ind key+ | explicitKey key = fromText "? " <> buildFlow key <> singleton '\n' <> indent ind+ | otherwise = buildScalar key+++-- A conservative bound accounts for escape expansion as well as the 1024+-- character limit on an implicit key. Complex keys use the unrestricted form.+explicitKey :: Value -> Bool+explicitKey = \case+ YMap _ -> True+ YSeq _ -> True+ YTagged _ _ -> True+ YAnchored _ _ -> True+ YAlias _ -> True+ YString text -> T.length text > 100+ YInt number -> number >= 10 ^ (100 :: Int) || number <= negate (10 ^ (100 :: Int))+ _ -> False+++-- ---------------------------------------------------------------------------+-- Scalar emission+-- ---------------------------------------------------------------------------++buildScalar :: Value -> Builder+buildScalar = \case+ YNull -> fromText "null"+ YBool True -> fromText "true"+ YBool False -> fromText "false"+ YInt n -> BI.decimal n+ YFloat d+ | isNaN d -> fromText ".nan"+ | isInfinite d && d > 0 -> fromText ".inf"+ | isInfinite d -> fromText "-.inf"+ | otherwise -> renderFloat d+ YString t -> renderString t+ v -> buildFlow v -- container fallthrough (shouldn't normally hit)+++{- | Render a 'Double' so that decoding produces the same value and+it is unambiguously a YAML float (i.e. always contains @.@ or @e@).+-}+renderFloat :: Double -> Builder+renderFloat = BF.realFloat+{-# INLINE renderFloat #-}+++-- ---------------------------------------------------------------------------+-- Flow style (used for keys + as fallback)+-- ---------------------------------------------------------------------------++buildFlow :: Value -> Builder+buildFlow v = case v of+ YTagged tag inner ->+ buildTag tag+ <> singleton ' '+ <> buildFlow inner+ YAnchored (Anchor name) inner -> singleton '&' <> fromText name <> singleton ' ' <> buildFlow inner+ YAlias (Anchor name) -> singleton '*' <> fromText name+ YMap kvs ->+ singleton '{' <> commaSep (V.map kvFlow kvs) <> singleton '}'+ YSeq xs ->+ singleton '[' <> commaSep (V.map buildFlow xs) <> singleton ']'+ scalar -> buildScalar scalar+ where+ kvFlow (k, val) = (if explicitKey k then fromText "? " else mempty) <> buildFlow k <> fromText ": " <> buildFlow val+++{- | Emit a resolved tag without accidentally introducing a named handle.+Tags are URI spellings: percent escapes are retained as supplied.+-}+buildTag :: Tag -> Builder+buildTag (Tag tag)+ | tag == "!" = singleton '!'+ | Just suffix <- T.stripPrefix "tag:yaml.org,2002:" tag, shorthandSafe suffix = fromText "!!" <> fromText suffix+ | Just suffix <- T.stripPrefix "!" tag, shorthandSafe suffix = fromText tag+ | otherwise = fromText "!<" <> fromText tag <> singleton '>'+ where+ shorthandSafe suffix = not (T.null suffix) && not (T.any (`T.elem` "!,[]{}") suffix)+++commaSep :: V.Vector Builder -> Builder+commaSep bs+ | V.null bs = mempty+ | otherwise = V.ifoldl' step mempty bs+ where+ step acc 0 b = acc <> b+ step acc _ b = acc <> fromText ", " <> b+++-- ---------------------------------------------------------------------------+-- String quoting+-- ---------------------------------------------------------------------------++{- | Strategy: prefer plain when safe, otherwise single-quoted, only+fall back to double-quoted for strings containing characters that+must be escaped (control characters or single quotes that would+require doubling).+-}+renderString :: Text -> Builder+renderString t+ | T.null t = fromText "''"+ | needsDoubleQuote t = doubleQuoted t+ | safePlain t = fromText t+ | otherwise = singleQuoted t+++doubleQuoted :: Text -> Builder+doubleQuoted t = singleton '"' <> T.foldr step (singleton '"') t+ where+ step c acc = escapeDQ c <> acc+++escapeDQ :: Char -> Builder+escapeDQ c = case c of+ '"' -> fromText "\\\""+ '\\' -> fromText "\\\\"+ '\n' -> fromText "\\n"+ '\t' -> fromText "\\t"+ '\r' -> fromText "\\r"+ '\0' -> fromText "\\0"+ '\a' -> fromText "\\a"+ '\b' -> fromText "\\b"+ '\v' -> fromText "\\v"+ '\f' -> fromText "\\f"+ '\x1B' -> fromText "\\e"+ _+ | mustEscape c ->+ let cp = ord c+ in if cp <= 0xFF+ then fromText "\\x" <> hex 2 cp+ else+ if cp <= 0xFFFF+ then fromText "\\u" <> hex 4 cp+ else fromText "\\U" <> hex 8 cp+ | otherwise -> singleton c+++hex :: Int -> Int -> Builder+hex width value =+ let digits number | number < 16 = 1 | otherwise = 1 + digits (number `quot` 16)+ in fromText (T.replicate (max 0 (width - digits value)) "0") <> BI.hexadecimal value+++singleQuoted :: Text -> Builder+singleQuoted t =+ singleton '\'' <> fromText (T.replace "'" "''" t) <> singleton '\''+++{- | A scalar can be emitted plain when:++* It's not parsed as a non-string scalar by the core schema+ (true / false / null / number / etc.).+* It does not contain any of the YAML indicator characters that+ would change the parse (@: { } [ ] , & * # ? | > ' " % @ \`@) in+ places that matter, or whitespace next to colons that would+ confuse the block scanner.+-}+safePlain :: Text -> Bool+safePlain t = not (parsesAsScalar t) && plainSyntaxSafe t+++{- | Conservative syntax check shared with the pretty-printer. Schema-like+words may be unquoted only when the caller deliberately permits coercion.+-}+plainSyntaxSafe :: Text -> Bool+plainSyntaxSafe t+ | T.null t = False+ | t == "..." = False+ | startBad (T.head t) = False+ | endsWithSpace = False+ | T.any unsafePlainChar t = False+ | T.any mustEscape t = False+ | T.isInfixOf ": " t = False+ | T.isInfixOf ":\t" t = False+ | T.isSuffixOf ":" t = False+ | T.isInfixOf " #" t = False+ | otherwise = True+ where+ startBad c = case c of+ '!' -> True+ '&' -> True+ '*' -> True+ '?' -> True+ '|' -> True+ '>' -> True+ '\'' -> True+ '"' -> True+ '%' -> True+ '@' -> True+ '`' -> True+ '#' -> True+ ',' -> True+ '[' -> True+ ']' -> True+ '{' -> True+ '}' -> True+ ':' -> True+ '-' -> True+ ' ' -> True+ '\t' -> True+ _ -> False+ endsWithSpace = case T.unsnoc t of+ Just (_, c) -> c == ' ' || c == '\t'+ Nothing -> False+++unsafePlainChar :: Char -> Bool+unsafePlainChar c =+ -- These cause parse ambiguity nearly anywhere in a plain scalar.+ c == ','+ || c == '['+ || c == ']'+ || c == '{'+ || c == '}'+ || c == '&'+ || c == '*'+ || c == '\n'+ || c == '\r'+++{- | Conservative recogniser for strings the core schema would parse+as a non-string scalar. We must quote those when they appear as a+string value so the round-trip is faithful.+-}+parsesAsScalar :: Text -> Bool+parsesAsScalar t = case T.toLower t of+ "<<" -> True+ "null" -> True+ "~" -> True+ "" -> True+ "true" -> True+ "false" -> True+ "yes" -> True+ "no" -> True+ "on" -> True+ "off" -> True+ ".inf" -> True+ "+.inf" -> True+ "-.inf" -> True+ ".nan" -> True+ s ->+ looksLikeInt s || looksLikeFloat s+++{- | Conservative integer recogniser matching the YAML 1.2 core+schema: optional sign, then decimal / hex (@0x@) / octal (@0o@).+-}+looksLikeInt :: Text -> Bool+looksLikeInt s = case T.uncons s of+ Just ('+', rest) -> goDec rest+ Just ('-', rest) -> goDec rest+ _ -> goDec s+ where+ goDec s'+ | T.isPrefixOf "0x" s' || T.isPrefixOf "0X" s' =+ let r = T.drop 2 s' in not (T.null r) && T.all isHex r+ | T.isPrefixOf "0o" s' || T.isPrefixOf "0O" s' =+ let r = T.drop 2 s' in not (T.null r) && T.all isOct r+ | otherwise = not (T.null s') && T.all isDigit s'+ isHex c = isDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')+ isOct c = c >= '0' && c <= '7'+++looksLikeFloat :: Text -> Bool+looksLikeFloat s =+ let s' = case T.uncons s of+ Just ('+', r) -> r+ Just ('-', r) -> r+ _ -> s+ hasDigit = T.any isDigit s'+ hasMark = T.any (\c -> c == '.' || c == 'e' || c == 'E') s'+ onlyOK =+ T.all+ ( \c ->+ isDigit c+ || c == '.'+ || c == 'e'+ || c == 'E'+ || c == '+'+ || c == '-'+ )+ s'+ in hasDigit && hasMark && onlyOK+++needsDoubleQuote :: Text -> Bool+needsDoubleQuote = T.any badForSingle+ where+ badForSingle c =+ mustEscape c && c /= '\t'+++mustEscape :: Char -> Bool+mustEscape c = isControl c || c == '\xFEFF' || c == '\xFFFE' || c == '\xFFFF'
+ src/YAML/Encoding.hs view
@@ -0,0 +1,35 @@+{- | Direct-to-AST YAML encoding, mirroring aeson's @toEncoding@+approach.++YAML's block-vs-flow / indentation decisions depend on the+surrounding document position, so a streaming 'Builder' is a+poor fit; 'YAML.Encoding.Encoding' wraps a fully-built+'YAML.Value.Value' and routes through 'YAML.Encode.encode'. The+aeson-style API matches the rest of the formats so it can be+swapped in transparently if a streaming pretty-printer arrives.+-}+module YAML.Encoding (+ Encoding (..),+ encodingToValue,+ encodingToText,+ value,+) where++import Data.Text (Text)+import YAML.Encode qualified as YE+import YAML.Value qualified as YV+++newtype Encoding = Encoding {runEncoding :: YV.Value}+++encodingToValue :: Encoding -> YV.Value+encodingToValue = runEncoding+++encodingToText :: Encoding -> Text+encodingToText = YE.encode . runEncoding+++value :: YV.Value -> Encoding+value = Encoding
+ src/YAML/Internal.hs view
@@ -0,0 +1,37 @@+{- | YAML separation is ASCII space and tab. Unicode spaces and NEL/LS/PS+remain scalar content under YAML 1.2, including at scalar boundaries.+-}+module YAML.Internal (+ isYamlSpace,+ stripYaml,+ stripYamlStart,+ stripYamlEnd,+ wordsYaml,+) where++import Data.Text (Text)+import Data.Text qualified as T+++isYamlSpace :: Char -> Bool+isYamlSpace char = char == ' ' || char == '\t'+{-# INLINE isYamlSpace #-}+++stripYaml :: Text -> Text+stripYaml = T.dropAround isYamlSpace+{-# INLINE stripYaml #-}+++stripYamlStart :: Text -> Text+stripYamlStart = T.dropWhile isYamlSpace+{-# INLINE stripYamlStart #-}+++stripYamlEnd :: Text -> Text+stripYamlEnd = T.dropWhileEnd isYamlSpace+{-# INLINE stripYamlEnd #-}+++wordsYaml :: Text -> [Text]+wordsYaml = filter (not . T.null) . T.split isYamlSpace
+ src/YAML/JSON.hs view
@@ -0,0 +1,98 @@+{- | Lossy bridge between YAML 'YV.Value' and Aeson 'A.Value'.++YAML is a superset of JSON in the data model, but the YAML core+schema admits scalars (notably non-string mapping keys) that JSON+cannot represent directly. We follow the same conventions other+@<Format>.JSON@ modules use:++* Mapping keys are coerced to text via 'showKey'. Keys that are+ already 'YV.YString' pass through verbatim; numeric, boolean and+ null keys are stringified.+* Non-finite floats and unresolved aliases become JSON null.+* Tags / anchors are stripped (they are part of the YAML+ representation graph, not the data model).+-}+module YAML.JSON (+ yamlToJSON,+ jsonToYAML,+) where++import Data.Aeson qualified as A+import Data.Aeson.Key qualified as AK+import Data.Aeson.KeyMap qualified as AKM+import Data.Scientific qualified as Sci+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Int qualified as BI+import Data.Text.Lazy.Builder.RealFloat qualified as BF+import Data.Text.Lazy.Builder.Scientific (scientificBuilder)+import Data.Vector qualified as V+import YAML.Decode qualified as YD+import YAML.Value qualified as YV+++yamlToJSON :: YV.Value -> A.Value+yamlToJSON v = case v of+ YV.YNull -> A.Null+ YV.YBool b -> A.Bool b+ YV.YInt n -> A.Number (fromIntegral n)+ YV.YFloat d+ | isNaN d || isInfinite d -> A.Null+ | otherwise -> A.Number (Sci.fromFloatDigits d)+ YV.YString t -> A.String t+ YV.YSeq xs -> A.Array (V.map yamlToJSON xs)+ YV.YMap kvs -> A.Object (AKM.fromList (V.toList (V.map mkPair kvs)))+ YV.YTagged tag inner -> applyTag tag inner+ YV.YAnchored _ inner -> yamlToJSON inner+ YV.YAlias _ -> A.Null+ where+ mkPair (k, val) = (AK.fromText (showKey k), yamlToJSON val)+++{- | Resolve the value under an explicit YAML tag. The standard+@tag:yaml.org,2002:str@ tag with a null body produces @""@,+because @!!str@ on an empty source means "force-string-typed+empty scalar"; without this rule round-tripping+@!!str@-tagged null values gives the wrong JSON shape.+-}+applyTag :: YV.Tag -> YV.Value -> A.Value+applyTag tag@(YV.Tag t) v+ | t == "tag:yaml.org,2002:str" = case YV.unwrap v of+ YV.YNull -> A.String T.empty+ YV.YString text -> A.String text+ YV.YBool b -> A.String (if b then "true" else "false")+ YV.YInt n -> A.String (builderText (BI.decimal n))+ YV.YFloat d -> A.String (builderText (BF.realFloat d))+ _ -> yamlToJSON v+ | otherwise = maybe (yamlToJSON v) yamlToJSON (YD.resolveExplicitTag tag v)+++builderText :: TB.Builder -> Text+builderText = TL.toStrict . TB.toLazyText+++showKey :: YV.Value -> Text+showKey v = case yamlToJSON v of+ A.String s -> s+ A.Null -> T.pack ""+ A.Bool b -> if b then T.pack "true" else T.pack "false"+ A.Number n -> builderText (scientificBuilder n)+ _ -> T.pack "<complex>"+++jsonToYAML :: A.Value -> YV.Value+jsonToYAML = \case+ A.Null -> YV.YNull+ A.Bool b -> YV.YBool b+ A.String t -> YV.YString t+ A.Number n ->+ case Sci.floatingOrInteger n of+ Left d -> YV.YFloat (d :: Double)+ Right i -> YV.YInt (i :: Integer)+ A.Array xs -> YV.YSeq (V.map jsonToYAML xs)+ A.Object o ->+ YV.YMap (V.fromList (fmap mkPair (AKM.toList o)))+ where+ mkPair (k, val) = (YV.YString (AK.toText k), jsonToYAML val)
+ src/YAML/Pretty.hs view
@@ -0,0 +1,1235 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Pretty-printing for 'YAML.Value.Value' and+'YAML.Annotated.AValue' with configurable layout.++The fast emitter in "YAML.Encode" is biased toward producing+compact, canonical output. 'YAML.Pretty.render' / 'renderAnnotated'+here lets you wrap long flow collections, force quoting on+ambiguous scalars, switch between block and flow styles, etc.+-}+module YAML.Pretty (+ -- * Options+ RenderOptions (..),+ defaultOptions,+ compactOptions,++ -- * Style preferences+ StringStyleHint (..),++ -- * Render entry points+ render,+ renderDocument,+ renderStream,+ renderBS,+ renderAnnotated,+ renderAnnotatedDocument,+ renderAnnotatedStream,+) where++import Control.DeepSeq (NFData)+import Data.ByteString qualified as BS+import Data.Char (isControl, isPrint, ord)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder (+ Builder,+ fromText,+ singleton,+ toLazyText,+ )+import Data.Text.Lazy.Builder.Int qualified as BI+import Data.Text.Lazy.Builder.RealFloat qualified as BF+import Data.Vector qualified as V+import GHC.Generics (Generic)+import YAML.Annotated (+ ABody (..),+ ADocument (..),+ AMapEntry (..),+ AStream (..),+ AValue (..),+ Comment (..),+ MapStyle (..),+ ScalarStyle (..),+ SeqStyle (..),+ SrcSpan (..),+ Trivia (..),+ prepareForRendering,+ )+import YAML.Decode qualified as YD+import YAML.Encode qualified as YE+import YAML.Internal (stripYamlStart)+import YAML.Value (+ Anchor (..),+ Document (..),+ Stream (..),+ Tag (..),+ Value (..),+ )+import YAML.Value qualified as YV+++-- ---------------------------------------------------------------------------+-- Options+-- ---------------------------------------------------------------------------++-- | What style to prefer for fresh strings.+data StringStyleHint+ = -- | Plain when safe, double-quoted otherwise.+ HintAuto+ | HintAlwaysDouble+ | HintAlwaysSingle+ | -- | For multi-line strings.+ HintLiteralBlock+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | Tunables for the pretty-printer.+data RenderOptions = RenderOptions+ { roIndent :: {-# UNPACK #-} !Int+ -- ^ Spaces per indent level. Default @2@.+ , roMaxLineWidth :: {-# UNPACK #-} !Int+ {- ^ Soft maximum line width, used to decide when to wrap+ long flow collections onto multiple lines and when to+ promote a long block scalar to a literal block. Default+ @100@. Set to 'maxBound' to disable wrapping.+ -}+ , roDefaultMapStyle :: !MapStyle+ -- ^ How fresh mappings render. Default 'MapBlock'.+ , roDefaultSeqStyle :: !SeqStyle+ -- ^ How fresh sequences render. Default 'SeqBlock'.+ , roStringStyleHint :: !StringStyleHint+ -- ^ How fresh strings render. Default 'HintAuto'.+ , roCompactSeqOfMap :: !Bool+ {- ^ Use the @- key: value@ compact form for mappings as+ sequence items. Default 'True'.+ -}+ , roQuoteAmbiguousScalars :: !Bool+ {- ^ Quote a fresh plain string when its content would parse+ back as another core-schema literal (number, bool, null).+ Default 'True'.+ -}+ , roDocStartMarker :: !Bool+ {- ^ Emit a leading @---@ on every document. Default 'False'+ for single-document streams; 'True' for multi-document+ streams (forced by 'renderStream').+ -}+ , roDocEndMarker :: !Bool+ -- ^ Emit a trailing @...@ marker. Default 'False'.+ , roTrailingNewline :: !Bool+ -- ^ Emit a final @\n@ at end of stream. Default 'True'.+ , roPreserveOriginalText :: !Bool+ {- ^ When 'True' (the default), unchanged sub-trees in an+ annotated render reuse their original source bytes+ verbatim. Set to 'False' to force re-emission everywhere+ (useful for normalising / canonicalising a document).+ -}+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | Sensible defaults for human-readable output.+defaultOptions :: RenderOptions+defaultOptions =+ RenderOptions+ { roIndent = 2+ , roMaxLineWidth = 100+ , roDefaultMapStyle = MapBlock+ , roDefaultSeqStyle = SeqBlock+ , roStringStyleHint = HintAuto+ , roCompactSeqOfMap = True+ , roQuoteAmbiguousScalars = True+ , roDocStartMarker = False+ , roDocEndMarker = False+ , roTrailingNewline = True+ , roPreserveOriginalText = True+ }+++{- | Compact emission: short lines, no padding, prefer flow when+it's shorter.+-}+compactOptions :: RenderOptions+compactOptions =+ defaultOptions+ { roIndent = 2+ , roMaxLineWidth = 200+ , roDefaultMapStyle = MapFlow+ , roDefaultSeqStyle = SeqFlow+ , roStringStyleHint = HintAuto+ , roCompactSeqOfMap = True+ , roTrailingNewline = False+ }+++-- ---------------------------------------------------------------------------+-- Render entry points+-- ---------------------------------------------------------------------------++-- | Render a 'Value' to 'Text' using the given options.+render :: RenderOptions -> Value -> Text+render opts v = TL.toStrict (toLazyText (build (validIndent opts) v))+++renderBS :: RenderOptions -> Value -> BS.ByteString+renderBS opts = TE.encodeUtf8 . render opts+++renderDocument :: RenderOptions -> Document -> Text+renderDocument opts (Document start end body) =+ render (opts {roDocStartMarker = start || roDocStartMarker opts, roDocEndMarker = end || roDocEndMarker opts}) body+++renderStream :: RenderOptions -> Stream -> Text+renderStream opts (Stream docs) = TL.toStrict (toLazyText (V.ifoldl' step mempty docs))+ where+ step acc i doc =+ acc+ <> fromText+ ( renderDocument+ (opts {roDocStartMarker = i > 0 || roDocStartMarker opts, roTrailingNewline = i < V.length docs - 1 || roTrailingNewline opts})+ doc+ )+++{- | Render an 'AValue' tree. Uses the original source bytes for+sub-trees that haven't been modified (when+'roPreserveOriginalText' is on); falls back to the pretty-+printer otherwise.+-}+data SourceText = SourceText+ { originalText :: !Text+ , originalBytes :: !BS.ByteString+ }+++sourceText :: Text -> SourceText+sourceText text = SourceText text (TE.encodeUtf8 text)+++renderAnnotated :: RenderOptions -> AValue -> Maybe Text -> Text+renderAnnotated requested av original =+ let options = freshOptions requested+ body = buildAValue options (sourceText <$> original) 0 ChildOfDoc (prepareForRendering av) {avDirty = True}+ rendered = frameValue options body+ in preserveLineEndings requested original (TL.toStrict (toLazyText rendered))+++renderAnnotatedDocument :: RenderOptions -> ADocument -> Maybe Text -> Text+renderAnnotatedDocument opts doc original = renderAnnotatedDocumentWithSource opts doc (sourceText <$> original)+++renderAnnotatedDocumentWithSource :: RenderOptions -> ADocument -> Maybe SourceText -> Text+renderAnnotatedDocumentWithSource opts doc@(ADocument start end body _ original _ _) msrc+ | roPreserveOriginalText opts+ , not (avDirty body)+ , not (roDocStartMarker opts && not start)+ , not (roDocEndMarker opts && not end)+ , Just sp <- original+ , Just src <- msrc+ , Just text <- spanSlice src sp =+ text+ | otherwise = renderAnnotatedDocumentFresh opts doc msrc+++renderAnnotatedDocumentFresh :: RenderOptions -> ADocument -> Maybe SourceText -> Text+renderAnnotatedDocumentFresh requested (ADocument start end originalBody leading original trailing directives) msrc =+ preserveLineEndings requested documentSource $+ TL.toStrict+ ( toLazyText+ ( finish+ ( foldMap (\line -> fromText line <> singleton '\n') directives+ <> (if start || roDocStartMarker opts || not (null directives) then fromText "---\n" else mempty)+ <> emitComments 0 leading+ <> emittedBody+ <> emitComments 0 trailing+ <> (if end || roDocEndMarker opts then fromText "...\n" else mempty)+ )+ )+ )+ where+ documentSource =+ msrc >>= \source -> case original of+ Just span_ -> spanSlice source span_+ Nothing -> Just (originalText source)+ body = prepareForRendering originalBody+ opts = freshOptions requested+ rawBody = buildAValue opts msrc 0 ChildOfDoc (case original of Just _ -> body {avDirty = True}; Nothing -> body)+ emittedBody = if roTrailingNewline opts || end || roDocEndMarker opts || not (null trailing) then ensureNewline rawBody else rawBody+ finish = if roTrailingNewline opts then id else dropFinalNewline+++-- Removing the final physical newline of a copied literal can change its value.+-- When regenerating without a final newline, emit scalars with escaped breaks.+freshOptions :: RenderOptions -> RenderOptions+freshOptions opts+ | roTrailingNewline opts = validIndent opts+ | otherwise = (validIndent opts) {roPreserveOriginalText = False}+++validIndent :: RenderOptions -> RenderOptions+validIndent opts = opts {roIndent = max 1 (roIndent opts)}+++preserveLineEndings :: RenderOptions -> Maybe Text -> Text -> Text+preserveLineEndings opts (Just source) output+ | roPreserveOriginalText opts+ , Just ending <- uniformEnding source =+ T.replace "\n" ending (T.replace "\r" "\n" (T.replace "\r\n" "\n" output))+ where+ uniformEnding text+ | T.isInfixOf "\r\n" text, not (T.any (\c -> c == '\r' || c == '\n') (T.replace "\r\n" "" text)) = Just "\r\n"+ | T.any (== '\r') text, not (T.any (== '\n') text) = Just "\r"+ | otherwise = Nothing+preserveLineEndings _ _ output = output+++renderAnnotatedStream :: RenderOptions -> AStream -> Maybe Text -> Text+renderAnnotatedStream opts (AStream docs) msrc+ | V.null docs = if roPreserveOriginalText opts then maybe T.empty id msrc else T.empty+ | V.length docs == 1 =+ renderAnnotatedDocumentWithSource opts (V.head docs) cachedSource+ | otherwise = TL.toStrict (toLazyText (V.foldl' step mempty (V.indexed docs)))+ where+ cachedSource = sourceText <$> msrc+ step acc (i, d) =+ let docOpts = opts {roDocStartMarker = roDocStartMarker opts || (i > 0 && not (adExplicitEnd (docs V.! (i - 1)))), roTrailingNewline = i < V.length docs - 1 || roTrailingNewline opts}+ text = renderAnnotatedDocumentWithSource docOpts d cachedSource+ separator = if i < V.length docs - 1 && not (T.isSuffixOf "\n" text || T.isSuffixOf "\r" text) then singleton '\n' else mempty+ in acc <> fromText text <> separator+++-- ---------------------------------------------------------------------------+-- Common building blocks+-- ---------------------------------------------------------------------------++build :: RenderOptions -> Value -> Builder+build opts v0 = frameValue opts (buildValue opts 0 ChildOfDoc v0)+++frameValue :: RenderOptions -> Builder -> Builder+frameValue opts body =+ let body' = if roTrailingNewline opts || roDocEndMarker opts then ensureNewline body else body+ framed =+ (if roDocStartMarker opts then fromText "---\n" else mempty)+ <> body'+ <> (if roDocEndMarker opts then fromText "...\n" else mempty)+ in if roTrailingNewline opts then framed else dropFinalNewline framed+++ensureNewline :: Builder -> Builder+ensureNewline body = if endsWithNL body then body else body <> singleton '\n'+++dropFinalNewline :: Builder -> Builder+dropFinalNewline builder =+ let text = toLazyText builder+ in fromText (TL.toStrict (maybe text id (TL.stripSuffix "\n" text)))+++-- A 'ChildContext' tells emitters how the value is being placed+-- (top-level, inside a block sequence item, inside a mapping+-- value at column N, etc.). It governs leading whitespace and+-- compact-form decisions.+data ChildContext+ = ChildOfDoc+ | {- | Same line as the mapping key's @:@; if the value fits+ inline we emit it after a single space, otherwise we go+ to the next line indented past the key.+ -}+ ChildOfMapValueInline+ | {- | Following a @-@ on the same line; treat similarly to+ 'ChildOfMapValueInline'.+ -}+ ChildOfSeqItem+++{- | Approximate the rendered length of a value to decide whether+it fits on one line. We don't need exactness — only enough to+make a flow / block / wrap decision.+-}+approxFlowLength :: Value -> Int+approxFlowLength = go+ where+ go = \case+ YNull -> 4+ YBool b -> if b then 4 else 5+ YInt n -> fromIntegral (TL.length (toLazyText (BI.decimal n)))+ YFloat d -> fromIntegral (TL.length (toLazyText (formatDouble d)))+ YString t -> 2 + T.length t -- worst case: quoted+ YSeq xs+ | V.null xs -> 2+ | otherwise ->+ 2+ + V.length xs * 2+ + V.sum (V.map go xs)+ YMap kvs+ | V.null kvs -> 2+ | otherwise ->+ 2+ + V.length kvs * 4+ + V.sum (V.map (\(k, v) -> go k + go v) kvs)+ YTagged _ x -> 6 + go x+ YAnchored _ x -> 6 + go x+ YAlias (Anchor name) -> 1 + T.length name+{-# INLINE approxFlowLength #-}+++-- | Indent emission: @n@ spaces.+spaces :: Int -> Builder+spaces n+ | n <= 0 = mempty+ | otherwise = fromText (T.replicate n (T.singleton ' '))+++{- | Does this builder, when forced, end with @\n@? We need only+a coarse approximation; if in doubt, return 'False' so the+caller emits a separator.+-}+endsWithNL :: Builder -> Bool+endsWithNL b = case TL.unsnoc (toLazyText b) of+ Just (_, '\n') -> True+ _ -> False+++-- ---------------------------------------------------------------------------+-- Value rendering (un-annotated)+-- ---------------------------------------------------------------------------++buildValue :: RenderOptions -> Int -> ChildContext -> Value -> Builder+buildValue opts !ind ctx v = case v of+ YNull -> emitScalar opts ind ctx YNull+ YBool _ -> emitScalar opts ind ctx v+ YInt _ -> emitScalar opts ind ctx v+ YFloat _ -> emitScalar opts ind ctx v+ YString _ -> emitScalar opts ind ctx v+ YSeq xs+ | V.null xs -> contextSeparator ctx <> fromText "[]\n"+ | otherwise -> emitSeq opts ind ctx xs (roDefaultSeqStyle opts)+ YMap kvs+ | V.null kvs -> contextSeparator ctx <> fromText "{}\n"+ | otherwise -> emitMap opts ind ctx kvs (roDefaultMapStyle opts)+ property -> contextSeparator ctx <> emitFlowValue opts ind property <> singleton '\n'+++{- | Builder used inline (after the colon / dash separator) on the+same line as the parent's marker.+-}+buildValueFlat :: RenderOptions -> Int -> Value -> Builder+buildValueFlat opts ind = buildValue opts ind ChildOfMapValueInline+++contextSeparator :: ChildContext -> Builder+contextSeparator = \case+ ChildOfDoc -> mempty+ ChildOfMapValueInline -> singleton ' '+ ChildOfSeqItem -> mempty+++-- ----- Sequences -----++emitSeq :: RenderOptions -> Int -> ChildContext -> V.Vector Value -> SeqStyle -> Builder+emitSeq opts ind ctx xs style+ | shouldFlowSeq opts ind xs style =+ contextSeparator ctx <> emitFlowSeq opts ind xs <> singleton '\n'+ | otherwise =+ ( case ctx of+ ChildOfMapValueInline -> singleton '\n'+ ChildOfSeqItem -> singleton '\n'+ _ -> mempty+ )+ <> V.foldl' step mempty xs+ where+ step acc x =+ acc+ <> spaces ind+ <> fromText "- "+ <> buildSeqItem opts (ind + 2) x+++shouldFlowSeq :: RenderOptions -> Int -> V.Vector Value -> SeqStyle -> Bool+shouldFlowSeq opts ind xs style =+ case style of+ SeqFlow -> True+ SeqBlock ->+ ind + V.sum (V.map approxFlowLength xs) + 2 * V.length xs + 2+ <= roMaxLineWidth opts+ && V.all isLeaf xs+ -- only auto-flow when items are leaf scalars, avoid+ -- nesting flow inside block by accident+ && False -- block style stays block by default+ where+ isLeaf = \case+ YSeq {} -> False+ YMap {} -> False+ YTagged _ x -> isLeaf (YV.unwrap x)+ YAnchored _ x -> isLeaf (YV.unwrap x)+ _ -> True+++buildSeqItem :: RenderOptions -> Int -> Value -> Builder+buildSeqItem opts ind v+ | roCompactSeqOfMap opts+ , roDefaultMapStyle opts == MapBlock+ , YMap kvs <- v+ , not (V.null kvs) =+ emitCompactSeqMap opts ind kvs+ | YSeq xs <- v+ , not (V.null xs) =+ singleton '\n' <> emitSeq opts ind ChildOfDoc xs (roDefaultSeqStyle opts)+ | otherwise = buildValue opts ind ChildOfSeqItem v+++emitCompactSeqMap :: RenderOptions -> Int -> V.Vector (Value, Value) -> Builder+emitCompactSeqMap opts ind kvs+ | V.null kvs = fromText "{}\n"+ | otherwise =+ let (k0, v0) = V.head kvs+ rest = V.tail kvs+ in emitMapEntry opts ind 0 k0 v0+ <> V.foldl' step mempty rest+ where+ step acc (k, v) = acc <> emitMapEntry opts ind ind k v+++-- ----- Mappings -----++emitMap :: RenderOptions -> Int -> ChildContext -> V.Vector (Value, Value) -> MapStyle -> Builder+emitMap opts ind ctx kvs style+ | shouldFlowMap opts ind kvs style =+ contextSeparator ctx <> emitFlowMap opts ind kvs <> singleton '\n'+ | otherwise =+ ( case ctx of+ ChildOfMapValueInline -> singleton '\n'+ ChildOfSeqItem -> singleton '\n'+ _ -> mempty+ )+ <> V.foldl' step mempty kvs+ where+ step acc (k, v) = acc <> emitMapEntry opts ind ind k v+++shouldFlowMap :: RenderOptions -> Int -> V.Vector (Value, Value) -> MapStyle -> Bool+shouldFlowMap opts ind kvs = \case+ MapFlow -> True+ MapBlock ->+ ind+ + V.sum (V.map (\(k, v) -> approxFlowLength k + approxFlowLength v) kvs)+ + 4 * V.length kvs+ + 2+ <= roMaxLineWidth opts+ && False -- prefer block by default+++emitMapEntry :: RenderOptions -> Int -> Int -> Value -> Value -> Builder+emitMapEntry opts childInd indentForLine k v =+ spaces indentForLine+ <> emitBlockKey opts childInd k+ <> fromText ":"+ <> buildValueFlat opts (childInd + roIndent opts) v+++emitBlockKey :: RenderOptions -> Int -> Value -> Builder+emitBlockKey opts ind key+ | YE.explicitKey key = fromText "? " <> emitFlowValue opts (ind + 2) key <> singleton '\n' <> spaces ind+ | otherwise = emitMapKey opts ind key+++emitMapKey :: RenderOptions -> Int -> Value -> Builder+emitMapKey opts ind k = case k of+ YString t -> emitPlainOrQuotedKey opts t+ YInt n -> BI.decimal n+ YBool b -> fromText (if b then "true" else "false")+ YNull -> fromText "null"+ YFloat d -> formatDouble d+ other -> emitFlowValue opts ind other+++emitPlainOrQuotedKey :: RenderOptions -> Text -> Builder+emitPlainOrQuotedKey opts t+ | roStringStyleHint opts == HintAlwaysDouble = doubleQuoted t+ | roStringStyleHint opts == HintAlwaysSingle, not (T.any YE.mustEscape t) = singleQuoted t+ | needsQuoting opts t = doubleQuoted t+ | otherwise = fromText t+++-- ----- Scalars -----++emitScalar :: RenderOptions -> Int -> ChildContext -> Value -> Builder+emitScalar opts ind ctx (YString text)+ | useLiteral opts text = contextSeparator ctx <> literalFor opts ind ctx text+emitScalar opts ind ctx v =+ contextSeparator ctx <> emitScalarBody opts ind v <> singleton '\n'+++emitScalarBody :: RenderOptions -> Int -> Value -> Builder+emitScalarBody opts ind = \case+ YNull -> fromText "null"+ YBool b -> fromText (if b then "true" else "false")+ YInt n -> BI.decimal n+ YFloat d -> formatDouble d+ YString t -> emitString opts t+ v -> emitFlowValue opts ind v+++emitString :: RenderOptions -> Text -> Builder+emitString opts t+ | T.any YE.mustEscape t = doubleQuoted t+ | otherwise = case roStringStyleHint opts of+ HintAlwaysDouble -> doubleQuoted t+ HintAlwaysSingle -> singleQuoted t+ HintLiteralBlock | needsBlock -> literalBlock t+ _ -> case classifyString opts t of+ KsPlain -> fromText t+ KsDouble -> doubleQuoted t+ KsSingle -> singleQuoted t+ KsLiteral -> literalBlock t+ where+ needsBlock = T.any (== '\n') t+++data KeyStr = KsPlain | KsDouble | KsSingle | KsLiteral+++classifyString :: RenderOptions -> Text -> KeyStr+classifyString opts t+ | T.null t = KsDouble+ | T.any (\c -> c == '\n' || c == '\r') t = KsDouble+ | hasUnsafeChar = KsDouble+ | parsesAsLiteral = KsDouble+ | otherwise = KsPlain+ where+ hasUnsafeChar =+ T.any+ (\c -> c == '"' || c == '\\' || isControl c)+ t++ parsesAsLiteral = needsQuoting opts t+++needsQuoting :: RenderOptions -> Text -> Bool+needsQuoting opts text = not (YE.plainSyntaxSafe text) || (roQuoteAmbiguousScalars opts && not (YE.safePlain text))+++useLiteral :: RenderOptions -> Text -> Bool+useLiteral opts text =+ T.any (== '\n') text+ && not (T.any (\c -> c == '\r' || (YE.mustEscape c && c /= '\n' && c /= '\t')) text)+ && roStringStyleHint opts `elem` [HintAuto, HintLiteralBlock]+ && roTrailingNewline opts+++doubleQuoted :: Text -> Builder+doubleQuoted t = singleton '"' <> escapeDQ t <> singleton '"'+++escapeDQ :: Text -> Builder+escapeDQ = T.foldr step mempty+ where+ step c acc = case c of+ '"' -> fromText "\\\"" <> acc+ '\\' -> fromText "\\\\" <> acc+ '\n' -> fromText "\\n" <> acc+ '\r' -> fromText "\\r" <> acc+ '\t' -> fromText "\\t" <> acc+ _+ | isControl c || not (isPrint c) ->+ hexEscape (ord c) <> acc+ _ -> singleton c <> acc+++singleQuoted :: Text -> Builder+singleQuoted t = singleton '\'' <> fromText (T.replace "'" "''" t) <> singleton '\''+++literalBlock :: Text -> Builder+literalBlock = literalBlockAt 0 2+++literalFor :: RenderOptions -> Int -> ChildContext -> Text -> Builder+literalFor opts ind ctx text =+ let base = case ctx of+ ChildOfDoc -> 0+ ChildOfMapValueInline -> max 0 (ind - roIndent opts)+ ChildOfSeqItem -> max 0 (ind - 2)+ width = max 1 (min 9 (roIndent opts))+ in literalBlockAt base width text+++literalBlockAt :: Int -> Int -> Text -> Builder+literalBlockAt base width text =+ let trailing = T.length (T.takeWhileEnd (== '\n') text)+ chomp+ | trailing == 0 = "-"+ | trailing > 1 || T.all (== '\n') text = "+"+ | otherwise = ""+ body = if trailing == 0 then text else T.dropEnd 1 text+ rows = if T.null text then [] else T.splitOn "\n" body+ needsHint = case T.uncons (T.dropWhile (== '\n') text) of+ Just (c, _) -> c == ' ' || c == '\t'+ Nothing -> False+ in singleton '|'+ <> (if needsHint then BI.decimal width else mempty)+ <> fromText chomp+ <> singleton '\n'+ <> foldMap (\line -> (if T.null line then mempty else spaces (base + width) <> fromText line) <> singleton '\n') rows+++-- ----- Flow style -----++emitFlowValue :: RenderOptions -> Int -> Value -> Builder+emitFlowValue opts ind = \case+ YNull -> fromText "null"+ YBool b -> fromText (if b then "true" else "false")+ YInt n -> BI.decimal n+ YFloat d -> formatDouble d+ YString t -> emitFlowString opts t+ YSeq xs -> emitFlowSeq opts ind xs+ YMap kvs -> emitFlowMap opts ind kvs+ YTagged tg x ->+ tagPrefix tg <> singleton ' ' <> emitFlowValue opts ind x+ YAlias (Anchor n) -> singleton '*' <> fromText n+ YAnchored (Anchor n) x ->+ singleton '&'+ <> fromText n+ <> singleton ' '+ <> emitFlowValue opts ind x+++emitFlowSeq :: RenderOptions -> Int -> V.Vector Value -> Builder+emitFlowSeq opts ind xs+ | V.null xs = fromText "[]"+ | otherwise =+ let approx =+ ind+ + 2+ + V.length xs * 2+ + V.sum (V.map approxFlowLength xs)+ in if approx <= roMaxLineWidth opts+ then+ singleton '['+ <> V.ifoldl' (\acc i x -> acc <> (if i == 0 then mempty else fromText ", ") <> emitFlowValue opts ind x) mempty xs+ <> singleton ']'+ else multiLineFlowSeq opts ind xs+++multiLineFlowSeq :: RenderOptions -> Int -> V.Vector Value -> Builder+multiLineFlowSeq opts ind xs =+ fromText "[\n"+ <> V.foldl' step mempty (V.indexed xs)+ <> spaces ind+ <> singleton ']'+ where+ step acc (i, x) =+ acc+ <> spaces (ind + roIndent opts)+ <> emitFlowValue opts (ind + roIndent opts) x+ <> (if i < V.length xs - 1 then singleton ',' else mempty)+ <> singleton '\n'+++emitFlowMap :: RenderOptions -> Int -> V.Vector (Value, Value) -> Builder+emitFlowMap opts ind kvs+ | V.null kvs = fromText "{}"+ | otherwise =+ let approx =+ ind+ + 2+ + V.length kvs * 4+ + V.sum+ ( V.map+ ( \(k, v) ->+ approxFlowLength k + approxFlowLength v+ )+ kvs+ )+ in if approx <= roMaxLineWidth opts+ then+ singleton '{'+ <> V.ifoldl' (\acc i pair -> acc <> flowKV opts ind i pair) mempty kvs+ <> singleton '}'+ else multiLineFlowMap opts ind kvs+++flowKV :: RenderOptions -> Int -> Int -> (Value, Value) -> Builder+flowKV opts ind i (k, v) =+ (if i == 0 then mempty else fromText ", ")+ <> (if YE.explicitKey k then fromText "? " else mempty)+ <> emitFlowValue opts ind k+ <> fromText ": "+ <> emitFlowValue opts ind v+++multiLineFlowMap :: RenderOptions -> Int -> V.Vector (Value, Value) -> Builder+multiLineFlowMap opts ind kvs =+ fromText "{\n"+ <> V.foldl' step mempty (V.indexed kvs)+ <> spaces ind+ <> singleton '}'+ where+ step acc (i, (k, v)) =+ acc+ <> spaces (ind + roIndent opts)+ <> (if YE.explicitKey k then fromText "? " else mempty)+ <> emitFlowValue opts (ind + roIndent opts) k+ <> fromText ": "+ <> emitFlowValue opts (ind + roIndent opts) v+ <> (if i < V.length kvs - 1 then singleton ',' else mempty)+ <> singleton '\n'+++emitFlowString :: RenderOptions -> Text -> Builder+emitFlowString opts t = case classifyString opts t of+ KsPlain -> fromText t+ KsLiteral -> doubleQuoted t -- can't use literal in flow+ _ -> doubleQuoted t+++formatDouble :: Double -> Builder+formatDouble d+ | isNaN d = fromText ".nan"+ | isInfinite d && d > 0 = fromText ".inf"+ | isInfinite d = fromText "-.inf"+ | otherwise = BF.realFloat d+++tagPrefix :: Tag -> Builder+tagPrefix = YE.buildTag+++-- ---------------------------------------------------------------------------+-- Annotated rendering (with verbatim fallback)+-- ---------------------------------------------------------------------------++buildAValue+ :: RenderOptions+ -> Maybe SourceText+ -> Int+ -> ChildContext+ -> AValue+ -> Builder+buildAValue opts msrc !ind ctx av+ | roPreserveOriginalText opts+ , not (avDirty av)+ , Just sp <- avSpan av+ , Just src <- msrc+ , Just slice <- spanSlice src sp =+ -- Verbatim copy of the original bytes (with the+ -- caller-side context separator).+ contextSeparator ctx <> fromText slice+ | otherwise =+ emitAComments ind (triviaLeading (avTrivia av))+ <> withFinalComment (triviaTrailing (avTrivia av)) (buildABody opts msrc ind ctx av)+ <> (if flowBody av then mempty else indentTrivia ind (avTrailingText av))+++spanSlice :: SourceText -> SrcSpan -> Maybe Text+spanSlice source (SrcSpan s e)+ | s < 0 || e < s = Nothing+ | otherwise =+ let bs = originalBytes source+ n = BS.length bs+ in if e > n+ then Nothing+ else either (const Nothing) Just (TE.decodeUtf8' (BS.take (e - s) (BS.drop s bs)))+++buildABody+ :: RenderOptions+ -> Maybe SourceText+ -> Int+ -> ChildContext+ -> AValue+ -> Builder+buildABody opts msrc ind ctx av = case avBody av of+ ANull -> emitScalar opts ind ctx YNull+ ABool b -> emitScalar opts ind ctx (YBool b)+ AInt n -> emitScalar opts ind ctx (YInt n)+ AFloat d -> emitScalar opts ind ctx (YFloat d)+ AString t s -> emitAString opts ind ctx t s+ ASeq _ SeqFlow -> contextSeparator ctx <> emitAFlowNode opts msrc ind av {avDirty = True} <> singleton '\n'+ AMap _ MapFlow -> contextSeparator ctx <> emitAFlowNode opts msrc ind av {avDirty = True} <> singleton '\n'+ ASeq xs s -> emitASeq opts msrc ind ctx xs s+ AMap es s -> emitAMap opts msrc ind ctx es s+ ATagged tg inner ->+ contextSeparator ctx+ <> tagPrefix tg+ <> buildAValue opts msrc ind ChildOfMapValueInline inner+ AAnchored (Anchor n) inner ->+ contextSeparator ctx+ <> singleton '&'+ <> fromText n+ <> buildAValue opts msrc ind ChildOfMapValueInline inner+ AAlias (Anchor n) ->+ contextSeparator ctx+ <> singleton '*'+ <> fromText n+ <> singleton '\n'+ AResolvedAlias _ (Anchor n) _ ->+ contextSeparator ctx <> singleton '*' <> fromText n <> singleton '\n'+++flowBody :: AValue -> Bool+flowBody av = case avBody av of+ ASeq _ SeqFlow -> True+ AMap _ MapFlow -> True+ _ -> False+++-- Flow children retain their own token spans: an entry span may also contain+-- a block key or sequence dash, which cannot be copied inside braces.+emitAFlowNode :: RenderOptions -> Maybe SourceText -> Int -> AValue -> Builder+emitAFlowNode opts source ind av+ | roPreserveOriginalText opts+ , not (avDirty av)+ , Just span_ <- avNodeSpan av+ , Just original <- source+ , Just text <- spanSlice original span_+ , not (T.any (\char -> char == '\n' || char == '\r') text) =+ fromText text+ | otherwise = case avBody av of+ AString text SSSingleQuoted | not (T.any YE.mustEscape text) -> singleQuoted text+ AString text SSDoubleQuoted -> doubleQuoted text+ AString text _ -> emitFlowString opts text+ ASeq values _ -> collection '[' ']' ((\value -> (avTrivia value, emitAFlowNode opts source childIndent value)) <$> values)+ AMap entries _ -> collection '{' '}' (entry <$> entries)+ ATagged tag inner -> tagPrefix tag <> singleton ' ' <> emitAFlowNode opts source ind inner+ AAnchored (Anchor name) inner -> singleton '&' <> fromText name <> singleton ' ' <> emitAFlowNode opts source ind inner+ AAlias (Anchor name) -> singleton '*' <> fromText name+ AResolvedAlias _ (Anchor name) _ -> singleton '*' <> fromText name+ _ -> emitFlowValue opts ind (astripAnnotationsForFlow av)+ where+ childIndent = ind + roIndent opts+ entry item =+ let key = amKey item+ value = amValue item+ trailing = case triviaTrailing (avTrivia value) of Just comment -> Just comment; Nothing -> amTrailing item+ trivia = (avTrivia key) {triviaLeading = triviaLeading (avTrivia key) <> triviaLeading (avTrivia value), triviaTrailing = trailing}+ explicit = YE.explicitKey (astripAnnotationsForFlow key)+ in (trivia, (if explicit then fromText "? " else mempty) <> emitAFlowNode opts source childIndent key <> fromText ": " <> emitAFlowNode opts source childIndent value)+ collection open close rows+ | V.null rows && T.null (avTrailingText av) = singleton open <> singleton close+ | multiline =+ singleton open+ <> singleton '\n'+ <> V.ifoldl' (\acc index (trivia, content) -> acc <> emitTrivia childIndent trivia <> withFinalComment (triviaTrailing trivia) (spaces childIndent <> content <> (if index + 1 < V.length rows then singleton ',' else mempty) <> singleton '\n')) mempty rows+ <> indentTrivia childIndent (avTrailingText av)+ <> spaces ind+ <> singleton close+ | otherwise = singleton open <> V.ifoldl' (\acc index (_, content) -> acc <> (if index == 0 then mempty else fromText ", ") <> content) mempty rows <> singleton close+ where+ multiline = not (T.null (avTrailingText av)) || V.any (\(trivia, content) -> not (null (triviaLeading trivia)) || triviaTrailing trivia /= Nothing || triviaBlankLines trivia > 0 || TL.any (== '\n') (toLazyText content)) rows+++emitAString+ :: RenderOptions+ -> Int+ -> ChildContext+ -> Text+ -> ScalarStyle+ -> Builder+emitAString opts ind ctx text style+ | blockStyle && useLiteral (opts {roStringStyleHint = HintLiteralBlock}) text = contextSeparator ctx <> literalFor opts ind ctx text+ | otherwise = contextSeparator ctx <> styled <> singleton '\n'+ where+ blockStyle = case style of SSLiteral _ -> True; SSFolded _ -> True; _ -> False+ styled = case style of+ SSSingleQuoted | not (T.any YE.mustEscape text) -> singleQuoted text+ SSDoubleQuoted -> doubleQuoted text+ SSPlain | not (needsQuoting opts text) -> fromText text+ _ -> doubleQuoted text+++emitASeq+ :: RenderOptions+ -> Maybe SourceText+ -> Int+ -> ChildContext+ -> V.Vector AValue+ -> SeqStyle+ -> Builder+emitASeq opts _msrc ind ctx xs SeqFlow =+ contextSeparator ctx+ <> emitFlowSeq opts ind (V.map astripAnnotationsForFlow xs)+ <> singleton '\n'+emitASeq opts msrc ind ctx xs SeqBlock+ | V.null xs =+ contextSeparator ctx <> fromText "[]\n"+ | otherwise =+ ( case ctx of+ ChildOfMapValueInline -> singleton '\n'+ ChildOfSeqItem -> singleton '\n'+ _ -> mempty+ )+ <> V.foldl' step mempty xs+ where+ step !acc x = case verbatimEntry opts msrc x of+ Just slice+ | sequenceEntry slice ->+ acc+ <> emitTrivia ind (avTrivia x)+ <> copyEntry ind ind slice+ _ ->+ acc+ <> emitTrivia ind (avTrivia x)+ <> withTrailingComment+ (triviaTrailing (avTrivia x))+ (spaces ind <> fromText "- " <> buildAValueSeqItem opts msrc (ind + 2) x {avDirty = True})+++buildAValueSeqItem+ :: RenderOptions -> Maybe SourceText -> Int -> AValue -> Builder+buildAValueSeqItem opts msrc ind original+ | roCompactSeqOfMap opts+ , AMap es s <- avBody av+ , s == MapBlock+ , not (V.null es) =+ emitACompactSeqMap opts msrc ind es s+ | otherwise = buildAValue opts msrc ind ChildOfSeqItem av+ where+ av = original {avTrivia = (avTrivia original) {triviaLeading = [], triviaBlankLines = 0, triviaTrailing = Nothing}}+++emitACompactSeqMap+ :: RenderOptions+ -> Maybe SourceText+ -> Int+ -> V.Vector AMapEntry+ -> MapStyle+ -> Builder+emitACompactSeqMap opts msrc ind es _ =+ let (e0, rest) = V.splitAt 1 es+ in V.foldl' (entryRow 0) mempty e0+ <> V.foldl' (entryRow ind) mempty rest+ where+ entryRow indForLine acc entry =+ let trivia = emitTrivia indForLine (avTrivia (amKey entry))+ in case verbatimEntry opts msrc (amValue entry) of+ Just slice | not (avDirty (amKey entry)), matchingKey (amKey entry) slice -> acc <> trivia <> copyEntry indForLine ind slice+ _ ->+ acc+ <> trivia+ <> withTrailingComment+ (amTrailing entry)+ ( spaces indForLine+ <> emitAMapKey opts ind (amKey entry)+ <> fromText ":"+ <> buildAValue opts msrc (ind + roIndent opts) ChildOfMapValueInline (amValue entry) {avDirty = True}+ )+++emitAMap+ :: RenderOptions+ -> Maybe SourceText+ -> Int+ -> ChildContext+ -> V.Vector AMapEntry+ -> MapStyle+ -> Builder+emitAMap opts _msrc ind ctx es MapFlow =+ contextSeparator ctx+ <> emitFlowMap opts ind (V.map entryToPair es)+ <> singleton '\n'+ where+ entryToPair e =+ ( astripAnnotationsForFlow (amKey e)+ , astripAnnotationsForFlow (amValue e)+ )+emitAMap opts msrc ind ctx es MapBlock+ | V.null es = contextSeparator ctx <> fromText "{}\n"+ | otherwise =+ ( case ctx of+ ChildOfMapValueInline -> singleton '\n'+ ChildOfSeqItem -> singleton '\n'+ _ -> mempty+ )+ <> V.foldl' step mempty es+ where+ step !acc e =+ let kAv = amKey e+ vAv = amValue e+ in case verbatimEntry opts msrc vAv of+ Just slice+ | not (avDirty kAv)+ , matchingKey kAv slice ->+ acc+ <> emitTrivia ind (avTrivia kAv)+ <> copyEntry ind ind slice+ _ ->+ acc+ <> emitTrivia ind (avTrivia kAv)+ <> withTrailingComment+ (amTrailing e)+ ( spaces ind+ <> emitAMapKey opts ind kAv+ <> fromText ":"+ <> buildAValue opts msrc (ind + roIndent opts) ChildOfMapValueInline vAv {avDirty = True}+ )+++{- | Returns 'Just' the original entry slice (including its+trailing newline) when the entry's value has an unmodified+span and the renderer is configured to preserve original text.+-}+indentTrivia :: Int -> Text -> Builder+indentTrivia ind text =+ let rows = T.splitOn "\n" text+ in fromText (T.intercalate "\n" ((\row -> if T.null row then row else T.replicate ind " " <> row) <$> rows))+++data SourceEntry = SourceEntry+ { entryText :: !Text+ , entryIndent :: {-# UNPACK #-} !Int+ , entryLeading :: {-# UNPACK #-} !Int+ }+++sequenceEntry :: SourceEntry -> Bool+sequenceEntry entry =+ let text = stripYamlStart (entryText entry)+ in text == "-" || T.isPrefixOf "- " text || T.isPrefixOf "-\t" text || T.isPrefixOf "-\n" text || T.isPrefixOf "-\r" text+++matchingKey :: AValue -> SourceEntry -> Bool+matchingKey key entry = case YD.splitMappingLine (T.takeWhile (\c -> c /= '\n' && c /= '\r') (stripYamlStart (entryText entry))) of+ Nothing -> False+ Just (raw, _) -> case avBody key of+ AString text _ | raw == text, YE.safePlain text -> True+ AResolvedAlias _ (Anchor name) _ -> raw == "*" <> name+ _ -> case YD.decode raw of+ Left _ -> False+ Right original -> stripAnchors original == stripAnchors (astripAnnotationsForFlow key)+ where+ stripAnchors (YAnchored _ inner) = stripAnchors inner+ stripAnchors (YTagged tag inner) = YTagged tag (stripAnchors inner)+ stripAnchors value = value+++copyEntry :: Int -> Int -> SourceEntry -> Builder+copyEntry firstIndent targetIndent entry+ | sourceIndent == targetIndent = spaces firstIndent <> fromText (T.drop leading text)+ | otherwise =+ let rows = T.splitOn "\n" (T.replace "\r" "\n" (T.replace "\r\n" "\n" text))+ restRow row+ | T.null row = row+ | otherwise = T.replicate targetIndent " " <> T.drop (min sourceIndent (T.length (T.takeWhile (== ' ') row))) row+ adjusted = case rows of+ [] -> []+ first : rest -> (T.replicate firstIndent " " <> T.drop leading first) : (restRow <$> rest)+ in fromText (T.intercalate "\n" adjusted)+ where+ text = entryText entry+ sourceIndent = entryIndent entry+ leading = entryLeading entry+++verbatimEntry :: RenderOptions -> Maybe SourceText -> AValue -> Maybe SourceEntry+verbatimEntry opts msrc av+ | roPreserveOriginalText opts+ , not (avDirty av)+ , Just sp <- avSpan av+ , Just source <- msrc+ , Just text <- spanSlice source sp =+ let findBreak !position+ | position < 0 = -1+ | let byte = BS.index (originalBytes source) position, byte == 10 || byte == 13 = position+ | otherwise = findBreak (position - 1)+ lastBreak = findBreak (srcStart sp - 1)+ column = srcStart sp - lastBreak - 1+ leading = T.length (T.takeWhile (== ' ') text)+ in Just (SourceEntry text (column + leading) leading)+ | otherwise = Nothing+++emitAMapKey :: RenderOptions -> Int -> AValue -> Builder+emitAMapKey opts ind av+ | YE.explicitKey (astripAnnotationsForFlow av) = fromText "? " <> emitFlowValue opts (ind + 2) (astripAnnotationsForFlow av) <> singleton '\n' <> spaces ind+ | otherwise = case avBody av of+ AString t SSPlain -> emitPlainOrQuotedKey opts t+ AString t SSDoubleQuoted -> doubleQuoted t+ AString t SSSingleQuoted | not (T.any YE.mustEscape t) -> singleQuoted t+ AString t _ -> emitPlainOrQuotedKey opts t+ AInt n -> BI.decimal n+ ABool b -> fromText (if b then "true" else "false")+ ANull -> fromText "null"+ AFloat d -> formatDouble d+ _ -> emitFlowValue opts ind (astripAnnotationsForFlow av)+++astripAnnotationsForFlow :: AValue -> Value+astripAnnotationsForFlow = astrip+ where+ astrip av = case avBody av of+ ANull -> YNull+ ABool b -> YBool b+ AInt n -> YInt n+ AFloat d -> YFloat d+ AString t _ -> YString t+ ASeq xs _ -> YSeq (V.map astrip xs)+ AMap es _ ->+ YMap+ ( V.map+ ( \e ->+ ( astrip (amKey e)+ , astrip (amValue e)+ )+ )+ es+ )+ ATagged tg x -> YTagged tg (astrip x)+ AAnchored a x -> YAnchored a (astrip x)+ AAlias anchor -> YAlias anchor+ AResolvedAlias _ anchor _ -> YAlias anchor+++withTrailingComment :: Maybe Comment -> Builder -> Builder+withTrailingComment Nothing row = row+withTrailingComment (Just comment) row =+ let (first, rest) = TL.breakOn "\n" (toLazyText row)+ in fromText (TL.toStrict first)+ <> fromText " # "+ <> fromText (commentText comment)+ <> (if TL.null rest then singleton '\n' else fromText (TL.toStrict rest))+++withFinalComment :: Maybe Comment -> Builder -> Builder+withFinalComment Nothing value = value+withFinalComment (Just comment) value =+ let text = toLazyText value+ body = case TL.unsnoc text of Just (prefix, '\n') -> prefix; _ -> text+ in fromText (TL.toStrict body) <> fromText " # " <> fromText (commentText comment) <> singleton '\n'+++emitAComments :: Int -> [Comment] -> Builder+emitAComments ind = foldMap (\comment -> spaces (max ind (commentColumn comment)) <> fromText "# " <> fromText (commentText comment) <> singleton '\n')+++-- | Emit blank lines + leading comments before an entry.+emitTrivia :: Int -> Trivia -> Builder+emitTrivia ind tr =+ mconcat (replicate (triviaBlankLines tr) (singleton '\n'))+ <> emitAComments ind (triviaLeading tr)+++emitComments :: Int -> [Comment] -> Builder+emitComments = emitAComments+++-- Write escapes directly to the builder; supplementary scalars need eight digits.+hexEscape :: Int -> Builder+hexEscape codepoint =+ let width = if codepoint > 0xFFFF then 8 else 4+ prefix = if width == 8 then "\\U" else "\\u"+ digits n+ | n < 16 = 1+ | otherwise = 1 + digits (n `quot` 16)+ in fromText prefix <> fromText (T.replicate (width - digits codepoint) "0") <> BI.hexadecimal codepoint
+ src/YAML/Value.hs view
@@ -0,0 +1,168 @@+{- | YAML 1.2 value representation.++The 'Value' ADT models the YAML 1.2 representation graph:++* Scalars corresponding to the YAML 1.2 /core schema/:+ 'YNull', 'YBool', 'YInt', 'YFloat', and 'YString'.+* 'YSeq' for sequences (\"YAML lists\").+* 'YMap' for mappings (\"YAML dicts\"). Insertion order is preserved+ in the underlying 'Vector'; YAML mappings are unordered in the+ data model but downstream consumers (round-tripping in particular)+ typically want the source order.+* 'YAnchored' and 'YTagged' wrap sub-values with anchor identifiers and+ tag URIs so that anchor / alias relationships and explicit tags+ round-trip cleanly. An un-anchored, untagged scalar lives+ directly as 'YString' / 'YInt' / etc. without a wrapper.++A 'Document' carries the optional directives end marker and+optional document end marker so that emitters can faithfully+preserve multi-document streams.+-}+module YAML.Value (+ Value (..),+ Document (..),+ Stream (..),+ Tag (..),+ Anchor (..),++ -- * Construction helpers+ null_,+ bool,+ int,+ float,+ string,+ seq_,+ mapping,++ -- * Accessors+ unwrap,+ lookupKey,+) where++import Control.DeepSeq (NFData)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import GHC.Generics (Generic)+++-- | An anchor identifier, e.g. the @ref@ in @&ref@.+newtype Anchor = Anchor {unAnchor :: Text}+ deriving stock (Show, Eq, Ord, Generic)+ deriving newtype (NFData)+++{- | A YAML tag URI, e.g. @tag:yaml.org,2002:str@. Short-hand tags+(@!!str@) are resolved to their full URI form during decoding.+-}+newtype Tag = Tag {unTag :: Text}+ deriving stock (Show, Eq, Ord, Generic)+ deriving newtype (NFData)+++{- | YAML representation node.++Integers have arbitrary precision. Presentation details such as quoting+and comments live in 'YAML.Annotated.AValue', rather than this data model.+-}+data Value+ = YNull+ | YBool !Bool+ | YInt !Integer+ | YFloat !Double+ | YString !Text+ | YSeq !(Vector Value)+ | YMap !(Vector (Value, Value))+ | -- | A node carrying an explicit YAML tag.+ YTagged !Tag !Value+ | {- | A node introduced with @&anchor@. Subsequent @*anchor@+ references in the source resolve to the same logical node;+ decoders expand aliases while retaining anchor metadata on the+ definition and on each resolved reference.+ -}+ YAnchored !Anchor !Value+ | -- | An alias reference. Decoders resolve these before returning a value.+ YAlias !Anchor+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | A single YAML document within a stream.+data Document = Document+ { docDirectivesEnd :: !Bool+ -- ^ @True@ when a @---@ marker preceded the body in the source.+ , docExplicitEnd :: !Bool+ -- ^ @True@ when a @...@ marker followed the body in the source.+ , docBody :: !Value+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)+++-- | A YAML stream is a sequence of documents.+newtype Stream = Stream {unStream :: Vector Document}+ deriving stock (Show, Eq, Generic)+ deriving newtype (NFData)+++-- ---------------------------------------------------------------------------+-- Construction helpers+-- ---------------------------------------------------------------------------++null_ :: Value+null_ = YNull+++bool :: Bool -> Value+bool = YBool+++int :: Integer -> Value+int = YInt+++float :: Double -> Value+float = YFloat+++string :: Text -> Value+string = YString+++seq_ :: [Value] -> Value+seq_ = YSeq . V.fromList+++mapping :: [(Value, Value)] -> Value+mapping = YMap . V.fromList+++-- ---------------------------------------------------------------------------+-- Accessors+-- ---------------------------------------------------------------------------++-- | Strip outer 'YAnchored' / 'YTagged' wrappers.+unwrap :: Value -> Value+unwrap = go+ where+ go (YAnchored _ v) = go v+ go (YTagged _ v) = go v+ go v = v+++{- | Lookup by 'YString' key in a 'YMap'. Skips wrappers on both the+node we're searching and on its keys. Returns the first match in+source order.+-}+lookupKey :: Text -> Value -> Maybe Value+lookupKey k v = case unwrap v of+ YMap kvs -> goV 0+ where+ !len = V.length kvs+ goV !i+ | i >= len = Nothing+ | otherwise = case kvs V.! i of+ (kk, vv) -> case unwrap kk of+ YString k' | k' == k -> Just vv+ _ -> goV (i + 1)+ _ -> Nothing
+ test/Main.hs view
@@ -0,0 +1,33 @@+module Main (main) where++import Hedgehog.Internal.Config (resolveSkip)+import Test.Syd+import Test.YAML.Annotated qualified+import Test.YAML.Class qualified+import Test.YAML.Conformance qualified+import Test.YAML.Decode qualified+import Test.YAML.Derive qualified+import Test.YAML.Encode qualified+import Test.YAML.JSON qualified+import Test.YAML.Pretty qualified+import Test.YAML.Roundtrip qualified+import Test.YAML.Security qualified+++main :: IO ()+main = do+ -- Initialize Hedgehog's shared skip configuration before starting workers.+ _ <- resolveSkip Nothing+ conformance <- Test.YAML.Conformance.tests+ sydTest $+ describe "wireform-yaml" $ do+ Test.YAML.Decode.tests+ Test.YAML.Encode.tests+ Test.YAML.Class.tests+ Test.YAML.Derive.tests+ Test.YAML.JSON.tests+ Test.YAML.Pretty.tests+ Test.YAML.Annotated.tests+ Test.YAML.Roundtrip.tests+ Test.YAML.Security.tests+ conformance
+ test/Test/YAML/Annotated.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Annotated (tests) where++import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Test.Syd+import YAML.Annotated+import YAML.Annotated qualified as A+import YAML.Decode qualified as D+import YAML.Decode.Annotated (decodeAnnotated)+import YAML.Decode.Annotated qualified as AD+import YAML.JSON qualified as J+import YAML.Pretty (defaultOptions, renderAnnotatedDocument)+import YAML.Pretty qualified as P+import YAML.Value+++tests :: Spec+tests =+ describe "Annotated" $+ sequence_+ [ roundTripExact+ , roundTripWithComments+ , roundTripSeq+ , modifyPreservesUnmodified+ , modifyPreservesComments+ , addKeyAppears+ , deleteKeyDisappears+ , presentationTests+ ]+++{- | Parse and re-render an unmodified document; the result must+be byte-identical to the input.+-}+roundTripExact :: Spec+roundTripExact = it "round-trip preserves source verbatim" $ do+ let src =+ T.unlines+ [ "# top comment"+ , "name: alice"+ , "age: 30"+ , ""+ , "# group comment"+ , "address:"+ , " street: 1 main st"+ , " city: springfield"+ , "tags: [a, b, c]"+ ]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let out = renderAnnotatedDocument defaultOptions adoc (Just srcText)+ out `shouldBe` src+++{- | Modifying one mapping key only changes that key's value; the+surrounding entries — including comments and the unrelated+entries' formatting — stay byte-identical.+-}+modifyPreservesUnmodified :: Spec+modifyPreservesUnmodified =+ it "single-key modification preserves rest" $ do+ let src =+ T.unlines+ [ "# top comment"+ , "name: alice"+ , "age: 30"+ , "city: springfield"+ ]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let body = adBody adoc+ body' = setKey "age" (aInt 31) body+ adoc' = adoc {adBody = body'}+ out = renderAnnotatedDocument defaultOptions adoc' (Just srcText)+ (if ("31" `T.isInfixOf` out) then pure () else expectationFailure ("must mention 31, got: " <> T.unpack out))+ (if ("name: alice" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `name: alice`: " <> T.unpack out))+ (if ("city: springfield" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `city: springfield`: " <> T.unpack out))+ (if (not ("age: 30" `T.isInfixOf` out)) then pure () else expectationFailure ("must drop original `age: 30`: " <> T.unpack out))+++-- | Appending a new key produces output that contains it.+addKeyAppears :: Spec+addKeyAppears = it "appendKey adds the new entry" $ do+ let src = T.unlines ["name: alice", "age: 30"]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let body = adBody adoc+ body' = appendKey "city" (aString "springfield") body+ adoc' = adoc {adBody = body'}+ out = renderAnnotatedDocument defaultOptions adoc' (Just srcText)+ (if ("city" `T.isInfixOf` out) then pure () else expectationFailure ("expected city: " <> T.unpack out))+ (if ("name: alice" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `name: alice` byte-equal: " <> T.unpack out))+ (if ("age: 30" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `age: 30` byte-equal: " <> T.unpack out))+++-- | Round-trip with comments scattered throughout.+roundTripWithComments :: Spec+roundTripWithComments =+ it "round-trip preserves comments verbatim" $ do+ let src =+ T.unlines+ [ "# header comment"+ , "name: alice # eol comment on name"+ , ""+ , "# group comment"+ , "age: 30"+ , ""+ , "# trailing comment"+ ]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let out = renderAnnotatedDocument defaultOptions adoc (Just srcText)+ out `shouldBe` src+++-- | Round-trip a top-level sequence with item comments.+roundTripSeq :: Spec+roundTripSeq = it "round-trip preserves top-level seq" $ do+ let src =+ T.unlines+ [ "- alice"+ , "- bob"+ , "- carol"+ ]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let out = renderAnnotatedDocument defaultOptions adoc (Just srcText)+ out `shouldBe` src+++{- | Modifying one entry preserves the *exact bytes* (including+end-of-line comments and surrounding blank lines) of all the+other entries.+-}+modifyPreservesComments :: Spec+modifyPreservesComments =+ it "modify preserves untouched-entry comments" $ do+ let src =+ T.unlines+ [ "# header"+ , "name: alice # eol on name"+ , ""+ , "age: 30"+ , ""+ , "# group"+ , "city: springfield"+ ]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let body = adBody adoc+ body' = setKey "age" (aInt 31) body+ adoc' = adoc {adBody = body'}+ out = renderAnnotatedDocument defaultOptions adoc' (Just srcText)+ (if ("# eol on name" `T.isInfixOf` out) then pure () else expectationFailure ("must keep eol comment on name: " <> T.unpack out))+ (if ("# group" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `# group` comment: " <> T.unpack out))+ (if ("city: springfield" `T.isInfixOf` out) then pure () else expectationFailure ("must keep `city: springfield`: " <> T.unpack out))+ (if ("31" `T.isInfixOf` out) then pure () else expectationFailure ("must mention 31: " <> T.unpack out))+++-- | Deleting a key removes it.+deleteKeyDisappears :: Spec+deleteKeyDisappears = it "deleteKey removes the entry" $ do+ let src = T.unlines ["a: 1", "b: 2", "c: 3"]+ case decodeAnnotated src of+ Left err -> (if (False) then pure () else expectationFailure (err))+ Right (adoc, srcText) -> do+ let body = adBody adoc+ body' = deleteKey "b" body+ adoc' = adoc {adBody = body'}+ out = renderAnnotatedDocument defaultOptions adoc' (Just srcText)+ (if (not ("b: 2" `T.isInfixOf` out)) then pure () else expectationFailure ("must remove b entirely: " <> T.unpack out))+ (if ("a: 1" `T.isInfixOf` out) then pure () else expectationFailure ("must keep a: " <> T.unpack out))+ (if ("c: 3" `T.isInfixOf` out) then pure () else expectationFailure ("must keep c: " <> T.unpack out))+++presentationTests :: Spec+presentationTests = describe "source preservation" $ do+ it "does not duplicate trailing comments when adding document markers" $ do+ let src = "a: 1\n# tail\n"+ case AD.decodeAnnotated src of+ Left err -> expectationFailure err+ Right (doc, original) ->+ P.renderAnnotatedDocument (P.defaultOptions {P.roDocStartMarker = True}) doc (Just original)+ `shouldBe` "---\na: 1\n# tail\n"+ it "round-trips annotated document framing and multi-document sources exactly" $+ mapM_+ assertVerbatimRoundtrip+ [ "---\na: 1\n...\n"+ , "---\na: 1\n...\n---\nb: 2\n"+ , "# lead\n%YAML 1.2\n---\na: 1\n...\n# next\n%YAML 1.2\n---\nb: 2\n# tail\n"+ , "a: 1\n...\nb: 2\n"+ , "---\n---\n"+ ]+ it "preserves trailing comments after edits" $ do+ let src = "a: 'quoted'\nb: 2\n# trailing\n"+ case AD.decodeAnnotated src of+ Left err -> expectationFailure err+ Right (doc, original) ->+ P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = A.setKey "b" (A.aInt 3) (A.adBody doc)}) (Just original)+ `shouldBe` "a: 'quoted'\nb: 3\n# trailing\n"+ it "edits one document without copying another document's source" $ do+ let src = "---\na: 1\n---\nb: 2\n"+ case AD.decodeAnnotatedStream src of+ Left err -> expectationFailure err+ Right (A.AStream docs, original) -> do+ let changed = V.imap (\i doc -> if i == 1 then doc {A.adBody = A.setKey "b" (A.aInt 3) (A.adBody doc)} else doc) docs+ P.renderAnnotatedStream P.defaultOptions (A.AStream changed) (Just original) `shouldBe` "---\na: 1\n---\nb: 3\n"+ it "does not duplicate literal-block content that looks like a comment" $ do+ let src = "a: 1\ncode: |\n # scalar content\n"+ case AD.decodeAnnotated src of+ Left err -> expectationFailure err+ Right (doc, original) ->+ P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = A.setKey "a" (A.aInt 2) (A.adBody doc)}) (Just original)+ `shouldBe` "a: 2\ncode: |\n # scalar content\n"+ it "preserves TAG directives when another entry is edited" $+ assertEditedDocument+ "%TAG !e! tag:example.com,2020:\n---\nkeep: !e!thing value\nchange: 1\n"+ ["change"]+ (A.aInt 9)+ "%TAG !e! tag:example.com,2020:\n---\nkeep: !e!thing value\nchange: 9\n"+ it "preserves comment-only annotated streams" $+ mapM_+ ( \source -> case AD.decodeAnnotatedStream source of+ Left err -> expectationFailure err+ Right (stream, original) -> P.renderAnnotatedStream P.defaultOptions stream (Just original) `shouldBe` source+ )+ ["# just a comment\n", "\n# comment\n...\n"]+ it "keeps nested comments and untouched scalar styles when one leaf changes" $+ assertEditedDocument+ "outer:\n # group\n x: 1 # inline\n y: 'old'\nother: 2\n"+ ["outer", "x"]+ (A.aInt 9)+ "outer:\n # group\n x: 9 # inline\n y: 'old'\nother: 2\n"+ it "preserves the existing quoting style when changing a nested string" $+ assertEditedDocument+ "outer:\n name: 'old'\n other: \"keep\"\n"+ ["outer", "name"]+ (A.aString "new")+ "outer:\n name: 'new'\n other: \"keep\"\n"+ it "keeps nested blank lines and trailing comments" $+ assertEditedDocument+ "outer:\n x: 1\n\n # group\n y: 'old'\n # tail\n"+ ["outer", "x"]+ (A.aInt 9)+ "outer:\n x: 9\n\n # group\n y: 'old'\n # tail\n"+ it "keeps nested sequence-of-mapping annotations during edits" $ do+ let source = "items:\n - name: 'first'\n value: 1 # note\n - name: 'second'\n value: 2\n"+ case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let changeItems value = case A.avBody value of+ A.ASeq items _ -> A.setIndex 0 (A.setKey "value" (A.aInt 9) (items V.! 0)) value+ _ -> value+ changed = doc {A.adBody = A.updateKey "items" (Just . changeItems) (A.adBody doc)}+ output = P.renderAnnotatedDocument P.defaultOptions changed (Just original)+ output `shouldBe` "items:\n - name: 'first'\n value: 9 # note\n - name: 'second'\n value: 2\n"+ D.decode output `shouldSatisfy` either (const False) (const True)+ it "edits mappings transparently through node properties" $+ mapM_+ (\source -> checkEditedValue source (A.setKey "x" (A.aInt 9)) (\value -> lookupKey "x" value `shouldBe` Just (YInt 9)))+ ["!foo {x: 1, y: 2}\n", "&a\nx: 1\ny: 2\n"]+ it "retains anchor definitions when their values are replaced" $+ checkEditedValue "x: &a 1\ny: *a\n" (A.setKey "x" (A.aInt 9)) (\value -> fmap unwrap (lookupKey "y" value) `shouldBe` Just (YInt 9))+ it "keeps sequence item comments and styles after replacement" $+ checkEditedValue "- 'old' # note\n- keep\n" (A.setIndex 0 (A.aString "new")) (\value -> unwrap value `shouldBe` seq_ [YString "new", YString "keep"])+ it "preserves sequence item comment text exactly once after replacement" $+ case AD.decodeAnnotated "# lead\n- 'old' # note\n- keep\n" of+ Left err -> expectationFailure err+ Right (doc, original) ->+ P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = A.setIndex 0 (A.aString "new") (A.adBody doc)}) (Just original)+ `shouldBe` "# lead\n- 'new' # note\n- keep\n"+ it "honours newline preferences when normalizing annotated documents" $ do+ case AD.decodeAnnotated "text: |+\n a\n\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let options = P.compactOptions {P.roPreserveOriginalText = False}+ text = P.renderAnnotatedDocument options doc (Just original)+ T.isSuffixOf "\n" text `shouldBe` False+ D.decode text `shouldBe` D.decode original+ it "normalizes edited anchors while retaining live alias relationships" $ do+ let source = "base: &a {x: 1}\ncopy: *a\n"+ assertEditedValue (P.defaultOptions {P.roPreserveOriginalText = False}) source (A.updateAt ["base", "x"] (A.aInt 9)) "base: {x: 9}\ncopy: {x: 9}\n"+ it "materializes aliases when their anchor definition is deleted" $+ assertEditedValue P.defaultOptions "base: &a {x: 1}\ncopy: *a\n" (A.deleteKey "base") "copy: {x: 1}\n"+ it "distinguishes deleted bindings after legal anchor-name rebinding" $+ mapM_+ ( \options -> do+ let source = "old: &a 1\nold-copy: *a\nnew: &a 2\nnew-copy: *a\n"+ assertEditedValue options source (A.deleteKey "new") "old: 1\nold-copy: 1\nnew-copy: 2\n"+ assertEditedValue options source (A.deleteKey "old") "old-copy: 1\nnew: 2\nnew-copy: 2\n"+ )+ [P.defaultOptions, P.defaultOptions {P.roPreserveOriginalText = False}]+ it "materializes deleted anchor references inside flow collections" $+ assertEditedValue P.defaultOptions "base: &a 1\nrest: [*a, {x: *a}]\n" (A.deleteKey "base") "rest: [1, {x: 1}]\n"+ it "edits an alias target as an independent copy" $+ assertEditedValue P.defaultOptions "base: &a {x: 1}\ncopy: *a\nother: *a\n" (A.updateAt ["copy", "x"] (A.aInt 9)) "base: {x: 1}\ncopy: {x: 9}\nother: {x: 1}\n"+ it "can replace an anchored sequence item with its own resolved reference" $+ assertEditedValue+ P.defaultOptions+ "- &a 1\n- *a\n"+ ( \value -> case A.avBody value of+ A.ASeq items _ -> A.setIndex 0 (items V.! 1) value+ _ -> value+ )+ "[1, 1]"+ it "materializes an alias moved before its definition" $+ assertEditedValue+ P.defaultOptions+ "- &a 1\n- *a\n"+ ( \value -> case A.avBody value of+ A.ASeq items style -> A.markDirty value {A.avBody = A.ASeq (V.reverse items) style}+ _ -> value+ )+ "[1, 1]"+ it "preserves comments inside a root property-wrapped mapping" $ do+ case AD.decodeAnnotated "&root\n# note\nx: 1\ny: 'old'\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let out = P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = A.setKey "x" (A.aInt 9) (A.adBody doc)}) (Just original)+ T.count "# note" out `shouldBe` 1+ T.isInfixOf "y: 'old'" out `shouldBe` True+ fmap J.yamlToJSON (D.decode out) `shouldBe` fmap J.yamlToJSON (D.decode "x: 9\ny: old\n")+ it "preserves comments, quoting, and uniform CR/CRLF endings during edits" $+ mapM_+ ( \ending -> do+ let source = T.replace "\n" ending "outer:\n # note\n x: 1\n y: 'old'\n"+ expected = T.replace "\n" ending "outer:\n # note\n x: 9\n y: 'old'\n"+ case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) -> P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = A.updateAt ["outer", "x"] (A.aInt 9) (A.adBody doc)}) (Just original) `shouldBe` expected+ )+ ["\r", "\r\n"]+ it "round-trips empty annotated documents verbatim" $+ case AD.decodeAnnotated "" of+ Left err -> expectationFailure err+ Right (doc, original) -> P.renderAnnotatedDocument P.defaultOptions doc (Just original) `shouldBe` ""+ it "renders an annotated scalar subtree without leaking its mapping header" $+ case AD.decodeAnnotated "key: 'value'\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> case A.avBody (A.adBody doc) of+ A.AMap entries _ -> D.decode (P.renderAnnotated P.defaultOptions (A.amValue (V.head entries)) (Just original)) `shouldBe` Right (YString "value")+ _ -> expectationFailure "expected mapping"+ it "reindents a rendered annotated mapping subtree" $+ case AD.decodeAnnotated "outer:\n a: 1\n nested:\n b: 'two'\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> case A.avBody (A.adBody doc) of+ A.AMap entries _ ->+ let out = P.renderAnnotated P.defaultOptions (A.amValue (V.head entries)) (Just original)+ in D.decode out `shouldBe` D.decode "a: 1\nnested:\n b: two\n"+ _ -> expectationFailure "expected mapping"+ it "can reuse an annotated mapping under a new key at a deeper indentation" $+ assertEditedValue+ P.defaultOptions+ "outer:\n a: 1\n nested:\n b: 'two'\n"+ ( \root -> case A.avBody root of+ A.AMap entries _ -> A.appendKey "new" (A.aMap [(A.aString "copy", A.amValue (V.head entries))]) root+ _ -> root+ )+ "outer: {a: 1, nested: {b: two}}\nnew: {copy: {a: 1, nested: {b: two}}}\n"+ it "can reuse an annotated mapping value as a sequence item" $+ case AD.decodeAnnotated "source: {x: 1}\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> case A.avBody (A.adBody doc) of+ A.AMap entries _ -> D.decode (P.renderAnnotated P.defaultOptions (A.aSeq [A.amValue (V.head entries)]) (Just original)) `shouldBe` D.decode "[{x: 1}]"+ _ -> expectationFailure "expected mapping"+ it "separates forced end markers from a copied final entry without a newline" $+ case AD.decodeAnnotated "a: 1\nb: 2" of+ Left err -> expectationFailure err+ Right (doc, original) ->+ D.decodeStream (P.renderAnnotatedDocument (P.defaultOptions {P.roDocEndMarker = True}) doc (Just original))+ `shouldBe` D.decodeStream "a: 1\nb: 2\n...\n"+ it "keeps untouched flow-map tokens and comments when replacing a sibling" $+ assertFlowPresentation+ "# prologue\n{\"name\": 'a''b', # keep this\n count: 0x0A, changed: 1, # ending\n}\n"+ (A.setKey "changed" (A.aInt 2))+ ["# prologue", "\"name\"", "'a''b'", "0x0A", "# keep this", "# ending"]+ "{name: a'b, count: 10, changed: 2}"+ it "keeps flow-sequence comments and quote styles after structural edits" $+ assertFlowPresentation+ "['first', # before second\n \"second\", # before third\n third]\n"+ (A.appendItem (A.aString "fourth") . A.setIndex 1 (A.aString "changed"))+ ["'first'", "\"changed\"", "# before second", "# before third"]+ "[first, changed, third, fourth]"+ it "retains nested flow presentation through block-entry source relocation" $+ assertFlowPresentation+ "outer:\r\n flow: {keep: 'é', # inner\r\n nested: [\"old\", 0x10]}\r\n"+ (A.updateKey "outer" (Just . A.updateKey "flow" (Just . A.updateKey "nested" (Just . A.setIndex 0 (A.aString "new")))))+ ["'é'", "# inner", "\"new\"", "0x10"]+ "outer: {flow: {keep: é, nested: [new, 16]}}"+ it "can delete and append commented flow entries" $+ assertFlowPresentation+ "{remove: 1, # keep comment\n keep: 'value', # last\n}\n"+ (A.appendKey "added" (A.aBool True) . A.deleteKey "remove")+ ["# keep comment", "'value'", "# last"]+ "{keep: value, added: true}"+ it "preserves comments between flow properties and the collection" $+ assertFlowPresentation+ "!tag # properties\n{key: ':colon', empty: !!str, other: 1}\n"+ (A.setKey "other" (A.aInt 2))+ ["# properties", "':colon'", "!!str"]+ "!tag {key: ':colon', empty: !!str, other: 2}"+ it "safely renders a moved multiline flow subtree at a deeper indentation" $+ assertEditedValue+ P.defaultOptions+ "source: {nested: [\n 'one',\n 'two'\n ]}\n"+ ( \root -> case A.avBody root of+ A.AMap entries _ -> A.appendKey "outer" (A.aMap [(A.aString "deeper", A.amValue (V.head entries))]) root+ _ -> root+ )+ "source: {nested: [one, two]}\nouter: {deeper: {nested: [one, two]}}\n"+ it "preserves a root flow collection's final inline comment" $+ assertFlowPresentation+ "{a: 'value', b: 1} # final comment\n"+ (A.setKey "b" (A.aInt 2))+ ["# final comment", "'value'"]+ "{a: value, b: 2}"+ it "retains an implicit empty-key flow pair when replacing a sibling" $+ assertFlowPresentation+ "[? : , other]\n"+ (A.setIndex 1 (A.aString "changed"))+ ["?"]+ "[{null: null}, changed]"+ it "keeps property comments from swallowing the next flow separator" $+ assertFlowPresentation+ "{empty: !!str # note\n, other: 1}\n"+ (A.setKey "other" (A.aInt 2))+ ["# note"]+ "{empty: !!str, other: 2}"+ it "keeps a copied root's inline comment when inserting it into a flow collection" $+ case AD.decodeAnnotated "{key: 'value'} # copied comment\n" of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let root = (A.aSeq [A.adBody doc, A.aInt 2]) {A.avBody = A.ASeq (V.fromList [A.adBody doc, A.aInt 2]) A.SeqFlow}+ out = P.renderAnnotated P.defaultOptions root (Just original)+ out `shouldSatisfy` T.isInfixOf "# copied comment"+ D.decode out `shouldBe` D.decode "[{key: value}, 2]"+ it "retains the original numeric token after a leading flow comment" $+ assertFlowPresentation+ "[ # before\n 0x0A, 1]\n"+ (A.setIndex 1 (A.aInt 2))+ ["# before", "0x0A"]+ "[10, 2]"+ it "normalizes commented flow collections without dropping comments or quoting" $+ case AD.decodeAnnotated "{a: 'one', # comment\n b: [\"two\"]}\n" of+ Left err -> expectationFailure err+ Right (doc, source) -> do+ let out = P.renderAnnotatedDocument (P.defaultOptions {P.roPreserveOriginalText = False}) doc (Just source)+ mapM_ (\part -> out `shouldSatisfy` T.isInfixOf part) ["'one'", "\"two\"", "# comment"]+ D.decode out `shouldBe` D.decode source+ it "does not introduce an alias cycle when a copied subtree contains its new anchor" $+ assertEditedValue+ P.defaultOptions+ "base: &a 1\nnew: {nested: [*a]}\ncopy: *a\n"+ ( \root -> case A.avBody root of+ A.AMap entries _ -> A.setKey "base" (A.amValue (entries V.! 1)) root+ _ -> root+ )+ "base: {nested: [1]}\nnew: {nested: [{nested: [1]}]}\ncopy: {nested: [1]}\n"+++assertVerbatimRoundtrip :: Text -> IO ()+assertVerbatimRoundtrip src = case AD.decodeAnnotatedStream src of+ Left err -> expectationFailure err+ Right (docs, original) -> P.renderAnnotatedStream P.defaultOptions docs (Just original) `shouldBe` src+++assertEditedDocument :: Text -> [Text] -> A.AValue -> Text -> IO ()+assertEditedDocument source path value expected = case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let changed = doc {A.adBody = A.updateAt path value (A.adBody doc)}+ output = P.renderAnnotatedDocument P.defaultOptions changed (Just original)+ output `shouldBe` expected+ D.decode output `shouldBe` D.decode expected+++checkEditedValue :: Text -> (A.AValue -> A.AValue) -> (Value -> IO ()) -> IO ()+checkEditedValue source change verify = case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) -> case D.decode (P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = change (A.adBody doc)}) (Just original)) of+ Left err -> expectationFailure err+ Right value -> verify value+++assertEditedValue :: P.RenderOptions -> Text -> (A.AValue -> A.AValue) -> Text -> IO ()+assertEditedValue options source change expected = case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) ->+ let output = P.renderAnnotatedDocument options (doc {A.adBody = change (A.adBody doc)}) (Just original)+ in fmap J.yamlToJSON (D.decode output) `shouldBe` fmap J.yamlToJSON (D.decode expected)+++assertFlowPresentation :: Text -> (A.AValue -> A.AValue) -> [Text] -> Text -> IO ()+assertFlowPresentation source change retained expected = case AD.decodeAnnotated source of+ Left err -> expectationFailure err+ Right (doc, original) -> do+ let output = P.renderAnnotatedDocument P.defaultOptions (doc {A.adBody = change (A.adBody doc)}) (Just original)+ mapM_ (\text -> output `shouldSatisfy` T.isInfixOf text) retained+ fmap J.yamlToJSON (D.decode output) `shouldBe` fmap J.yamlToJSON (D.decode expected)
+ test/Test/YAML/Class.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Class (tests) where++import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Either (isLeft, isRight)+import Data.Int (Int64, Int8)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Vector qualified as V+import Data.Word (Word64, Word8)+import Numeric.Natural (Natural)+import Test.Syd+import YAML.Class qualified as C+import YAML.Decode qualified as D+import YAML.JSON qualified as J+import YAML.Value+++tests :: Spec+tests = describe "native codecs" $ do+ it "preserves arbitrary precision integers in parsing, typed codecs, and JSON" $ do+ let n = 18446744073709551616+ D.decode "18446744073709551616" `shouldBe` Right (YInt n)+ D.decode "-9223372036854775809" `shouldBe` Right (YInt (-9223372036854775809))+ C.decodeYAML (C.encodeYAML n) `shouldBe` Right (n :: Integer)+ C.decodeYAML (C.encodeYAML (maxBound :: Word64)) `shouldBe` Right (maxBound :: Word64)+ C.decodeYAML (C.encodeYAML (fromInteger n :: Natural)) `shouldBe` Right (fromInteger n :: Natural)+ J.jsonToYAML (Aeson.Number (fromInteger n)) `shouldBe` YInt n+ it "rejects bounded overflow, negative unsigned values, and fractional integers" $ do+ (C.decodeYAML "256" :: Either String Word8) `shouldSatisfy` isLeft+ (C.decodeYAML "-1" :: Either String Word8) `shouldSatisfy` isLeft+ (C.decodeYAML "128" :: Either String Int8) `shouldSatisfy` isLeft+ (C.decodeYAML "9223372036854775808" :: Either String Int64) `shouldSatisfy` isLeft+ (C.decodeYAML "1.9" :: Either String Int) `shouldSatisfy` isLeft+ (C.decodeYAML ".inf" :: Either String Int) `shouldSatisfy` isLeft+ it "resolves explicitly tagged scalars before typed decoding" $ do+ (C.decodeYAML "!!str 001" :: Either String Text) `shouldBe` Right "001"+ (C.decodeYAML "!!str null" :: Either String Text) `shouldBe` Right "null"+ (C.decodeYAML "!!bool \"false\"" :: Either String Bool) `shouldBe` Right False+ (C.decodeYAML "!!int \"001\"" :: Either String Int) `shouldBe` Right 1+ fmap J.yamlToJSON (D.decode "[!!str 001, !!bool \"false\"]") `shouldBe` Right (Aeson.Array (V.fromList [Aeson.String "001", Aeson.Bool False]))+ it "round-trips arbitrary strict and lazy byte payloads without UTF-8 exceptions" $ do+ let bytes = BS.pack [255, 0, 128, 65]+ (C.decodeYAML (C.encodeYAML bytes) :: Either String BS.ByteString) `shouldBe` Right bytes+ let lazyBytes = BSL.fromStrict bytes+ (C.decodeYAML (C.encodeYAML lazyBytes) :: Either String BSL.ByteString) `shouldBe` Right lazyBytes+ (C.decodeYAML "[256]" :: Either String BS.ByteString) `shouldSatisfy` isLeft+ it "preserves Value metadata through the typeclass identity instance" $ do+ let value = YAnchored (Anchor "a") (YTagged (Tag "!custom") (YString "value"))+ C.fromYAML (C.toYAML value) `shouldBe` Right value+ it "rejects native map key collisions introduced by dropping tag metadata" $ do+ let source = "!a key: 1\n!b key: 2\n"+ (C.decodeYAML source :: Either String (Map.Map Text Int)) `shouldSatisfy` isLeft+ (C.decodeYAML source :: Either String Value) `shouldSatisfy` isRight+ (C.fromYAML (mapping [(YInt 1, YInt 1), (YInt 1, YInt 2)]) :: Either String (IntMap.IntMap Int)) `shouldSatisfy` isLeft+ it "preserves non-finite Float values and signed zero through native conversion" $ do+ let nan = C.decodeYAML ".nan" :: Either String Float+ either (const False) isNaN nan `shouldBe` True+ (C.decodeYAML ".inf" :: Either String Float) `shouldBe` Right (1 / 0)+ (C.decodeYAML "-.inf" :: Either String Float) `shouldBe` Right (-1 / 0)+ either (const False) isNegativeZero (C.decodeYAML (C.encodeYAML (negate 0 :: Float)) :: Either String Float) `shouldBe` True
+ test/Test/YAML/Conformance.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Optional spec-conformance harness.++The official YAML test suite (https://github.com/yaml/yaml-test-suite)+ships ~400 test cases of the form++@+ <case-id>/in.yaml -- raw YAML input+ <case-id>/error -- present iff the input must fail+ <case-id>/in.json -- equivalent JSON (where applicable)+ <case-id>/=== -- one-line label+@++We run every test we can find by reading the @YAML_TEST_SUITE@+environment variable and walking the directory. When the variable+is unset, the suite is skipped and a stub success test is emitted+so CI stays green out-of-the-box.++A built-in mini-suite (the cases in @wireform-yaml/test-data/yaml@)+always runs so that core compliance is exercised even without the+external suite.+-}+module Test.YAML.Conformance (tests) where++import Control.DeepSeq (force)+import Control.Exception (SomeException, evaluate, try)+import Control.Monad (filterM)+import Data.Aeson qualified as A+import Data.Aeson.Decoding (toEitherValue)+import Data.Aeson.Decoding.ByteString.Lazy (lbsToTokens)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable (traverse_)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Vector qualified as V+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ listDirectory,+ )+import System.Environment (lookupEnv)+import System.FilePath (takeFileName, (</>))+import Test.Syd+import YAML.Decode qualified as YD+import YAML.Decode.Annotated qualified as YA+import YAML.Encode qualified as YE+import YAML.JSON qualified as YJ+import YAML.Pretty qualified as YP+import YAML.Value qualified as YV+++tests :: IO Spec+tests = do+ builtin <- builtinSuite+ ext <- externalSuite+ pure (describe "conformance" $ sequence_ [builtin, ext])+++-- ---------------------------------------------------------------------------+-- Built-in mini-suite+-- ---------------------------------------------------------------------------++{- | A handful of cases distilled from the YAML 1.2 spec that we+never want to regress on.+-}+builtinSuite :: IO Spec+builtinSuite =+ pure $+ describe "builtin" $+ sequence_+ [ caseOK+ "spec ex 2.1 seq of strings"+ ( T.unlines+ [ "- Mark McGwire"+ , "- Sammy Sosa"+ , "- Ken Griffey"+ ]+ )+ ( \v -> case v of+ YV.YSeq xs -> V.length xs `shouldBe` 3+ _ -> expectationFailure "expected sequence"+ )+ , caseOK+ "spec ex 2.2 mapping of scalars"+ ( T.unlines+ [ "hr: 65"+ , "avg: 0.278"+ , "rbi: 147"+ ]+ )+ ( \v -> do+ YV.lookupKey "hr" v `shouldBe` Just (YV.YInt 65)+ case YV.lookupKey "rbi" v of+ Just (YV.YInt 147) -> pure ()+ r -> expectationFailure (show r)+ )+ , caseOK+ "spec ex 7.1 alias nodes"+ ( T.unlines+ [ "First occurrence: &anchor Foo"+ , "Second occurrence: *anchor"+ ]+ )+ ( \v -> do+ fmap YV.unwrap (YV.lookupKey "First occurrence" v)+ `shouldBe` Just (YV.YString "Foo")+ fmap YV.unwrap (YV.lookupKey "Second occurrence" v)+ `shouldBe` Just (YV.YString "Foo")+ )+ , caseOK+ "spec ex 8.1 block scalar header"+ ( T.unlines+ [ "literal: |"+ , " text"+ , "folded: >"+ , " text"+ ]+ )+ ( \v -> do+ YV.lookupKey "literal" v `shouldBe` Just (YV.YString "text\n")+ YV.lookupKey "folded" v `shouldBe` Just (YV.YString "text\n")+ )+ , caseOK+ "spec ex 5.3 block sequence"+ ( T.unlines+ [ "block sequence:"+ , " - one"+ , " - two : three"+ ]+ )+ ( \v -> case YV.lookupKey "block sequence" v of+ Just (YV.YSeq xs) -> V.length xs `shouldBe` 2+ _ -> expectationFailure "expected nested sequence"+ )+ , caseOK+ "flow nested in block"+ ( T.unlines+ [ "flow: { a: 1, b: 2, c: [3, 4] }"+ ]+ )+ ( \v -> case YV.lookupKey "flow" v of+ Just (YV.YMap _) -> pure ()+ r -> expectationFailure (show r)+ )+ , caseOK+ "string preserves int-like value when quoted"+ "version: \"1.0\""+ (\v -> YV.lookupKey "version" v `shouldBe` Just (YV.YString "1.0"))+ ]+++caseOK :: String -> T.Text -> (YV.Value -> IO ()) -> Spec+caseOK name src k = it name $+ case YD.decode src of+ Left e -> expectationFailure $ "decode failed: " ++ e+ Right v -> k v+++-- ---------------------------------------------------------------------------+-- External suite (yaml-test-suite)+-- ---------------------------------------------------------------------------++externalSuite :: IO Spec+externalSuite = do+ mDir <- lookupEnv "YAML_TEST_SUITE"+ case mDir of+ Nothing -> pure (describe "yaml-test-suite (skipped, set YAML_TEST_SUITE)" $ sequence_ [])+ Just dir -> do+ exists <- doesDirectoryExist dir+ if not exists+ then pure (it "YAML_TEST_SUITE must exist" (expectationFailure ("missing conformance path: " ++ dir) :: IO ()))+ else do+ cases <- discoverCases dir+ pure+ ( describe+ ("yaml-test-suite (" ++ show (length cases) ++ " cases)")+ (if null cases then it "suite contains cases" (expectationFailure "no in.yaml cases found; use yaml-test-suite data branch" :: IO ()) else mapM_ (mkCase dir) cases)+ )+++-- | Each case-id is a path relative to the test-suite root.+discoverCases :: FilePath -> IO [FilePath]+discoverCases root = walk root+ where+ -- "tags/" and "name/" are symlink farms grouping the same+ -- cases by category / human-readable name; skip them to+ -- avoid double-counting.+ isTagDir d = case reverse (splitPath d) of+ (last_ : _) ->+ let l = dropTrailingSlash last_+ in l == "tags" || l == "name"+ [] -> False++ splitPath = words . map (\c -> if c == '/' then ' ' else c)+ dropTrailingSlash s = case reverse s of+ ('/' : rs) -> reverse rs+ _ -> s++ walk d+ | isTagDir d = pure []+ | otherwise = do+ entries <- listDirectory d+ let absEntries = map (d </>) entries+ dirs <- filterM doesDirectoryExist absEntries+ hasIn <- doesFileExist (d </> "in.yaml")+ let here = if hasIn then [d] else []+ subs <- mapM walk dirs+ pure (here ++ concat subs)+++mkCase :: FilePath -> FilePath -> Spec+mkCase _root caseDir = it caseDir $ do+ let inPath = caseDir </> "in.yaml"+ errPath = caseDir </> "error"+ jsonPath = caseDir </> "in.json"+ isErr <- doesFileExist errPath+ bytes <- BS.readFile inPath+ res <-+ try (evaluate (force (YD.decodeStreamBS bytes)))+ :: IO (Either SomeException (Either String YV.Stream))+ case (isErr, res) of+ (True, Right (Left _)) -> pure ()+ (True, Right (Right _)) -> expectationFailure "expected parse error, got success"+ (True, Left e) -> expectationFailure $ "exception instead of parse error: " ++ show e+ (False, Right (Right s))+ | takeFileName caseDir `elem` ["X38W", "2JQS"] -> expectationFailure "duplicate keys must fail composition"+ | otherwise -> do+ compareToExpectedJSON jsonPath s+ checkEmittedForms bytes s+ (False, Right (Left e))+ | takeFileName caseDir `elem` ["X38W", "2JQS"] ->+ -- Event-only fixtures with duplicate collection/null keys are valid+ -- parser events, but cannot form a mapping value with unique keys.+ e `shouldBe` "YAML: duplicate mapping key"+ | otherwise -> expectationFailure $ "decode failed: " ++ e+ (False, Left e) -> expectationFailure $ "exception: " ++ show e+++-- Check every valid upstream value through each public renderer as well as the+-- decoder. JSON alone cannot detect corruption of collection-valued keys.+checkEmittedForms :: BS.ByteString -> YV.Stream -> IO ()+checkEmittedForms bytes stream = do+ traverse_+ check+ [ ("encode", YE.encodeStream stream)+ , ("pretty", YP.renderStream YP.defaultOptions stream)+ , ("compact", YP.renderStream YP.compactOptions stream)+ ]+ case TE.decodeUtf8' bytes of+ Left _ -> pure ()+ Right source -> case YA.decodeAnnotatedStream source of+ Left err -> expectationFailure err+ Right (annotated, original) -> check ("normalized annotations", YP.renderAnnotatedStream (YP.defaultOptions {YP.roPreserveOriginalText = False}) annotated (Just original))+ where+ expected = representation stream+ check (label, text) = case YD.decodeStream text of+ Left err -> expectationFailure (label <> ": " <> err <> "\n" <> T.unpack text)+ Right result -> representation result `shouldBe` expected+ representation = show . V.map (strip . YV.docBody) . YV.unStream+ strip = \case+ YV.YAnchored _ inner -> strip inner+ YV.YTagged _ inner -> strip inner+ YV.YSeq xs -> YV.YSeq (strip <$> xs)+ YV.YMap entries -> YV.YMap ((\(k, v) -> (strip k, strip v)) <$> entries)+ value -> value+++{- | When the case ships an @in.json@ companion, compare it against+the JSON projection of every parsed document. Numeric and string+values stay distinct, and multi-document results are checked in full.+-}+compareToExpectedJSON :: FilePath -> YV.Stream -> IO ()+compareToExpectedJSON jsonPath stream = do+ hasJson <- doesFileExist jsonPath+ if not hasJson+ then pure ()+ else do+ raw <- BSL.readFile jsonPath+ case decodeJSONStream raw of+ Left err -> expectationFailure ("invalid expected JSON: " ++ err)+ Right expected ->+ fmap (YJ.yamlToJSON . YV.docBody) (V.toList (YV.unStream stream)) `shouldBe` expected+++-- The upstream data branch stores one JSON value per YAML document, including+-- pretty-printed and scalar values. Decode the whole stream, retaining types.+decodeJSONStream :: BSL.ByteString -> Either String [A.Value]+decodeJSONStream bytes+ | BSL.null rest = Right []+ | otherwise = do+ (value, remaining) <- toEitherValue (lbsToTokens rest)+ (value :) <$> decodeJSONStream remaining+ where+ rest = BSL.dropWhile (\c -> c == 32 || c == 9 || c == 10 || c == 13) bytes
+ test/Test/YAML/Decode.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Decode (tests) where++import Data.Aeson qualified as Aeson+import Data.ByteString qualified as BS+import Data.Either (isLeft)+import Data.Text qualified as T+import Data.Text.Array qualified as TA+import Data.Text.Encoding qualified as TE+import Data.Text.Internal qualified as TI+import Data.Vector qualified as V+import GHC.Exts (Int (..), sizeofByteArray#)+import Test.Syd+import Test.YAML.Helpers (assertRenderRoundtrip)+import YAML.Decode qualified as D+import YAML.Encode qualified as E+import YAML.JSON qualified as J+import YAML.Pretty qualified as P+import YAML.Value+++tests :: Spec+tests =+ describe "decode" $+ sequence_+ [ scalarTests+ , collectionTests+ , flowTests+ , stringTests+ , blockScalarTests+ , anchorTests+ , streamTests+ , validationTests+ ]+++scalarTests :: Spec+scalarTests =+ describe "scalars" $+ sequence_+ [ it "null" $ D.decode "null" `shouldBe` Right YNull+ , it "tilde" $ D.decode "~" `shouldBe` Right YNull+ , it "true" $ D.decode "true" `shouldBe` Right (YBool True)+ , it "false" $ D.decode "false" `shouldBe` Right (YBool False)+ , it "int" $ D.decode "42" `shouldBe` Right (YInt 42)+ , it "neg" $ D.decode "-17" `shouldBe` Right (YInt (-17))+ , it "hex" $ D.decode "0x2A" `shouldBe` Right (YInt 42)+ , it "oct" $ D.decode "0o52" `shouldBe` Right (YInt 42)+ , it "float" $ case D.decode "3.14" of+ Right (YFloat d) -> (abs (d - 3.14) < 1e-9) `shouldBe` True+ r -> expectationFailure (show r)+ , it ".inf" $ case D.decode ".inf" of+ Right (YFloat d) -> (isInfinite d && d > 0) `shouldBe` True+ r -> expectationFailure (show r)+ , it "-.inf" $ case D.decode "-.inf" of+ Right (YFloat d) -> (isInfinite d && d < 0) `shouldBe` True+ r -> expectationFailure (show r)+ , it ".nan" $ case D.decode ".nan" of+ Right (YFloat d) -> (isNaN d) `shouldBe` True+ r -> expectationFailure (show r)+ , it "unquoted string" $ D.decode "hello" `shouldBe` Right (YString "hello")+ ]+++collectionTests :: Spec+collectionTests =+ describe "block style" $+ sequence_+ [ it "block mapping" $ do+ let src =+ T.unlines+ [ "name: alice"+ , "age: 30"+ ]+ case D.decode src of+ Right v -> do+ lookupKey "name" v `shouldBe` Just (YString "alice")+ lookupKey "age" v `shouldBe` Just (YInt 30)+ Left e -> expectationFailure e+ , it "block sequence" $ do+ let src =+ T.unlines+ [ "- 1"+ , "- 2"+ , "- 3"+ ]+ case D.decode src of+ Right (YSeq xs) -> V.toList xs `shouldBe` [YInt 1, YInt 2, YInt 3]+ r -> expectationFailure (show r)+ , it "nested mapping" $ do+ let src =+ T.unlines+ [ "server:"+ , " host: localhost"+ , " port: 8080"+ ]+ case D.decode src of+ Right v ->+ case lookupKey "server" v of+ Just inner -> do+ lookupKey "host" inner `shouldBe` Just (YString "localhost")+ lookupKey "port" inner `shouldBe` Just (YInt 8080)+ _ -> expectationFailure "no server"+ Left e -> expectationFailure e+ , it "sequence of mappings" $ do+ let src =+ T.unlines+ [ "- name: a"+ , " v: 1"+ , "- name: b"+ , " v: 2"+ ]+ case D.decode src of+ Right (YSeq xs) -> do+ V.length xs `shouldBe` 2+ let m0 = xs V.! 0+ lookupKey "name" m0 `shouldBe` Just (YString "a")+ lookupKey "v" m0 `shouldBe` Just (YInt 1)+ r -> expectationFailure (show r)+ , it "comment + blank lines" $ do+ let src =+ T.unlines+ [ "# header"+ , ""+ , "foo: bar # trailing"+ ]+ case D.decode src of+ Right v -> lookupKey "foo" v `shouldBe` Just (YString "bar")+ Left e -> expectationFailure e+ ]+++flowTests :: Spec+flowTests =+ describe "flow style" $+ sequence_+ [ it "flow seq" $+ D.decode "[1, 2, 3]"+ `shouldBe` Right (YSeq (V.fromList [YInt 1, YInt 2, YInt 3]))+ , it "flow map" $ case D.decode "{a: 1, b: 2}" of+ Right (YMap kvs) -> do+ V.length kvs `shouldBe` 2+ r -> expectationFailure (show r)+ , it "nested flow" $+ case D.decode "[[1, 2], [3, 4]]" of+ Right (YSeq xs) -> V.length xs `shouldBe` 2+ r -> expectationFailure (show r)+ ]+++stringTests :: Spec+stringTests =+ describe "strings" $+ sequence_+ [ it "double quoted" $+ D.decode "\"hello world\"" `shouldBe` Right (YString "hello world")+ , it "single quoted" $+ D.decode "'it''s ok'" `shouldBe` Right (YString "it's ok")+ , it "escape \\n" $+ D.decode "\"a\\nb\"" `shouldBe` Right (YString "a\nb")+ , it "escape \\u" $+ D.decode "\"\\u00E9\"" `shouldBe` Right (YString "\233")+ , it "quoted in mapping" $ do+ case D.decode "msg: \"hello\\tworld\"" of+ Right v -> lookupKey "msg" v `shouldBe` Just (YString "hello\tworld")+ Left e -> expectationFailure e+ ]+++blockScalarTests :: Spec+blockScalarTests =+ describe "block scalars" $+ sequence_+ [ it "literal" $ do+ let src =+ T.unlines+ [ "txt: |"+ , " one"+ , " two"+ ]+ case D.decode src of+ Right v -> lookupKey "txt" v `shouldBe` Just (YString "one\ntwo\n")+ Left e -> expectationFailure e+ , it "literal strip" $ do+ let src =+ T.unlines+ [ "txt: |-"+ , " one"+ , " two"+ ]+ case D.decode src of+ Right v -> lookupKey "txt" v `shouldBe` Just (YString "one\ntwo")+ Left e -> expectationFailure e+ , it "folded" $ do+ let src =+ T.unlines+ [ "txt: >"+ , " one"+ , " two"+ ]+ case D.decode src of+ Right v -> lookupKey "txt" v `shouldBe` Just (YString "one two\n")+ Left e -> expectationFailure e+ ]+++anchorTests :: Spec+anchorTests =+ describe "anchors" $+ sequence_+ [ it "anchor + alias scalar" $ do+ let src =+ T.unlines+ [ "a: &x 1"+ , "b: *x"+ ]+ case D.decode src of+ Right v -> do+ -- Aliases come back wrapped in 'YAnchored' so the+ -- size-of walk can identify shared subtrees by name;+ -- 'unwrap' strips the wrapper for value comparison.+ fmap unwrap (lookupKey "a" v) `shouldBe` Just (YInt 1)+ fmap unwrap (lookupKey "b" v) `shouldBe` Just (YInt 1)+ Left e -> expectationFailure e+ ]+++streamTests :: Spec+streamTests =+ describe "stream" $+ sequence_+ [ it "single doc, no markers" $+ case D.decodeStream "k: 1" of+ Right (Stream xs) -> V.length xs `shouldBe` 1+ Left e -> expectationFailure e+ , it "two docs" $ do+ let src =+ T.unlines+ [ "---"+ , "a: 1"+ , "..."+ , "---"+ , "b: 2"+ ]+ case D.decodeStream src of+ Right (Stream xs) -> V.length xs `shouldBe` 2+ Left e -> expectationFailure e+ ]+++validationTests :: Spec+validationTests = describe "validation" $ do+ it "decodes escapes after Unicode characters and Unicode flow siblings" $+ mapM_+ (\(src, expected) -> D.decode src `shouldBe` Right expected)+ [ ("\"é\\n\"", YString "é\n")+ , ("[é, \"😀\\t\\u0061\"]", seq_ [YString "é", YString "😀\ta"])+ , ("\"é\\x41\\U0001F600\"", YString "éA😀")+ ]+ it "rejects invalid Unicode scalar escapes through Either" $+ mapM_+ (\src -> D.decode src `shouldSatisfy` isLeft)+ ["\"\\U00110000\"", "\"\\UFFFFFFFF\"", "\"\\uD800\"", "[\"\\uDFFF\"]"]+ it "does not mistake quoted strings for aliases" $ do+ D.decode "[\"\\0alias\\0missing\"]" `shouldBe` Right (seq_ [YString "\0alias\0missing"])+ case D.decode "[&a secret, \"\\0alias\\0a\"]" of+ Right (YSeq xs) -> xs V.! 1 `shouldBe` YString "\0alias\0a"+ other -> expectationFailure (show other)+ it "ignores stream end markers that do not terminate a document" $ do+ D.decodeStream "# comment\n...\n" `shouldBe` Right (Stream V.empty)+ fmap (V.map docBody . unStream) (D.decodeStream "a\n...\n...\nb\n")+ `shouldBe` Right (V.fromList [YString "a", YString "b"])+ it "keeps document-start comments out of scalar content" $+ D.decode "--- # comment\nscalar\n" `shouldBe` Right (YString "scalar")+ it "resolves overridden secondary tag handles in block and flow nodes" $ do+ fmap J.yamlToJSON (D.decode "%TAG !! tag:example.com,2000:app/\n---\n!!int 1 - 3\n")+ `shouldBe` Right (Aeson.String "1 - 3")+ fmap J.yamlToJSON (D.decode "%TAG !! tag:example.com,2000:app/\n---\n[!!int 1 - 3]\n")+ `shouldBe` Right (Aeson.Array (V.singleton (Aeson.String "1 - 3")))+ it "aliases inherit a tag applied before their anchor" $+ mapM_+ (\src -> fmap J.yamlToJSON (D.decode src) `shouldBe` Right (Aeson.Array (V.fromList [Aeson.Bool False, Aeson.Bool False])))+ ["[!!bool &a false, *a]", "- !!bool &a false\n- *a\n"]+ it "implements core-schema numeric spellings" $+ mapM_+ (\(src, expected) -> D.decode src `shouldBe` Right expected)+ [("01", YInt 1), (".5", YFloat 0.5), ("1.", YFloat 1), ("-.5", YFloat (-0.5)), ("1.e2", YFloat 100), ("0XFF", YString "0XFF"), ("+0xFF", YString "+0xFF")]+ it "rejects malformed UTF-8 in both byte entry points" $ do+ D.decodeBS (BS.pack [0xff]) `shouldSatisfy` isLeft+ D.decodeStreamBS (BS.pack [0xc0, 0x80]) `shouldSatisfy` isLeft+ it "accepts CR and CRLF line endings" $+ mapM_+ (\src -> D.decode src `shouldBe` Right (mapping [(YString "a", YInt 1), (YString "b", YInt 2)]))+ ["a: 1\rb: 2\r", "a: 1\r\nb: 2\r\n"]+ it "keeps earlier alias bindings when a source name is reused" $+ fmap J.yamlToJSON (D.decode "[&a [1], &b [*a, &a 2], *a, *b]")+ `shouldBe` Right (Aeson.Array (V.fromList [Aeson.Array (V.singleton (Aeson.Number 1)), Aeson.Array (V.fromList [Aeson.Array (V.singleton (Aeson.Number 1)), Aeson.Number 2]), Aeson.Number 2, Aeson.Array (V.fromList [Aeson.Array (V.singleton (Aeson.Number 1)), Aeson.Number 2])]))+ it "decodes all YAML escapes in quoted mapping keys" $+ D.decode "\"\\u0061\\x62\\U0001F600\": 1\n\"é\\n\": 2\n"+ `shouldBe` Right (mapping [(YString "ab😀", YInt 1), (YString "é\n", YInt 2)])+ it "rejects malformed escapes in mapping keys" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["\"\\q\": 1", "\"\\uD800\": 1", "x: 0\n\"\\U00110000\": 1", "\"unterminated: 1"]+ it "handles URI punctuation inside verbatim flow tags" $ do+ let value = seq_ [YTagged (Tag "urn:comma,a") (YString "x")]+ D.decode "[!<urn:comma,a> x]" `shouldBe` Right value+ D.decode (P.render P.compactOptions value) `shouldBe` Right value+ it "expands each tag handle exactly once" $+ D.decode "%TAG ! !prefix-\n---\n!foo key: value\n"+ `shouldBe` Right (mapping [(YTagged (Tag "!prefix-foo") (YString "key"), YString "value")])+ it "rejects duplicate keys after scalar and tag resolution" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["a: 1\na: 2", "{a: 1, a: 2}", "01: a\n1: b", "!!str a: 1\na: 2", "? [1,2]\n: a\n? [1,2]\n: b", ".nan: a\n.NaN: b", "-0.0: a\n0.0: b"]+ it "rejects stray flow commas and empty anchor names" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["{,a: 1}", "{a: 1,, b: 2}", "{,,}", "[& x]", "& value", "[* ]"]+ it "supports merge mappings with explicit overrides and earlier-map precedence" $+ fmap J.yamlToJSON (D.decode "a: &a {x: 1, y: 2}\nb: &b {x: 3, z: 4}\nvalue:\n <<: [*a, *b]\n y: 9\n")+ `shouldBe` Right (Aeson.object ["a" Aeson..= Aeson.object ["x" Aeson..= (1 :: Int), "y" Aeson..= (2 :: Int)], "b" Aeson..= Aeson.object ["x" Aeson..= (3 :: Int), "z" Aeson..= (4 :: Int)], "value" Aeson..= Aeson.object ["x" Aeson..= (1 :: Int), "y" Aeson..= (9 :: Int), "z" Aeson..= (4 :: Int)]])+ it "keeps quoted merge-looking keys literal and rejects invalid merge sources" $ do+ let literal = mapping [(YString "<<", YInt 1)]+ D.decode "\"<<\": 1" `shouldBe` Right literal+ D.decode (E.encode literal) `shouldBe` Right literal+ D.decode (P.render P.defaultOptions literal) `shouldBe` Right literal+ D.decode (E.encode (YString "<<")) `shouldBe` Right (YString "<<")+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["<<: 1", "<<: [{x: 1}, 2]"]+ it "does not retain discarded literal blank lines in the decoded text buffer" $+ mapM_+ ( \header -> case D.decode (header <> "\n text\n" <> T.replicate 10000 "\n") of+ Right (YString text@(TI.Text (TA.ByteArray bytes#) _ _)) -> do+ T.stripEnd text `shouldBe` "text"+ I# (sizeofByteArray# bytes#) `shouldSatisfy` (<= 128)+ result -> expectationFailure (show result)+ )+ ["|-", "|"]+ it "validates controls at every byte alignment through the ASCII fast path" $+ mapM_+ ( \offset -> do+ let prefix = "key: " <> T.replicate offset "x"+ mapM_ (\char -> D.decode (prefix <> T.singleton char) `shouldSatisfy` isLeft) ['\0', '\v', '\x7f', '\x80', '\xFFFF']+ D.decode (prefix <> "\r\nnext: valid\r\n") `shouldBe` D.decode (prefix <> "\nnext: valid\n")+ )+ [0 .. 15]+ it "keeps non-ASCII quoted content on the lexical validation path" $+ mapM_+ ( \offset -> do+ let content = T.replicate offset "x" <> "\x7f\x80\xFFFF"+ D.decode ("\"" <> content <> "\"") `shouldBe` Right (YString content)+ )+ [0 .. 15]+ it "copies literal UTF-8, relative indentation, and chomping without changing content" $ do+ D.decode "|-\n é\n 🧰\n\n\n" `shouldBe` Right (YString "é\n 🧰")+ D.decode "|\n é\n 🧰\n\n\n" `shouldBe` Right (YString "é\n 🧰\n")+ D.decode "|+\n é\n 🧰\n\n\n" `shouldBe` Right (YString "é\n 🧰\n\n\n")+ D.decode "|2-\n a\n b\n\n" `shouldBe` Right (YString " a\n b")+ it "rounds decimal floats correctly and bounds extreme exponents" $ do+ mapM_+ (\number -> D.decode (E.encode (YFloat number)) `shouldBe` Right (YFloat number))+ [1.1930203655234305e70, -2.3686045112702234e69, 5e-324, 2.2250738585072014e-308, 1.7976931348623157e308]+ D.decode "1e999999999999999999999999" `shouldBe` Right (YFloat (1 / 0))+ D.decode "1e-999999999999999999999999" `shouldBe` Right (YFloat 0)+ D.decode "0e999999999999999999999999" `shouldBe` Right (YFloat 0)+ it "rejects raw C0 controls even inside quoted strings and comments" $+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["x\0y", "\"x\0y\"", "'x\1y'", "# comment\2\n"]+ it "rejects non-printable characters in plain and block scalars" $+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["x\x7fy", "x\x9fy", "x\xfffey", "|\n x\xffffy\n", "x\xfeffy"]+ it "accepts byte order marks at document prefixes" $ do+ D.decode "\xfeffkey: value" `shouldBe` Right (mapping [(YString "key", YString "value")])+ fmap (fmap docBody . V.toList . unStream) (D.decodeStream "\xfeff---\n1\n...\n\xfeff---\n2\n") `shouldBe` Right [YInt 1, YInt 2]+ D.decode "- one\n\xfeff\n- two\n" `shouldSatisfy` isLeft+ it "detects UTF-16 and UTF-32 with and without a BOM" $ do+ let source = "key: \"hello 😀\"\n"+ expected = D.decode source+ encoders = [TE.encodeUtf16LE, TE.encodeUtf16BE, TE.encodeUtf32LE, TE.encodeUtf32BE]+ mapM_ (\encode -> mapM_ (\text -> D.decodeBS (encode text) `shouldBe` expected) [source, "\xfeff" <> source]) encoders+ it "rejects malformed wide encodings instead of throwing or replacing characters" $+ mapM_+ (\bytes -> D.decodeBS (BS.pack bytes) `shouldSatisfy` isLeft)+ [[255, 254, 0], [254, 255, 216, 0], [255, 254, 0, 220], [0, 0, 254, 255, 0, 17, 0, 0], [255, 254, 0, 0, 0, 216, 0, 0]]+ it "validates directive versions, handles, and repeated handle declarations" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["%YAML 2.0\n---\nx", "%TAG bad tag:example.com,2020:\n---\nx", "%TAG !bad_! !prefix\n---\nx", "%TAG !e! !a\n%TAG !e! !b\n---\nx"]+ it "rejects repeated properties on one node in both block and flow contexts" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["!foo !bar x", "&a &b x", "[!foo !bar x]", "[&a &b x]", "!foo &a !bar x", "&a !foo &b x"]+ it "validates tag URI spelling without expanding percent escapes" $ do+ D.decode "!<tag:example.com,%41> x" `shouldBe` Right (YTagged (Tag "tag:example.com,%41") (YString "x"))+ mapM_+ (\source -> D.decode source `shouldSatisfy` isLeft)+ ["!<urn:bad%> x", "[!<urn:bad%GG> x]", "!<> x", "!<!> x", "!<$:?> x", "%TAG !e! urn:x\n---\n!e! x", "!<urn:x>value"]+ it "resolves a non-specific tag on an empty node as an empty string" $+ fmap unwrap (D.decode "!") `shouldBe` Right (YString "")+ it "allows a root anchor before a same-column mapping" $+ D.decode "&a\nx: 1\ny: 2\n" `shouldBe` Right (YAnchored (Anchor "a") (mapping [(YString "x", YInt 1), (YString "y", YInt 2)]))+ it "registers properties on later mapping keys before parsing their values" $+ mapM_+ (\source -> D.decode source `shouldSatisfy` either (const False) (const True))+ ["first: 1\n&a second: *a\n", "? first\n: 1\n&a second: *a\n", "[1]: value\n&a second: *a\n"]+ it "decodes quoted keys followed by quoted values as mappings" $+ mapM_+ (\source -> D.decode source `shouldBe` Right (mapping [(YString "", YString "")]))+ ["\"\": \"\"", "'': ''"]+ it "uses null for empty implicit keys and honours explicit flow-key markers" $ do+ D.decode ":" `shouldBe` Right (mapping [(YNull, YNull)])+ D.decode "{? foo :, : bar}" `shouldBe` Right (mapping [(YString "foo", YNull), (YNull, YString "bar")])+ D.decode "{?}" `shouldBe` Right (mapping [(YNull, YNull)])+ it "keeps compact mapping keys inside explicit keys" $+ D.decode "? []: x\n" `shouldBe` Right (mapping [(mapping [(seq_ [], YString "x")], YNull)])+ it "does not absorb sibling sequence entries into empty anchored values or keys" $ do+ D.decode "- first: &a\n- second\n" `shouldBe` Right (seq_ [mapping [(YString "first", YAnchored (Anchor "a") YNull)], YString "second"])+ D.decode "- ? &a\n- second\n" `shouldBe` Right (seq_ [mapping [(YAnchored (Anchor "a") YNull, YNull)], YString "second"])+ it "preserves comment-looking block scalar content at its baseline" $+ D.decode "text: |\n first\n # content\n last\n" `shouldBe` Right (mapping [(YString "text", YString "first\n# content\nlast\n")])+ it "rejects reserved indicators in plain scalars at roots and in flow values" $+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["@foo", "`foo", "[%foo]", "[|foo]", "{a: :}", "key: @foo", "key: `foo"]+ it "rejects multiple documents through single-document entry points" $ do+ D.decode "1\n---\n2" `shouldSatisfy` isLeft+ D.decodeBS "1\n---\n2" `shouldSatisfy` isLeft+ it "treats empty custom-tag scalars as empty strings" $+ D.decode "!custom" `shouldBe` Right (YTagged (Tag "!custom") (YString ""))+ it "distinguishes raw non-C0 quoted content from non-printable comments" $ do+ mapM_ (\source -> fmap unwrap (D.decode source) `shouldBe` Right (YString "\x9f")) ["\"\x9f\"", "'\x9f'", "--- \"\x9f\"", "\xfeff\"\x9f\""]+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["# \"\x9f\"\n", "key: value # \xfffe", "'key': \"value\" # \x7f"]+ it "preserves Unicode spaces and non-ASCII line separators as scalar content" $+ mapM_+ ( \char -> do+ let space = T.singleton char+ strings = [space, "left" <> space, space <> "right", "left" <> space <> "right"]+ mapM_+ ( \text -> do+ D.decode text `shouldBe` Right (YString text)+ D.decode (E.encode (YString text)) `shouldBe` Right (YString text)+ mapM_ (\options -> assertRenderRoundtrip options (mapping [(YString ("key" <> space), YString text)])) [P.defaultOptions, P.compactOptions]+ )+ strings+ )+ ['\xA0', '\x85', '\x2009', '\x2028', '\x2029']+ it "keeps non-breaking spaces next to comment indicators and continuation prefixes" $ do+ let nbsp = T.singleton '\xA0'+ D.decode ("key: " <> nbsp <> "#content") `shouldBe` Right (mapping [(YString "key", YString (nbsp <> "#content"))])+ D.decode ("first\n " <> nbsp <> "second") `shouldBe` Right (YString ("first " <> nbsp <> "second"))+ D.decode ("\"first\n " <> nbsp <> "second\"") `shouldBe` Right (YString ("first " <> nbsp <> "second"))+ it "requires ASCII directive separation and float tag spellings" $ do+ D.decode ("%YAML " <> T.singleton '\xA0' <> "1.2\n---\nx") `shouldSatisfy` isLeft+ D.decode "!!float 0x10" `shouldSatisfy` isLeft+ case D.decode "!!float -0" of+ Right value -> case unwrap value of YFloat number -> isNegativeZero number `shouldBe` True; _ -> expectationFailure "expected float"+ Left err -> expectationFailure err+ it "accepts numeric YAML versions with leading zeroes" $+ D.decode "%YAML 01.02\n---\nx" `shouldBe` Right (YString "x")+ it "accepts indented comments throughout multiline flow collections" $ do+ D.decode "{\n # key comment\n key: 1\n # before close\n}\n" `shouldBe` D.decode "{key: 1}"+ D.decode "[\n # item comment\n 1, # inline\n # next comment\n 2\n]\n" `shouldBe` D.decode "[1, 2]"+ it "decodes expanding Unicode escapes into their UTF-8 scalars" $ do+ let source = "\"é" <> T.replicate 500 "\\L\\P\\u00a0\\U0010ffff" <> "\\nlast\""+ expected = YString ("é" <> T.replicate 500 "\x2028\x2029\xA0\x10FFFF" <> "\nlast")+ D.decode source `shouldBe` Right expected+ it "distinguishes escaped quotes after odd and even backslash runs" $+ mapM_+ (\text -> assertRenderRoundtrip (P.defaultOptions {P.roStringStyleHint = P.HintAlwaysDouble}) (YString text))+ ["\\", "\\\"", "\\\\", "\\\\\"", "a\"b\\c", "é\\\\\"last"]+ it "rejects incomplete and out-of-range escapes at the end of a quoted buffer" $+ mapM_ (\source -> D.decode source `shouldSatisfy` isLeft) ["\"trailing\\", "[\"\\u\"]", "\"\\Uffffffff\"", "\"\\U00110000\"", "\"\\uD800\""]
+ test/Test/YAML/Derive.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Derive (tests) where++import Data.Either (isLeft)+import Data.Vector qualified as V+import Test.Syd+import Test.YAML.Derive.Instances ()+import Test.YAML.Derive.Types+import YAML.Class qualified as Y+import YAML.Value qualified as YV+++tests :: Spec+tests =+ describe "YAML.Derive" $+ sequence_+ [ describe "defaults and coercion" $ do+ it "derives coercion constraints for polymorphic record fields" $+ Y.decodeYAML (Y.encodeYAML (CoercedBox (Wrapped 7))) `shouldBe` Right (CoercedBox (Wrapped 7))+ it "derives coercion constraints for optional polymorphic record fields" $+ mapM_ (\value -> Y.decodeYAML (Y.encodeYAML value) `shouldBe` Right value) [OptionalCoercedBox (Just (Wrapped 9)), OptionalCoercedBox Nothing]+ it "uses defaults for missing ordinary fields" $+ Y.decodeYAML "{}" `shouldBe` Right (DefaultRecord 3)+ it "decodes provided fields instead of their default" $+ Y.decodeYAML "retries: 9" `shouldBe` Right (DefaultRecord 9)+ it "combines optional defaults and coercion" $ do+ Y.decodeYAML "{}" `shouldBe` Right (OptionalCoerced (Just (Wrapped 5)))+ Y.decodeYAML "optional-wrapped: null" `shouldBe` Right (OptionalCoerced Nothing)+ it "round-trips present and absent coerced optional fields" $+ mapM_ (\value -> Y.decodeYAML (Y.encodeYAML value) `shouldBe` Right value) [OptionalCoerced Nothing, OptionalCoerced (Just (Wrapped 9))]+ it "round-trips through the annotated coercion target" $+ Y.decodeYAML (Y.encodeYAML (CoercedRecord (Wrapped 7))) `shouldBe` Right (CoercedRecord (Wrapped 7))+ , describe "optional fields" $ do+ it "round-trips null and present values" $+ mapM_ (\v -> Y.decodeYAML (Y.encodeYAML v) `shouldBe` Right v) [OptionalRecord Nothing, OptionalRecord (Just 3)]+ it "accepts an absent optional field" $+ Y.decodeYAML "{}" `shouldBe` Right (OptionalRecord Nothing)+ , describe "record constructors in sums" $ do+ it "encodes record contents as a mapping with field modifiers" $ do+ let value = NamedRecord "test" 7 "secret"+ case Y.toYAML value of+ YV.YMap entries -> case YV.lookupKey "contents" (YV.YMap entries) of+ Just contents -> do+ YV.lookupKey "name" contents `shouldBe` Just (YV.YString "test")+ YV.lookupKey "record-private" contents `shouldBe` Nothing+ Nothing -> expectationFailure "missing contents"+ _ -> expectationFailure "expected mapping"+ it "applies defaults and skipped-field defaults to record sum contents" $+ Y.decodeYAML "tag: named-record\ncontents: {name: test}\n" `shouldBe` Right (NamedRecord "test" 3 "<redacted>")+ it "round-trips record and nullary constructors" $+ mapM_ (\value -> Y.decodeYAML (Y.encodeYAML value) `shouldBe` Right value) [NoRecord, NamedRecord "test" 7 "<redacted>"]+ , describe "native field names" $ do+ it "rejects ambiguous tagged field names in TH records" $+ (Y.decodeYAML "!a boxed: 1\n!b boxed: 2\n" :: Either String (Box Int)) `shouldSatisfy` isLeft+ it "rejects ambiguous tagged field names in generic records" $+ (Y.decodeYAML "!a genericCount: 1\n!b genericCount: 2\n" :: Either String GenericRecord) `shouldSatisfy` isLeft+ it "decodes ordinary generic records" $+ Y.decodeYAML "genericCount: 3" `shouldBe` Right (GenericRecord 3)+ , recordTests+ , newtypeTests+ , enumTests+ , sumTests+ , describe "polymorphic types" $ do+ it "derives constraints for record fields" $+ Y.decodeYAML (Y.encodeYAML (Box (3 :: Int))) `shouldBe` Right (Box (3 :: Int))+ it "constrains applied higher-kinded parameters" $+ Y.decodeYAML (Y.encodeYAML (WrappedF (Just (3 :: Int)))) `shouldBe` Right (WrappedF (Just (3 :: Int)))+ it "supports recursive polymorphic sums" $ do+ let tree = Branch (Leaf (3 :: Int)) (Just (Leaf 4))+ Y.decodeYAML (Y.encodeYAML tree) `shouldBe` Right tree+ it "leaves phantom parameters unconstrained" $+ Y.toYAML (Phantom :: Phantom (Int -> Int)) `shouldBe` YV.YString "phantom"+ ]+++recordTests :: Spec+recordTests =+ describe "record" $+ sequence_+ [ it "encode applies rename + renameStyle, drops skipped" $ do+ let p = Profile "Alice" 30 "a@x" "secret"+ case Y.toYAML p of+ YV.YMap kvs -> do+ (V.elem (YV.YString "name", YV.YString "Alice") kvs) `shouldBe` True+ (V.any (keyIs "profile_age") kvs) `shouldBe` True+ (V.any (keyIs "email") kvs) `shouldBe` True+ (not (V.any (keyIs "profilePrivate") kvs)) `shouldBe` True+ v -> expectationFailure ("expected YMap, got " ++ show v)+ , it "round-trip fills skipped from defaults" $ do+ let p = Profile "Alice" 30 "a@x" "secret"+ case Y.fromYAML (Y.toYAML p) of+ Right p' -> do+ profileName p' `shouldBe` profileName p+ profileAge p' `shouldBe` profileAge p+ profileEmail p' `shouldBe` profileEmail p+ profilePrivate p' `shouldBe` defaultPrivate+ Left e -> expectationFailure e+ ]+ where+ keyIs t (YV.YString k, _) = k == t+ keyIs _ _ = False+++newtypeTests :: Spec+newtypeTests =+ describe "newtype" $+ sequence_+ [ it "pass-through" $+ Y.toYAML (Tag 42) `shouldBe` YV.YInt 42+ , it "round-trip" $+ Y.fromYAML (Y.toYAML (Tag 7)) `shouldBe` Right (Tag 7)+ ]+++enumTests :: Spec+enumTests =+ describe "enum" $+ sequence_+ [ it "Red" $ Y.toYAML Red `shouldBe` YV.YString "red"+ , it "DarkBlue" $ Y.toYAML DarkBlue `shouldBe` YV.YString "dark-blue"+ , it "round-trip" $+ mapM_ rt [Red, Green, DarkBlue]+ , it "unknown fails" $+ case Y.fromYAML (YV.YString "purple") :: Either String Color of+ Left _ -> pure ()+ Right c -> expectationFailure ("unexpected " ++ show c)+ ]+ where+ rt :: Color -> IO ()+ rt c = Y.fromYAML (Y.toYAML c) `shouldBe` Right c+++sumTests :: Spec+sumTests =+ describe "sum" $+ sequence_+ [ it "Origin (nullary) -> tag only, no contents" $+ Y.toYAML Origin+ `shouldBe` YV.YMap+ ( V.fromList+ [ (YV.YString "tag", YV.YString "origin")+ ]+ )+ , it "Circle (unary) -> contents = inner value" $+ Y.toYAML (Circle 1.5)+ `shouldBe` YV.YMap+ ( V.fromList+ [ (YV.YString "tag", YV.YString "circle")+ , (YV.YString "contents", YV.YFloat 1.5)+ ]+ )+ , it "Rect (n-ary) -> contents = YSeq" $+ Y.toYAML (Rect 2 3)+ `shouldBe` YV.YMap+ ( V.fromList+ [ (YV.YString "tag", YV.YString "rect")+ ,+ ( YV.YString "contents"+ , YV.YSeq (V.fromList [YV.YFloat 2, YV.YFloat 3])+ )+ ]+ )+ , it "round-trip Origin" $ rt Origin+ , it "round-trip Circle" $ rt (Circle 2.5)+ , it "round-trip Rect" $ rt (Rect 4 5)+ , it "unknown tag fails" $ do+ let bad =+ YV.YMap+ ( V.fromList+ [ (YV.YString "tag", YV.YString "ellipse")+ ]+ )+ case Y.fromYAML bad :: Either String Shape of+ Left _ -> pure ()+ Right s -> expectationFailure ("unexpected " ++ show s)+ ]+ where+ rt :: Shape -> IO ()+ rt s = Y.fromYAML (Y.toYAML s) `shouldBe` Right s
+ test/Test/YAML/Derive/Instances.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.YAML.Derive.Instances () where++import Test.YAML.Derive.Types+import YAML.Class (FromYAML, ToYAML)+import YAML.Derive+++deriveYAML ''Profile+deriveYAML ''Tag+deriveYAML ''Color+deriveYAML ''Shape+++deriveYAML ''OptionalRecord+++deriveYAML ''DefaultRecord+deriveYAML ''CoercedRecord+++deriveYAML ''OptionalCoerced+++deriveYAML ''Box+deriveYAML ''WrappedF+deriveYAML ''Tree+deriveYAML ''Phantom+++deriveYAML ''RecordChoice+++instance ToYAML GenericRecord+++instance FromYAML GenericRecord+++deriveYAML ''CoercedBox+deriveYAML ''OptionalCoercedBox
+ test/Test/YAML/Derive/Types.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Annotated fixture types for the YAML deriver round-trip tests.+module Test.YAML.Derive.Types (+ Profile (..),+ OptionalRecord (..),+ DefaultRecord (..),+ Wrapped (..),+ CoercedRecord (..),+ CoercedBox (..),+ OptionalCoercedBox (..),+ OptionalCoerced (..),+ Box (..),+ WrappedF (..),+ Tree (..),+ Phantom (..),+ RecordChoice (..),+ GenericRecord (..),+ defaultWrapped,+ defaultRetries,+ Tag (..),+ Color (..),+ Shape (..),+ defaultPrivate,+) where++import Data.Text (Text)+import GHC.Generics (Generic)+import Wireform.Derive.Backend+import Wireform.Derive.Modifier+import Wireform.Derive.NameStyle+++data Box a = Box {boxed :: a} deriving (Eq, Show)+++newtype WrappedF f a = WrappedF (f a) deriving (Eq, Show)+++data Tree a = Leaf a | Branch (Tree a) (Maybe (Tree a)) deriving (Eq, Show)+++data Phantom a = Phantom deriving (Eq, Show)+++data Profile = Profile+ { profileName :: !Text+ , profileAge :: !Int+ , profileEmail :: !Text+ , profilePrivate :: !Text+ }+ deriving (Eq, Show)+++defaultPrivate :: Text+defaultPrivate = "<redacted>"+++{-# ANN profileName (rename "name") #-}+++{-# ANN profileAge (renameStyle SnakeCase) #-}+++{-# ANN profileEmail (renameStyle (StripPrefix "profile" `andThen` SnakeCase)) #-}+++{-# ANN profilePrivate (forBackend backendYAML skip) #-}+{-# ANN profilePrivate (forBackend backendYAML (defaults 'defaultPrivate)) #-}+++newtype Tag = Tag {unTag :: Int}+ deriving (Eq, Show)+++data Color = Red | Green | DarkBlue+ deriving (Eq, Show)+++{-# ANN Red (rename "red") #-}+++{-# ANN Green (rename "green") #-}+++{-# ANN DarkBlue (renameStyle KebabCase) #-}+++data Shape+ = Origin+ | Circle !Double+ | Rect !Double !Double+ deriving (Eq, Show)+++{-# ANN Origin (rename "origin") #-}+++{-# ANN Circle (rename "circle") #-}+++{-# ANN Rect (renameStyle SnakeCase) #-}+++data OptionalRecord = OptionalRecord {optionalCount :: Maybe Int}+ deriving (Eq, Show)+++{-# ANN optionalCount optional #-}+++data DefaultRecord = DefaultRecord {retries :: Int} deriving (Eq, Show)+++defaultRetries :: Int+defaultRetries = 3+++{-# ANN retries (defaults 'defaultRetries) #-}+++newtype Wrapped = Wrapped Int deriving (Eq, Show)+++data CoercedRecord = CoercedRecord {wrapped :: Wrapped} deriving (Eq, Show)+++{-# ANN wrapped (coerced ''Int) #-}+++data OptionalCoerced = OptionalCoerced {optionalWrapped :: Maybe Wrapped} deriving (Eq, Show)+++defaultWrapped :: Maybe Wrapped+defaultWrapped = Just (Wrapped 5)+++{-# ANN optionalWrapped optional #-}+{-# ANN optionalWrapped (coerced ''Int) #-}+{-# ANN optionalWrapped (defaults 'defaultWrapped) #-}+++data RecordChoice+ = NoRecord+ | NamedRecord+ { recordName :: Text+ , recordRetries :: Int+ , recordPrivate :: Text+ }+ deriving (Eq, Show)+++{-# ANN recordName (rename "name") #-}+++{-# ANN recordRetries (defaults 'defaultRetries) #-}+++{-# ANN recordPrivate (forBackend backendYAML skip) #-}+{-# ANN recordPrivate (forBackend backendYAML (defaults 'defaultPrivate)) #-}+++data GenericRecord = GenericRecord {genericCount :: Int} deriving (Eq, Show, Generic)+++data CoercedBox a = CoercedBox {coercedBox :: a} deriving (Eq, Show)+++{-# ANN coercedBox (coerced ''Int) #-}+++data OptionalCoercedBox a = OptionalCoercedBox {optionalCoercedBox :: Maybe a} deriving (Eq, Show)+++{-# ANN optionalCoercedBox optional #-}+{-# ANN optionalCoercedBox (coerced ''Int) #-}
+ test/Test/YAML/Encode.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Encode (tests) where++import Data.Either (isLeft)+import Data.Text qualified as T+import Data.Vector qualified as V+import Test.Syd+import Test.YAML.Helpers (assertRenderRoundtrip)+import YAML.Decode qualified as D+import YAML.Encode qualified as E+import YAML.JSON qualified as J+import YAML.Pretty qualified as P+import YAML.Value+++tests :: Spec+tests =+ describe "encode" $+ sequence_+ [ scalarOutput+ , collectionOutput+ , quotingTests+ , structuralRoundtripTests+ ]+++scalarOutput :: Spec+scalarOutput =+ describe "scalars" $+ sequence_+ [ it "null" $ E.encode YNull `shouldBe` "null\n"+ , it "true" $ E.encode (YBool True) `shouldBe` "true\n"+ , it "false" $ E.encode (YBool False) `shouldBe` "false\n"+ , it "int" $ E.encode (YInt 42) `shouldBe` "42\n"+ , it "float" $ (T.last (E.encode (YFloat 3.14)) == '\n') `shouldBe` True+ ]+++collectionOutput :: Spec+collectionOutput =+ describe "collections" $+ sequence_+ [ it "empty seq" $ E.encode (YSeq V.empty) `shouldBe` "[]\n"+ , it "empty map" $ E.encode (YMap V.empty) `shouldBe` "{}\n"+ , it "block map" $ do+ let v = YMap (V.fromList [(YString "a", YInt 1), (YString "b", YInt 2)])+ E.encode v `shouldBe` "a: 1\nb: 2\n"+ , it "nested map" $ do+ let v =+ YMap+ ( V.fromList+ [+ ( YString "outer"+ , YMap (V.fromList [(YString "x", YInt 1)])+ )+ ]+ )+ E.encode v `shouldBe` "outer:\n x: 1\n"+ , it "block seq" $ do+ let v = YSeq (V.fromList [YInt 1, YInt 2])+ E.encode v `shouldBe` "- 1\n- 2\n"+ ]+++quotingTests :: Spec+quotingTests =+ describe "quoting" $+ sequence_+ [ it "string that looks like int is quoted" $ do+ let v = YString "42"+ let out = E.encode v+ case D.decode out of+ Right (YString "42") -> pure ()+ r -> expectationFailure ("did not roundtrip: " ++ show r ++ " from " ++ T.unpack out)+ , it "string that looks like bool is quoted" $ do+ let v = YString "true"+ let out = E.encode v+ case D.decode out of+ Right (YString "true") -> pure ()+ r -> expectationFailure ("did not roundtrip: " ++ show r ++ " from " ++ T.unpack out)+ , it "string with newline" $ do+ let v = YString "a\nb"+ let out = E.encode v+ case D.decode out of+ Right (YString "a\nb") -> pure ()+ r -> expectationFailure (show r)+ ]+++structuralRoundtripTests :: Spec+structuralRoundtripTests = describe "structural round trips" $ do+ it "quotes structural string boundaries" $+ mapM_+ (\str -> D.decode (E.encode (YString str)) `shouldBe` Right (YString str))+ ["foo:", "a:\tvalue", ":", "---", "...", " #", "é\n", "\0alias\0x"]+ it "frames constructed streams without merging documents" $ do+ let docs = V.fromList [Document False False (YInt 1), Document False False (YInt 2)]+ fmap (V.map docBody . unStream) (D.decodeStream (E.encodeStream (Stream docs))) `shouldBe` Right (V.fromList [YInt 1, YInt 2])+ it "preserves tags and anchors at the root and inside collections" $ do+ let tagged = YTagged (Tag "!secret") (YString "x")+ customURI = YTagged (Tag "urn:example:secret") (YString "x")+ mapM_+ (\v -> D.decode (E.encode v) `shouldBe` Right v)+ [YAnchored (Anchor "node") (YInt 1), tagged, customURI, seq_ [tagged], mapping [(YString "x", tagged)], YTagged (Tag "!list") (seq_ [YInt 1]), mapping [(tagged, YInt 1), (customURI, YInt 2)]]+ let source = "[&a [1], *a]"+ case D.decode source of+ Left err -> expectationFailure err+ Right v -> fmap J.yamlToJSON (D.decode (E.encode v)) `shouldBe` Right (J.yamlToJSON v)+ it "preserves non-string block keys through encode and decode" $+ mapM_+ (\value -> D.decode (E.encode value) `shouldBe` Right value)+ [mapping [(YInt 1, YString "integer"), (YBool True, YString "bool"), (YNull, YString "null"), (YFloat 1.5, YString "float"), (YString "1", YString "string")]]+ it "allows escaped controls and JSON-compatible non-C0 quoted content" $+ mapM_ (\text -> D.decode (E.encode (YString text)) `shouldBe` Right (YString text)) ["x\0y", "x\x7fy", "x\x9fy", "x\xfffey", "x\xffffy", "x\xfeffy"]+ it "uses verbatim syntax for local tags containing handle or flow punctuation" $+ mapM_+ ( \tag ->+ let value = YTagged (Tag tag) (YString "x")+ in do+ D.decode (E.encode value) `shouldBe` Right value+ assertRenderRoundtrip P.defaultOptions value+ )+ ["!local!suffix", "!local,comma", "!local[brackets]", "!"]+ it "uses explicit notation for long and collection-valued keys" $ do+ let value = mapping [(YString (T.replicate 1100 "a"), seq_ [YInt 1]), (seq_ [YInt 1], YString "collection")]+ D.decode (E.encode value) `shouldBe` Right value+ mapM_ (\opts -> assertRenderRoundtrip opts value) [P.defaultOptions, P.compactOptions]+ D.decode (T.replicate 1025 "a" <> ": value") `shouldSatisfy` isLeft+ D.decode ("[" <> T.replicate 1025 "a" <> "]: value") `shouldSatisfy` isLeft
+ test/Test/YAML/Helpers.hs view
@@ -0,0 +1,17 @@+module Test.YAML.Helpers (+ assertRenderRoundtrip,+ assertDefaultRenderRoundtrip,+) where++import Test.Syd+import YAML.Decode qualified as D+import YAML.Pretty qualified as P+import YAML.Value (Value)+++assertRenderRoundtrip :: P.RenderOptions -> Value -> IO ()+assertRenderRoundtrip opts value = D.decode (P.render opts value) `shouldBe` Right value+++assertDefaultRenderRoundtrip :: Value -> IO ()+assertDefaultRenderRoundtrip value = D.decode (P.render P.defaultOptions value) `shouldBe` Right value
+ test/Test/YAML/JSON.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.JSON (tests) where++import Data.Aeson qualified as Aeson+import Test.Syd+import YAML.JSON qualified as J+import YAML.Value+++tests :: Spec+tests = describe "json" $ do+ it "projects non-finite JSON values to null" $+ mapM_ (\d -> J.yamlToJSON (YFloat d) `shouldBe` Aeson.Null) [0 / 0, 1 / 0, -1 / 0]
+ test/Test/YAML/Pretty.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Pretty (tests) where++import Data.Text qualified as T+import Data.Vector qualified as V+import Test.Syd+import Test.YAML.Helpers (assertDefaultRenderRoundtrip, assertRenderRoundtrip)+import YAML.Annotated qualified as A+import YAML.Decode qualified as D+import YAML.Pretty qualified as P+import YAML.Value+++tests :: Spec+tests = describe "pretty" $ do+ prettyOptionsRespected+ prettyMaxLineWidth+ it "pretty-prints nested mappings and sequences without changing their shape" $+ mapM_+ assertDefaultRenderRoundtrip+ [ mapping [(YString "outer", mapping [(YString "x", YInt 1)])]+ , mapping [(YString "outer", seq_ [seq_ [YInt 1, YInt 2], mapping [(YString "x", seq_ [YInt 3])]])]+ , seq_ [seq_ [seq_ [YInt 1]], mapping [(YString "x", mapping [(YString "y", YInt 2)])]]+ ]+ it "preserves tagged and anchored containers in pretty output" $+ mapM_ assertDefaultRenderRoundtrip [seq_ [YTagged (Tag "!custom") (mapping [(YString "x", YInt 1)])], mapping [(YTagged (Tag "!key") (YString "x"), YInt 1)]]+ it "preserves exact string content in pretty output" $+ mapM_+ (assertDefaultRenderRoundtrip . YString)+ [" leading", "trailing ", " a ", "a\nb", "a\n", "a\n\n", "\n", "\n\n", "\r", "a\r\nb", "\nleading\nlast\n\n"]+ it "indents literal scalars at their actual nesting level" $+ assertDefaultRenderRoundtrip (mapping [(YString "outer", mapping [(YString "text", YString "a\nb\n\n")])])+ it "quotes whitespace and punctuation in flow collections" $+ mapM_+ (\value -> D.decode (P.render P.compactOptions value) `shouldBe` Right value)+ [seq_ (YString <$> ["a,b", "a[b]", " leading", "trailing ", "a\nb"]), mapping [(YString "a,b", YString "x{y}")]]+ it "keeps flow punctuation quoted when ambiguous scalar coercion is allowed" $ do+ let value = seq_ [YString "a,b", YString " leading"]+ options = P.compactOptions {P.roQuoteAmbiguousScalars = False}+ D.decode (P.render options value) `shouldBe` Right value+ it "uses eight-digit escapes for supplementary non-printing characters" $ do+ let value = YString "x\x1D173y"+ D.decode (P.render (P.defaultOptions {P.roStringStyleHint = P.HintAlwaysDouble}) value) `shouldBe` Right value+ it "keeps null values in mappings" $+ assertRenderRoundtrip P.defaultOptions (mapping [(YString "key", YNull)])+ it "preserves leading whitespace in literal strings at every nesting level" $+ mapM_+ (\text -> mapM_ (assertRenderRoundtrip P.defaultOptions) [YString text, mapping [(YString "text", YString text)], seq_ [YString text]])+ [" first\nnext", "\tfirst\nnext", " \nnext", "\n first\nnext", " first\nnext\n\n", "\n\n"]+ it "round-trips nested containers without compact sequence mappings" $+ assertRenderRoundtrip (P.defaultOptions {P.roCompactSeqOfMap = False}) (seq_ [mapping [(YString "x", seq_ [YInt 1])], seq_ [YInt 2]])+ it "honours fresh trailing-newline preferences" $ do+ P.render P.compactOptions (YInt 1) `shouldBe` "1"+ assertRenderRoundtrip P.compactOptions (YString "a\nb\n\n")+ it "preserves document framing flags" $+ P.renderDocument P.defaultOptions (Document True True (YInt 1)) `shouldBe` "---\n1\n...\n"+ it "emits each requested stream marker exactly once" $ do+ let docs = Stream (V.fromList [Document True True (YInt 1), Document False False (YInt 2)])+ opts = P.defaultOptions {P.roDocStartMarker = True, P.roDocEndMarker = True}+ out = P.renderStream opts docs+ out `shouldBe` "---\n1\n...\n---\n2\n...\n"+ fmap (fmap docBody . V.toList . unStream) (D.decodeStream out) `shouldBe` Right [YInt 1, YInt 2]+ it "indents wrapped flow collections within block mappings" $ do+ let flow = YTagged (Tag "!collection") (seq_ [seq_ (YInt <$> [1 .. 20])])+ value = mapping [(YString "outer", mapping [(YString "nested", flow)])]+ assertRenderRoundtrip (P.defaultOptions {P.roMaxLineWidth = 20}) value+ it "wraps complex explicit keys without dedenting their flow content" $ do+ let value = mapping [(seq_ (YInt <$> [1 .. 20]), YInt 9)]+ assertRenderRoundtrip (P.defaultOptions {P.roMaxLineWidth = 20}) value+ it "applies forced quote styles to fresh mapping keys" $+ P.render (P.defaultOptions {P.roStringStyleHint = P.HintAlwaysSingle}) (mapping [(YString "key", YString "value")]) `shouldBe` "'key': 'value'\n"+ it "uses a positive indentation even when zero or negative is requested" $+ mapM_ (\indent -> assertRenderRoundtrip (P.defaultOptions {P.roIndent = indent}) (mapping [(YString "outer", mapping [(YString "x", YInt 1)])])) [0, -2]+ it "honours flow mapping style for block-sequence items" $ do+ let options = P.defaultOptions {P.roDefaultMapStyle = A.MapFlow}+ value = seq_ [mapping [(YString "x", YInt 1)]]+ T.isInfixOf "{" (P.render options value) `shouldBe` True+ assertRenderRoundtrip options value+ it "preserves whitespace-only literal content with an explicit indentation hint" $+ mapM_ (\text -> mapM_ (assertRenderRoundtrip P.defaultOptions) [YString text, seq_ [seq_ [seq_ [YString text]]]]) [" \n", " \n\n", " \n "]+++prettyOptionsRespected :: Spec+prettyOptionsRespected = it "pretty options affect output" $ do+ let v =+ YMap+ ( V.fromList+ [ (YString "key", YString "value")+ ,+ ( YString "items"+ , YSeq+ ( V.fromList+ [YInt 1, YInt 2, YInt 3]+ )+ )+ ]+ )+ compact = P.render P.compactOptions v+ (if ("{" `T.isInfixOf` compact) then pure () else expectationFailure ("compact emits flow {}: " <> T.unpack compact))+++prettyMaxLineWidth :: Spec+prettyMaxLineWidth = it "max line width wraps long flows" $ do+ let manyItems = YSeq (V.fromList (YInt <$> [1 .. 30]))+ narrow = (P.compactOptions {P.roMaxLineWidth = 20})+ out = P.render narrow manyItems+ -- Should contain at least one newline inside the brackets+ -- because the items don't fit on one line of 20 columns.+ (if (T.count "\n" out > 1) then pure () else expectationFailure ("expected wrapping: " <> T.unpack out))
+ test/Test/YAML/Roundtrip.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.YAML.Roundtrip (tests) where++import Data.HashSet qualified as HS+import Data.Text qualified as T+import Data.Vector qualified as V+import Hedgehog (Property, forAll, property, tripping)+import Hedgehog qualified as H+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Syd+import Test.Syd.Hedgehog ()+import YAML.Decode (decode)+import YAML.Decode qualified as D+import YAML.Encode (encode)+import YAML.Encode qualified as E+import YAML.Pretty qualified as P+import YAML.Value+++tests :: Spec+tests =+ modifyMaxSuccess (const 1000) $+ describe "roundtrip properties" $+ sequence_+ [ it "scalar roundtrip" prop_scalarRoundtrip+ , it "value roundtrip" prop_valueRoundtrip+ , it "pretty value roundtrip across layout options" prop_prettyRoundtrip+ , modifyMaxSuccess (const 100) largeIntegerTests+ ]+++genScalar :: H.Gen Value+genScalar =+ Gen.choice+ [ pure YNull+ , YBool <$> Gen.bool+ , YInt <$> Gen.integral (Range.linearFrom 0 (-1_000_000) 1_000_000)+ , YFloat <$> Gen.double (Range.linearFracFrom 0 (-1e100) 1e100)+ , YString <$> genSafeString+ ]+++genSafeString :: H.Gen T.Text+genSafeString = Gen.text (Range.linear 0 32) (Gen.choice [Gen.unicode, Gen.element [' ', '\NUL', '\r', '\n', '\t', '\xFEFF', '\xFFFE', '\xFFFF', '\xA0', '\x85', '\x2009', '\x2028', '\x2029']])+++genValue :: Int -> H.Gen Value+genValue 0 = genScalar+genValue n =+ Gen.choice+ [ genScalar+ , YSeq . V.fromList <$> Gen.list (Range.linear 0 5) (genValue (n - 1))+ , YMap . V.fromList <$> Gen.filter (\pairs -> let keys = fst <$> pairs in length keys == HS.size (HS.fromList ((\key -> case key of YString text -> text; _ -> "") <$> keys))) (Gen.list (Range.linear 0 5) genKV)+ ]+ where+ genKV = (,) <$> (YString <$> genSafeKey) <*> genValue (n - 1)+ genSafeKey = genSafeString+++prop_scalarRoundtrip :: Property+prop_scalarRoundtrip = property $ do+ v <- forAll genScalar+ tripping v encode decode+++prop_valueRoundtrip :: Property+prop_valueRoundtrip = property $ do+ v <- forAll (genValue 3)+ tripping v encode decode+++prop_prettyRoundtrip :: Property+prop_prettyRoundtrip = property $ do+ value <- forAll (genValue 3)+ opts <- forAll (Gen.element [P.defaultOptions, P.compactOptions, P.defaultOptions {P.roIndent = 4}, P.defaultOptions {P.roCompactSeqOfMap = False}, P.defaultOptions {P.roStringStyleHint = P.HintAlwaysSingle}, P.defaultOptions {P.roStringStyleHint = P.HintAlwaysDouble}])+ tripping value (P.render opts) decode+++largeIntegerTests :: Spec+largeIntegerTests = do+ it "round-trips large integers across signs" $ property $ do+ n <- forAll (Gen.integral (Range.linear (negate (2 ^ (256 :: Int))) (2 ^ (256 :: Int))))+ tripping (YInt n) E.encode D.decode
+ test/Test/YAML/Security.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Tests for the parser's defensive limits against the+well-known YAML denial-of-service classes:++* 'billion laughs' — a small input with N levels of K-fold+ alias references that expands to K^N nodes when traversed+ naively.+* deep nesting — '[[[[…]]]]' / line-after-indented-line that+ consumes recursive Haskell stack proportional to its depth.+* cyclic aliases — an anchor that references itself.+-}+module Test.YAML.Security (tests) where++import Data.Either (isLeft)+import Data.List (isInfixOf)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TB+import Data.Text.Lazy.Builder.Int qualified as BI+import Test.Syd+import YAML.Decode qualified as D+import YAML.Decode qualified as Y+import YAML.Value qualified as YV+++tests :: Spec+tests =+ describe "Security" $+ sequence_+ [ billionLaughsRefused+ , deepBlockRefused+ , selfCycleRejected+ , flowCycleResolution+ , normalAliasesAllowed+ , normalNestingAllowed+ , limitTests+ ]+++{- | A 9-level / 9-fold billion-laughs document expands to 9^9+~ 4×10^8 logical nodes and must be rejected before the parser+hands a 'Value' to the caller.+-}+billionLaughsRefused :: Spec+billionLaughsRefused =+ it "9-level billion laughs is refused" $ do+ let src =+ T.unlines+ [ "a: &a [1,1,1,1,1,1,1,1,1]"+ , "b: &b [*a,*a,*a,*a,*a,*a,*a,*a,*a]"+ , "c: &c [*b,*b,*b,*b,*b,*b,*b,*b,*b]"+ , "d: &d [*c,*c,*c,*c,*c,*c,*c,*c,*c]"+ , "e: &e [*d,*d,*d,*d,*d,*d,*d,*d,*d]"+ , "f: &f [*e,*e,*e,*e,*e,*e,*e,*e,*e]"+ , "g: &g [*f,*f,*f,*f,*f,*f,*f,*f,*f]"+ , "h: &h [*g,*g,*g,*g,*g,*g,*g,*g,*g]"+ , "i: &i [*h,*h,*h,*h,*h,*h,*h,*h,*h]"+ , "value: *i"+ ]+ case Y.decode src of+ Left e ->+ ( if ( "billion-laughs" `isInfixOf` e+ || "alias DAG" `isInfixOf` e+ || "expand" `isInfixOf` e+ )+ then pure ()+ else expectationFailure ("expected billion-laughs error, got: " <> e)+ )+ Right _ -> expectationFailure "expected the 9-level billion-laughs to be refused"+++{- | A document nested past 'maxParserDepth' must error rather+than blowing the runtime stack.+-}+deepBlockRefused :: Spec+deepBlockRefused = it "deep block nesting is refused" $ do+ -- Build a 2000-deep nested mapping: 'a:\\n a:\\n a:\\n …'+ let depth = 2000 :: Int+ src =+ T.intercalate+ "\n"+ ((\i -> T.replicate (2 * i) " " <> "a:") <$> [0 .. depth - 1])+ <> "\n"+ <> T.replicate (2 * depth) " "+ <> "leaf"+ case Y.decode src of+ Left e ->+ (if ("nesting" `isInfixOf` e || "depth" `isInfixOf` e) then pure () else expectationFailure ("expected nesting error, got: " <> e))+ Right _ -> expectationFailure "expected deep nesting to be refused"+++{- | A self-referencing alias must error. Forward references are+illegal per YAML 1.2, so this is a pre-existing guarantee;+the test pins it down.+-}+selfCycleRejected :: Spec+selfCycleRejected = it "self-cycle in alias is rejected" $ do+ let cases = ["a: &a [*a]", "&a\n- *a", "key: &a *a"]+ mapM_ check cases+ where+ check src =+ (if (isLeft (Y.decode src)) then pure () else expectationFailure ("expected error on " <> show src))+++{- | A flow document whose registered anchor's body contains an+alias to the SAME anchor must error rather than producing a+value tree with unresolved alias sentinels.+-}+flowCycleResolution :: Spec+flowCycleResolution = it "flow alias cycle is rejected" $ do+ -- The flow alias '*a' inside '&a [ ... ]' is recorded after+ -- the surrounding flow node is fully parsed; the resolution+ -- pass then encounters the cycle.+ let src = T.pack "{a: &a {self: *a}}"+ case Y.decode src of+ Left _ -> pure () -- any rejection is acceptable; the+ -- combined record-and-resolve pass+ -- naturally surfaces the cycle as a+ -- 'no anchor' error because we walk+ -- bottom-up.+ Right _ -> expectationFailure "expected flow cycle to be refused"+++{- | A modest, normal use of aliases (small fan-out, single+level) must continue to parse.+-}+normalAliasesAllowed :: Spec+normalAliasesAllowed = it "small aliases are allowed" $ do+ let src =+ T.unlines+ [ "defaults: &d"+ , " retries: 3"+ , " timeout: 30"+ , "alpha: *d"+ , "beta: *d"+ ]+ case Y.decode src of+ Right v ->+ case YV.lookupKey "alpha" v of+ Just _ -> pure ()+ Nothing -> expectationFailure "expected alpha to resolve"+ Left e -> expectationFailure ("unexpected error: " <> e)+++{- | A document nested below 'maxParserDepth' must continue to+parse. Pin the limit at 'a few hundred'.+-}+normalNestingAllowed :: Spec+normalNestingAllowed = it "moderate nesting is allowed" $ do+ let depth = 200 :: Int+ src =+ T.intercalate+ "\n"+ ((\i -> T.replicate (2 * i) " " <> "a:") <$> [0 .. depth - 1])+ <> "\n"+ <> T.replicate (2 * depth) " "+ <> "leaf"+ case Y.decode src of+ Right _ -> pure ()+ Left e ->+ expectationFailure+ ( "unexpected error at depth "+ <> show depth+ <> ": "+ <> e+ )+++limitTests :: Spec+limitTests = describe "limits" $ do+ it "bounds both flow and mixed block/flow nesting" $ do+ let nested = T.replicate 2000 "[" <> "0" <> T.replicate 2000 "]"+ D.decode nested `shouldSatisfy` isLeft+ D.decode ("items: " <> nested) `shouldSatisfy` isLeft+ let block = T.unlines ((\i -> T.replicate (2 * i) " " <> "a:") <$> [0 .. 899])+ D.decode (block <> T.replicate 1800 " " <> T.replicate 200 "[" <> "0" <> T.replicate 200 "]") `shouldSatisfy` isLeft+ D.decode (T.replicate 200 "[" <> "0" <> T.replicate 200 "]") `shouldSatisfy` either (const False) (const True)+ it "rejects alias amplification after legal name rebinding" $ do+ let layer i =+ let (old, new) = if odd i then ("a", "b") else ("b", "a")+ in "&" <> new <> " [" <> T.intercalate ", " (replicate 9 ("*" <> old) <> ["&" <> old <> " 0"]) <> "]"+ source = "[" <> T.intercalate ", " ("&a [0]" : (layer <$> [1 .. 10 :: Int])) <> "]"+ D.decode source `shouldSatisfy` isLeft+ it "bounds total document expansion as well as individual anchors" $ do+ let layer (i, prior) = "&a" <> numberText i <> " [" <> T.intercalate "," (replicate 9 ("*a" <> numberText prior)) <> "]"+ anchors = "&a0 [0]" : (layer <$> zip [1 .. 6 :: Int] [0 .. 5])+ source = "[" <> T.intercalate "," (anchors <> replicate 100 "*a6") <> "]"+ D.decode source `shouldSatisfy` isLeft+ it "rejects indentation that cannot fit the parser state instead of wrapping it" $+ D.decode ("outer:\n" <> T.replicate 1048575 " " <> "key: value\n") `shouldSatisfy` isLeft+++numberText :: Int -> Text+numberText = TL.toStrict . TB.toLazyText . BI.decimal
+ wireform-yaml.cabal view
@@ -0,0 +1,144 @@+cabal-version: 3.0+name: wireform-yaml+version: 0.1.0.0+synopsis: Spec-conformant YAML 1.2 encoding/decoding+description:+ YAML 1.2 codecs with a dynamic value model, generic and Template Haskell+ derivation, and an aeson bridge. Supports block and flow collections,+ tags, anchors, aliases, literal and folded scalars, and document streams.+ An annotated syntax tree supports source-preserving edits. Decoders bound+ nesting depth and alias expansion.+category: Data, Codec, Serialization+homepage: https://github.com/iand675/wireform-+bug-reports: https://github.com/iand675/wireform-/issues+tested-with: GHC == 9.10.3, GHC == 9.12.4, GHC == 9.14.1+license: BSD-3-Clause+license-file: LICENSE+author: Ian Duncan+maintainer: ian@iankduncan.com+copyright: 2026 Ian Duncan+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md+ bench-results/charts/*.svg++source-repository head+ type: git+ location: https://github.com/iand675/wireform-.git+ subdir: wireform-yaml++common defaults+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints+ -O2+ -funbox-strict-fields+ -fspec-constr+ -fspec-constr-keen+ -flate-dmd-anal+ default-language: GHC2021+ default-extensions:+ StrictData+ DerivingStrategies+ DeriveGeneric+ DeriveAnyClass+ OverloadedStrings+ LambdaCase++library+ import: defaults+ hs-source-dirs: src+ exposed-modules:+ YAML+ YAML.Annotated+ YAML.Class+ YAML.Decode+ YAML.Decode.Annotated+ YAML.Derive+ YAML.Encode+ YAML.Encoding+ YAML.JSON+ YAML.Pretty+ YAML.Value+ other-modules:+ YAML.Internal+ YAML.Decode.Flow+ build-depends:+ base >= 4.20 && < 5,+ wireform-derive ^>= 0.2.0.0,+ mtl >= 2.2 && < 2.4,+ hashable >= 1.4 && < 1.6,+ unordered-containers >= 0.2 && < 0.3,+ bytestring >= 0.11 && < 0.13,+ text >= 2.0 && < 2.2,+ vector >= 0.13 && < 0.14,+ containers >= 0.6 && < 0.9,+ aeson >= 2.1 && < 2.4,+ scientific >= 0.3 && < 0.4,+ deepseq >= 1.4 && < 1.6,+ template-haskell >= 2.18 && < 2.25++benchmark wireform-yaml-bench+ import: defaults+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Bench.hs+ ghc-options: -O2 -fproc-alignment=64 -rtsopts+ build-depends:+ base,+ wireform-yaml,+ bytestring,+ text,+ vector,+ HsYAML,+ yaml,+ aeson,+ deepseq,+ containers,+ criterion >= 1.5++test-suite wireform-yaml-test+ import: defaults+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Test.YAML.Annotated+ Test.YAML.Class+ Test.YAML.Conformance+ Test.YAML.Decode+ Test.YAML.Derive+ Test.YAML.Derive.Instances+ Test.YAML.Derive.Types+ Test.YAML.Encode+ Test.YAML.Helpers+ Test.YAML.JSON+ Test.YAML.Pretty+ Test.YAML.Roundtrip+ Test.YAML.Security+ default-extensions:+ ScopedTypeVariables+ TemplateHaskell+ build-depends:+ base,+ deepseq,+ wireform-yaml,+ wireform-derive ^>= 0.2.0.0,+ aeson >= 2.2 && < 2.4,+ bytestring,+ scientific,+ text,+ vector,+ containers,+ unordered-containers,+ directory,+ filepath,+ sydtest,+ sydtest-hedgehog,+ hedgehog