diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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.
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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
+```
+
+
+_No data yet. Run `cabal test wireform-yaml:all --test-show-details=streaming --xml=dist-stats/test-results/wireform-yaml.junit.xml` to populate._
+
+
+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
+```
+
+
+
+
+ 
+
+
+| 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 |
+
+Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.
+
+
+
+
+
+ 
+
+
+| 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 |
+
+Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.
+
+
+### Escaped strings and derived records
+
+
+
+
+ 
+
+
+| 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 |
+
+Last run 2026-11-02 14:35:47 UTC. ghc-9.10.3 on darwin-aarch64, criterion 1.6.5.
+
+
+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)
diff --git a/bench-results/charts/yaml-decode-vs-hsyaml-dark.svg b/bench-results/charts/yaml-decode-vs-hsyaml-dark.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-decode-vs-hsyaml-dark.svg
@@ -0,0 +1,62 @@
+
diff --git a/bench-results/charts/yaml-decode-vs-hsyaml-light.svg b/bench-results/charts/yaml-decode-vs-hsyaml-light.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-decode-vs-hsyaml-light.svg
@@ -0,0 +1,62 @@
+
diff --git a/bench-results/charts/yaml-decode-vs-libyaml-dark.svg b/bench-results/charts/yaml-decode-vs-libyaml-dark.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-decode-vs-libyaml-dark.svg
@@ -0,0 +1,62 @@
+
diff --git a/bench-results/charts/yaml-decode-vs-libyaml-light.svg b/bench-results/charts/yaml-decode-vs-libyaml-light.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-decode-vs-libyaml-light.svg
@@ -0,0 +1,62 @@
+
diff --git a/bench-results/charts/yaml-extra-vs-libyaml-dark.svg b/bench-results/charts/yaml-extra-vs-libyaml-dark.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-extra-vs-libyaml-dark.svg
@@ -0,0 +1,52 @@
+
diff --git a/bench-results/charts/yaml-extra-vs-libyaml-light.svg b/bench-results/charts/yaml-extra-vs-libyaml-light.svg
new file mode 100644
--- /dev/null
+++ b/bench-results/charts/yaml-extra-vs-libyaml-light.svg
@@ -0,0 +1,52 @@
+
diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench.hs
@@ -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 ()
diff --git a/src/YAML.hs b/src/YAML.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML.hs
@@ -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.
diff --git a/src/YAML/Annotated.hs b/src/YAML/Annotated.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Annotated.hs
@@ -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
diff --git a/src/YAML/Class.hs b/src/YAML/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Class.hs
@@ -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
diff --git a/src/YAML/Decode.hs b/src/YAML/Decode.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Decode.hs
@@ -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@, @!\@,
+ 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 @\\@ 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 '\\' 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 @- @ / @-@.
+-}
+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
+ -- '-' or '- ' (nested block
+ -- marker reached via a tab in the indent column) is 'tab as
+ -- indentation' per spec §6.1. The plain-scalar form
+ -- '-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' / ':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)
+ -- '!' 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 #-}
diff --git a/src/YAML/Decode/Annotated.hs b/src/YAML/Decode/Annotated.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Decode/Annotated.hs
@@ -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
diff --git a/src/YAML/Decode/Flow.hs b/src/YAML/Decode/Flow.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Decode/Flow.hs
@@ -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)
diff --git a/src/YAML/Derive.hs b/src/YAML/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Derive.hs
@@ -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
diff --git a/src/YAML/Encode.hs b/src/YAML/Encode.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Encode.hs
@@ -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'
diff --git a/src/YAML/Encoding.hs b/src/YAML/Encoding.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Encoding.hs
@@ -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
diff --git a/src/YAML/Internal.hs b/src/YAML/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Internal.hs
@@ -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
diff --git a/src/YAML/JSON.hs b/src/YAML/JSON.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/JSON.hs
@@ -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
+@.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 ""
+
+
+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)
diff --git a/src/YAML/Pretty.hs b/src/YAML/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Pretty.hs
@@ -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
diff --git a/src/YAML/Value.hs b/src/YAML/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/YAML/Value.hs
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -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
diff --git a/test/Test/YAML/Annotated.hs b/test/Test/YAML/Annotated.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Annotated.hs
@@ -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)
diff --git a/test/Test/YAML/Class.hs b/test/Test/YAML/Class.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Class.hs
@@ -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
diff --git a/test/Test/YAML/Conformance.hs b/test/Test/YAML/Conformance.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Conformance.hs
@@ -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
+
+@
+ /in.yaml -- raw YAML input
+ /error -- present iff the input must fail
+ /in.json -- equivalent JSON (where applicable)
+ /=== -- 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
diff --git a/test/Test/YAML/Decode.hs b/test/Test/YAML/Decode.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Decode.hs
@@ -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 "[! 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 "! x" `shouldBe` Right (YTagged (Tag "tag:example.com,%41") (YString "x"))
+ mapM_
+ (\source -> D.decode source `shouldSatisfy` isLeft)
+ ["! x", "[! x]", "!<> x", "! x", "!<$:?> x", "%TAG !e! urn:x\n---\n!e! 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\""]
diff --git a/test/Test/YAML/Derive.hs b/test/Test/YAML/Derive.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Derive.hs
@@ -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 "")
+ it "round-trips record and nullary constructors" $
+ mapM_ (\value -> Y.decodeYAML (Y.encodeYAML value) `shouldBe` Right value) [NoRecord, NamedRecord "test" 7 ""]
+ , 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
diff --git a/test/Test/YAML/Derive/Instances.hs b/test/Test/YAML/Derive/Instances.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Derive/Instances.hs
@@ -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
diff --git a/test/Test/YAML/Derive/Types.hs b/test/Test/YAML/Derive/Types.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Derive/Types.hs
@@ -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 = ""
+
+
+{-# 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) #-}
diff --git a/test/Test/YAML/Encode.hs b/test/Test/YAML/Encode.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Encode.hs
@@ -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
diff --git a/test/Test/YAML/Helpers.hs b/test/Test/YAML/Helpers.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Helpers.hs
@@ -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
diff --git a/test/Test/YAML/JSON.hs b/test/Test/YAML/JSON.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/JSON.hs
@@ -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]
diff --git a/test/Test/YAML/Pretty.hs b/test/Test/YAML/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Pretty.hs
@@ -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))
diff --git a/test/Test/YAML/Roundtrip.hs b/test/Test/YAML/Roundtrip.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Roundtrip.hs
@@ -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
diff --git a/test/Test/YAML/Security.hs b/test/Test/YAML/Security.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/YAML/Security.hs
@@ -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
diff --git a/wireform-yaml.cabal b/wireform-yaml.cabal
new file mode 100644
--- /dev/null
+++ b/wireform-yaml.cabal
@@ -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
+
+
+