packages feed

yamlet (empty) → 1.0.0.0

raw patch · 1955 files changed

+33363/−0 lines, 1955 filesdep +HsYAMLdep +aesondep +attoparsec

Dependencies added: HsYAML, aeson, attoparsec, attoparsec-aeson, base, bytestring, containers, deepseq, directory, filepath, ghc-heap, inspection-testing, integer-logarithms, scientific, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, template-haskell, text, text-builder-linear, text-iso8601, time, uuid-types, vector, yaml, yamlet

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# yamlet-1.0.0.0 (2026-10-11)+* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2026, Andrzej Rybczak++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Andrzej Rybczak nor the names of other+      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+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,240 @@+# yamlet++[![CI](https://github.com/arybczak/yamlet/actions/workflows/haskell-gha.yaml/badge.svg?branch=master)](https://github.com/arybczak/yamlet/actions/workflows/haskell-gha.yaml?query=branch%3Amaster)+[![Hackage](https://img.shields.io/hackage/v/yamlet.svg)](https://hackage.haskell.org/package/yamlet)+[![Stackage LTS](https://www.stackage.org/package/yamlet/badge/lts)](https://www.stackage.org/lts/package/yamlet)+[![Stackage Nightly](https://www.stackage.org/package/yamlet/badge/nightly)](https://www.stackage.org/nightly/package/yamlet)++A YAML 1.2.2 library written in Haskell. Main features:++- Conformance: the parser passes all cases of the+  [YAML test suite](https://github.com/yaml/yaml-test-suite).+- Performance: decoding and encoding are very fast, see the+  [benchmarks](#performance).+- Decoding and encoding with the classes `FromYaml` and `ToYaml`, with+  instances for common types.+- Instances for your own data types, derived via `GenericYaml`.+  Inspection tests check that the generic representation optimizes away+  for common shapes of data types.+- Errors with the line, the column and the path of the problem, e.g.+  `jobs[1].name`. The decoder reports the errors of independent parts+  together, e.g. every bad field of a record.+- A syntax tree that keeps the comments and the empty lines. A program can+  change a file and write it back with its comments, and a decoded value+  can keep a part of the document as it was written.+- Output that YAML 1.1 parsers read the same way, e.g. PyYAML and go-yaml+  v2, which Kubernetes uses.+- Safe for untrusted input. The time of a decode is close to linear in the+  size of the input, and the memory is linear.++The library supports GHC 9.2 and later.++## Example++A configuration type derives its decoder. The decoder rejects unknown keys,+and the default gives the paths when the key is missing:++```haskell+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NoFieldSelectors #-}++import Data.Text (Text)+import Yamlet++data Config = Config+  { name :: Text+  , paths :: [FilePath]+  }+  deriving stock (Generic, Show)+  deriving (FromYaml) via GenericYaml Config++instance GenericYamlOptions Config where+  yamlDefault = Just Config {name = requiredField, paths = ["."]}++main :: IO ()+main = do+  result <- decodeFile @Config path+  case result of+    Left errs -> mapM_ (putStrLn . prettyError path) errs+    Right config -> print config+  where+    path :: FilePath+    path = "config.yaml"+```++For this file:++```yaml+name: app+```++the program prints the configuration with the default paths:++```+Config {name = "app", paths = ["."]}+```++For this file:++```yaml+paths:+- src+- 42+port: 80+```++the program prints every error:++```+config.yaml:1:1: missing key "name"+  |+1 | paths:+  | ^+config.yaml:3:3: paths[1]: expected a string, but got an integer, quote the value, e.g. '42'+  |+3 | - 42+  |   ^+config.yaml:4:1: unknown key "port", expected one of: name, paths+  |+4 | port: 80+  | ^+```++A decoded type can also keep comments and parts of a document as they were+written:++```haskell+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NoFieldSelectors #-}++import Data.Text (Text)+import Yamlet++data Workflow = Workflow+  { name :: Commented Text+  , matrix :: Node+  }+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Workflow+```++This input decodes to a `Workflow`, and `encodeText` writes it back+unchanged:++```yaml+# The name in the UI.+name: build # short+matrix:+  # Each system runs the jobs.+  os: [linux, macos]+  ghc: ['9.10', '9.12']+```++The record types of the library, e.g. `Error` and `YamlOptions`, have no+field selectors. Read a field with the `OverloadedRecordDot` extension, e.g.+`err.message`, and set one with the record syntax, e.g.+`defaultYamlOptions {fieldLabelModifier = snakeCase}`, or with the generic+optics of [optics-core](https://hackage.haskell.org/package/optics-core),+e.g. `defaultYamlOptions & #fieldLabelModifier .~ snakeCase`.++## Performance++Each library decodes three generated inputs into the same Haskell type and+encodes a value of that type back to YAML:++- `config`: a list of records in block style, as in a configuration file.+- `json`: a list of records in JSON syntax.+- `text`: a mapping of long multi-line strings.++Decoding:++| Input              | yamlet | HsYAML  | yaml   |+|--------------------|--------|---------|--------|+| `config`, 1105 KiB | 27 ms  | 3017 ms | 116 ms |+| `json`, 432 KiB    | 15 ms  | 2420 ms | 61 ms  |+| `text`, 834 KiB    | 7.1 ms | 637 ms  | 13 ms  |++Encoding:++| Input              | yamlet | HsYAML | yaml   |+|--------------------|--------|--------|--------|+| `config`, 1105 KiB | 21 ms  | 39 ms  | 57 ms  |+| `json`, 432 KiB    | 12 ms  | 19 ms  | 34 ms  |+| `text`, 834 KiB    | 3.2 ms | 11 ms  | 9.5 ms |++The times come from GHC 9.10.3 on a Ryzen 9950X3D. Each benchmark ran in its+own process, pinned to one core of the CCD with the 3D V-cache. The `yaml`+package uses the libyaml C library and converts the data by way of an aeson+`Value`. The section [Development](#development) shows how to run the+benchmarks.++## Known limits++- No streaming. The parser reads the whole input, and a decode of a stream+  parses all its documents before it decodes the first one. The library has+  no interface to the events of the parser.+- Only YAML 1.2. A document with `%YAML 1.1` follows the rules of YAML 1.2,+  e.g. `yes` is a string and `0755` is the integer 755. The merge keys of+  YAML 1.1 (`<<`) are not supported.+- The renderer writes its own layout. A file written back keeps its+  comments, empty lines, styles and anchors, but not its indentation or the+  spaces between tokens.+- Limits for untrusted input. The aliases of a stream can add at most+  100000 nodes and characters, or as many as the stream has if it has+  more. The prefixes of `%TAG` directives can add at most 100000 bytes to+  the tags of a stream, or as many as the stream has. A float with an+  exponent beyond the range from -1000 to 1000 is an error, e.g. `1e1001`.+  The library does not limit the size of the input, so a program that+  reads untrusted input must limit it.+- No deriving with Template Haskell. The generic instances optimize well for+  the common shapes of data types, and a second way to derive instances+  would double what the tests must cover.++## Coming from the yaml package++The instances of yamlet read and write the same YAML as the aeson instances+that the [yaml](https://hackage.haskell.org/package/yaml) package uses, with+a few exceptions. Some come from YAML 1.2, e.g. `yes` is a string and `<<`+is an ordinary key. Others come from the types, e.g. the keys of a+`Map Int` are integers and `1.0` is not an `Int`. The document+[Coming from the yaml package](https://github.com/arybczak/yamlet/blob/master/docs/coming-from-yaml.md)+lists all of them.++The package [yamlet-aeson](https://hackage.haskell.org/package/yamlet-aeson)+decodes and encodes with the instances of aeson, so a program can switch to+yamlet before it has instances of yamlet.++## Development++The test suite reads the data of the YAML test suite, release+`data-2022-01-17`, from `tests/fixtures/yaml-test-suite`. The repository+contains the data. To download it again, e.g. after you change the release+in the script, run this command:++```+scripts/fetch-test-suite.sh+```++The file `tests/fixtures/error-messages.txt` holds the expected error+message for each invalid input of the YAML test suite. If you change an+error message on purpose, update the file with this command and review the+diff:++```+YAMLET_ACCEPT_ERRORS=1 cabal test+```++To run the benchmarks of the section [Performance](#performance) and print+its tables, run this command:++```+scripts/bench-readme.sh+```++The script runs each benchmark in its own process and pins it to core 2. To+use another core, set the `CORE` variable, e.g.+`CORE=4 scripts/bench-readme.sh`.
+ bench/Main.hs view
@@ -0,0 +1,18 @@+module Main (main) where++import Data.ByteString qualified as BS+import Test.Tasty.Bench++import Yamlet.Bench.Derive+import Yamlet.Bench.Inputs+import Yamlet.Bench.Libraries++main :: IO ()+main = do+  mapM_ (uncurry printSize) inputs+  checkDerived+  defaultMain $ libraryBenchmarks ++ [deriveBenchmarks]+  where+    printSize :: String -> BS.ByteString -> IO ()+    printSize name bs =+      putStrLn $ name ++ ": " ++ show (BS.length bs `div` 1024) ++ " KiB"
+ bench/Yamlet/Bench/Derive.hs view
@@ -0,0 +1,83 @@+-- | The benchmarks that compare generic instances with written ones.+module Yamlet.Bench.Derive+  ( checkDerived+  , deriveBenchmarks+  ) where++import Control.DeepSeq+import Control.Monad+import Data.ByteString qualified as BS+import Test.Tasty.Bench++import Yamlet+import Yamlet.Bench.Derive.Generic qualified as G+import Yamlet.Bench.Derive.Manual qualified as M++-- | Fail if the two versions of a type give different YAML.+checkDerived :: IO ()+checkDerived = do+  same "contents" G.mkX M.mkX+  same "flat" G.mkF M.mkF+  where+    same :: (ToYaml g, ToYaml m) => String -> (Int -> g) -> (Int -> m) -> IO ()+    same name mkG mkM =+      unless (encode (map mkG values) == encode (map mkM values)) $+        fail ("the generic and the written instances differ: " ++ name)++-- | The benchmarks of each format, grouped by the operation, so that the+-- times of the two versions are next to each other.+deriveBenchmarks :: Benchmark+deriveBenchmarks =+  bgroup+    "derive"+    [ format "contents" G.mkX M.mkX+    , format "flat" G.mkF M.mkF+    ]+  where+    format+      :: forall g m+       . (NFData g, FromYaml g, ToYaml g, NFData m, FromYaml m, ToYaml m)+      => String+      -> (Int -> g)+      -> (Int -> m)+      -> Benchmark+    format name mkG mkM =+      bgroup+        name+        [ bgroup+            "toYaml"+            [ bench "generic" $ nf toYaml gs+            , bench "manual" $ nf toYaml ms+            ]+        , bgroup+            "parseYaml"+            [ bench "generic" $ nf (runParser (parseYaml @[g])) yaml+            , bench "manual" $ nf (runParser (parseYaml @[m])) yaml+            ]+        , bgroup+            "encode"+            [ bench "generic" $ nf encode gs+            , bench "manual" $ nf encode ms+            ]+        , bgroup+            "decode"+            [ bench "generic" $ nf (either (error . show) id . decode @[g]) bs+            , bench "manual" $ nf (either (error . show) id . decode @[m]) bs+            ]+        ]+      where+        gs :: [g]+        gs = map mkG values++        ms :: [m]+        ms = map mkM values++        -- Both versions give the same YAML, see 'checkDerived'.+        yaml :: Node+        yaml = toYaml gs++        bs :: BS.ByteString+        bs = encode gs++values :: [Int]+values = [1 .. 1000]
+ bench/Yamlet/Bench/Derive/Fields.hs view
@@ -0,0 +1,37 @@+-- | The values of the benchmark types, shared by "Yamlet.Bench.Derive.Generic" and+-- "Yamlet.Bench.Derive.Manual".+module Yamlet.Bench.Derive.Fields+  ( fields+  ) where++import Data.Text qualified as T++-- | The fields of a record of the benchmarks for the number, given to its+-- constructor. The records have the same field types.+fields+  :: ( T.Text+       -> Maybe Int+       -> Int+       -> T.Text+       -> Maybe Int+       -> Int+       -> T.Text+       -> Maybe Int+       -> Int+       -> T.Text+       -> r+     )+  -> Int+  -> r+fields con i =+  con+    (T.pack (show i))+    (if even i then Nothing else Just 2)+    (i + 3)+    (T.pack (show (i * 4)))+    (if even i then Nothing else Just 5)+    (i + 6)+    (T.pack (show (i * 7)))+    (if even i then Nothing else Just 8)+    (i + 9)+    (T.pack (show (i * 10)))
+ bench/Yamlet/Bench/Derive/Generic.hs view
@@ -0,0 +1,92 @@+-- | The benchmark types with generic instances. "Yamlet.Bench.Derive.Manual" has the+-- same types with written instances, which give the same YAML.+module Yamlet.Bench.Derive.Generic+  ( A (..)+  , B (..)+  , C (..)+  , X (..)+  , F (..)+  , mkX+  , mkF+  ) where++import Control.DeepSeq+import Data.Text qualified as T++import Yamlet+import Yamlet.Bench.Derive.Fields++data A = A+  { a01 :: T.Text+  , a02 :: Maybe Int+  , a03 :: Int+  , a04 :: T.Text+  , a05 :: Maybe Int+  , a06 :: Int+  , a07 :: T.Text+  , a08 :: Maybe Int+  , a09 :: Int+  , a10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData, GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml A++data B = B+  { b01 :: T.Text+  , b02 :: Maybe Int+  , b03 :: Int+  , b04 :: T.Text+  , b05 :: Maybe Int+  , b06 :: Int+  , b07 :: T.Text+  , b08 :: Maybe Int+  , b09 :: Int+  , b10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData, GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml B++data C = C+  { c01 :: T.Text+  , c02 :: Maybe Int+  , c03 :: Int+  , c04 :: T.Text+  , c05 :: Maybe Int+  , c06 :: Int+  , c07 :: T.Text+  , c08 :: Maybe Int+  , c09 :: Int+  , c10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData, GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml C++-- | A sum of records with the default encoding.+data X = X1 A | X2 B | X3 C+  deriving stock (Generic)+  deriving anyclass (NFData, GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml X++-- | The same sum with flat fields.+data F = F1 A | F2 B | F3 C+  deriving stock (Generic)+  deriving anyclass (NFData)+  deriving (FromYaml, ToYaml) via GenericYaml F++instance GenericYamlOptions F where+  type SumEncoding F = TaggedFlat++mkX :: Int -> X+mkX i = case i `mod` 3 of+  0 -> X1 (fields A i)+  1 -> X2 (fields B i)+  _ -> X3 (fields C i)++mkF :: Int -> F+mkF i = case i `mod` 3 of+  0 -> F1 (fields A i)+  1 -> F2 (fields B i)+  _ -> F3 (fields C i)
+ bench/Yamlet/Bench/Derive/Manual.hs view
@@ -0,0 +1,208 @@+-- | The types of "Yamlet.Bench.Derive.Generic" with written instances.+module Yamlet.Bench.Derive.Manual+  ( A (..)+  , B (..)+  , C (..)+  , X (..)+  , F (..)+  , mkX+  , mkF+  ) where++import Control.DeepSeq+import Data.Text qualified as T++import Yamlet+import Yamlet.Bench.Derive.Fields++data A = A+  { a01 :: T.Text+  , a02 :: Maybe Int+  , a03 :: Int+  , a04 :: T.Text+  , a05 :: Maybe Int+  , a06 :: Int+  , a07 :: T.Text+  , a08 :: Maybe Int+  , a09 :: Int+  , a10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++instance ToYaml A where+  toYaml x =+    mapping+      [ "a01" .= x.a01+      , "a02" .= x.a02+      , "a03" .= x.a03+      , "a04" .= x.a04+      , "a05" .= x.a05+      , "a06" .= x.a06+      , "a07" .= x.a07+      , "a08" .= x.a08+      , "a09" .= x.a09+      , "a10" .= x.a10+      ]++instance FromYaml A where+  parseYaml = withMapping $ \o ->+    A+      <$> parseField o "a01"+      <*> parseFieldMaybe o "a02"+      <*> parseField o "a03"+      <*> parseField o "a04"+      <*> parseFieldMaybe o "a05"+      <*> parseField o "a06"+      <*> parseField o "a07"+      <*> parseFieldMaybe o "a08"+      <*> parseField o "a09"+      <*> parseField o "a10"++data B = B+  { b01 :: T.Text+  , b02 :: Maybe Int+  , b03 :: Int+  , b04 :: T.Text+  , b05 :: Maybe Int+  , b06 :: Int+  , b07 :: T.Text+  , b08 :: Maybe Int+  , b09 :: Int+  , b10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++instance ToYaml B where+  toYaml x =+    mapping+      [ "b01" .= x.b01+      , "b02" .= x.b02+      , "b03" .= x.b03+      , "b04" .= x.b04+      , "b05" .= x.b05+      , "b06" .= x.b06+      , "b07" .= x.b07+      , "b08" .= x.b08+      , "b09" .= x.b09+      , "b10" .= x.b10+      ]++instance FromYaml B where+  parseYaml = withMapping $ \o ->+    B+      <$> parseField o "b01"+      <*> parseFieldMaybe o "b02"+      <*> parseField o "b03"+      <*> parseField o "b04"+      <*> parseFieldMaybe o "b05"+      <*> parseField o "b06"+      <*> parseField o "b07"+      <*> parseFieldMaybe o "b08"+      <*> parseField o "b09"+      <*> parseField o "b10"++data C = C+  { c01 :: T.Text+  , c02 :: Maybe Int+  , c03 :: Int+  , c04 :: T.Text+  , c05 :: Maybe Int+  , c06 :: Int+  , c07 :: T.Text+  , c08 :: Maybe Int+  , c09 :: Int+  , c10 :: T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++instance ToYaml C where+  toYaml x =+    mapping+      [ "c01" .= x.c01+      , "c02" .= x.c02+      , "c03" .= x.c03+      , "c04" .= x.c04+      , "c05" .= x.c05+      , "c06" .= x.c06+      , "c07" .= x.c07+      , "c08" .= x.c08+      , "c09" .= x.c09+      , "c10" .= x.c10+      ]++instance FromYaml C where+  parseYaml = withMapping $ \o ->+    C+      <$> parseField o "c01"+      <*> parseFieldMaybe o "c02"+      <*> parseField o "c03"+      <*> parseField o "c04"+      <*> parseFieldMaybe o "c05"+      <*> parseField o "c06"+      <*> parseField o "c07"+      <*> parseFieldMaybe o "c08"+      <*> parseField o "c09"+      <*> parseField o "c10"++-- | A sum of records with the default encoding.+data X = X1 A | X2 B | X3 C+  deriving stock (Generic)+  deriving anyclass (NFData)++instance ToYaml X where+  toYaml = \case+    X1 a -> tagged "X1" a+    X2 b -> tagged "X2" b+    X3 c -> tagged "X3" c+    where+      tagged :: ToYaml a => T.Text -> a -> Node+      tagged t a = mapping ["tag" .= t, "contents" .= a]++instance FromYaml X where+  parseYaml = withMapping $ \o -> do+    tag <- parseField o "tag"+    case tag :: T.Text of+      "X1" -> X1 <$> parseField o "contents"+      "X2" -> X2 <$> parseField o "contents"+      "X3" -> X3 <$> parseField o "contents"+      _ -> fail ("unknown tag " ++ show tag)++-- | The same sum with flat fields.+data F = F1 A | F2 B | F3 C+  deriving stock (Generic)+  deriving anyclass (NFData)++instance ToYaml F where+  toYaml = \case+    F1 a -> tagged "F1" (toYaml a)+    F2 b -> tagged "F2" (toYaml b)+    F3 c -> tagged "F3" (toYaml c)+    where+      tagged :: T.Text -> Node -> Node+      tagged t n = case view n of+        MappingView kvs -> mapping (("tag" .= t) : kvs)+        _ -> mapping ["tag" .= t, "contents" .= n]++instance FromYaml F where+  parseYaml = withMapping $ \o -> do+    tag <- parseField o "tag"+    case tag :: T.Text of+      "F1" -> F1 <$> parseYaml (objectNode o)+      "F2" -> F2 <$> parseYaml (objectNode o)+      "F3" -> F3 <$> parseYaml (objectNode o)+      _ -> fail ("unknown tag " ++ show tag)++mkX :: Int -> X+mkX i = case i `mod` 3 of+  0 -> X1 (fields A i)+  1 -> X2 (fields B i)+  _ -> X3 (fields C i)++mkF :: Int -> F+mkF i = case i `mod` 3 of+  0 -> F1 (fields A i)+  1 -> F2 (fields B i)+  _ -> F3 (fields C i)
+ bench/Yamlet/Bench/Inputs.hs view
@@ -0,0 +1,72 @@+-- | The generated YAML inputs of the benchmarks.+module Yamlet.Bench.Inputs+  ( inputs+  , configInput+  , jsonInput+  , textInput+  ) where++import Data.ByteString qualified as BS+import Data.Text qualified as T+import Data.Text.Encoding qualified as T++-- | The inputs of the benchmarks that do not decode to a type.+inputs :: [(String, BS.ByteString)]+inputs = [("config", configInput), ("json", jsonInput), ("text", textInput)]++-- | A block sequence of block mappings, as in a configuration file.+configInput :: BS.ByteString+configInput = T.encodeUtf8 . T.concat $ map record [1 .. 5000]+  where+    record :: Int -> T.Text+    record i =+      T.unlines+        [ "- name: item " <> num i+        , "  id: " <> num i+        , "  tags: [alpha, beta, gamma]"+        , "  description: \"an \\\"escaped\\\" string\\twith a tab\""+        , "  path: /usr/local/share/item-" <> num i+        , "  enabled: true"+        , "  nested:"+        , "    x: 1.5"+        , "    y: -3"+        , "    list:"+        , "      - one"+        , "      - 'two'"+        ]++-- | JSON-like flow collections.+jsonInput :: BS.ByteString+jsonInput = T.encodeUtf8 $ "[" <> T.intercalate ",\n " (map record [1 .. 5000]) <> "]\n"+  where+    record :: Int -> T.Text+    record i =+      T.concat+        [ "{\"id\": "+        , num i+        , ", \"name\": \"item "+        , num i+        , "\", \"values\": [1, 2.5, true, null], \"child\": {\"a\": \"b\"}}"+        ]++-- | Block scalars and multi-line plain scalars.+textInput :: BS.ByteString+textInput = T.encodeUtf8 . T.concat $ map entry [1 .. 2000]+  where+    entry :: Int -> T.Text+    entry i =+      T.unlines+        [ "key" <> num i <> ": |"+        , "  Lorem ipsum dolor sit amet, consectetur adipiscing elit."+        , "  Sed do eiusmod tempor incididunt ut labore et dolore."+        , ""+        , "    Ut enim ad minim veniam, quis nostrud exercitation."+        , "folded" <> num i <> ": >-"+        , "  Duis aute irure dolor in reprehenderit in voluptate velit"+        , "  esse cillum dolore eu fugiat nulla pariatur."+        , "plain" <> num i <> ": Excepteur sint occaecat cupidatat non proident,"+        , "  sunt in culpa qui officia deserunt mollit anim id est laborum."+        ]++num :: Int -> T.Text+num = T.pack . show
+ bench/Yamlet/Bench/Libraries.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | The benchmarks that compare yamlet with the other libraries.+module Yamlet.Bench.Libraries+  ( libraryBenchmarks+  ) where++import Control.DeepSeq+import Data.Aeson qualified as J+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Data.YAML qualified as H+import Data.YAML.Event qualified as HE+import Data.Yaml qualified as Y+import Test.Tasty.Bench++import Yamlet+import Yamlet.Bench.Inputs+import Yamlet.Bench.Types+import Yamlet.Syntax qualified as S++-- | The benchmarks are grouped by the operation, so that the times of the+-- libraries for one operation and input are next to each other.+libraryBenchmarks :: [Benchmark]+libraryBenchmarks =+  [ bgroup "parse" (map (uncurry parsing) inputs)+  , bgroup "render" (map (uncurry rendering) inputs)+  , bgroup+      "decode"+      [ decoding @[Config] "config" configInput []+      , decoding @[Json] "json" jsonInput [aesonDecoding @[Json] jsonInput]+      , decoding @(M.Map T.Text T.Text) "text" textInput []+      ]+  , bgroup+      "encode"+      [ encoding @[Config] "config" configInput []+      , encoding @[Json] "json" jsonInput [aesonEncoding @[Json] jsonInput]+      , encoding @(M.Map T.Text T.Text) "text" textInput []+      ]+  ]+  where+    -- The benchmarks that parse an input into the trees of each library.+    parsing :: String -> BS.ByteString -> Benchmark+    parsing name bs =+      bgroup+        name+        [ bgroup+            "yamlet"+            [ bench "syntax tree" $ nf S.parseDocuments bs+            , bench "values" $ nf (decodeAll @Value) bs+            ]+        , bgroup+            "HsYAML"+            [ bench "events" $ nf HE.parseEvents lazy+            , bench "nodes" $+                nf+                  ( foldMap (\(H.Doc n) -> forceNode n)+                      . either (error . show) id+                      . H.decodeNode+                  )+                  lazy+            ]+        , bgroup+            "yaml"+            [ bench "aeson value" $+                nf (either (error . show) id . Y.decodeEither' @J.Value) bs+            ]+        ]+      where+        lazy :: BL.ByteString+        lazy = BL.fromStrict bs++        -- HsYAML has no NFData instance for nodes.+        forceNode :: H.Node loc -> ()+        forceNode = \case+          H.Scalar _ s -> case s of+            H.SNull -> ()+            H.SBool b -> b `seq` ()+            H.SFloat d -> d `seq` ()+            H.SInt i -> i `seq` ()+            H.SStr t -> t `seq` ()+            H.SUnknown tag t -> tag `seq` t `seq` ()+          H.Mapping _ _ m -> foldMap (\(k, v) -> forceNode k `seq` forceNode v) (M.toList m)+          H.Sequence _ _ xs -> foldMap forceNode xs+          H.Anchor _ _ n -> forceNode n++    -- The benchmark that renders the syntax tree of an input.+    rendering :: String -> BS.ByteString -> Benchmark+    rendering name bs =+      bgroup name [bench "yamlet" $ nf (S.renderSyntax S.defaultRenderOptions) trees]+      where+        trees :: [S.Document]+        trees = either (error . show) id $ S.parseDocuments bs++    -- The benchmarks that decode an input into a value of the type, and the+    -- given benchmarks for other libraries.+    decoding+      :: forall a+       . (NFData a, FromYaml a, H.FromYAML a, J.FromJSON a)+      => String+      -> BS.ByteString+      -> [Benchmark]+      -> Benchmark+    decoding name bs others =+      bgroup name $+        [ bench "yamlet" $ nf (either (error . show) id . decode @a) bs+        , bench "HsYAML" $ nf (either (error . show) id . H.decode1Strict @a) bs+        , bench "yaml" $ nf (either (error . show) id . Y.decodeEither' @a) bs+        ]+          ++ others++    -- The benchmarks that encode the value of an input, decoded as the type,+    -- and the given benchmarks for other libraries.+    encoding+      :: forall a+       . (NFData a, FromYaml a, ToYaml a, H.ToYAML a, J.ToJSON a)+      => String+      -> BS.ByteString+      -> [Benchmark]+      -> Benchmark+    encoding name bs others =+      bgroup name $+        [ bench "yamlet" $ nf encode value+        , bench "HsYAML" $ nf H.encode1Strict value+        , bench "yaml" $ nf Y.encode value+        ]+          ++ others+      where+        value :: a+        value = either (error . show) id $ decode bs++    -- The benchmark that decodes a JSON input with aeson.+    aesonDecoding :: forall a. (NFData a, J.FromJSON a) => BS.ByteString -> Benchmark+    aesonDecoding bs = bench "aeson" $ nf (either error id . J.eitherDecodeStrict' @a) bs++    -- The benchmark that encodes the value of a JSON input as JSON with aeson.+    aesonEncoding+      :: forall a. (NFData a, FromYaml a, J.ToJSON a) => BS.ByteString -> Benchmark+    aesonEncoding bs = bench "aeson" $ nf J.encode value+      where+        value :: a+        value = either (error . show) id $ decode bs
+ bench/Yamlet/Bench/Types.hs view
@@ -0,0 +1,259 @@+-- | The types that the inputs decode into, with written instances for each+-- library.+module Yamlet.Bench.Types+  ( Config (..)+  , Nested (..)+  , Json (..)+  , Item (..)+  ) where++import Control.DeepSeq+import Data.Aeson qualified as J+import Data.Map.Strict qualified as M+import Data.Scientific qualified as Sci+import Data.Text qualified as T+import Data.YAML qualified as H++import Yamlet++-- | An entry of 'Yamlet.Bench.Inputs.config'.+data Config = Config+  { name :: T.Text+  , itemId :: Int+  , tags :: [T.Text]+  , description :: T.Text+  , path :: T.Text+  , enabled :: Bool+  , nested :: Nested+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++data Nested = Nested+  { x :: Double+  , y :: Int+  , list :: [T.Text]+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | An entry of 'Yamlet.Bench.Inputs.json'.+data Json = Json+  { itemId :: Int+  , name :: T.Text+  , values :: [Item]+  , child :: M.Map T.Text T.Text+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | An item of the values of a 'Json'.+data Item = ItemNumber Double | ItemBool Bool | ItemNull+  deriving stock (Generic)+  deriving anyclass (NFData)++instance FromYaml Config where+  parseYaml = withMapping $ \o ->+    Config+      <$> parseField o "name"+      <*> parseField o "id"+      <*> parseField o "tags"+      <*> parseField o "description"+      <*> parseField o "path"+      <*> parseField o "enabled"+      <*> parseField o "nested"++instance H.FromYAML Config where+  parseYAML = H.withMap "Config" $ \o ->+    Config+      <$> o H..: "name"+      <*> o H..: "id"+      <*> o H..: "tags"+      <*> o H..: "description"+      <*> o H..: "path"+      <*> o H..: "enabled"+      <*> o H..: "nested"++instance J.FromJSON Config where+  parseJSON = J.withObject "Config" $ \o ->+    Config+      <$> o J..: "name"+      <*> o J..: "id"+      <*> o J..: "tags"+      <*> o J..: "description"+      <*> o J..: "path"+      <*> o J..: "enabled"+      <*> o J..: "nested"++instance FromYaml Nested where+  parseYaml = withMapping $ \o ->+    Nested+      <$> parseField o "x"+      <*> parseField o "y"+      <*> parseField o "list"++instance H.FromYAML Nested where+  parseYAML = H.withMap "Nested" $ \o ->+    Nested+      <$> o H..: "x"+      <*> o H..: "y"+      <*> o H..: "list"++instance J.FromJSON Nested where+  parseJSON = J.withObject "Nested" $ \o ->+    Nested+      <$> o J..: "x"+      <*> o J..: "y"+      <*> o J..: "list"++instance FromYaml Json where+  parseYaml = withMapping $ \o ->+    Json+      <$> parseField o "id"+      <*> parseField o "name"+      <*> parseField o "values"+      <*> parseField o "child"++instance H.FromYAML Json where+  parseYAML = H.withMap "Json" $ \o ->+    Json+      <$> o H..: "id"+      <*> o H..: "name"+      <*> o H..: "values"+      <*> o H..: "child"++instance J.FromJSON Json where+  parseJSON = J.withObject "Json" $ \o ->+    Json+      <$> o J..: "id"+      <*> o J..: "name"+      <*> o J..: "values"+      <*> o J..: "child"++instance FromYaml Item where+  parseYaml n = case view n of+    IntView i -> pure $ ItemNumber (fromInteger i)+    FloatView f -> pure $ ItemNumber (floatValueToRealFloat f)+    BoolView b -> pure $ ItemBool b+    NullView -> pure ItemNull+    _ -> typeMismatch "a number, a boolean or null" n++instance H.FromYAML Item where+  parseYAML = \case+    H.Scalar _ (H.SInt i) -> pure $ ItemNumber (fromInteger i)+    H.Scalar _ (H.SFloat d) -> pure $ ItemNumber d+    H.Scalar _ (H.SBool b) -> pure $ ItemBool b+    H.Scalar _ H.SNull -> pure ItemNull+    n -> H.typeMismatch "a number, a boolean or null" n++instance J.FromJSON Item where+  parseJSON = \case+    J.Number s -> pure $ ItemNumber (Sci.toRealFloat s)+    J.Bool b -> pure $ ItemBool b+    J.Null -> pure ItemNull+    _ -> fail "expected a number, a boolean or null"++instance ToYaml Config where+  toYaml r =+    mapping+      [ "name" .= r.name+      , "id" .= r.itemId+      , "tags" .= r.tags+      , "description" .= r.description+      , "path" .= r.path+      , "enabled" .= r.enabled+      , "nested" .= r.nested+      ]++instance H.ToYAML Config where+  toYAML r =+    H.mapping+      [ "name" H..= r.name+      , "id" H..= r.itemId+      , "tags" H..= r.tags+      , "description" H..= r.description+      , "path" H..= r.path+      , "enabled" H..= r.enabled+      , "nested" H..= r.nested+      ]++instance J.ToJSON Config where+  toJSON r =+    J.object+      [ "name" J..= r.name+      , "id" J..= r.itemId+      , "tags" J..= r.tags+      , "description" J..= r.description+      , "path" J..= r.path+      , "enabled" J..= r.enabled+      , "nested" J..= r.nested+      ]++instance ToYaml Nested where+  toYaml n =+    mapping+      [ "x" .= n.x+      , "y" .= n.y+      , "list" .= n.list+      ]++instance H.ToYAML Nested where+  toYAML n =+    H.mapping+      [ "x" H..= n.x+      , "y" H..= n.y+      , "list" H..= n.list+      ]++instance J.ToJSON Nested where+  toJSON n =+    J.object+      [ "x" J..= n.x+      , "y" J..= n.y+      , "list" J..= n.list+      ]++instance ToYaml Json where+  toYaml r =+    mapping+      [ "id" .= r.itemId+      , "name" .= r.name+      , "values" .= r.values+      , "child" .= r.child+      ]++instance H.ToYAML Json where+  toYAML r =+    H.mapping+      [ "id" H..= r.itemId+      , "name" H..= r.name+      , "values" H..= r.values+      , "child" H..= r.child+      ]++instance J.ToJSON Json where+  toJSON r =+    J.object+      [ "id" J..= r.itemId+      , "name" J..= r.name+      , "values" J..= r.values+      , "child" J..= r.child+      ]++instance ToYaml Item where+  toYaml = \case+    ItemNumber d -> toYaml d+    ItemBool b -> toYaml b+    ItemNull -> toYaml ()++instance H.ToYAML Item where+  toYAML = \case+    ItemNumber d -> H.toYAML d+    ItemBool b -> H.toYAML b+    ItemNull -> H.Scalar () H.SNull++instance J.ToJSON Item where+  toJSON = \case+    ItemNumber d -> J.toJSON d+    ItemBool b -> J.toJSON b+    ItemNull -> J.Null
+ docs/coming-from-yaml.md view
@@ -0,0 +1,115 @@+# Coming from the yaml package++The [yaml](https://hackage.haskell.org/package/yaml) package decodes and+encodes with the instances of aeson. The instances of yamlet, the generic+ones too, read and write the same YAML as the instances of aeson, so files+written for the yaml package keep working, with the exceptions below.++## Switching in steps++The package [yamlet-aeson](https://hackage.haskell.org/package/yamlet-aeson)+decodes and encodes a type with its instances of aeson, wrapped in+`ViaAeson`, e.g. `decodeFile @(ViaAeson Config)`. A program can switch to+the parser of yamlet first and derive the instances of yamlet later, one+type at a time. A field whose type has only instances of aeson derives its+instances of yamlet via `ViaAeson`. A program that reads and writes both+JSON and YAML can keep the instances of aeson as the only ones, e.g. with+`deriving (FromYaml, ToYaml) via ViaAeson Config`.++Through `ViaAeson`, the rules of YAML 1.2 below apply, but the types follow+the instances of aeson, e.g. `1.0` is an `Int`.++## YAML 1.2++yamlet follows YAML 1.2 where the yaml package does not:++- `y`, `yes`, `on`, `n`, `no` and `off` are strings, not booleans. A+  decoder that expects a `Bool` suggests `true` or `false`.+- `.5`, `+.5`, `.inf`, `-.Inf`, `.NaN` and similar values are floats. The+  yaml package reads a number only if a digit comes first, after an+  optional sign, e.g. `1`, `+1`, `007` or `0x1F`. It reads such values as+  strings and writes such strings without quotes, although YAML 1.1 reads+  them as floats too. A yamlet decoder that expects a string suggests+  quotes.+- A scalar with a tag that is not of the core schema is a string, e.g.+  `!secret 123` is the string `123`. The yaml package ignores such a tag+  and reads `123` as a number.+- `<<` is an ordinary key. The yaml package merges the entries of a `<<`+  key into its mapping, as YAML 1.1 does.+- U+2028 and U+2029 in a string are ordinary characters. In a string that+  the yaml package writes in single quotes, e.g. `true` followed by U+2028,+  it writes them as line breaks with indentation after them, so the string+  that yamlet reads back keeps the spaces of the indentation.+- The keys of a mapping must be unique, so two equal keys are an error. The+  yaml package keeps the value of the last one.+- Every line of a flow collection or of a quoted scalar must be indented+  more than the key or the `-` of its entry, the closing bracket too. The+  yaml package also reads lines with less indentation, e.g. a `}` at the+  start of a line:++  ```yaml+  server: {+    port: 80+  }+  ```++## Types++yamlet does not convert values to the types of JSON:++- The keys of a map keep their type, e.g. the keys of a `Map Int` are+  integers. aeson writes every key as a string, so the yaml package writes+  the key `1` as `'1'`, which yamlet does not decode as an `Int`. The other+  way round, the yaml package reads every key as a string, e.g. the key+  `404` or `true` of a `Map Text`. yamlet rejects such a key without+  quotes.+- An `IntMap` and a map with keys that aeson cannot write as strings, e.g.+  a `Map (Int, Int)`, are mappings in yamlet. aeson writes them as lists of+  pairs.+- An infinite `Double` is `.inf` or `-.inf`. aeson writes the string `+inf`+  or `-inf`, because JSON has no infinity, and yamlet reads these as+  strings.+- A NaN `Double` is `.nan`. aeson writes `null`, which yamlet rejects for a+  `Double`. The yaml package reads `.nan` as a string, so it does not decode+  it as a `Double`.+- A float with an exponent beyond the range from -1000 to 1000 is an error,+  e.g. `1e1001`, which keeps the decoding of untrusted input fast. The yaml+  package reads `1e1001` as an infinite `Double`.+- A value must have the YAML type of its Haskell type. yamlet rejects some+  values that aeson converts, e.g. `1.0` for an `Int`, `0.5` for a+  `Rational` and `null` for a `Double`.+- The elements of a `Set` or an `IntSet` must be unique, so `[a, a]` is an+  error. aeson keeps one of them.+- A `Fixed` value must be a multiple of the resolution of its type, so+  `1.255` is an error for a `Centi`. aeson rounds it down to `1.25`.+- The mapping of a `Rational`, a `CalendarDiffDays` or a+  `CalendarDiffTime` must have only the keys of the type, e.g. `numerator`+  and `denominator`. aeson ignores other keys.+- `()` must be an empty list, `[]`, which is how aeson writes it. aeson+  reads any value as `()`, and since aeson 2.2 also a missing field of type+  `()`.+- `Proxy` has no instances, because it holds no value. aeson writes it as+  `null` and reads any value as a `Proxy`.++## Generic instances++- A key that is not a field of the constructor is an error. aeson ignores+  such a key. To ignore it in yamlet too, turn off the option+  `rejectUnknownFields`.+- A type with one constructor without fields is the name of the+  constructor, e.g. `Unit`. aeson writes `[]`.+- With the encoding `SingleField`, a constructor without fields is its+  name, e.g. `Dot`. aeson writes `{Dot: []}`.+- A constructor with several fields without names is a compile error.+  aeson writes the fields as a list. Give the fields names.+- A type cannot mix a constructor with named fields and a constructor with+  one field without a name, except with the encoding `SingleField`. Such a+  type is a compile error. aeson writes the field without a name under the+  key `contents`.++The documentation of the instances in+[Yamlet.Decode](https://hackage.haskell.org/package/yamlet/docs/Yamlet-Decode.html)+and [Yamlet.Encode](https://hackage.haskell.org/package/yamlet/docs/Yamlet-Encode.html),+and of the options in+[Yamlet.Generic](https://hackage.haskell.org/package/yamlet/docs/Yamlet-Generic.html),+describes the remaining details.
+ src/Yamlet.hs view
@@ -0,0 +1,398 @@+-- | A YAML 1.2.2 library.+--+-- The library handles two typical use cases well:+--+-- 1. Decoding a document that describes a configuration:+--+--     >>> :{+--     data Config = Config+--       { name :: T.Text+--       , paths :: [FilePath]+--       }+--       deriving stock (Generic, Show)+--       deriving (FromYaml) via GenericYaml Config+--     instance GenericYamlOptions Config where+--       yamlDefault = Just Config {name = requiredField, paths = ["."]}+--     :}+--+--     >>> input = "name: app\n"+--+--     >>> T.putStr input+--     name: app+--+--     >>> either printErrors print (decodeText @Config input)+--     Config {name = "app", paths = ["."]}+--+--     When a document fails to decode, you get multiple errors pointing at what+--     failed and why:+--+--     >>> input = "paths:\n- src\n- 42\nport: 80\n"+--+--     >>> T.putStr input+--     paths:+--     - src+--     - 42+--     port: 80+--+--     >>> either printErrors print (decodeText @Config input)+--     input.yaml:1:1: missing key "name"+--       |+--     1 | paths:+--       | ^+--     input.yaml:3:3: paths[1]: expected a string, but got an integer, quote the value, e.g. '42'+--       |+--     3 | - 42+--       |   ^+--     input.yaml:4:1: unknown key "port", expected one of: name, paths+--       |+--     4 | port: 80+--       | ^+--+-- 2. Decoding a document into a Haskell type and encoding it back. A type+--    can keep the comments of a value with t'Yamlet.Commented', and a part+--    of the document as it was written with t'Yamlet.Node':+--+--     >>> :{+--     data Workflow = Workflow+--       { name :: Commented T.Text+--       , matrix :: Node+--       }+--       deriving stock (Generic)+--       deriving anyclass (GenericYamlOptions)+--       deriving (FromYaml, ToYaml) via GenericYaml Workflow+--     :}+--+--     >>> input = "# The name in the UI.\nname: build # short\nmatrix:\n  # Each system runs the jobs.\n  os: [linux, macos]\n  ghc: ['9.10', '9.12']\n"+--+--     >>> T.putStr input+--     # The name in the UI.+--     name: build # short+--     matrix:+--       # Each system runs the jobs.+--       os: [linux, macos]+--       ghc: ['9.10', '9.12']+--+--     >>> Right workflow = decodeText @Workflow input+--+--     The decoded name keeps the comment above its key and the comment after+--     its value:+--+--     >>> print workflow.name+--     Commented {value = "build", comments = Comments {before = [Comment "The name in the UI."], inline = Just "short", after = []}}+--+--     >>> T.putStr (encodeText workflow)+--     # The name in the UI.+--     name: build # short+--     matrix:+--       # Each system runs the jobs.+--       os: [linux, macos]+--       ghc: ['9.10', '9.12']+--+-- The record types of the library, e.g. t'Error' and t'YamlOptions', have no+-- field selectors. Read a field with the @OverloadedRecordDot@ extension,+-- e.g. @err.message@, and set one with the record syntax, e.g.+-- @defaultYamlOptions {fieldLabelModifier = snakeCase}@, or with the generic+-- optics of <https://hackage.haskell.org/package/optics-core optics-core>,+-- e.g. @defaultYamlOptions & #fieldLabelModifier .~ snakeCase@.+module Yamlet+  ( -- * Decoding+    decode+  , decodeAll+  , decodeText+  , decodeAllText+  , decodeInput+  , decodeFile+  , decodeAllFile++    -- * Syntax trees+  , decodeWithDocument+  , decodeDocument+  , decodeDocuments++    -- * Encoding+  , encode+  , encodeAll+  , encodeText+  , encodeAllText+  , encodeFile+  , encodeAllFile++    -- * Nodes+  , S.Node+  , S.Offset (..)+  , S.noOffset+  , S.Located (..)++    -- * Comments+  , S.Commented (..)+  , S.Comments (..)+  , S.noComments+  , S.Line (..)++    -- * Values+  , module Yamlet.Value++    -- * Conversion from nodes+  , module Yamlet.Decode++    -- * Conversion to nodes+  , module Yamlet.Encode++    -- * Generic instances+  , module Yamlet.Generic++    -- * Errors+  , module Yamlet.Error+  ) where++import Control.Monad+import Data.Bifunctor+import Data.ByteString qualified as BS+import Data.List.NonEmpty qualified as NE+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Encoding qualified as T++import Yamlet.Decode+import Yamlet.Encode+import Yamlet.Error+import Yamlet.Generic+import Yamlet.Internal.Compose+import Yamlet.Internal.Encoder+import Yamlet.Internal.FromYaml+import Yamlet.Internal.Input+import Yamlet.Internal.Parser+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils+import Yamlet.Value++-- | Decode a stream with one document. An empty stream is null.+--+-- If the input has a syntax error or fails a check that 'decodeDocument'+-- describes, the result has only that error, with its notes, e.g. the first+-- key of a duplicate key. Otherwise the result has every error that the+-- 'Parser' collects, in the order of their positions.+--+-- >>> decode @[Int] "- 1\n- 2\n"+-- Right [1,2]+--+-- >>> decode @(Maybe Int) ""+-- Right Nothing+--+-- >>> either printErrors print (decode @[Int] "- 1\n- x\n- true\n")+-- input.yaml:2:3: [1]: expected an integer, but got a string+--   |+-- 2 | - x+--   |   ^+-- input.yaml:3:3: [2]: expected an integer, but got a boolean+--   |+-- 3 | - true+--   |   ^+decode :: FromYaml a => BS.ByteString -> Either (NE.NonEmpty Error) a+decode bs = single (decodeInput bs) >>= decodeText++-- | Decode every document of a stream. The errors are as for 'decode', from+-- the first document that fails. The parser reads the whole stream first, so+-- a syntax error in any document comes before the errors of the others.+--+-- >>> decodeAll @Int "1\n---\n2\n"+-- Right [1,2]+decodeAll :: FromYaml a => BS.ByteString -> Either (NE.NonEmpty Error) [a]+decodeAll bs = single (decodeInput bs) >>= decodeAllText++-- | Decode a stream with one document. An empty stream is null. The errors+-- are as for 'decode'.+--+-- >>> decodeText @Value "ports: [80, 443]\nenabled: yes\n"+-- Right (Mapping [(String "ports",Sequence [Int 80,Int 443]),(String "enabled",String "yes")])+decodeText :: FromYaml a => T.Text -> Either (NE.NonEmpty Error) a+decodeText input = do+  (a, _) <- decodeWithDocument input+  pure a++-- | Decode a stream with one document as 'decodeText' does, and give the+-- document too, e.g. for 'documentErrors' or to write the file back with its+-- comments. An empty stream is a document with null. A stream of only+-- comments is empty too, so the document does not keep them, as the section+-- [Comments]("Yamlet.Syntax#comments") says.+decodeWithDocument :: FromYaml a => T.Text -> Either (NE.NonEmpty Error) (a, S.Document)+decodeWithDocument input =+  single (parseStream input) >>= \case+    [] ->+      withDocument . S.document $+        S.Node+          { S.offset = S.Offset 0+          , S.endOffset = S.Offset 0+          , S.props = S.noProps+          , S.comments = S.noComments+          , S.content = S.ScalarContent S.Plain ""+          }+    [doc] -> withDocument doc+    docs@(_ : doc : _) -> do+      let limit = aliasLimit (map (.root) docs)+          check :: Int -> S.Document -> Either (NE.NonEmpty Error) Int+          check added d =+            snd <$> first (decoderErrors input d) (prepareWithin limit added d.root)+      foldM_ check 0 docs+      single . Left $+        errorAt input doc.root.offset "expected a single document, but got a second one"+  where+    withDocument :: FromYaml a => S.Document -> Either (NE.NonEmpty Error) (a, S.Document)+    withDocument doc = do+      a <- decodeDocument input doc+      pure (a, doc)++-- | Decode every document of a stream. The errors are as for 'decodeAll'.+decodeAllText :: FromYaml a => T.Text -> Either (NE.NonEmpty Error) [a]+decodeAllText input = single (parseStream input) >>= decodeDocuments input++single :: Either Error a -> Either (NE.NonEmpty Error) a+single = first (NE.:| [])++-- | Decode a document of a syntax tree, e.g. to read the values of a file and+-- keep its comments from one parse.+--+-- As for a parsed input, the decoder checks the document first. The check+-- fails for:+--+-- * a duplicate key,+--+-- * an undefined alias,+--+-- * an alias inside the node that it refers to, e.g. @&a [*a]@,+--+-- * aliases beyond the limit in "Yamlet.Value",+--+-- * a value that is not valid for its tag,+--+-- * a float whose exponent in scientific notation is beyond the range+--   from -1000 to 1000.+--+-- The text is the input of the document. An error takes its line from the+-- text. For a document that the program built, the text can be empty. If+-- such a document contains the nodes of a parsed input, pass that input, so+-- that their errors get their lines. The errors are as for 'decode'.+--+-- The document has the limit of the aliases to itself. For the documents of+-- a stream, use 'decodeDocuments', so that they share the limit.+decodeDocument :: FromYaml a => T.Text -> S.Document -> Either (NE.NonEmpty Error) a+decodeDocument input doc =+  firstOfResult $ decodeDocumentWithin (aliasLimit [doc.root]) 0 input doc++-- | Decode the documents of a syntax tree as 'decodeDocument' does, e.g. the+-- documents of a stream from 'Yamlet.Syntax.parseDocumentsText'. The+-- documents share the limit of the aliases, as the documents of a stream do.+-- The errors are as for 'decodeAll'.+decodeDocuments :: FromYaml a => T.Text -> [S.Document] -> Either (NE.NonEmpty Error) [a]+decodeDocuments input docs = go 0 docs+  where+    limit :: Int+    limit = aliasLimit (map (.root) docs)++    go :: FromYaml a => Int -> [S.Document] -> Either (NE.NonEmpty Error) [a]+    go added = \case+      [] -> Right []+      d : ds -> do+        (a, added') <- decodeDocumentWithin limit added input d+        (a :) <$> go added' ds++-- | 'decodeDocument' with the visits of the aliases as for 'prepareWithin'.+decodeDocumentWithin+  :: FromYaml a+  => Int -> Int -> T.Text -> S.Document -> Either (NE.NonEmpty Error) (a, Int)+decodeDocumentWithin limit added input doc =+  first (decoderErrors input doc) (runParserWithin limit added parseYaml root)+  where+    -- The root with the lines of the document, e.g. the lines above a @---@+    -- marker and below a @...@ marker, so that a decoder can keep them. The+    -- renderer writes them at the same places. The comment on the line of the+    -- marker becomes a line above the root.+    root :: S.Node+    root+      | null dc.before && isNothing dc.inline && null dc.after = r+      | otherwise = S.withComments comments r++    dc :: S.Comments+    dc = doc.docComments++    r :: S.Node+    r = doc.root++    comments :: S.Comments+    comments =+      S.Comments+        { S.before =+            dc.before ++ [S.Comment c | Just c <- [dc.inline]] ++ r.comments.before+        , S.inline = r.comments.inline+        , S.after = r.comments.after ++ dc.after+        }++-- | The errors of the decoder in the document, with their paths.+decoderErrors+  :: T.Text -> S.Document -> NE.NonEmpty (S.Offset, String) -> NE.NonEmpty Error+decoderErrors input doc = NE.fromList . documentErrors input doc . NE.toList++-- | Encode a value as a document.+--+-- >>> encode [1, 2 :: Int]+-- "- 1\n- 2\n"+encode :: ToYaml a => a -> BS.ByteString+encode = T.encodeUtf8 . encodeText++-- | Encode values as a stream of documents.+encodeAll :: ToYaml a => [a] -> BS.ByteString+encodeAll = T.encodeUtf8 . encodeAllText++-- | Encode a value as a document.+--+-- >>> T.putStr (encodeText (mapping ["name" .= ("app" :: T.Text), "ports" .= [80, 443 :: Int]]))+-- name: app+-- ports:+-- - 80+-- - 443+encodeText :: ToYaml a => a -> T.Text+encodeText a = renderDocuments [toYaml a]++-- | Encode values as a stream of documents.+--+-- >>> T.putStr (encodeAllText [1, 2 :: Int])+-- 1+-- ---+-- 2+encodeAllText :: ToYaml a => [a] -> T.Text+encodeAllText = renderDocuments . map toYaml++-- | Decode the file as 'decode' does. The file is read as bytes, so the+-- encoding does not depend on the locale. It is UTF-8, UTF-16 or UTF-32,+-- detected as the YAML specification describes.+--+-- For the errors, give the same path to 'prettyError':+--+-- @+-- decodeFile \@Config path >>= \\case+--   Left errs -> mapM_ (putStrLn . prettyError path) errs+--   Right config -> ...+-- @+decodeFile :: FromYaml a => FilePath -> IO (Either (NE.NonEmpty Error) a)+decodeFile path = decode <$> BS.readFile path++-- | Decode every document of the file as 'decodeAll' does, with the encoding+-- of 'decodeFile'.+decodeAllFile :: FromYaml a => FilePath -> IO (Either (NE.NonEmpty Error) [a])+decodeAllFile path = decodeAll <$> BS.readFile path++-- | Encode a value as a document in the file, in UTF-8. The file is written+-- as bytes, so the encoding does not depend on the locale.+encodeFile :: ToYaml a => FilePath -> a -> IO ()+encodeFile path = BS.writeFile path . encode++-- | Encode values as a stream of documents in the file, as 'encodeFile'+-- does.+encodeAllFile :: ToYaml a => FilePath -> [a] -> IO ()+encodeAllFile path = BS.writeFile path . encodeAll++-- $setup+-- >>> import Data.Text qualified as T+-- >>> import Data.Text.IO qualified as T+-- >>> import Yamlet+-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")
+ src/Yamlet/Decode.hs view
@@ -0,0 +1,50 @@+-- | Conversion of nodes to Haskell values, with errors that point to the+-- node that caused them.+module Yamlet.Decode+  ( -- * Class+    FromYaml (..)++    -- * Parser+  , Parser+  , runParser+  , parseNode+  , failAt+  , typeMismatch+  , orElse++    -- * Views+  , View (..)+  , view+  , describeNode++    -- * Scalars+  , withNull+  , withBool+  , withInt+  , withFloat+  , withScientific+  , withText+  , oneOf++    -- * Collections+  , withSequence+  , parseItems+  , withMapping+  , Object+  , objectNode+  , objectEntries+  , objectKeys+  , lookupKey+  , parseField+  , parseFieldMaybe+  , parseFieldIfPresent+  , parseFieldDefault+  , parseFieldWith+  , parseFieldMaybeWith+  , parseFieldIfPresentWith+  , parseFieldDefaultWith+  , rejectUnknownKeys+  ) where++import Yamlet.Internal.FromYaml+import Yamlet.Internal.View
+ src/Yamlet/Encode.hs view
@@ -0,0 +1,9 @@+-- | Conversion of Haskell values to nodes.+module Yamlet.Encode+  ( -- * Class+    ToYaml (..)+  , (.=)+  , mapping+  ) where++import Yamlet.Internal.ToYaml
+ src/Yamlet/Error.hs view
@@ -0,0 +1,551 @@+-- | Errors with the position in the input that caused them.+module Yamlet.Error+  ( -- * Errors+    Error (..)+  , Location (..)+  , Path+  , pathElements+  , pathFromElements+  , PathElement (..)+  , prettyError+  , renderPath++    -- * Construction+  , errorAt+  , errorsAt+  , documentErrors+  , locate+  , nodePath+  , nodePaths+  ) where++import Control.DeepSeq+import Data.Char+import Data.List qualified as L+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Text.Internal qualified as T+import Data.Text.Unsafe qualified as T+import GHC.Generics++import Yamlet.Internal.Chars+import Yamlet.Internal.Syntax+import Yamlet.Internal.Utils++-- | An error of the parser or the decoder.+--+-- An error from the functions of this module keeps no part of the input+-- alive once it is in weak head normal form. Its message and its path are+-- evaluated then, because a message often contains a slice of the input,+-- e.g. a key, and a path comes from the syntax tree.+data Error = Error+  { location :: !Location+  , message :: !String+  , sourceLine :: !T.Text+  -- ^ The line of the input that contains the location.+  , sourceIndex :: !Int+  -- ^ The index of the location in the UTF-8 bytes of+  -- 'Yamlet.Error.sourceLine'. It lets 'prettyError' find the column without+  -- a scan of the whole line.+  , path :: !Path+  -- ^ The path to the node of a decoder error. An error at a key has the+  -- path of its mapping. The path is empty for an error of the parser and+  -- for a node that a program built.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The keys and the indices from the root of a document to a node.+--+-- The path of a node shares the path of its parent, so the paths of many+-- errors in a deep document take memory linear in its size.+data Path+  = Root+  | Child !Path !PathElement+  deriving stock (Eq)++-- Written by hand, because every field is strict and has no lazy parts, and+-- a generic instance would walk the shared paths of all errors.+instance NFData Path where+  rnf = rwhnf++instance Show Path where+  showsPrec d p =+    showParen (d > 10) $ showString "pathFromElements " . shows (pathElements p)++-- | The steps of a path, from the root.+pathElements :: Path -> [PathElement]+pathElements = go []+  where+    go :: [PathElement] -> Path -> [PathElement]+    go acc = \case+      Root -> acc+      Child p e -> go (e : acc) p++-- | A path with the steps from the root.+pathFromElements :: [PathElement] -> Path+pathFromElements = L.foldl' Child Root++-- | A step of a path into a document.+data PathElement+  = -- | The value of a key that is a scalar, with the text of the key, e.g.+    -- @1@ for the integer key 1.+    Key !T.Text+  | -- | The item of a sequence, from 0.+    Index !Int+  | -- | The value of a key that is a collection, e.g. @? [1, 2]@. The path+    -- has no steps into the key.+    CollectionKey+  | -- | The value of a key that is an alias, with the name of the anchor.+    AliasKey !T.Text+  deriving stock (Eq, Show, Generic)++-- Written by hand, because GHC does not always remove the generic+-- representation of a sum type. Every field is strict and has no lazy parts.+instance NFData PathElement where+  rnf = rwhnf++-- | A position in the input. Lines and columns count from 1, and a column+-- counts characters, not bytes. Line 0 and column 0 mean that the error has+-- no position, e.g. because it comes from a node that a program built, or+-- from a parsed node that is decoded without its input.+data Location = Location+  { offset :: !Offset+  , line :: !Int+  , column :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Render an error in the format that editors recognize. The result does not+-- end with a line break. If the line is longer than 80 characters, the+-- excerpt shows only the 80 characters around the column. A control+-- character other than a tab shows as its symbol, e.g. U+241B for escape, or+-- as U+FFFD if Unicode has no symbol for it.+--+-- >>> either printErrors print (decodeText @(M.Map T.Text [[Int]]) "jobs:\n  - [1]\n  - 42\n")+-- input.yaml:3:5: jobs[1]: expected a list, but got an integer+--   |+-- 3 |   - 42+--   |     ^+--+-- An error with no position gives only the file and the message, e.g.+-- @input.yaml: duplicate key \"a\"@.+prettyError :: FilePath -> Error -> String+prettyError file err+  | err.location.line == 0 = file ++ ": " ++ message+  | otherwise =+      concat+        [ file+        , ":"+        , show err.location.line+        , ":"+        , show err.location.column+        , ": "+        , message+        , "\n"+        , pad+        , " |\n"+        , lineNo+        , " | "+        , shown+        , "\n"+        , pad+        , " | "+        , caret+        , "^"+        ]+  where+    message :: String+    message+      | err.path == Root = err.message+      | otherwise = renderPath err.path ++ ": " ++ err.message++    lineNo :: String+    lineNo = show err.location.line++    pad :: String+    pad = map (const ' ') lineNo++    -- The usual width of a terminal.+    width :: Int+    width = 80++    -- The characters of the line before and from the location. Each count+    -- stops one past the width, so that a long line takes no longer.+    back, ahead :: Int+    back = fst (stepBack (width + 1))+    ahead = fst (stepAhead (width + 1))++    short :: Bool+    short = back + ahead <= width++    -- The characters of the excerpt before the location.+    inExcerpt :: Int+    inExcerpt = min back (max (width `div` 2) (width - ahead))++    cutBefore, cutAfter :: Bool+    cutBefore = back > inExcerpt+    cutAfter = ahead > width - inExcerpt++    shown :: String+    shown+      | short = map visible (T.unpack err.sourceLine)+      | otherwise =+          (if cutBefore then ellipsis else "")+            ++ map visible (T.unpack (T.Text arr excerptStart (excerptEnd - excerptStart)))+            ++ (if cutAfter then ellipsis else "")+      where+        excerptStart, excerptEnd :: Int+        excerptStart = snd (stepBack inExcerpt)+        excerptEnd = snd (stepAhead (width - inExcerpt))++    -- A terminal would act on a control character, e.g. on an escape+    -- sequence. The block Control Pictures has a symbol for each C0 control+    -- character, at its code point plus 0x2400, and one for DEL.+    visible :: Char -> Char+    visible c+      | c == '\t' = c+      | c == '\DEL' = '\x2421'+      | c < ' ' = chr (ord c + 0x2400)+      | isControl c = '\xFFFD'+      | otherwise = c++    ellipsis :: String+    ellipsis = "..."++    before :: Int+    before+      | short = back+      | otherwise = (if cutBefore then length ellipsis else 0) + inExcerpt++    T.Text arr lineStart lineLen = err.sourceLine++    lineEnd :: Int+    lineEnd = lineStart + lineLen++    -- The index of the location in the array, at the start of a character.+    index :: Int+    index = charStart (lineStart + max 0 (min lineLen err.sourceIndex))++    charStart :: Int -> Int+    charStart i+      | i > lineStart && i < lineEnd && not (isCharStart (A.unsafeIndex arr i)) =+          charStart (i - 1)+      | otherwise = i++    -- Step over at most the given number of characters before or from the+    -- location. Give the number of steps and the index in the array.+    stepBack, stepAhead :: Int -> (Int, Int)+    stepBack = go index 0+      where+        go :: Int -> Int -> Int -> (Int, Int)+        go i !k n+          | n == 0 || i <= lineStart = (k, i)+          | otherwise = go (charStart (i - 1)) (k + 1) (n - 1)+    stepAhead = go index 0+      where+        go :: Int -> Int -> Int -> (Int, Int)+        go i !k n+          | n == 0 || i >= lineEnd = (k, i)+          | otherwise = go (charEnd (i + 1)) (k + 1) (n - 1)++        charEnd :: Int -> Int+        charEnd i =+          if i < lineEnd && not (isCharStart (A.unsafeIndex arr i))+            then charEnd (i + 1)+            else i++    -- A tab before the column keeps the caret aligned in a terminal, and a+    -- combining mark takes no cell. A wide character, e.g. of CJK, takes two+    -- cells, so the caret is one cell to the left for each one before the+    -- column. base has no data on the width of characters, and the library+    -- does not keep a copy of the Unicode table for this.+    caret :: String+    caret = concatMap cell (take before shown)+      where+        cell :: Char -> String+        cell c = case generalCategory c of+          NonSpacingMark -> ""+          EnclosingMark -> ""+          _ -> if c == '\t' then "\t" else " "++-- | A path in the form @jobs[1].name@. A key that is a collection is @?@,+-- and a key that is an alias is its alias, e.g. @*base@.+--+-- A key is in double quotes, e.g. @\"a.b\"@, if it:+--+-- * is empty,+--+-- * has white space, a character that cannot be printed, or one of the+--   characters @.[]\"\\@,+--+-- * starts with @?@ or @*@.+--+-- In the quotes, a character that cannot be printed has an escape as in+-- YAML, e.g. @\"a\\nb\"@.+--+-- >>> renderPath (pathFromElements [Key "jobs", Index 1, Key "name"])+-- "jobs[1].name"+--+-- >>> renderPath (pathFromElements [Key "a.b", Key ""])+-- "\"a.b\".\"\""+renderPath :: Path -> String+renderPath path = case pathElements path of+  [] -> ""+  e : rest -> step e ++ concatMap next rest+  where+    next :: PathElement -> String+    next = \case+      Index i -> index i+      e -> "." ++ step e++    step :: PathElement -> String+    step = \case+      Key k -> key k+      Index i -> index i+      CollectionKey -> "?"+      AliasKey name -> '*' : T.unpack name++    key :: T.Text -> String+    key k+      | not (T.null k)+          && T.all plain k+          && not (T.isPrefixOf "?" k || T.isPrefixOf "*" k) =+          T.unpack k+      | otherwise = showText k+      where+        plain :: Char -> Bool+        plain c = notElem @[] c ".[]\"\\" && isPrint c && not (isSpace c)++    index :: Int -> String+    index i = "[" ++ show i ++ "]"++-- | The path from the root to the node at the offset. If several nodes start+-- there, e.g. a block mapping and its first key, the outermost one counts. A+-- key does not add to the path, and a node inside a key that is a collection+-- has the path of the mapping.+nodePath :: Offset -> Node -> Path+nodePath off root = fromMaybe Root (listToMaybe (nodePaths [off] root))++-- | The paths of 'nodePath' for several offsets, in the order of the offsets,+-- from one walk of the tree.+nodePaths :: [Offset] -> Node -> [Path]+nodePaths offs root = map (\off -> M.findWithDefault Root off found) offs+  where+    found :: M.Map Offset Path+    found = walk (Set.delete noOffset (Set.fromList offs)) Root root M.empty++    walk :: Set.Set Offset -> Path -> Node -> M.Map Offset Path -> M.Map Offset Path+    walk wanted path n acc+      | Set.null inside = here+      | otherwise = case n.content of+          SequenceContent _ xs ->+            L.foldl'+              (\a (i, x) -> walk inside (Child path (Index i)) x a)+              here+              (zip [0 ..] xs)+          MappingContent _ kvs ->+            L.foldl'+              ( \a (k, v) ->+                  walk inside (Child path (keyElement k)) v (key inside path k a)+              )+              here+              kvs+          _ -> here+      where+        here :: M.Map Offset Path+        here+          | n.offset `Set.member` wanted = M.insertWith (\_ old -> old) n.offset path acc+          | otherwise = acc++        inside :: Set.Set Offset+        inside = within n wanted++    -- Every node of a key has the path of the mapping. An index or a key+    -- inside the key would read as a step into the mapping.+    key :: Set.Set Offset -> Path -> Node -> M.Map Offset Path -> M.Map Offset Path+    key wanted path k acc =+      Set.foldl' (\a off -> M.insertWith (\_ old -> old) off path a) acc offsets+      where+        -- A value can start at the end of its key, e.g. the empty value in+        -- "{a}", so the end is not a node of the key, unless the key is empty.+        offsets :: Set.Set Offset+        offsets =+          Set.takeWhileAntitone (\o -> o < k.endOffset || o == k.offset) $+            Set.dropWhileAntitone (< k.offset) wanted++    -- A node that a program built has no offsets, but it can contain the+    -- nodes of a parsed input.+    within :: Node -> Set.Set Offset -> Set.Set Offset+    within n+      | n.offset == noOffset = id+      | otherwise =+          Set.takeWhileAntitone (<= n.endOffset) . Set.dropWhileAntitone (< n.offset)++    -- The texts of a parsed tree are slices of the input, which an error+    -- would keep alive.+    keyElement :: Node -> PathElement+    keyElement k = case k.content of+      ScalarContent _ t -> Key (T.copy t)+      AliasContent name -> AliasKey (T.copy name)+      _ -> CollectionKey++-- | Create an error at the given offset of the input.+errorAt :: T.Text -> Offset -> String -> Error+errorAt input off msg+  | noPosition input off = errorOnLine (locate input off) msg T.empty 0+  | otherwise =+      let (loc, index, _) = locateFrom input (startScan input) off+      in errorOnLine loc msg (T.copy (lineAt input off)) index++-- | An error at the location, with the line that contains it and the index of+-- the location in the bytes of the line.+errorOnLine :: Location -> String -> T.Text -> Int -> Error+errorOnLine loc msg sourceLine index =+  force $+    Error+      { location = loc+      , message = msg+      , sourceLine = sourceLine+      , sourceIndex = min (T.lengthWord8 sourceLine) index+      , path = Root+      }++-- | Create errors at the given offsets of a document, with their paths, in the+-- order of the list. The text is the input of the document, e.g. for the+-- offsets of t'Located' values.+documentErrors :: T.Text -> Document -> [(Offset, String)] -> [Error]+documentErrors input doc errs =+  zipWith+    (\err p -> force err {path = p})+    (errorsAt input errs)+    (nodePaths (map fst errs) doc.root)++-- | Create errors at the given offsets of the input, in the order of the+-- list. One scan of the input locates all of them, and the errors on one+-- line share the copy of the line.+errorsAt :: T.Text -> [(Offset, String)] -> [Error]+errorsAt input errs =+  map snd . L.sortOn fst $+    go (startScan input) Nothing (L.sortOn (fst . snd) (zip [0 :: Int ..] errs))+  where+    -- The line of the previous error, with the copy of its text.+    go :: Scan -> Maybe (Int, T.Text) -> [(Int, (Offset, String))] -> [(Int, Error)]+    go s prev = \case+      [] -> []+      (i, (off, msg)) : rest+        | noPosition input off ->+            (i, errorOnLine (locate input off) msg T.empty 0) : go s prev rest+        | otherwise ->+            let (loc, index, s') = locateFrom input s off+                sourceLine = case prev of+                  Just (ln, t) | ln == loc.line -> t+                  _ -> T.copy (lineAt input off)+            in (i, errorOnLine loc msg sourceLine index)+                 : go s' (Just (loc.line, sourceLine)) rest++-- | Compute the line and the column of an offset. The byte order marks at the+-- start of a line are not columns, because they are not content. For+-- 'noOffset' or an offset beyond the end of the input, the line and the+-- column are 0.+locate :: T.Text -> Offset -> Location+locate input off+  | noPosition input off = Location {offset = off, line = 0, column = 0}+  | otherwise = let (loc, _, _) = locateFrom input (startScan input) off in loc++-- | The offset has no position in the input: it is 'noOffset', or it is+-- beyond the end of the input, e.g. the offset of a parsed node in a+-- document that a program built, decoded with another text.+noPosition :: T.Text -> Offset -> Bool+noPosition (T.Text _ _ len) (Offset off) = off < 0 || off > len++-- | A scan of the input: the index, the line, the start of the columns of+-- the line, and an index on the line with its column. The columns of a line+-- start after its byte order marks.+data Scan = Scan !Int !Int !Int !Int !Int++startScan :: T.Text -> Scan+startScan (T.Text arr base len) = Scan base 1 start start 1+  where+    start :: Int+    start = skipBomsIn arr (base + len) base++-- | Locate an offset that is not before the index of the scan, and continue+-- the scan from there. Also give the index of the offset in the bytes of the+-- line from the start of its columns, or 0 for an offset in a byte order mark+-- at the start of the line.+locateFrom :: T.Text -> Scan -> Offset -> (Location, Int, Scan)+locateFrom (T.Text arr base len) s0 (Offset off0) = go s0+  where+    end, off :: Int+    end = base + len+    off = base + max 0 (min len off0)++    go :: Scan -> (Location, Int, Scan)+    go s@(Scan i ln ls ci col)+      | i >= off =+          if off <= ci+            -- An offset before the start of the columns is in a byte order+            -- mark.+            then (location ln (if off == ci then col else 1), max 0 (off - ls), s)+            else+              let col' = col + countChars ci off+              in (location ln col', off - ls, Scan i ln ls off col')+      | otherwise = case A.unsafeIndex arr i of+          LF -> newLine (i + 1)+          CR+            | i + 1 < end && A.unsafeIndex arr (i + 1) == LF ->+                go (Scan (i + 1) ln ls ci col)+            | otherwise -> newLine (i + 1)+          _ -> go (Scan (i + 1) ln ls ci col)+      where+        newLine :: Int -> (Location, Int, Scan)+        newLine j =+          let start' = skipBomsIn arr end j in go (Scan j (ln + 1) start' start' 1)++    location :: Int -> Int -> Location+    location ln col = Location {offset = Offset (off - base), line = ln, column = col}++    countChars :: Int -> Int -> Int+    countChars i0 i1 =+      length+        [() | i <- [i0 .. i1 - 1], isCharStart (A.unsafeIndex arr i)]++-- | The line of the input that contains the offset, without the line break+-- and without the byte order marks at its start.+lineAt :: T.Text -> Offset -> T.Text+lineAt (T.Text arr base len) (Offset off0) = T.Text arr start (stop - start)+  where+    end, i0, off, start, stop :: Int+    end = base + len+    i0 = base + max 0 (min len off0)++    -- An offset between the characters of a CRLF line break is on the line+    -- before the break.+    off+      | i0 > base+          && i0 < end+          && A.unsafeIndex arr i0 == LF+          && A.unsafeIndex arr (i0 - 1) == CR =+          i0 - 1+      | otherwise = i0+    start = skipBomsIn arr end (findStart off)+    stop = max start (findStop off)++    findStart :: Int -> Int+    findStart i+      | i > base && not (isBreak (A.unsafeIndex arr (i - 1))) = findStart (i - 1)+      | otherwise = i++    findStop :: Int -> Int+    findStop i+      | i < end && not (isBreak (A.unsafeIndex arr i)) = findStop (i + 1)+      | otherwise = i++-- $setup+-- >>> import Yamlet+-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")
+ src/Yamlet/Generic.hs view
@@ -0,0 +1,1447 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Instances of t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml' from+-- the t'GHC.Generics.Generic' representation of a type.+--+-- A type derives the instances via t'GenericYaml', and its instance of+-- 'GenericYamlOptions' gives the options:+--+-- >>> :{+-- data Server = Server {host :: T.Text, port :: Int}+--   deriving stock (Generic, Show)+--   deriving anyclass (GenericYamlOptions)+--   deriving (FromYaml, ToYaml) via GenericYaml Server+-- :}+--+-- >>> decodeText @Server "host: localhost\nport: 80\n"+-- Right (Server {host = "localhost", port = 80})+--+-- >>> T.putStr (encodeText (Server "localhost" 80))+-- host: localhost+-- port: 80+--+-- A type with other options defines 'yamlOptions' in its instance of+-- 'GenericYamlOptions':+--+-- >>> :{+-- data Build = Build {sourcePaths :: [T.Text], ghcOptions :: [T.Text]}+--   deriving stock (Generic)+--   deriving (ToYaml) via GenericYaml Build+-- instance GenericYamlOptions Build where+--   yamlOptions = defaultYamlOptions {fieldLabelModifier = snakeCase}+-- :}+--+-- >>> T.putStr (encodeText (Build ["src"] ["-Wall"]))+-- source_paths:+-- - src+-- ghc_options:+-- - -Wall+--+-- = Encoding+--+-- The encoding of a type depends on its constructors and their fields:+--+-- * A record is a mapping of its fields, e.g. @{host: localhost, port: 80}@.+--+-- * A type whose constructors have no fields is a string with the name of+--   the constructor, e.g. @TurnLeft@. This includes a type with one such+--   constructor, which aeson writes as an empty list.+--+-- * A type with several constructors is a mapping with the name of the+--   constructor under the tag key, next to the fields of the constructor,+--   e.g. @{tag: Circle, radius: 1}@. A constructor with a field without a+--   name has its field under the contents key, e.g.+--   @{tag: Forward, contents: 10}@.+--+-- * A type with one constructor and a field without a name is its field.+--+-- * With the encoding 'TaggedFlat', the entries of a field without a name go+--   in the mapping of the constructor, e.g. @{tag: Ahead, distance: 10}@ for+--   @Ahead (Distance 10)@.+--+-- * With the encoding 'SingleField', a constructor is a mapping with its+--   name as the only key, e.g. @{Circle: {radius: 1}}@ or @{Forward: 10}@,+--   and a constructor without fields is its name, e.g. @Dot@. aeson writes+--   such a constructor as @{Dot: []}@.+--+-- The default encoding of a sum type is 'TaggedObject':+--+-- >>> :{+-- data Shape = Circle {radius :: Double} | Dot+--   deriving stock (Generic)+--   deriving anyclass (GenericYamlOptions)+--   deriving (ToYaml) via GenericYaml Shape+-- :}+--+-- >>> T.putStr (encodeText [Circle 1, Dot])+-- - tag: Circle+--   radius: 1.0+-- - tag: Dot+--+-- >>> :{+-- data Move = Forward Int | Stop+--   deriving stock (Generic)+--   deriving anyclass (GenericYamlOptions)+--   deriving (ToYaml) via GenericYaml Move+-- :}+--+-- >>> T.putStr (encodeText [Forward 10, Stop])+-- - tag: Forward+--   contents: 10+-- - tag: Stop+--+-- The instance of 'GenericYamlOptions' chooses another encoding:+--+-- >>> :{+-- data Distance = Distance {distance :: Int}+--   deriving stock (Generic)+--   deriving anyclass (GenericYamlOptions)+--   deriving (ToYaml) via GenericYaml Distance+-- :}+--+-- >>> :{+-- data Step = Ahead Distance | Halt+--   deriving stock (Generic)+--   deriving (ToYaml) via GenericYaml Step+-- instance GenericYamlOptions Step where+--   type SumEncoding Step = TaggedFlat+-- :}+--+-- >>> T.putStr (encodeText [Ahead (Distance 10), Halt])+-- - tag: Ahead+--   distance: 10+-- - tag: Halt+--+-- >>> :{+-- data Figure = Round {radius :: Double} | Named T.Text | Point+--   deriving stock (Generic)+--   deriving (ToYaml) via GenericYaml Figure+-- instance GenericYamlOptions Figure where+--   type SumEncoding Figure = SingleField+-- :}+--+-- >>> T.putStr (encodeText [Round 1, Named "x", Point])+-- - Round:+--     radius: 1.0+-- - Named: x+-- - Point+--+-- = Shapes+--+-- Every constructor must have no fields, one field without a name, or named+-- fields. A type with several constructors cannot mix named fields with a+-- field without a name, but a constructor without fields fits with both.+-- 'SingleField' allows the mix, because each constructor has its own value.+-- 'TaggedFlat' needs constructors with one field without a name or no+-- fields.+--+-- Another shape is a compile error that names the constructors, e.g. a+-- constructor with several fields without names. Give such fields names, or+-- with 'TaggedFlat', put them in a record type and make it the one field of+-- the constructor.+--+-- = Missing keys+--+-- A missing field takes its value from the 'yamlDefault' of the type that+-- has the field, if that type has a default. Otherwise the field decodes as+-- if its value is null. A missing contents key does the same. Thus a field+-- of type 'Maybe' is optional, and a missing field of another type is an+-- error, even if the type of the field has its own 'yamlDefault': only the+-- default of the type that has the field counts.+--+-- A type with a default configuration derives the decoder like this:+--+-- >>> :{+-- data Config = Config {name :: T.Text, retries :: Int, proxy :: Maybe T.Text}+--   deriving stock (Generic, Show)+--   deriving (FromYaml) via GenericYaml Config+-- instance GenericYamlOptions Config where+--   yamlDefault = Just (Config "app" 3 (Just "proxy.local"))+-- :}+--+-- >>> decodeText @Config "retries: 5\n"+-- Right (Config {name = "app", retries = 5, proxy = Just "proxy.local"})+--+-- >>> decodeText @Config "proxy: null\n"+-- Right (Config {name = "app", retries = 3, proxy = Nothing})+--+-- A field with the value 'requiredField' has no default:+--+-- >>> :{+-- data Account = Account {user :: T.Text, shell :: T.Text}+--   deriving stock (Generic, Show)+--   deriving (FromYaml) via GenericYaml Account+-- instance GenericYamlOptions Account where+--   yamlDefault = Just (Account requiredField "/bin/sh")+-- :}+--+-- >>> decodeText @Account "user: alice\n"+-- Right (Account {user = "alice", shell = "/bin/sh"})+--+-- >>> either printErrors print (decodeText @Account "shell: /bin/zsh\n")+-- input.yaml:1:1: missing key "user"+--   |+-- 1 | shell: /bin/zsh+--   | ^+--+-- A present key that holds a mapping takes the missing keys of that mapping+-- from the default of its own type, not from the outer default:+--+-- >>> :{+-- data Endpoint = Endpoint {host :: T.Text, port :: Int}+--   deriving stock (Generic, Show)+--   deriving (FromYaml) via GenericYaml Endpoint+-- instance GenericYamlOptions Endpoint where+--   yamlDefault = Just (Endpoint "localhost" 80)+-- :}+--+-- >>> :{+-- data Service = Service {name :: T.Text, endpoint :: Endpoint}+--   deriving stock (Generic, Show)+--   deriving (FromYaml) via GenericYaml Service+-- instance GenericYamlOptions Service where+--   yamlDefault = Just (Service "app" (Endpoint "example.com" 443))+-- :}+--+-- >>> decodeText @Service "endpoint:\n  port: 8080\n"+-- Right (Service {name = "app", endpoint = Endpoint {host = "localhost", port = 8080}})+--+-- >>> decodeText @Service "name: web\n"+-- Right (Service {name = "web", endpoint = Endpoint {host = "example.com", port = 443}})+--+-- With 'TaggedFlat', the keys of a field without a name are next to the tag,+-- but they belong to the field. The missing keys of the field also come+-- from the default of its type. The outer default applies to such a field+-- only if the constructor has no keys besides the tag.+--+-- An explicit null is not a missing key, so it goes to the decoder of the+-- field. E.g. @proxy: null@ gives 'Nothing' for a field of type 'Maybe', and+-- @proxy:@ without a value gives 'Nothing' too. An empty document is also+-- null, so a type with a default does not decode from it.+module Yamlet.Generic+  ( -- * Deriving+    GenericYaml (..)+  , GenericYamlOptions (..)+  , YamlOptions (..)+  , defaultYamlOptions+  , SumEncodingKind (..)+  , requiredField++    -- * Modifiers+  , snakeCase+  , kebabCase++    -- * Instances by hand+  , genericToYaml+  , genericParseYaml++    -- * Classes of the representation+  , GDatatype (Constructors)+  , GConstructors+  , GEncoding+  , GToConstructor+  , GFromConstructor+  , GFields+  , GToFields+  , GFromFields++    -- * Re-exports+  , Generic+  ) where++import Control.Exception hiding (TypeError)+import Control.Monad+import Data.Char+import Data.Coerce+import Data.Kind+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Proxy+import Data.Text qualified as T+import GHC.Generics+import GHC.TypeLits+import System.IO.Unsafe++import Yamlet.Internal.FromYaml+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.ToYaml+import Yamlet.Internal.Utils+import Yamlet.Internal.View+import Yamlet.Value++----------------------------------------+-- Deriving++-- | A newtype to derive t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml'+-- with @deriving via@. The instances come from the t'GHC.Generics.Generic'+-- representation of the type and its instance of 'GenericYamlOptions'.+newtype GenericYaml a = GenericYaml a++instance+  ( Generic a+  , GenericYamlOptions a+  , GDatatype (Rep a)+  , Constructors (Rep a) ~ f+  , GConstructors f+  , GEncoding (SumEncoding a) f+  , GToConstructor f+  , ToYaml a+  )+  => ToYaml (GenericYaml a)+  where+  toYaml = coerce (genericToYaml @a)+  -- The pragma keeps the source of the method as its unfolding, and GHC+  -- inlines it at the type of the derived instance, together with+  -- 'genericToYaml'. Without it, GHC does not inline the optimized method+  -- there, the derived encoders keep the generic representation, and the+  -- inspection tests of the encoders fail.+  {-# INLINE toYaml #-}++  -- The list and the field encode their values with the instance of+  -- 'ToYaml a', for the reason at 'parseYamlList' below. With the defaults+  -- of the class, the benchmark derive.contents.toYaml.generic is slower.+  toYamlList xs = S.sequenceNode (map (toYaml @a) (coerce xs))++  -- A type that is its field passes the key to the field.+  toYamlField k (GenericYaml x)+    | not (isTagged @f (yamlOptions @a))+    , Just entry <- gToUntaggedEntry k (gUnwrap (from x)) =+        entry+    | otherwise = (k, toYaml @a x)++instance+  ( Generic a+  , GenericYamlOptions a+  , GDatatype (Rep a)+  , Constructors (Rep a) ~ f+  , GConstructors f+  , GEncoding (SumEncoding a) f+  , GFromConstructor f+  , FromYaml a+  )+  => FromYaml (GenericYaml a)+  where+  parseYaml = coerce (genericParseYaml @a)+  -- The pragma has the reason of the one on 'toYaml'. Without it, the+  -- optimized method is too large for an unfolding, and the inspection tests+  -- of the decoders fail.+  {-# INLINE parseYaml #-}++  -- The list and the field decode their values with the instance of+  -- 'FromYaml a', i.e. the derived instance of the type, where GHC inlined+  -- the generic decoder at that type. The defaults of the class would call+  -- 'parseYaml' of this instance instead. GHC inlines the defaults here,+  -- where the type is not known, and the derived instance only calls the+  -- result. Each value would then go through the generic representation,+  -- and the benchmark derive.contents.parseYaml.generic would be slower.+  parseYamlList = coerce (withSequence (parseItems (parseYaml @a)))+  -- The derived method applies this one to the dictionaries of the instance.+  -- The pragma inlines it there, so only the dictionary of 'FromYaml a'+  -- remains. Without the pragma, GHC 9.14 keeps the call with all the+  -- dictionaries, because its worker/wrapper does not drop unused+  -- dictionaries, and the inspection tests of the list decoders fail.+  {-# INLINE parseYamlList #-}++  -- A type that is its field passes the key to the field.+  parseYamlField k v+    | not (isTagged @f (yamlOptions @a))+    , Just p <- gFromUntaggedEntry (to . gWrap) (k, v) =+        coerce @(Parser a) p+    | otherwise = coerce (parseYaml @a v)++----------------------------------------+-- Options++-- | How a type is encoded and decoded.+--+-- The instances do not check the options. Options that give two keys of a+-- mapping or two constructors the same text encode values that do not read+-- back, as the fields below describe.+data YamlOptions = YamlOptions+  { fieldLabelModifier :: !(String -> String)+  -- ^ The key of a field from the name of the field. If two fields of a+  -- constructor get the same key, e.g. @fooBar@ and @foo_bar@ with+  -- 'snakeCase', the constructor encodes as a mapping with two equal keys,+  -- which does not read back.+  , constructorTagModifier :: !(String -> String)+  -- ^ The tag of a constructor from the name of the constructor. If two+  -- constructors get the same tag, e.g. @FooBar@ and @Foo_bar@ with+  -- 'snakeCase', the decoder reads the tag as the first of them.+  , tagKey :: !T.Text+  -- ^ The key of the tag, @tag@ by default. A record with a field of the same+  -- key encodes as a mapping with two equal keys, which does not read back.+  , contentsKey :: !T.Text+  -- ^ The key of the fields of a tagged constructor without field names,+  -- @contents@ by default. If it is the same as 'Yamlet.Generic.tagKey', such+  -- a constructor encodes as a mapping with two equal keys, which does not+  -- read back.+  , tagSingleConstructors :: !Bool+  -- ^ Give a type with one constructor a tag too, unless the constructor has+  -- no fields. Off by default.+  , omitNullFields :: !Bool+  -- ^ Leave out a field whose value is null, e.g. 'Nothing'. Off by default.+  -- A null field with comments stays, e.g. a t'Yamlet.Commented' field with+  -- the value 'Nothing' and a comment. So does a null field with an anchor,+  -- which an alias elsewhere can refer to.+  --+  -- With 'yamlDefault', a null field stays unless its default is null without+  -- comments. Otherwise the value would not read back: the decoder fills a+  -- missing key from the default, so e.g. a field 'Nothing' with the default+  -- @Just 1@ would read back as @Just 1@. A value that encodes as its default+  -- still reads back as the default, e.g. a field 'Nothing' of type+  -- @Maybe (Maybe a)@ with the default @Just Nothing@, because both encode as+  -- null.+  , rejectUnknownFields :: !Bool+  -- ^ Reject a key that is not a field of the constructor. On by default.+  --+  -- Turn it off for a document with keys that the type does not model, e.g.+  -- keys that only hold anchors. The decoder then ignores such keys, and an+  -- encode of the value leaves them out.+  }+  deriving stock (Generic)++-- | The options with the defaults that the fields of t'YamlOptions' name.+defaultYamlOptions :: YamlOptions+defaultYamlOptions =+  YamlOptions+    { fieldLabelModifier = id+    , constructorTagModifier = id+    , tagKey = "tag"+    , contentsKey = "contents"+    , tagSingleConstructors = False+    , omitNullFields = False+    , rejectUnknownFields = True+    }++-- | How a tagged constructor goes in a mapping. The choice is a type, see+-- 'SumEncoding', because it changes the shapes of the constructors that a+-- type can have.+data SumEncodingKind+  = -- | The fields go next to the tag, e.g. @{tag: Circle, radius: 1}@, and a+    -- field without a name goes under the contents key, e.g.+    -- @{tag: Forward, contents: 10}@.+    --+    -- An enumeration is a string, but a constructor without fields in a type+    -- with fields is a mapping, e.g. @{tag: Stop}@. To keep the encoding of an+    -- enumeration when you add a constructor with fields, use 'SingleField'.+    TaggedObject+  | -- | The entries of a field without a name go next to the tag, e.g.+    -- @{tag: Ahead, distance: 10}@ for @Ahead (Distance 10)@. The+    -- constructors must have one field without a name or no fields,+    -- otherwise the derived instances are a type error.+    --+    -- The field must encode as a mapping with a key and without an anchor or+    -- a tag, and no key can be the tag key or the contents key. Otherwise+    -- the constructor encodes as with 'TaggedObject'. Thus the field of a+    -- type with the same tag key stays under the contents key, and so do a+    -- mapping with an anchor that an alias can refer to and a+    -- v'Yamlet.Value.Tagged' value.+    --+    -- Only the entries of the mapping go next to the tag. The comments of the+    -- mapping are lost, e.g. the comments of a t'Yamlet.Commented' value.+    -- 'TaggedObject' keeps them.+    --+    -- The decoder reads a mapping with the contents key as with+    -- 'TaggedObject', and the other keys are unknown keys. Without the+    -- contents key, the other keys are the field, so a field that is not a+    -- mapping needs the contents key. An error at the mapping itself, e.g.+    -- that a mapping is not an integer, has a note at the tag that says so.+    --+    -- The keys of the mapping belong to the field, so the options of its+    -- type apply to them, e.g. 'Yamlet.Generic.rejectUnknownFields'.+    TaggedFlat+  | -- | A mapping with one key, the tag, and the fields as its value, e.g.+    -- @{Circle: {radius: 1}}@. A field without a name is the value, e.g.+    -- @{Forward: 10}@, and a constructor without fields is its tag, e.g.+    -- @Dot@. The tag key and the contents key play no part.+    --+    -- Each constructor has its own value, so the constructors of a type can+    -- mix named fields with a field without a name. A second key in the+    -- mapping is an error. 'Yamlet.Generic.rejectUnknownFields' applies to+    -- the named fields in the value.+    --+    -- The key of a constructor with named fields is not a field, so its+    -- comments are lost. The key of a field without a name goes to the+    -- field, e.g. for a 'Yamlet.Commented' value.+    SingleField+  deriving stock (Eq, Show)++-- | The configuration of the generic instances of t'Yamlet.Decode.FromYaml'+-- and t'Yamlet.Encode.ToYaml' for a type: the options and the default value.+class GenericYamlOptions a where+  -- | How a tagged constructor goes in a mapping, 'TaggedObject' by default.+  type SumEncoding a :: SumEncodingKind++  type SumEncoding a = TaggedObject++  -- | The options of the type, 'defaultYamlOptions' by default.+  yamlOptions :: YamlOptions+  yamlOptions = defaultYamlOptions++  -- | The value that gives the fields of missing keys, e.g. the default+  -- configuration. Without it, a missing key decodes like null. A key with+  -- the value null is not missing. For a sum type, the default applies only+  -- to the constructor of the default value.+  yamlDefault :: Maybe a+  yamlDefault = Nothing++-- | The value of a field without a default in 'yamlDefault'. A missing key+-- of the field is an error, also if the field accepts null, e.g. for a field+-- of type 'Maybe'. The encoder with 'Yamlet.Generic.omitNullFields' keeps+-- such a field.+--+-- The value throws an exception when it is evaluated, also in your own code+-- that uses 'yamlDefault'. The generic instances evaluate each field of the+-- default to find the required fields, so:+--+-- * The field must be 'requiredField' itself, e.g. @Just requiredField@ is not+--   a valid default value for the field of type @Maybe Text@.+--+-- * The field must be lazy and not a field of a newtype.+--+-- With 'TaggedFlat', the keys next to the tag can belong to a field without+-- a name, e.g. @distance@ in @{tag: Ahead, distance: 10}@ for+-- @Ahead (Distance 10)@. To require such a key, use 'requiredField' in the+-- default of the type of the field, e.g. @Distance@, not of the sum type.+requiredField :: a+requiredField = throw RequiredField++-- | The exception of 'requiredField'.+data RequiredField = RequiredField+  deriving stock (Show)++instance Exception RequiredField where+  displayException _ = "the field has no default"++-- | The field of a default, or 'Nothing' for 'requiredField'.+defaultField :: a -> Maybe a+-- Masking asynchronous exceptions inside 'unsafeDupablePerformIO' is a+-- workaround for https://gitlab.haskell.org/ghc/ghc/-/work_items/24189.+defaultField x = case unsafeDupablePerformIO (uninterruptibleMask_ (try (evaluate x))) of+  Left RequiredField -> Nothing+  Right _ -> Just x++-- | An error if the 'yamlDefault' of the type has a 'requiredField' in a+-- strict field or in the field of a newtype. Without the check, each field+-- would look required, and a missing key would give the error of a field+-- that has a default.+checkDefault :: forall a. (GenericYamlOptions a, GDatatype (Rep a)) => ()+checkDefault = case yamlDefault @a of+  Just d+    | isNothing (defaultField d) ->+        error $+          "requiredField in a strict field or a newtype of the default of "+            ++ gDatatypeName @(Rep a)+  _ -> ()+-- Without the pragma, the derived encoders and decoders of lists and fields+-- keep the generic dictionaries, and their inspection tests fail.+{-# INLINE checkDefault #-}++-- | The words of a name in lower case, separated by underscores, e.g.+-- @source_paths@ for @sourcePaths@ or @SourcePaths@, and @http_server@ for+-- @HTTPServer@. The rules are the same as for @camelTo2 \'_\'@ of aeson.+--+-- >>> map snakeCase ["sourcePaths", "SourcePaths", "HTTPServer", "ghcVersion2"]+-- ["source_paths","source_paths","http_server","ghc_version2"]+snakeCase :: String -> String+snakeCase = separateWords '_'++-- | Like 'snakeCase', but with hyphens, e.g. @source-paths@ for+-- @sourcePaths@.+--+-- >>> kebabCase "sourcePaths"+-- "source-paths"+kebabCase :: String -> String+kebabCase = separateWords '-'++-- A word starts at an upper-case letter after a lower-case one, and at the+-- last letter of an acronym before a lower-case one.+separateWords :: Char -> String -> String+separateWords sep = map toLower . afterLower . beforeLower+  where+    beforeLower :: String -> String+    beforeLower = \case+      x : u : l : rest | isUpper u && isLower l -> x : sep : u : l : beforeLower rest+      x : rest -> x : beforeLower rest+      [] -> []++    afterLower :: String -> String+    afterLower = \case+      l : u : rest | isLower l && isUpper u -> l : sep : u : afterLower rest+      x : rest -> x : afterLower rest+      [] -> []++----------------------------------------+-- Constructors++-- An equality such as @Rep a ~ D1 d f@ would do the same as this class, but+-- for a type without a 'Generic' instance, GHC would report that the equality+-- fails instead of the missing instance.++-- | The layer of the data type at the top of a representation, and the+-- constructors below it. This class and the others of the representation+-- appear in the constraints of 'genericToYaml' and 'genericParseYaml'. Their+-- methods are internal.+class GDatatype (r :: Type -> Type) where+  type Constructors r :: Type -> Type++  gUnwrap :: r p -> Constructors r p++  gWrap :: Constructors r p -> r p++  gDatatypeName :: String++instance KnownSymbol name => GDatatype (D1 (MetaData name m p nt) f) where+  type Constructors (D1 (MetaData name m p nt) f) = f++  gUnwrap = unM1++  gWrap = M1++  gDatatypeName = symbolVal (Proxy @name)++-- | The names and the number of the constructors of a representation.+class GConstructors f where+  gConstructorNames :: [String]++  gConstructorCount :: Int++  -- | No constructor has fields.+  gNullary :: Bool++instance (GConstructors f, GConstructors g) => GConstructors (f :+: g) where+  gConstructorNames = gConstructorNames @f ++ gConstructorNames @g++  gConstructorCount = gConstructorCount @f + gConstructorCount @g++  gNullary = gNullary @f && gNullary @g++instance GConstructors V1 where+  gConstructorNames = []++  gConstructorCount = 0++  gNullary = True++-- | The error for a type without constructors, whose representation is 'V1'.+type NoConstructors = Text "A type without constructors cannot derive FromYaml or ToYaml"++instance+  (KnownSymbol name, GFields f)+  => GConstructors (C1 (MetaCons name fixity isRecord) f)+  where+  gConstructorNames = [symbolVal (Proxy @name)]++  gConstructorCount = 1++  gNullary = gArity @f == 0++-- The instances check the shape of the constructors, because every derived+-- instance needs this class.++-- | The value of 'SumEncoding', if the constructors allow it.+class GEncoding (e :: SumEncodingKind) f where+  gEncoding :: SumEncodingKind++instance ValidShape (GShape TaggedObject f) => GEncoding TaggedObject f where+  gEncoding = validShape @(GShape TaggedObject f) `seq` TaggedObject++instance ValidShape (GShape TaggedFlat f) => GEncoding TaggedFlat f where+  gEncoding = validShape @(GShape TaggedFlat f) `seq` TaggedFlat++instance ValidShape (SingleShape f) => GEncoding SingleField f where+  gEncoding = validShape @(SingleShape f) `seq` SingleField++-- | The fields of the constructors of a type. A constructor without fields+-- fits with both kinds of fields.+data Shape+  = NoFields+  | -- | One field without a name, in the constructor with the name.+    UnnamedField Symbol+  | -- | Named fields, in the constructor with the name.+    NamedFields Symbol++-- | The shape of the constructors with the sum encoding. A constructor with+-- several fields without names, named fields with 'TaggedFlat', and a type+-- that mixes named fields with a field without a name, are type errors.+type family GShape (e :: SumEncodingKind) (f :: Type -> Type) :: Shape where+  GShape e (f :+: g) = CombineShapes (GShape e f) (GShape e g)+  GShape TaggedFlat (C1 (MetaCons name fixity True) f) =+    TypeError+      ( Text "TaggedFlat needs constructors with one field without a name, but the constructor "+          :<>: Text name+          :<>: Text " has named fields."+          :$$: FlatFieldsFix+      )+  GShape e (C1 (MetaCons name fixity True) f) = NamedFields name+  GShape e (C1 (MetaCons name fixity False) U1) = NoFields+  GShape e (C1 (MetaCons name fixity False) (S1 m f)) = UnnamedField name+  GShape e (C1 (MetaCons name fixity False) (f :*: g)) =+    TypeError+      ( Text "The constructor "+          :<>: Text name+          :<>: Text " has several fields without names."+          :$$: SeveralFieldsFix e+      )+  GShape e V1 = TypeError NoConstructors++type family SeveralFieldsFix (e :: SumEncodingKind) :: ErrorMessage where+  SeveralFieldsFix TaggedFlat = FlatFieldsFix+  SeveralFieldsFix e = Text "Give the fields names."++type FlatFieldsFix =+  Text "Put the fields in a record type, and make it the one field of the constructor."++type family CombineShapes (a :: Shape) (b :: Shape) :: Shape where+  CombineShapes NoFields b = b+  CombineShapes a NoFields = a+  CombineShapes (NamedFields a) (NamedFields _) = NamedFields a+  CombineShapes (UnnamedField a) (UnnamedField _) = UnnamedField a+  CombineShapes (NamedFields a) (UnnamedField b) = MixedFields a b+  CombineShapes (UnnamedField b) (NamedFields a) = MixedFields a b++type family MixedFields (named :: Symbol) (unnamed :: Symbol) :: Shape where+  MixedFields named unnamed =+    TypeError+      ( Text "The constructor "+          :<>: Text named+          :<>: Text " has named fields and the constructor "+          :<>: Text unnamed+          :<>: Text " has one field without a name."+          :$$: Text+                 "Give them the same kind of fields, or use the sum encoding SingleField, where each constructor has its own value."+      )++-- | The shape is valid. The instances match on the shape, so that GHC+-- reduces it and reports its type errors. With deferred type errors, e.g. in+-- a test of the errors, the method throws the error at run time.+class ValidShape (s :: Shape) where+  validShape :: ()++instance ValidShape NoFields where validShape = ()+instance ValidShape (UnnamedField name) where validShape = ()+instance ValidShape (NamedFields name) where validShape = ()++-- | A shape of 'SingleField', which checks each constructor as 'GShape' does,+-- but lets the constructors mix their fields. The equations match both+-- shapes, so that GHC reduces both and reports their type errors.+type family SingleShape (f :: Type -> Type) :: Shape where+  SingleShape (f :+: g) = EitherShape (SingleShape f) (SingleShape g)+  SingleShape f = GShape SingleField f++type family EitherShape (a :: Shape) (b :: Shape) :: Shape where+  EitherShape NoFields b = b+  EitherShape a NoFields = a+  EitherShape (NamedFields a) (NamedFields _) = NamedFields a+  EitherShape (NamedFields a) (UnnamedField _) = NamedFields a+  EitherShape (UnnamedField a) (NamedFields _) = UnnamedField a+  EitherShape (UnnamedField a) (UnnamedField _) = UnnamedField a++isTagged :: forall f. GConstructors f => YamlOptions -> Bool+isTagged opts = opts.tagSingleConstructors || gConstructorCount @f > 1++constructorTag :: YamlOptions -> String -> T.Text+constructorTag opts = T.pack . opts.constructorTagModifier++-- | The tag of the constructor with the name.+constructorTagOf :: forall name. KnownSymbol name => YamlOptions -> T.Text+constructorTagOf opts = constructorTag opts (symbolVal (Proxy @name))++-- | The default of the first constructor of a sum, if it is the default.+leftDefault :: Maybe ((f :+: g) p) -> Maybe (f p)+leftDefault def =+  def >>= \case+    L1 x -> Just x+    R1 _ -> Nothing++-- | The default of the second constructor of a sum, if it is the default.+rightDefault :: Maybe ((f :+: g) p) -> Maybe (g p)+rightDefault def =+  def >>= \case+    R1 x -> Just x+    L1 _ -> Nothing++-- | The first fields of the default of a product.+firstDefault :: Maybe ((f :*: g) p) -> Maybe (f p)+firstDefault = fmap (\(a :*: _) -> a)++-- | The second fields of the default of a product.+secondDefault :: Maybe ((f :*: g) p) -> Maybe (g p)+secondDefault = fmap (\(_ :*: b) -> b)++----------------------------------------+-- Fields++-- | The names and the number of the fields of a constructor.+class GFields f where+  -- | The fields have names.+  gNamed :: Bool++  gArity :: Int++  -- | The keys of the fields.+  gNames :: YamlOptions -> [T.Text]++instance GFields U1 where+  gNamed = False++  gArity = 0++  gNames _ = []++instance (GFields f, GFields g) => GFields (f :*: g) where+  gNamed = gNamed @f++  gArity = gArity @f + gArity @g++  gNames opts = gNames @f opts ++ gNames @g opts++instance KnownSymbol name => GFields (S1 (MetaSel (Just name) u s d) f) where+  gNamed = True++  gArity = 1++  gNames opts = [fieldKey @name opts]++instance GFields (S1 (MetaSel Nothing u s d) f) where+  gNamed = False++  gArity = 1++  gNames _ = []++fieldKey :: forall name. KnownSymbol name => YamlOptions -> T.Text+fieldKey opts = T.pack (opts.fieldLabelModifier (symbolVal (Proxy @name)))++----------------------------------------+-- Encoding++-- | The generic encoder, e.g. for an instance by hand that encodes some+-- values in another way.+--+-- >>> :{+-- data Size = Size {width :: Int, height :: Int}+--   deriving stock (Generic)+--   deriving anyclass (GenericYamlOptions)+-- instance ToYaml Size where+--   toYaml s+--     | s.width == 0 && s.height == 0 = toYaml ("empty" :: T.Text)+--     | otherwise = genericToYaml s+-- :}+--+-- >>> T.putStr (encodeText [Size 0 0, Size 1 2])+-- - empty+-- - width: 1+--   height: 2++-- GHC must inline the generic code in the derived method before the+-- specializer runs. Otherwise the specializer makes a copy of the code for+-- each node of the representation, and a large type takes several times+-- longer to compile. For the same reason, the top of the representation goes+-- to a plain function, not to a class with one method. GHC represents the+-- dictionary of such a class as a partial application of the method, and it+-- does not inline that.+genericToYaml+  :: forall a f+   . ( Generic a+     , GenericYamlOptions a+     , GDatatype (Rep a)+     , Constructors (Rep a) ~ f+     , GConstructors f+     , GEncoding (SumEncoding a) f+     , GToConstructor f+     )+  => a -> S.Node+genericToYaml x =+  -- Forcing the encoding forces the check of the shape, e.g. with deferred+  -- type errors in a test of the errors.+  let enc = gEncoding @(SumEncoding a) @f+      -- The keys of the options are texts that GHC does not know to be+      -- evaluated. Without the bang, it evaluates them in each branch of the+      -- constructors, and it keeps the generic representation of a sum, as+      -- the inspection test of encodeShape shows. GHC before 9.12 keeps it+      -- also with the bang.+      !opts = yamlOptions @a+  in enc+       `seq` checkDefault @a+       `seq` gToYaml opts enc (gUnwrap . from <$> yamlDefault @a) (gUnwrap (from x))+{-# INLINE genericToYaml #-}++-- The encoder takes the default for 'omitNullFields': it leaves out a null+-- field only if the default of the field is null without comments too.+-- Otherwise the decoder would fill the missing key from the default, and the+-- value would not read back.+gToYaml+  :: forall f p+   . ( GConstructors f+     , GToConstructor f+     )+  => YamlOptions -> SumEncodingKind -> Maybe (f p) -> f p -> S.Node+gToYaml opts enc def x+  | gNullary @f = scalar (String (gTag opts x))+  | otherwise = gToConstructor opts (if isTagged @f opts then Just enc else Nothing) def x+-- Without the pragma, GHC 9.2 does not inline this function, and GHC 9.4 does+-- not inline it for an enumeration. Then the inspection tests of these+-- derived encoders fail. Later versions inline it anyway.+{-# INLINE gToYaml #-}++-- | The encoder of the constructors of a representation.+class GToConstructor f where+  gTag :: YamlOptions -> f p -> T.Text++  -- | The constructor, with the tag in the given encoding.+  gToConstructor :: YamlOptions -> Maybe SumEncodingKind -> Maybe (f p) -> f p -> S.Node++  -- | The mapping entry under the key of a constructor without a tag, if it+  -- has one field without a name. The field gets the key, e.g. for the+  -- comments above the key of a 'Yamlet.Commented' field.+  gToUntaggedEntry :: S.Node -> f p -> Maybe (S.Node, S.Node)++instance GToConstructor V1 where+  gTag _ = \case {}++  gToConstructor _ _ _ = \case {}++  gToUntaggedEntry _ = \case {}++instance (GToConstructor f, GToConstructor g) => GToConstructor (f :+: g) where+  gTag opts = \case+    L1 x -> gTag opts x+    R1 x -> gTag opts x+  {-# INLINE gTag #-}++  gToConstructor opts flat def = \case+    L1 x -> gToConstructor opts flat (leftDefault def) x+    R1 x -> gToConstructor opts flat (rightDefault def) x+  {-# INLINE gToConstructor #-}++  -- A type with several constructors always has a tag.+  gToUntaggedEntry _ _ = Nothing++instance+  ( KnownSymbol name+  , GFields f+  , GToFields f+  )+  => GToConstructor (C1 (MetaCons name fixity isRecord) f)+  where+  gTag opts _ = constructorTagOf @name opts+  {-# INLINE gTag #-}++  gToConstructor opts tagging def c@(M1 x) = case tagging of+    Just SingleField+      | gNamed @f ->+          mapping [(string (gTag opts c), mapping (gToEntries opts (unM1 <$> def) x))]+      | otherwise -> case gToValue x of+          Nothing -> string (gTag opts c)+          Just _ -> mapping [gToEntry (string (gTag opts c)) x]+    Just enc+      | gNamed @f -> mapping (withTagEntry (gToEntries opts (unM1 <$> def) x))+      | otherwise -> case gToValue x of+          Nothing -> mapping (withTagEntry [])+          Just v+            | enc == TaggedFlat+            , Just entries <- flatEntries v ->+                mapping (withTagEntry entries)+            | otherwise -> mapping (withTagEntry [gToEntry (string opts.contentsKey) x])+    Nothing+      | gNamed @f -> mapping (gToEntries opts (unM1 <$> def) x)+      | otherwise -> fromMaybe (mapping []) (gToValue x)+    where+      withTagEntry :: [(S.Node, S.Node)] -> [(S.Node, S.Node)]+      withTagEntry entries = (opts.tagKey .= gTag opts c) : entries++      -- The entries of a field next to the tag, if the decoder can read them+      -- back. The field must be a mapping with a key, and no key can be the+      -- tag key or the contents key. The decoder reads a mapping with the+      -- contents key as the other form. A mapping with an anchor or a tag+      -- keeps it under the contents key, because an alias elsewhere can refer+      -- to the anchor, and the tag is part of the value.+      flatEntries :: S.Node -> Maybe [(S.Node, S.Node)]+      flatEntries v = case v.content of+        S.MappingContent _ kvs+          | null kvs -> Nothing+          | isJust v.props.anchor -> Nothing+          | v.props.tag /= S.NoTag -> Nothing+          | any (\(k, _) -> isKey opts.tagKey k || isKey opts.contentsKey k) kvs ->+              Nothing+          | otherwise -> Just kvs+        _ -> Nothing+  {-# INLINE gToConstructor #-}++  gToUntaggedEntry k (M1 x)+    | gNamed @f || gArity @f == 0 = Nothing+    | otherwise = Just (gToEntry k x)++-- | The encoder of the fields of a constructor.+--+-- The shape check allows named fields, no fields, or one field without a+-- name. The default methods are for the kind of fields that never calls+-- them.+class GToFields f where+  -- | The entries of the named fields, with the given default.+  gToEntries :: YamlOptions -> Maybe (f p) -> f p -> [(S.Node, S.Node)]+  gToEntries _ _ _ = []++  -- | The value of the only field without a name.+  gToValue :: f p -> Maybe S.Node+  gToValue _ = Nothing++  -- | The mapping entry of the only field without a name under the key, e.g.+  -- with the comments of a 'Yamlet.Commented' field on the contents key.+  gToEntry :: S.Node -> f p -> (S.Node, S.Node)+  gToEntry k x = (k, fromMaybe (mapping []) (gToValue x))++instance GToFields U1++instance (GToFields f, GToFields g) => GToFields (f :*: g) where+  gToEntries opts def (a :*: b) =+    gToEntries opts (firstDefault def) a ++ gToEntries opts (secondDefault def) b+  {-# INLINE gToEntries #-}++instance+  ( KnownSymbol name+  , ToYaml a+  )+  => GToFields (S1 (MetaSel (Just name) u s d) (Rec0 a))+  where+  gToEntries opts def (M1 (K1 x))+    | opts.omitNullFields+        && isNullNode (snd entry)+        && uncommented+        && unanchored+        && nullDefault =+        []+    | otherwise = [entry]+    where+      entry :: (S.Node, S.Node)+      entry = fieldKey @name opts .= x++      -- The comments would go away with the entry.+      uncommented :: Bool+      uncommented =+        (fst entry).comments == S.noComments && (snd entry).comments == S.noComments++      -- An alias elsewhere can refer to the anchor.+      unanchored :: Bool+      unanchored = isNothing (snd entry).props.anchor++      -- The decoder fills a missing key from the default.+      nullDefault :: Bool+      nullDefault = case def of+        Just (M1 (K1 d)) -> isNullDefault d+        Nothing -> True+  {-# INLINE gToEntries #-}++-- | The field of a default is null without comments, and not+-- 'requiredField'.+isNullDefault :: ToYaml a => a -> Bool+isNullDefault d = case toYaml <$> defaultField d of+  Just n -> isNullNode n && n.comments == S.noComments+  Nothing -> False+-- Not inlined, the call has only constant arguments, so GHC computes it once+-- for each field of a default. Inlined in the encoder, as in the @where@+-- clause of its caller, it ran on each encode, and the encode of records with+-- a default and 'omitNullFields' was slower and allocated more.+{-# NOINLINE isNullDefault #-}++instance ToYaml a => GToFields (S1 (MetaSel Nothing u s d) (Rec0 a)) where+  gToValue (M1 (K1 x)) = Just (toYaml x)++  gToEntry k (M1 (K1 x)) = toYamlField k x++----------------------------------------+-- Decoding++-- | The generic decoder, e.g. for an instance by hand with a check after the+-- decode.+--+-- >>> :{+-- data Range = Range {low :: Int, high :: Int}+--   deriving stock (Generic, Show)+--   deriving anyclass (GenericYamlOptions)+-- instance FromYaml Range where+--   parseYaml n = do+--     r <- genericParseYaml n+--     if r.low <= r.high then pure r else failAt n "expected low <= high"+-- :}+--+-- >>> decodeText @Range "low: 1\nhigh: 2\n"+-- Right (Range {low = 1, high = 2})+--+-- >>> either printErrors print (decodeText @Range "low: 3\nhigh: 2\n")+-- input.yaml:1:1: expected low <= high+--   |+-- 1 | low: 3+--   | ^++-- The code inlines in the derived method, for the reasons at 'genericToYaml'.+genericParseYaml+  :: forall a f+   . ( Generic a+     , GenericYamlOptions a+     , GDatatype (Rep a)+     , Constructors (Rep a) ~ f+     , GConstructors f+     , GEncoding (SumEncoding a) f+     , GFromConstructor f+     )+  => S.Node -> Parser a+genericParseYaml n =+  -- Forcing the encoding forces the check of the shape, e.g. with deferred+  -- type errors in a test of the errors.+  let enc = gEncoding @(SumEncoding a) @f+  in enc+       `seq` checkDefault @a+       `seq` gParseYaml+         (yamlOptions @a)+         enc+         (gUnwrap . from <$> yamlDefault @a)+         (to . gWrap)+         n+{-# INLINE genericParseYaml #-}++-- Each constructor applies 'to' to its own representation, e.g.+-- @to (M1 (L1 (M1 fields)))@, and the optimizer reduces this to the real+-- constructor in the same place. For this, the decoders of the constructors+-- take a continuation. It starts as 'to' after 'gWrap' and grows by 'M1',+-- 'L1' or 'R1' at each level of the sum.+--+-- In the direct style, each constructor returns its representation, the+-- branches meet in 'mplus', and 'to' comes after them. The optimizer then no+-- longer knows which branch produced the value, so the program builds 'L1',+-- 'R1' and ':*:' at run time and 'to' matches on them again.+--+-- The fields of one constructor need no continuation, because they build+-- their product in one place, and 'to' of the same branch consumes it.+--+-- The representation of the default goes down with the options, so that each+-- field finds its default value.+gParseYaml+  :: forall f p a+   . ( GConstructors f+     , GFromConstructor f+     )+  => YamlOptions -> SumEncodingKind -> Maybe (f p) -> (f p -> a) -> S.Node -> Parser a+gParseYaml opts enc def k n+  | gNullary @f =+      withName tags (\t -> fromMaybe (unknown n "value" t) (gFromTag opts k n t)) n+  | isTagged @f opts, enc == SingleField = single+  | isTagged @f opts = withMapping tagged n+  | otherwise = gFromUntagged opts def k n+  where+    tagged :: Object -> Parser a+    tagged o = case M.lookup opts.tagKey o.index of+      Nothing -> missingKey o opts.tagKey+      Just (_, tn) -> do+        t <- withName tags pure tn+        fromMaybe (unknown tn "tag" t) (gFromTagged opts (enc == TaggedFlat) def k t o)++    -- A constructor without fields is its tag, and another constructor is a+    -- mapping with its tag as the only key.+    single :: Parser a+    single = case view n of+      StringView t -> fromMaybe (withoutValue t) (gFromTag opts k n t)+      _ | S.MappingContent {} <- n.content -> withMapping singleEntry n+      _ | Just msg <- unquotedName tags n -> failAt n msg+      _ -> typeMismatch "a string or a mapping with one key" n++    singleEntry :: Object -> Parser a+    singleEntry o = case objectEntries o of+      [(kn, v)] -> do+        t <- withName tags pure kn+        fromMaybe (unknown kn "constructor" t) (gFromSingle opts def k t (kn, v))+      _ : (kn, _) : _ -> failAt kn "expected a mapping with one key, but got a second key"+      [] -> failAt n "expected a mapping with one key, but got an empty mapping"++    -- A string that is the tag of a constructor with fields.+    withoutValue :: T.Text -> Parser a+    withoutValue t+      | t `elem` tags =+          failAt n $+            "expected a mapping with the key "+              ++ showText t+              ++ ", because the constructor has fields"+      | otherwise = unknown n "constructor" t++    unknown :: S.Node -> String -> T.Text -> Parser a+    unknown node what = unknownName what tags node++    tags :: [T.Text]+    tags = map (constructorTag opts) (gConstructorNames @f)+{-# INLINE gParseYaml #-}++-- | The decoder of the constructors of a representation.+class GFromConstructor f where+  -- | The constructor without fields with the tag, from the node of the tag.+  gFromTag :: YamlOptions -> (f p -> a) -> S.Node -> T.Text -> Maybe (Parser a)++  -- | The constructor with the tag, from the mapping that holds the tag, with+  -- the flag of 'TaggedFlat'.+  gFromTagged+    :: YamlOptions+    -> Bool+    -> Maybe (f p)+    -> (f p -> a)+    -> T.Text+    -> Object+    -> Maybe (Parser a)++  -- | The constructor with the tag, from the only entry of a mapping, for+  -- 'SingleField'.+  gFromSingle+    :: YamlOptions+    -> Maybe (f p)+    -> (f p -> a)+    -> T.Text+    -> (S.Node, S.Node)+    -> Maybe (Parser a)++  -- | The only constructor, without a tag.+  gFromUntagged :: YamlOptions -> Maybe (f p) -> (f p -> a) -> S.Node -> Parser a++  -- | The only constructor, without a tag, from a mapping entry, if it has+  -- one field without a name. The field gets the key, e.g. for the comments+  -- above the key of a 'Yamlet.Commented' field.+  gFromUntaggedEntry :: (f p -> a) -> (S.Node, S.Node) -> Maybe (Parser a)++instance GFromConstructor V1 where+  gFromTag _ _ _ _ = Nothing++  gFromTagged _ _ _ _ _ _ = Nothing++  gFromSingle _ _ _ _ _ = Nothing++  gFromUntagged _ _ _ _ = fail "expected a type with constructors"++  gFromUntaggedEntry _ _ = Nothing++instance (GFromConstructor f, GFromConstructor g) => GFromConstructor (f :+: g) where+  gFromTag opts k n t = gFromTag opts (k . L1) n t `mplus` gFromTag opts (k . R1) n t+  {-# INLINE gFromTag #-}++  gFromTagged opts flat def k t o =+    gFromTagged opts flat (leftDefault def) (k . L1) t o+      `mplus` gFromTagged opts flat (rightDefault def) (k . R1) t o+  {-# INLINE gFromTagged #-}++  gFromSingle opts def k t entry =+    gFromSingle opts (leftDefault def) (k . L1) t entry+      `mplus` gFromSingle opts (rightDefault def) (k . R1) t entry+  {-# INLINE gFromSingle #-}++  -- A type with several constructors always has a tag.+  gFromUntagged _ _ _ _ = fail "expected a tag"++  gFromUntaggedEntry _ _ = Nothing++instance+  ( KnownSymbol name+  , GFields f+  , GFromFields f+  )+  => GFromConstructor (C1 (MetaCons name fixity isRecord) f)+  where+  gFromTag opts k n t+    | t == tag && gArity @f == 0 = Just (k . M1 <$> gFromValue n)+    | otherwise = Nothing+    where+      tag :: T.Text+      tag = constructorTagOf @name opts+  {-# INLINE gFromTag #-}++  gFromTagged opts flat def k t o+    | t == constructorTagOf @name opts =+        Just (k . M1 <$> fromObject opts flat [opts.tagKey] (unM1 <$> def) o)+    | otherwise = Nothing+  {-# INLINE gFromTagged #-}++  gFromSingle opts def k t entry@(kn, v)+    | t /= constructorTagOf @name opts = Nothing+    | gNamed @f =+        Just (withMapping (fmap (k . M1) . fromObject opts False [] (unM1 <$> def)) v)+    | gArity @f == 0 =+        Just . failAt kn $+          "expected the string "+            ++ showText t+            ++ ", because the constructor has no fields"+    | otherwise = Just (k . M1 <$> gFromEntry entry)+  {-# INLINE gFromSingle #-}++  gFromUntagged opts def k n+    | gNamed @f || gArity @f == 0 =+        withMapping (fmap (k . M1) . fromObject opts False [] (unM1 <$> def)) n+    | otherwise = k . M1 <$> gFromValue n+  {-# INLINE gFromUntagged #-}++  gFromUntaggedEntry k entry+    | gNamed @f || gArity @f == 0 = Nothing+    | otherwise = Just (k . M1 <$> gFromEntry entry)++-- | The fields of a constructor from a mapping. The given keys, e.g. the tag+-- key, are no fields but valid keys.+fromObject+  :: forall f p+   . ( GFields f+     , GFromFields f+     )+  => YamlOptions -> Bool -> [T.Text] -> Maybe (f p) -> Object -> Parser (f p)+fromObject opts flat keys def o+  | gNamed @f || gArity @f == 0 = checked (gNames @f opts) (gFromObject opts def o)+  | flat+  , not (null others)+  , not (any (isKey opts.contentsKey . fst) others) =+      merged+  | otherwise = checked [opts.contentsKey] $ case M.lookup opts.contentsKey o.index of+      Just entry -> gFromEntry entry+      -- A missing contents key is null, if the fields accept null. A flat+      -- field can also have only optional keys. A flat field has no key to+      -- require.+      Nothing+        | Just fields <- gDefaultValue =<< def -> pure fields+        | isJust def, not flat -> missingKey o opts.contentsKey+        | flat -> maybe onlyTag pure (succeeds gFromValue nullNode)+        | otherwise ->+            maybe (missingKey o opts.contentsKey) pure (succeeds gFromValue nullNode)+  where+    -- The fields, with the errors of the unknown keys if the options reject+    -- them.+    checked :: [T.Text] -> Parser (f p) -> Parser (f p)+    checked fields =+      (when opts.rejectUnknownFields (rejectUnknownKeys (keys ++ fields) o) *>)++    -- A mapping with only the tag gives the field an empty mapping. Its error+    -- does not show that, so a note at the tag says it. Each error of the+    -- field is at the mapping, because the empty mapping has no other nodes.+    onlyTag :: Parser (f p)+    onlyTag =+      withNote+        (objectNode o).offset+        ( maybe S.noOffset (.offset) tag+        , "the mapping has no key "+            ++ showText opts.contentsKey+            ++ " and no other keys for the field of "+            ++ maybe "" constructorName tag+        )+        merged+      where+        tag :: Maybe S.Node+        tag = snd <$> M.lookup opts.tagKey o.index++        constructorName :: S.Node -> String+        constructorName n = case n.content of+          S.ScalarContent _ t -> T.unpack t+          _ -> ""++    -- The field decodes from the mapping without the given keys, and without+    -- the comments, the tag and the anchor of the mapping. The record drops+    -- the comments, and the tag and the anchor belong to the value of the+    -- sum type, as with 'TaggedObject'.+    merged :: Parser (f p)+    merged =+      let n = objectNode o+          style = case n.content of+            S.MappingContent s _ -> s+            _ -> S.Block+      in gFromValue $+           S.Node+             { S.offset = n.offset+             , S.endOffset = n.endOffset+             , S.props = S.noProps+             , S.comments = S.noComments+             , S.content = S.MappingContent style others+             }++    -- The duplicates of a key go too. The mapping has their errors, and a+    -- field of a recursive type would give them again at each level.+    others :: [(S.Node, S.Node)]+    others+      | o.duplicates = filter (\(k, _) -> not (any (`isKey` k) keys)) (objectEntries o)+      | otherwise = foldr removeKey (objectEntries o) keys++    -- The keys are unique, so the entries after the match stay shared.+    removeKey :: T.Text -> [(S.Node, S.Node)] -> [(S.Node, S.Node)]+    removeKey key = \case+      kv@(k, _) : kvs+        | isKey key k -> kvs+        | otherwise -> kv : removeKey key kvs+      [] -> []+{-# INLINE fromObject #-}++-- | The decoder of the fields of a constructor.+--+-- The shape check allows named fields, no fields, or one field without a+-- name. The default methods are for the kind of fields that never calls+-- them.+class GFromFields f where+  -- | The fields from a mapping, with the given default for missing keys.+  gFromObject :: YamlOptions -> Maybe (f p) -> Object -> Parser (f p)+  gFromObject _ _ o =+    fail $ "expected a field without a name in " ++ describeNode (objectNode o)++  -- | The only field without a name from its value.+  gFromValue :: S.Node -> Parser (f p)+  gFromValue n = fail $ "expected named fields in " ++ describeNode n++  -- | The only field from a mapping entry, with the key, e.g. for the+  -- comments of a 'Yamlet.Commented' field under the contents key.+  gFromEntry :: (S.Node, S.Node) -> Parser (f p)+  gFromEntry (_, v) = gFromValue v++  -- | The only field without a name from a default, or 'Nothing' for+  -- 'requiredField'.+  gDefaultValue :: f p -> Maybe (f p)+  gDefaultValue = Just++-- The value of a constructor without fields is its tag.+instance GFromFields U1 where+  gFromObject _ _ _ = pure U1++  gFromValue _ = pure U1++instance (GFromFields f, GFromFields g) => GFromFields (f :*: g) where+  gFromObject opts def o =+    (:*:)+      <$> gFromObject opts (firstDefault def) o+      <*> gFromObject opts (secondDefault def) o+  {-# INLINE gFromObject #-}++instance+  ( KnownSymbol name+  , FromYaml a+  )+  => GFromFields (S1 (MetaSel (Just name) u s d) (Rec0 a))+  where+  gFromObject opts def o =+    M1 . K1 <$> case M.lookup key o.index of+      Just entry -> parseEntry entry+      Nothing -> case def of+        Just (M1 (K1 d))+          | Just x <- defaultField d -> x <$ findKey o key+          | otherwise -> missingKey o key+        -- A missing field is null, if its type accepts null.+        Nothing ->+          maybe (missingKey o key) (<$ findKey o key) (succeeds parseYaml nullNode)+    where+      key :: T.Text+      key = fieldKey @name opts+  {-# INLINE gFromObject #-}++instance FromYaml a => GFromFields (S1 (MetaSel Nothing u s d) (Rec0 a)) where+  gFromValue n = M1 . K1 <$> parseNode parseYaml n++  gFromEntry entry = M1 . K1 <$> parseEntry entry++  gDefaultValue (M1 (K1 x)) = M1 . K1 <$> defaultField x++-- | The key is a string with the text.+isKey :: T.Text -> S.Node -> Bool+isKey key k = case stringValue k of+  Just t -> t == key+  _ -> False++-- $setup+-- >>> import Data.Text qualified as T+-- >>> import Data.Text.IO qualified as T+-- >>> import Yamlet+-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")
+ src/Yamlet/Internal/Chars.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | The bytes of UTF-8 encoded YAML and the classes of characters that the+-- parser, the renderer and the error messages share.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Chars+  ( -- * Characters+    pattern TAB+  , pattern LF+  , pattern CR+  , pattern SPACE+  , pattern EXCL+  , pattern DQUOTE+  , pattern HASH+  , pattern PERCENT+  , pattern AMP+  , pattern SQUOTE+  , pattern STAR+  , pattern PLUS+  , pattern COMMA+  , pattern MINUS+  , pattern DOT+  , pattern DIGIT_0+  , pattern DIGIT_1+  , pattern DIGIT_9+  , pattern COLON+  , pattern LESS+  , pattern GREATER+  , pattern QUESTION+  , pattern AT+  , pattern UPPER_A+  , pattern UPPER_F+  , pattern UPPER_Z+  , pattern LBRACKET+  , pattern BACKSLASH+  , pattern RBRACKET+  , pattern GRAVE+  , pattern LOWER_A+  , pattern LOWER_F+  , pattern LOWER_U+  , pattern LOWER_Z+  , pattern LBRACE+  , pattern PIPE+  , pattern RBRACE+  , pattern DEL+  , isWhite+  , isBreak+  , isAsciiByte+  , asciiChar+  , isCharStart+  , isNsChar+  , isFlowIndicator+  , isIndicator+  , isDecDigit+  , isHexDigit'+  , hexValue+  , isWordChar+  , isUriChar+  , isTagChar+  , isAnchorChar+  , bomLength+  , isBomIn+  , skipBomsIn+  ) where++import Data.Bits+import Data.Char+import Data.Text.Array qualified as A+import Data.Word++pattern+  TAB+  , LF+  , CR+  , SPACE+  , EXCL+  , DQUOTE+  , HASH+  , PERCENT+  , AMP+  , SQUOTE+  , STAR+  , PLUS+  , COMMA+  , MINUS+  , DOT+  , DIGIT_0+  , DIGIT_1+  , DIGIT_9+  , COLON+  , LESS+  , GREATER+  , QUESTION+  , AT+  , UPPER_A+  , UPPER_F+  , UPPER_Z+  , LBRACKET+  , BACKSLASH+  , RBRACKET+  , GRAVE+  , LOWER_A+  , LOWER_F+  , LOWER_U+  , LOWER_Z+  , LBRACE+  , PIPE+  , RBRACE+  , DEL+    :: Word8+pattern TAB = 0x09+pattern LF = 0x0A+pattern CR = 0x0D+pattern SPACE = 0x20+pattern EXCL = 0x21+pattern DQUOTE = 0x22+pattern HASH = 0x23+pattern PERCENT = 0x25+pattern AMP = 0x26+pattern SQUOTE = 0x27+pattern STAR = 0x2A+pattern PLUS = 0x2B+pattern COMMA = 0x2C+pattern MINUS = 0x2D+pattern DOT = 0x2E+pattern DIGIT_0 = 0x30+pattern DIGIT_1 = 0x31+pattern DIGIT_9 = 0x39+pattern COLON = 0x3A+pattern LESS = 0x3C+pattern GREATER = 0x3E+pattern QUESTION = 0x3F+pattern AT = 0x40+pattern UPPER_A = 0x41+pattern UPPER_F = 0x46+pattern UPPER_Z = 0x5A+pattern LBRACKET = 0x5B+pattern BACKSLASH = 0x5C+pattern RBRACKET = 0x5D+pattern GRAVE = 0x60+pattern LOWER_A = 0x61+pattern LOWER_F = 0x66+pattern LOWER_U = 0x75+pattern LOWER_Z = 0x7A+pattern LBRACE = 0x7B+pattern PIPE = 0x7C+pattern RBRACE = 0x7D+pattern DEL = 0x7F++isWhite :: Word8 -> Bool+isWhite w = w == SPACE || w == TAB++isBreak :: Word8 -> Bool+isBreak w = w == LF || w == CR++isAsciiByte :: Word8 -> Bool+isAsciiByte w = w < 0x80++-- | A predicate on bytes for a character, e.g. 'isFlowIndicator' for the+-- emitter. A character beyond ASCII does not satisfy it.+asciiChar :: (Word8 -> Bool) -> Char -> Bool+asciiChar p c = isAscii c && p (fromIntegral (ord c))++-- | The byte starts a character in UTF-8, i.e. it is not a continuation byte.+isCharStart :: Word8 -> Bool+isCharStart w = isAsciiByte w || w >= 0xC0++-- | ns-char. Every byte of a multibyte character counts, because the input+-- contains printable characters only, except in quoted scalars, which the+-- parser checks after it parses the stream.+isNsChar :: Word8 -> Bool+isNsChar w = w > SPACE && w /= DEL++isFlowIndicator :: Word8 -> Bool+isFlowIndicator w =+  w == COMMA+    || w == LBRACKET+    || w == RBRACKET+    || w == LBRACE+    || w == RBRACE++isIndicator :: Word8 -> Bool+isIndicator w = isAsciiByte w && testBit indicators (fromIntegral w)+  where+    indicators :: Integer+    indicators = foldr @[] (\c acc -> setBit acc (ord c)) 0 "-?:,[]{}#&*!|>'\"%@`"++isDecDigit :: Word8 -> Bool+isDecDigit w = w >= DIGIT_0 && w <= DIGIT_9++isHexDigit' :: Word8 -> Bool+isHexDigit' w =+  isDecDigit w || (w >= UPPER_A && w <= UPPER_F) || (w >= LOWER_A && w <= LOWER_F)++hexValue :: Word8 -> Int+hexValue w+  | w <= DIGIT_9 = fromIntegral (w - DIGIT_0)+  | w <= UPPER_F = fromIntegral (w - UPPER_A) + 10+  | otherwise = fromIntegral (w - LOWER_A) + 10++isWordChar :: Word8 -> Bool+isWordChar w =+  isDecDigit w+    || (w >= UPPER_A && w <= UPPER_Z)+    || (w >= LOWER_A && w <= LOWER_Z)+    || w == MINUS++-- | ns-uri-char without the escaped characters.+isUriChar :: Word8 -> Bool+isUriChar w = isWordChar w || w `elem` extra+  where+    extra :: [Word8]+    extra = map (fromIntegral . ord) "#;/?:@&=+$,_.!~*'()[]"++-- | ns-tag-char without the escaped characters.+isTagChar :: Word8 -> Bool+isTagChar w = isUriChar w && w /= EXCL && not (isFlowIndicator w)++isAnchorChar :: Word8 -> Bool+isAnchorChar w = isNsChar w && not (isFlowIndicator w)++-- | The number of bytes of a byte order mark, U+FEFF in UTF-8.+bomLength :: Int+bomLength = 3++-- | A byte order mark at the index of the array, before the end index.+isBomIn :: A.Array -> Int -> Int -> Bool+isBomIn arr end i =+  i + bomLength <= end+    && A.unsafeIndex arr i == 0xEF+    && A.unsafeIndex arr (i + 1) == 0xBB+    && A.unsafeIndex arr (i + 2) == 0xBF++-- | The index after the byte order marks at the index of the array, before+-- the end index.+skipBomsIn :: A.Array -> Int -> Int -> Int+skipBomsIn arr end i = if isBomIn arr end i then skipBomsIn arr end (i + bomLength) else i
+ src/Yamlet/Internal/Comments.hs view
@@ -0,0 +1,618 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Attachment of comments and empty lines to the nodes of a document.+--+-- The rules are in the documentation of "Yamlet.Syntax". The parser skips+-- comments, so this module finds them again in the input, outside of the+-- scalars, and gives each one to a node.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Comments+  ( attachComments+  , gapEnd+  , linesAbove+  ) where++import Control.Applicative+import Control.DeepSeq+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Array qualified as A++import Yamlet.Internal.Chars+import Yamlet.Internal.Parser.Monad hiding ((<|>))+import Yamlet.Internal.Parser.Scan+import Yamlet.Internal.Syntax+import Yamlet.Internal.Utils++-- | A comment or empty lines. The indices are offsets of the input.+data Item = Item+  { at :: !Int+  -- ^ The index of the @#@, or of the start of the first empty line.+  , lineStart :: !Int+  , own :: !Bool+  -- ^ Nothing else is on the line.+  , line :: !Line+  , count :: !Int+  -- ^ The number of lines. One item holds the empty lines that follow each+  -- other, because the nested collections hand the empty lines at their end+  -- to each other, and one by one the time would be quadratic.+  }++-- | The lines of the item.+itemLines :: Item -> [Line]+itemLines i = replicate i.count i.line++-- | Attach the comments of a document, and return the lines at its end that+-- belong to the next document. The flags tell if the document is the first+-- one and if another one follows it. The indices are the start of the lines+-- that belong to the document, its @---@ marker, the end of its root and its+-- end.+attachComments+  :: Env+  -> Bool+  -> Bool+  -> Int+  -> Maybe Int+  -> Int+  -> Int+  -> Document+  -> (Document, [Line])+attachComments e first hasNext start marker rootEnd end doc+  | not mayHaveItems = (doc, [])+  | null items = (doc, [])+  | otherwise =+      ( doc+          { docComments =+              strictComments+                ( (if first then dropWhile (== EmptyLine) else id)+                    (concatMap itemLines docItems)+                )+                markerComment+                docEnd+          , root = root''+          }+      , next+      )+  where+    -- Nothing is above the first document, so the empty lines at its start+    -- separate it from nothing.+    items :: [Item]+    items+      | isJust marker || not first = scanned+      | otherwise = dropWhile (\i -> isEmptyLine i && i.at < rootStart) scanned+      where+        scanned :: [Item]+        scanned = scanItems (skipRanges e doc.root)++    (docItems, afterMarker) = case marker of+      Just m -> span (\i -> i.at < m - e.base) items+      Nothing -> ([], items)++    rootStart, rootLine :: Int+    rootStart = offsetOf doc.root.offset+    rootLine = skipBoms e (lineStartAt e (rootStart + e.base)) - e.base++    -- The comment on the line of the marker, unless the root starts there.+    (markerComment, rest) = case (marker, afterMarker) of+      (Just m, i : is)+        | not i.own+        , i.lineStart == m - e.base+        , rootLine /= m - e.base+        , Comment t <- i.line ->+            (Just t, is)+      _ -> (Nothing, afterMarker)++    (root', leftover) =+      attachNode e (rootEnd - e.base) 0 (rootStart, rootLine) [] doc.root rest++    (below, afterEnd) = span (\i -> i.at < rootEnd - e.base) leftover++    -- The lines of a flow collection are inside its brackets, so the lines+    -- below a flow collection root belong to the document.+    holdsLines :: Bool+    holdsLines = case root'.content of+      SequenceContent Flow _ -> False+      MappingContent Flow _ -> False+      _ -> True++    -- Without a @...@ marker, the first empty line ends the lines of the+    -- document if another document follows it.+    endLines, next :: [Line]+    (endLines, next)+      | doc.explicitEnd || not hasNext = (rootLines, [])+      | otherwise = break (== EmptyLine) rootLines+      where+        rootLines :: [Line]+        rootLines =+          (if holdsLines then root'.comments.after else []) ++ concatMap itemLines below++    root'' :: Node+    root''+      | holdsLines =+          let c = root'.comments+          in Node+               { offset = root'.offset+               , endOffset = root'.endOffset+               , props = root'.props+               , comments =+                   strictComments+                     c.before+                     c.inline+                     (if doc.explicitEnd then endLines else atEnd endLines)+               , content = root'.content+               }+      | otherwise = root'++    -- Only the lines below a @...@ marker can be at the end of the stream.+    docEnd :: [Line]+    docEnd+      | holdsLines = atEnd (concatMap itemLines afterEnd)+      | doc.explicitEnd = endLines ++ atEnd (concatMap itemLines afterEnd)+      | otherwise = atEnd (endLines ++ concatMap itemLines afterEnd)++    -- The empty lines at the end of the stream belong to no node.+    atEnd :: [Line] -> [Line]+    atEnd ls+      | hasNext = ls+      | otherwise = reverse (dropWhile (== EmptyLine) (reverse ls))++    -- A quick check for a comment or an empty line in the document.+    mayHaveItems :: Bool+    mayHaveItems = go True start+      where+        go :: Bool -> Int -> Bool+        go blank i+          | i >= end = False+          | otherwise = case A.unsafeIndex e.array i of+              HASH -> True+              w+                | isBreak w -> blank || go True (i + 1)+                | isWhite w -> go blank (i + 1)+                | otherwise -> go False (i + 1)++    -- The comments and the empty lines of the document, outside the given+    -- ranges. The offsets of the items are relative to the start of the+    -- input.+    scanItems :: [(Int, Int)] -> [Item]+    scanItems = runs . go start start False+      where+        runs :: [Item] -> [Item]+        runs = \case+          i : is | isEmptyLine i -> run i 1 i.at is+          i : is -> i : runs is+          [] -> []++        -- The empty lines from the first item, with the start of the last+        -- one. A line joins them only if it comes right after the last one,+        -- so that no node is between them.+        run :: Item -> Int -> Int -> [Item] -> [Item]+        run i0 n lastAt = \case+          i : is+            | isEmptyLine i+            , i.at + e.base == breakEnd e (skipWhites e (lastAt + e.base)) ->+                run i0 (n + 1) i.at is+          is ->+            Item+              { at = i0.at+              , lineStart = i0.lineStart+              , own = True+              , line = EmptyLine+              , count = n+              }+              : runs is++        -- The flag tells if the line has something other than white space.+        go :: Int -> Int -> Bool -> [(Int, Int)] -> [Item]+        go i ls content ranges+          | i >= end = []+          | (rs, re) : others <- ranges+          , rs <= i =+              if re > i+                -- A block scalar can end at the start of a line.+                then let ls' = lineBefore i re ls in go re ls' (ls' /= re) others+                else go i ls content others+          -- The parser allows byte order marks at the start of a line only+          -- between documents, where a comment can follow them.+          | i == ls+          , isBom e i =+              let j = skipBoms e i in go j j content ranges+          | otherwise = case A.unsafeIndex e.array i of+              w+                | isBreak w ->+                    let j =+                          if w == CR && i + 1 < end && A.unsafeIndex e.array (i + 1) == LF+                            then i + 2+                            else i + 1+                        item =+                          [ Item+                              { at = ls - e.base+                              , lineStart = ls - e.base+                              , own = True+                              , line = EmptyLine+                              , count = 1+                              }+                          | not content+                          ]+                    in item ++ go j j False ranges+                | w == HASH && (i == ls || isWhite (A.unsafeIndex e.array (i - 1))) ->+                    let eol = lineEnd i+                        -- A comment at the end of a line keeps its text after+                        -- the first #, because 'Comments' has no count for it.+                        textStart = if content then i + 1 else hashesEnd i+                        text = T.stripEnd . dropSpace $ slice e textStart eol+                    in Item+                         { at = i - e.base+                         , lineStart = ls - e.base+                         , own = not content+                         , line = CommentLine (textStart - i) text+                         , count = 1+                         }+                         : go eol ls True ranges+                | isWhite w -> go (i + 1) ls content ranges+                | otherwise -> go (i + 1) ls True ranges++        hashesEnd :: Int -> Int+        hashesEnd i+          | i < end && A.unsafeIndex e.array i == HASH = hashesEnd (i + 1)+          | otherwise = i++        lineEnd :: Int -> Int+        lineEnd i+          | i < end && not (isBreak (A.unsafeIndex e.array i)) = lineEnd (i + 1)+          | otherwise = i++        -- The start of the line of the second index, or the given start if no+        -- line break is between the indices.+        lineBefore :: Int -> Int -> Int -> Int+        lineBefore i j ls+          | j <= i = ls+          | isBreak (A.unsafeIndex e.array (j - 1)) = j+          | otherwise = lineBefore i (j - 1) ls++        dropSpace :: T.Text -> T.Text+        dropSpace t = fromMaybe t (textStripPrefix " " t)++-- | The start of the first line from the index that is empty or has more than+-- a comment or a @...@ marker. The index is the start of a line.+gapEnd :: Env -> Int -> Int+gapEnd e i+  | i < e.end && isEndMarker e b = gapEnd e (nextLineStart e b)+  | i < e.end && byteAt e (skipWhites e b) == HASH = gapEnd e (nextLineStart e b)+  | otherwise = i+  where+    -- A byte order mark can start a line between documents.+    b :: Int+    b = skipBoms e i++-- | The documents with the lines above the first one.+linesAbove :: [Line] -> [Document] -> [Document]+linesAbove ls = \case+  d : ds+    | not (null ls) ->+        let c = d.docComments+            !d' = d {docComments = strictComments (ls ++ c.before) c.inline c.after}+        in d' : ds+  ds -> ds++-- | Comments with their lists evaluated. The parser returns a document+-- without thunks, and a lazy list would keep the items of the input alive.+strictComments :: [Line] -> Maybe T.Text -> [Line] -> Comments+strictComments before inline after =+  Comments {before = force before, inline = inline, after = force after}++isEmptyLine :: Item -> Bool+isEmptyLine i = case i.line of+  EmptyLine -> True+  Comment _ -> False++offsetOf :: Offset -> Int+offsetOf (Offset o) = o++-- | Attach the comments to a node and the nodes inside it. The limit is the+-- offset of the next node, and the column is the smallest one for the lines+-- after the last entry of a block collection. The pair is an offset at or+-- before the node and the start of its line. The first list holds the lines+-- on their own above the node that its parent gave to it, in reverse. They+-- are not in the items, so that a chain of nested first entries passes them+-- down without a walk over them at each level, which would make the time+-- quadratic.+attachNode+  :: Env -> Int -> Int -> (Int, Int) -> [Item] -> Node -> [Item] -> (Node, [Item])+attachNode e limit minColumn known above n items0 = node `seq` items5 `seq` (node, items5)+  where+    node :: Node+    node =+      n+        { comments =+            strictComments+              [l | i <- pre, isJust own || not (isFallback i), l <- itemLines i]+              (own <|> fallback)+              afterLines+        , content = content'+        }++    s, en :: Int+    s = offsetOf n.offset+    en = offsetOf n.endOffset++    lineStart, column :: Int+    lineStart = lineFrom known s+    column = s - lineStart++    -- The lines above the node. A comment at the end of a line that no node+    -- took, e.g. in "- # comment" above a mapping, belongs to the node. It is+    -- a line above the node if the node has a comment on its own line.+    (pre, toEntry, items1) =+      let (ls, rest) = span (\i -> i.at < s) items0+      in case n.content of+           SequenceContent Block (_ : _) | startsLine -> toFirstEntry ls rest+           MappingContent Block (_ : _) | startsLine -> toFirstEntry ls rest+           _ -> (reverse above ++ ls, [], rest)++    -- A collection after "- " on the same line keeps the lines above the+    -- indicator, so that a comment above an item stays with the item. The walk+    -- goes back from the node, so that it stops at the indicator of an outer+    -- collection. A walk from the start of the line would cross the whole+    -- indentation for each nested collection, and the time would be quadratic.+    startsLine :: Bool+    startsLine = go (s + e.base)+      where+        go :: Int -> Bool+        go i+          | i == lineStart + e.base = True+          | isWhite (A.unsafeIndex e.array (i - 1)) = go (i - 1)+          | otherwise = False++    -- The lines on their own after the last empty line go to the first entry,+    -- in reverse.+    toFirstEntry :: [Item] -> [Item] -> ([Item], [Item], [Item])+    toFirstEntry ls rest =+      let (ownLines, others) = span (.own) (reverse ls)+          (entry, kept) = break isEmptyLine ownLines+      in case (kept, others) of+           ([], []) -> ([], entry ++ above, rest)+           _ -> (reverse (kept ++ others ++ above), entry, rest)++    fallbackItem :: Maybe Item+    fallbackItem = case reverse (filter (not . (.own)) pre) of+      i : _ -> Just i+      [] -> Nothing++    fallback :: Maybe T.Text+    fallback = fallbackItem >>= comment++    isFallback :: Item -> Bool+    isFallback i = maybe False (\f -> f.at == i.at) fallbackItem++    own :: Maybe T.Text+    own = header <|> trailing++    -- The comment on the line of a block scalar header.+    (header, items2) = case (n.content, items1) of+      (ScalarContent style _, i : is)+        | isBlockScalar style+        , not i.own+        , i.lineStart == lineStart ->+            (comment i, is)+      _ -> (Nothing, items1)++    (content', items3) = case n.content of+      SequenceContent style xs ->+        let !(xs', is) = sequenceItems style xs items2+        in (SequenceContent style xs', is)+      MappingContent style kvs ->+        let !(kvs', is) = mappingEntries style kvs items2+        in (MappingContent style kvs', is)+      c -> (c, items2)++    -- The lines before the closing bracket come before the comment after it.+    (trailing, afterLines, items5) = case n.content of+      SequenceContent Block (_ : _) -> blockEnd+      MappingContent Block (_ : _) -> blockEnd+      SequenceContent Flow _ -> flowEnd+      MappingContent Flow _ -> flowEnd+      _ -> let (t, is) = trailingComment items3 in (t, [], is)++    blockEnd, flowEnd :: (Maybe T.Text, [Line], [Item])+    blockEnd =+      let (t, is) = trailingComment items3+          (ls, is') = blockAfter is+      in (t, ls, is')+    -- The empty lines before the bracket go to the node below, as after the+    -- last entry of a block collection. They go back after the comment+    -- after the bracket, which 'trailingComment' takes from the front.+    flowEnd =+      let (ls, empties, is) = flowAfter items3+          (t, is') = trailingComment is+      in (t, ls, empties ++ is')++    -- The comment at the end of the line of the node's end. A node that ends+    -- at the start of a line, e.g. a block scalar, ends on the line before,+    -- unless it is empty.+    trailingComment :: [Item] -> (Maybe T.Text, [Item])+    trailingComment = \case+      i : is+        | not i.own+        , i.at >= en+        , i.at < limit+        , i.lineStart < en || s == en+        , T.all (\c -> elem @[] c " \t,:") (between en i.at) ->+            (comment i, is)+      is -> (Nothing, is)++    -- The lines after the last entry, indented deep enough, and the empty+    -- lines between them.+    blockAfter :: [Item] -> ([Line], [Item])+    blockAfter =+      takeLines $ \i ->+        i.at < limit+          && i.own+          && (isEmptyLine i || i.at - i.lineStart >= max column minColumn)++    -- The lines of the items from the start that pass the check, without the+    -- empty lines at their end, which stay with the next items.+    takeLines :: (Item -> Bool) -> [Item] -> ([Line], [Item])+    takeLines ok is =+      let (taken, rest) = span ok is+          (empties, taken') = span isEmptyLine (reverse taken)+      in (concatMap itemLines (reverse taken'), reverse empties ++ rest)++    -- The lines before the closing bracket.+    flowAfter :: [Item] -> ([Line], [Item], [Item])+    flowAfter is =+      let (taken, rest) = span (\i -> i.at < en) is+          (empties, taken') = span isEmptyLine (reverse taken)+      in (concatMap itemLines (reverse taken'), reverse empties, rest)++    sequenceItems :: CollectionStyle -> [Node] -> [Item] -> ([Node], [Item])+    sequenceItems style = go [] toEntry+      where+        -- The nodes are in reverse, so that the list is evaluated when the+        -- result is.+        go :: [Node] -> [Item] -> [Node] -> [Item] -> ([Node], [Item])+        go acc _ [] is = let !xs = reverse acc in (xs, is)+        go acc xAbove (x : rest) is =+          let next = nextStart x rest+              !(x', is') =+                attachNode e next (entryColumn style) (s, lineStart) xAbove x is+              !(x'', is'')+                -- A list without indentation has no column of its own for the+                -- lines after its last item, so they stay with the list.+                | style == Block && not (null rest && minColumn > column) =+                    linesBelow next x' is'+                | otherwise = (x', is')+          in go (x'' : acc) [] rest is''++        nextStart :: Node -> [Node] -> Int+        nextStart x = \case+          y : _+            | style == Block -> entryStart (offsetOf x.endOffset) (offsetOf y.offset)+            | otherwise -> offsetOf y.offset+          [] -> if style == Flow then en else limit++    mappingEntries+      :: CollectionStyle -> [(Node, Node)] -> [Item] -> ([(Node, Node)], [Item])+    mappingEntries style = go [] toEntry+      where+        -- The entries are in reverse, as in 'sequenceItems'.+        go+          :: [(Node, Node)]+          -> [Item]+          -> [(Node, Node)]+          -> [Item]+          -> ([(Node, Node)], [Item])+        go acc _ [] is = let !kvs = reverse acc in (kvs, is)+        go acc kAbove ((k, v) : rest) is =+          let next = nextStart v rest+              !(k', is') =+                attachNode e (keyLimit k v) (entryColumn style) (s, lineStart) kAbove k is+              !(v', is'') = attachNode e next (entryColumn style) (s, lineStart) [] v is'+              !(v'', is''')+                | style == Block = linesBelow next v' is''+                | otherwise = (v', is'')+          in go ((k', v'') : acc) [] rest is'''++        nextStart :: Node -> [(Node, Node)] -> Int+        nextStart v = \case+          (k, _) : _+            | style == Block -> entryStart (offsetOf v.endOffset) (offsetOf k.offset)+            | otherwise -> offsetOf k.offset+          [] -> if style == Flow then en else limit++        -- The key takes the comment on the line of the colon, but not the+        -- lines below it, e.g. in ": &a".+        keyLimit :: Node -> Node -> Int+        keyLimit k v+          | style == Block =+              lineEnd+                (offsetOf v.offset)+                (entryStart (offsetOf k.endOffset) (offsetOf v.offset))+          | otherwise = offsetOf v.offset++    -- The start of the next entry of a block collection, between the end of+    -- the previous entry and the content of the next one: the first indicator+    -- or property, or the content. Lines between an indicator and the content,+    -- e.g. in "- &a", belong to the next entry.+    entryStart :: Int -> Int -> Int+    entryStart from to = go from from+      where+        go :: Int -> Int -> Int+        go i ls+          | i >= to = to+          | otherwise = case A.unsafeIndex e.array (i + e.base) of+              w+                | isBreak w -> go (i + 1) (i + 1)+                | isWhite w -> go (i + 1) ls+                | w == HASH && (i == ls || isWhite (A.unsafeIndex e.array (i + e.base - 1))) ->+                    go (lineEnd to i) ls+                | otherwise -> i++    -- The end of the line of the second offset, or the first offset if it+    -- comes first.+    lineEnd :: Int -> Int -> Int+    lineEnd to i+      | i < to && not (isBreak (A.unsafeIndex e.array (i + e.base))) = lineEnd to (i + 1)+      | otherwise = i++    -- The column of 'attachNode' for an entry of a collection in the style.+    entryColumn :: CollectionStyle -> Int+    entryColumn style = if style == Flow then 0 else column + 1++    -- The lines below a scalar or an alias in a block collection, before the+    -- limit, that are indented deeper than its entry, and the empty lines+    -- between them. They go after the node, as 'blockAfter' does for a+    -- collection. Below a block scalar, such a line is part of the scalar+    -- if it is indented as deep as its content.+    linesBelow :: Int -> Node -> [Item] -> (Node, [Item])+    linesBelow lim x is = case x.content of+      SequenceContent {} -> (x, is)+      MappingContent {} -> (x, is)+      ScalarContent style _ | isBlockScalar style -> (x, is)+      _ -> case takeLines (\i -> i.at < lim && i.own && (isEmptyLine i || i.at - i.lineStart > column)) is of+        ([], _) -> (x, is)+        (ls, rest) ->+          let !x' = withComments (strictComments x.comments.before x.comments.inline ls) x+          in (x', rest)++    between :: Int -> Int -> T.Text+    between i j = slice e (i + e.base) (j + e.base)++    comment :: Item -> Maybe T.Text+    comment i = case i.line of+      Comment t -> Just t+      EmptyLine -> Nothing++    -- The offset of the start of the line with the second offset, after the+    -- byte order marks, as for the items. The walk stops at the first offset+    -- of the pair, and the pair gives the start of its line. Without it, each+    -- nested block collection of a long line would walk back to the start of+    -- the line, and the time would be quadratic.+    lineFrom :: (Int, Int) -> Int -> Int+    lineFrom (p, ls) o = go (o + e.base)+      where+        go :: Int -> Int+        go i+          | i == p + e.base = ls+          | i > e.base && not (isBreak (A.unsafeIndex e.array (i - 1))) = go (i - 1)+          | otherwise = skipBoms e i - e.base++-- | The ranges of the scalars, which cannot contain comments, in the order of+-- the input. The range of a block scalar starts after its header.+skipRanges :: Env -> Node -> [(Int, Int)]+skipRanges e root = go root []+  where+    go :: Node -> [(Int, Int)] -> [(Int, Int)]+    go n acc = case n.content of+      ScalarContent style _+        | isBlockScalar style ->+            let s = nextLineStart e (offsetOf n.offset + e.base)+            in if s < en then (s, en) : acc else acc+        | offsetOf n.offset + e.base < en -> (offsetOf n.offset + e.base, en) : acc+        where+          en :: Int+          en = offsetOf n.endOffset + e.base+      SequenceContent _ xs -> foldr go acc xs+      MappingContent _ kvs -> foldr (\(k, v) a -> go k (go v a)) acc kvs+      _ -> acc
+ src/Yamlet/Internal/Compose.hs view
@@ -0,0 +1,547 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The checks of a syntax tree before the decoder reads it, and the values+-- of its nodes.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Compose+  ( prepareWithin+  , aliasLimit+  , representPrepared+  , Failure+  , noMergeKeys+  ) where++import Control.Monad+import Data.Foldable+import Data.IntMap.Strict qualified as IM+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Text qualified as T++import Yamlet.Internal.Schema+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils+import Yamlet.Internal.View+import Yamlet.Value++-- | Check that the tags of a node are valid and that the keys of every+-- mapping are unique, and replace each alias with the node that it refers+-- to. The result has no aliases. A node without aliases comes back+-- unchanged.+--+-- The arguments are the limit of the visits that the aliases can add, see+-- 'aliasLimit', and the visits that the aliases of the documents before+-- added. The result also gives the visits that the aliases added with this+-- document.+prepareWithin :: Int -> Int -> S.Node -> Either Failure (S.Node, Int)+prepareWithin limit added root+  | needsNumbering root = (expandAliases root,) <$> numberWithin limit added root+  | otherwise = (root, added) <$ check root+  where+    -- The node has an alias or a collection key inside it.+    needsNumbering :: S.Node -> Bool+    needsNumbering n = case n.content of+      S.ScalarContent {} -> False+      S.SequenceContent _ xs -> any needsNumbering xs+      S.MappingContent _ kvs ->+        any (\(k, v) -> isCollection k || needsNumbering k || needsNumbering v) kvs+      S.AliasContent {} -> True+      where+        isCollection :: S.Node -> Bool+        isCollection k = case k.content of+          S.SequenceContent {} -> True+          S.MappingContent {} -> True+          _ -> False++-- | The limit of the visits of a traversal that the aliases of the documents+-- can add together: as many visits as the documents have, or a fixed minimum+-- for small documents. A node is one visit and each character of its scalar,+-- tag and anchor is one more, because the decoder copies the texts of each+-- alias. Without a limit, the visits of a small input can be exponential in+-- its size. The documents of a stream share the limit, so that many small+-- documents cannot add the minimum each.+aliasLimit :: [S.Node] -> Int+aliasLimit roots = max minExpansion (sum (map syntaxSize roots))++-- | The visits of a traversal of a node without aliases.+syntaxSize :: S.Node -> Int+syntaxSize n =+  ownVisits n + case n.content of+    S.SequenceContent _ xs -> sum (map syntaxSize xs)+    S.MappingContent _ kvs -> sum [syntaxSize k + syntaxSize v | (k, v) <- kvs]+    _ -> 0++-- | The visits of a node without the nodes inside it.+ownVisits :: S.Node -> Int+ownVisits n = 1 + anchorChars + tagChars + scalarChars+  where+    anchorChars :: Int+    anchorChars = maybe 0 T.length n.props.anchor++    tagChars :: Int+    tagChars = case n.props.tag of+      S.Tag t -> T.length t+      _ -> 0++    scalarChars :: Int+    scalarChars = case n.content of+      S.ScalarContent _ t -> T.length t+      _ -> 0++-- | The checks of 'prepareWithin' for a node with aliases or collection keys,+-- which compare by the numbers of their values, and the visits that the+-- aliases added. The limit is evaluated only at an alias, so that the size+-- of a document without aliases is not computed.+numberWithin :: Int -> Int -> S.Node -> Either Failure Int+numberWithin limit added root = do+  (_, st) <- go (Numbering M.empty M.empty 0 added) root+  Right st.added+  where+    -- Each value comes with its number.+    go :: Numbering -> S.Node -> Either Failure ((Value, Int), Numbering)+    go st sn =+      let off = sn.offset; props = sn.props+      in case sn.content of+           S.AliasContent name -> case M.lookup name st.anchors of+             Just (Just (v, i, visits))+               | st.added + visits > limit ->+                   Left . failure off $+                     "the aliases add more than "+                       ++ show limit+                       ++ " nodes and characters"+               | otherwise ->+                   Right+                     ( (v, i)+                     , st {visits = st.visits + visits, added = st.added + visits}+                     )+             Just Nothing ->+               Left . failure off $+                 "the alias *" ++ T.unpack name ++ " refers to a node that contains it"+             Nothing ->+               Left . failure off $ "undefined alias *" ++ T.unpack name+           S.ScalarContent style t -> do+             v <- scalar off props style t+             let visits = ownVisits sn+             Right $ number props v (ScalarShape v) visits visits (open props st)+           S.SequenceContent _ xs -> do+             tag <- collectionTag off props seqTag+             (vs, st') <- goList (open props st) xs+             let v = withTag tag (Sequence (map fst vs))+             let own = ownVisits sn+             Right $+               number+                 props+                 v+                 (SequenceShape tag (map snd vs))+                 own+                 (st'.visits - st.visits + own)+                 st'+           S.MappingContent _ kvs -> do+             tag <- collectionTag off props mapTag+             (entries, st') <- goPairs (open props st) kvs+             checkUniqueNumbers entries+             let v = withTag tag (Mapping [(k, x) | (_, (k, _), (x, _)) <- entries])+                 shape =+                   MappingShape tag (L.sort [(i, j) | (_, (_, i), (_, j)) <- entries])+                 own = ownVisits sn+             Right $ number props v shape own (st'.visits - st.visits + own) st'++    -- The values are in reverse until the end, so that the stack does not+    -- grow with the number of items.+    goList :: Numbering -> [S.Node] -> Either Failure ([(Value, Int)], Numbering)+    goList = loop []+      where+        loop+          :: [(Value, Int)]+          -> Numbering+          -> [S.Node]+          -> Either Failure ([(Value, Int)], Numbering)+        loop acc st = \case+          [] -> Right (reverse acc, st)+          x : xs -> case go st x of+            Left err -> Left err+            Right (v, st') -> loop (v : acc) st' xs++    -- The entries come with the nodes of their keys, in reverse as in+    -- 'goList'.+    goPairs+      :: Numbering+      -> [(S.Node, S.Node)]+      -> Either Failure ([(S.Node, (Value, Int), (Value, Int))], Numbering)+    goPairs = loop []+      where+        loop+          :: [(S.Node, (Value, Int), (Value, Int))]+          -> Numbering+          -> [(S.Node, S.Node)]+          -> Either Failure ([(S.Node, (Value, Int), (Value, Int))], Numbering)+        loop acc st = \case+          [] -> Right (reverse acc, st)+          (k, v) : kvs -> case go st k of+            Left err -> Left err+            Right (kv, st') -> case go st' v of+              Left err -> Left err+              Right (vv, st'') -> loop ((k, kv, vv) : acc) st'' kvs++    open :: S.Props -> Numbering -> Numbering+    open props st = case props.anchor of+      Just a -> st {anchors = M.insert a Nothing st.anchors}+      Nothing -> st++    -- Give the value the number of its shape, and define its anchor. The+    -- own visits are those of the node alone, and the visits are those of the+    -- node and of everything inside it. The copy at an alias has no anchor,+    -- so its visits leave out the anchor. A node inside with the same anchor+    -- comes later in the document, so its definition stays.+    number+      :: S.Props -> Value -> Shape -> Int -> Int -> Numbering -> ((Value, Int), Numbering)+    number props v shape own visits st =+      ((v, i), st {anchors = anchors', shapes = shapes', visits = st.visits + own})+      where+        i :: Int+        shapes' :: M.Map Shape Int+        (i, shapes') = case M.lookup shape st.shapes of+          Just j -> (j, st.shapes)+          Nothing -> let j = M.size st.shapes in (j, M.insert shape j st.shapes)++        anchors' :: M.Map T.Text (Maybe (Value, Int, Int))+        anchors' = case props.anchor of+          Just a+            | Just Nothing <- M.lookup a st.anchors ->+                M.insert a (Just (v, i, visits - T.length a)) st.anchors+          _ -> st.anchors++    -- Unlike in 'duplicate', comparing all pairs is not faster for few keys.+    checkUniqueNumbers :: [(S.Node, (Value, Int), (Value, Int))] -> Either Failure ()+    checkUniqueNumbers = loop IM.empty+      where+        loop+          :: IM.IntMap (S.Node, Value)+          -> [(S.Node, (Value, Int), (Value, Int))]+          -> Either Failure ()+        loop seen = \case+          [] -> Right ()+          (kn, (k, i), _) : rest -> case IM.lookup i seen of+            Just first -> Left $ duplicateKey (kn, k) first+            Nothing -> loop (IM.insert i (kn, k) seen) rest++-- | The value of a node that passed 'prepareWithin', so it has no aliases and its+-- keys are unique already.+representPrepared :: S.Node -> Either Failure Value+representPrepared = go+  where+    go :: S.Node -> Either Failure Value+    go sn =+      let off = sn.offset; props = sn.props+      in case sn.content of+           S.ScalarContent style t -> scalar off props style t+           S.SequenceContent _ xs -> do+             tag <- collectionTag off props seqTag+             vs <- mapEither go xs+             Right $ withTag tag (Sequence vs)+           S.MappingContent _ kvs -> do+             tag <- collectionTag off props mapTag+             entries <- mapEither (\(k, v) -> (,) <$> go k <*> go v) kvs+             Right $ withTag tag (Mapping entries)+           S.AliasContent _ -> Left $ failure off "unexpected alias"++-- | 'mapM' for 'Either', with a stack that does not grow with the length of+-- the list.+mapEither :: forall a e b. (a -> Either e b) -> [a] -> Either e [b]+mapEither f = go []+  where+    go :: [b] -> [a] -> Either e [b]+    go acc = \case+      [] -> Right (reverse acc)+      x : xs -> case f x of+        Left err -> Left err+        Right y -> go (y : acc) xs++-- | The offset of the node that caused an error and the message, and the+-- notes that go after it, e.g. the first key of a duplicate key.+type Failure = NE.NonEmpty (S.Offset, String)++failure :: S.Offset -> String -> Failure+failure off msg = (off, msg) NE.:| []++-- | The checks of 'numberWithin' for a node without aliases and collection+-- keys.+-- Only the keys get values, for the comparison.+check :: S.Node -> Either Failure ()+check sn =+  let off = sn.offset; props = sn.props+  in case sn.content of+       S.ScalarContent style t+         -- Only a number can fail without a tag.+         | S.NoTag <- props.tag+         , style /= S.Plain || not (maybeNumber t) ->+             Right ()+         | otherwise -> void (scalar off props style t)+       S.SequenceContent _ xs -> collectionTag off props seqTag *> traverse_ check xs+       S.MappingContent _ kvs -> do+         _ <- collectionTag off props mapTag+         keys <- mapEither (\(k, v) -> key k <* check v) kvs+         checkUniqueKeys keys+       S.AliasContent _ -> Left $ failure off "unexpected alias"+  where+    maybeNumber :: T.Text -> Bool+    maybeNumber t = maybe False (startsNumber . fst) (T.uncons t)++    key :: S.Node -> Either Failure (S.Node, Value)+    key k = case k.content of+      S.ScalarContent style t -> (k,) <$> scalar k.offset k.props style t+      _ -> Left $ failure k.offset "unexpected collection key"++    -- The keys come with their nodes.+    checkUniqueKeys :: [(S.Node, Value)] -> Either Failure ()+    checkUniqueKeys keys = case duplicate of+      Just (k, first) -> Left $ duplicateKey k first+      Nothing -> Right ()+      where+        -- The first scalar key that is equal to an earlier one, and the+        -- earlier one. A document with a collection key gets numbers for its+        -- keys instead.+        duplicate :: Maybe ((S.Node, Value), (S.Node, Value))+        duplicate = case drop maxPairwise keys of+          _ : _ -> viaMap M.empty keys+          [] -> pairwise [] keys++        -- Comparing all pairs is faster for 16 keys or fewer, by a+        -- measurement.+        maxPairwise :: Int+        maxPairwise = 16++        viaMap+          :: M.Map Value S.Node+          -> [(S.Node, Value)]+          -> Maybe ((S.Node, Value), (S.Node, Value))+        viaMap seen = \case+          [] -> Nothing+          k@(n, v) : ks -> case M.lookup v seen of+            Just first -> Just (k, (first, v))+            Nothing -> viaMap (M.insert v n seen) ks++        pairwise+          :: [(S.Node, Value)]+          -> [(S.Node, Value)]+          -> Maybe ((S.Node, Value), (S.Node, Value))+        pairwise seen = \case+          [] -> Nothing+          k@(_, v) : ks -> case L.find ((== v) . snd) seen of+            Just first -> Just (k, first)+            Nothing -> pairwise (k : seen) ks++-- | Replace each alias with a copy of the node that it refers to. The copy+-- has the offsets and the comments of the alias, and no anchor. The nodes+-- inside the copy have the offsets of the alias too, so that an error inside+-- the copy names the place and the path where the document uses the value,+-- and not those of the anchor. They have no comments, because the comments+-- are at the anchor already. The node must pass 'numberWithin', so every+-- alias refers to an earlier anchor.+expandAliases :: S.Node -> S.Node+expandAliases = fst . go M.empty+  where+    go+      :: M.Map T.Text (S.Tag, S.Content)+      -> S.Node+      -> (S.Node, M.Map T.Text (S.Tag, S.Content))+    go anchors sn = case sn.content of+      S.AliasContent name -> case M.lookup name anchors of+        Just (tag, content) ->+          ( S.Node+              { S.offset = sn.offset+              , S.endOffset = sn.endOffset+              , S.props = S.Props Nothing tag+              , S.comments = sn.comments+              , S.content = copyAt sn content+              }+          , anchors+          )+        Nothing -> (sn, anchors)+      S.ScalarContent {} -> define sn anchors+      S.SequenceContent style xs ->+        let (xs', anchors') = goList (open anchors) xs+        in close (withContent (S.SequenceContent style xs')) anchors'+      S.MappingContent style kvs ->+        let (kvs', anchors') = goPairs (open anchors) kvs+        in close (withContent (S.MappingContent style kvs')) anchors'+      where+        withContent :: S.Content -> S.Node+        withContent c =+          S.Node+            { S.offset = sn.offset+            , S.endOffset = sn.endOffset+            , S.props = sn.props+            , S.comments = sn.comments+            , S.content = c+            }++        -- No alias inside refers to the anchor, so its old definition can+        -- go. A node inside with the same anchor comes later in the+        -- document, so its definition stays.+        open :: M.Map T.Text (S.Tag, S.Content) -> M.Map T.Text (S.Tag, S.Content)+        open = maybe id M.delete sn.props.anchor++        close+          :: S.Node+          -> M.Map T.Text (S.Tag, S.Content)+          -> (S.Node, M.Map T.Text (S.Tag, S.Content))+        close n anchors' = case sn.props.anchor of+          Just a | M.member a anchors' -> (n, anchors')+          _ -> define n anchors'++    define+      :: S.Node+      -> M.Map T.Text (S.Tag, S.Content)+      -> (S.Node, M.Map T.Text (S.Tag, S.Content))+    define sn anchors = case sn.props.anchor of+      Just a -> (sn, M.insert a (sn.props.tag, sn.content) anchors)+      Nothing -> (sn, anchors)++    -- The content at the alias.+    copyAt :: S.Node -> S.Content -> S.Content+    copyAt alias = \case+      S.SequenceContent style xs -> S.SequenceContent style (map node xs)+      S.MappingContent style kvs ->+        S.MappingContent style [(node k, node v) | (k, v) <- kvs]+      c -> c+      where+        node :: S.Node -> S.Node+        node n =+          S.Node+            { S.offset = alias.offset+            , S.endOffset = alias.endOffset+            , S.props = n.props+            , S.comments = S.noComments+            , S.content = copyAt alias n.content+            }++    goList+      :: M.Map T.Text (S.Tag, S.Content)+      -> [S.Node]+      -> ([S.Node], M.Map T.Text (S.Tag, S.Content))+    goList anchors = \case+      [] -> ([], anchors)+      x : xs ->+        let (x', anchors') = go anchors x+            (xs', anchors'') = goList anchors' xs+        in (x' : xs', anchors'')++    goPairs+      :: M.Map T.Text (S.Tag, S.Content)+      -> [(S.Node, S.Node)]+      -> ([(S.Node, S.Node)], M.Map T.Text (S.Tag, S.Content))+    goPairs anchors = \case+      [] -> ([], anchors)+      (k, v) : kvs ->+        let (k', anchors') = go anchors k+            (v', anchors'') = go anchors' v+            (kvs', anchors''') = goPairs anchors'' kvs+        in ((k', v') : kvs', anchors''')++-- | The value with the tag, in 'Tagged' if the tag is not the one of the core+-- schema for the value.+withTag :: T.Text -> Value -> Value+withTag tag v+  | tag == valueTag v = v+  | otherwise = Tagged tag v++scalar :: S.Offset -> S.Props -> S.ScalarStyle -> T.Text -> Either Failure Value+scalar off props style t = case props.tag of+  S.NoTag+    | style == S.Plain -> case resolvePlainExact t of+        Right v -> Right v+        -- The check comes before the decoder, which knows if the value is+        -- a string. A node that a program built has no input to quote.+        Left _+          | off == S.noOffset -> Left $ failure off exponentOutOfRange+          | otherwise ->+              Left . failure off $+                exponentOutOfRange+                  ++ ", quote the value if it is a string, e.g. '"+                  ++ T.unpack t+                  ++ "'"+    | otherwise -> Right (String t)+  S.NonSpecificTag -> Right (String t)+  S.Tag tag+    | tag == seqTag || tag == mapTag ->+        Left . failure off $+          "the tag !!"+            ++ T.unpack (T.drop (T.length coreTagPrefix) tag)+            ++ " cannot be used on a scalar"+    | otherwise -> case resolveTaggedExact tag t of+        Just (Right v) -> Right (withTag tag v)+        Just (Left _) -> Left $ failure off exponentOutOfRange+        Nothing ->+          Left . failure off $+            "invalid value for the tag !!"+              ++ T.unpack (T.drop (T.length coreTagPrefix) tag)+              ++ if tag == boolTag && isYaml11Bool t+                then ", " ++ showText t ++ " is a boolean only in YAML 1.1"+                else ""++collectionTag :: S.Offset -> S.Props -> T.Text -> Either Failure T.Text+collectionTag off props def = case props.tag of+  S.NoTag -> Right def+  S.NonSpecificTag -> Right def+  S.Tag tag+    | tag == def || not (isCoreTag tag) -> Right tag+    | otherwise ->+        Left . failure off $+          "the tag !!"+            ++ T.unpack (T.drop (T.length coreTagPrefix) tag)+            ++ " cannot be used on a "+            ++ (if def == seqTag then "sequence" else "mapping")+  where+    isCoreTag :: T.Text -> Bool+    isCoreTag tag =+      tag `elem` [nullTag, boolTag, intTag, floatTag, strTag, seqTag, mapTag]++-- | The error at a key, with a note at the first key that is equal to it.+duplicateKey :: (S.Node, Value) -> (S.Node, Value) -> Failure+duplicateKey (kn, k) (firstNode, _) =+  (kn.offset, message) NE.:| [(firstNode.offset, note)]+  where+    message :: String+    message = case (k, inputText kn, inputText firstNode) of+      (String "<<", _, _) -> "duplicate key \"<<\"" ++ noMergeKeys+      (_, Just t, Just f)+        | t /= f -> "duplicate key " ++ t ++ ", the same value as the first key"+      (_, Just t, _) -> "duplicate key " ++ t+      (_, Nothing, _) -> "duplicate key"++    note :: String+    note = "the first key" ++ maybe "" (' ' :) (inputText firstNode)++-- | The hint after the message of an error at a key @<<@. YAML 1.1 used it to+-- merge mappings, and some tools still do, but in YAML 1.2 it is a string.+noMergeKeys :: String+noMergeKeys = ", merge keys are not supported"++-- | The state of the composition of a document with aliases or collection+-- keys. Equal values get the same number, so that keys compare in constant+-- time, even if they are large collections or come from aliases that expand+-- to huge values.+data Numbering = Numbering+  { anchors :: !(M.Map T.Text (Maybe (Value, Int, Int)))+  -- ^ An anchor maps to its value, the number of the value and the visits of+  -- a traversal of the node. It maps to Nothing while its node is composed.+  , shapes :: !(M.Map Shape Int)+  , visits :: !Int+  -- ^ The visits of a traversal of the nodes so far.+  , added :: !Int+  -- ^ The visits that the aliases added so far, with those of the documents+  -- before in the stream.+  }++-- | A value with the numbers of its items or entries in place of them. The+-- entries of a mapping are sorted, so their order does not matter. A scalar+-- is small, so it stays a value.+data Shape+  = ScalarShape !Value+  | SequenceShape !T.Text ![Int]+  | MappingShape !T.Text ![(Int, Int)]+  deriving stock (Eq, Ord)
+ src/Yamlet/Internal/Emit.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE LinearTypes #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Building blocks of the YAML output.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Emit+  ( -- * Scalars+    plainSyntax+  , plainLines+  , singleQuoted+  , singleQuotedLines+  , quotedPlain+  , quotedPlainLines+  , doubleQuoted+  , doubleQuotedLines+  , literalBlock+  , foldedBlock+  , hasKeepIndicator+  , needsIndentIndicator++    -- * Other+  , indentStep+  , tagText+  , tagHandles+  , tagDirective+  , isPrintable+  , isScalarChar+  , spaces+  ) where++import Data.ByteString qualified as BS+import Data.Char+import Data.Containers.ListUtils+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Builder.Linear qualified as B+import Data.Text.Builder.Linear.Buffer qualified as B+import Data.Text.Encoding qualified as T+import Data.Text.Internal qualified as T+import Numeric++import Yamlet.Internal.Chars+import Yamlet.Internal.Syntax+import Yamlet.Internal.Utils++-- | The number of spaces that the content of a block collection or a block+-- scalar is indented by, relative to its parent. The output style is fixed.+indentStep :: Int+indentStep = 2++-- | The text reads back as the same text if it is a plain scalar on one line,+-- in a flow collection if the flag is set. The check ignores the schema, so+-- e.g. @12@ passes.+plainSyntax :: Bool -> T.Text -> Bool+plainSyntax inFlow t = case T.uncons t of+  Nothing -> False+  Just (c, rest) ->+    firstOk c rest+      && isPlainChar c+      && valid c rest+      && not (textIsPrefixOf "---" t)+      && not (textIsPrefixOf "..." t)+  where+    -- The characters after the given one are valid in a plain scalar, and+    -- the text has no ": " or " #" and does not end with white space or a+    -- colon.+    valid :: Char -> T.Text -> Bool+    valid prev s = case T.uncons s of+      Nothing -> not (asciiChar isWhite prev) && prev /= ':'+      Just (c, s')+        | not (isPlainChar c) -> False+        | prev == ':' && c == ' ' -> False+        | prev == ' ' && c == '#' -> False+        | otherwise -> valid c s'++    -- YAML 1.1 parsers end a plain scalar at a question mark in a flow+    -- collection, or reject it. As one top-level function with the flag for+    -- both callers, it made the encode benchmark of the text input allocate+    -- several times more.+    isPlainChar :: Char -> Bool+    isPlainChar c =+      (c == ' ' || (isScalarChar c && c /= '\t'))+        && not (inFlow && (asciiChar isFlowIndicator c || c == '?'))++    -- YAML 1.1 parsers reject a plain scalar that starts with a colon in a+    -- flow collection.+    firstOk :: Char -> T.Text -> Bool+    firstOk c rest+      | inFlow && c == ':' = False+      | elem @[] c "-?:" = case T.uncons rest of+          Just (c', _) -> not (asciiChar isWhite c')+          Nothing -> False+      | otherwise = not (asciiChar isWhite c) && not (asciiChar isIndicator c)++-- | A plain scalar on the lines that start at the positions, with the lines+-- after the first one at the given indentation, if the text can be plain. It+-- is in a flow collection if the flag is set.+plainLines :: Bool -> Int -> [Int] -> T.Text -> Maybe B.Builder+plainLines inFlow indent starts t+  | plainSyntax inFlow first && all (plainNextLine . snd) rest =+      Just (onLines indent B.fromText ls)+  | otherwise = Nothing+  where+    ls@(first, rest) = flowLines False False (asciiChar isWhite) starts t++    -- The text reads back as the same text on a line of a plain scalar after+    -- the first line. Such a line can start with an indicator, but not with a+    -- comment.+    plainNextLine :: T.Text -> Bool+    plainNextLine l = case (T.uncons l, T.unsnoc l) of+      (Just (c, _), Just (_, lastChar)) ->+        c /= '#'+          && not (asciiChar isWhite c)+          && not (asciiChar isWhite lastChar)+          && lastChar /= ':'+          && T.all isPlainChar l+          && not (T.isInfixOf ": " l)+          && not (T.isInfixOf " #" l)+      _ -> False++    -- As in 'plainSyntax'.+    isPlainChar :: Char -> Bool+    isPlainChar c =+      (c == ' ' || (isScalarChar c && c /= '\t'))+        && not (inFlow && (asciiChar isFlowIndicator c || c == '?'))++-- | A single-quoted scalar on one line, if the text has no line breaks.+singleQuoted :: T.Text -> Maybe B.Builder+singleQuoted t+  | T.all (\c -> c == '\t' || isScalarChar c) t =+      Just $ "'" <> B.fromText (T.replace "'" "''" t) <> "'"+  | otherwise = Nothing++-- | A single-quoted scalar on the lines that start at the positions, as in+-- 'plainLines', if single quotes can hold the text.+singleQuotedLines :: Int -> [Int] -> T.Text -> Maybe B.Builder+singleQuotedLines indent starts t+  | null starts = singleQuoted t+  | all (T.all (\c -> c == '\t' || isScalarChar c)) (first : map snd rest) =+      Just $ "'" <> onLines indent (B.fromText . T.replace "'" "''") ls <> "'"+  | otherwise = Nothing+  where+    ls@(first, rest) = flowLines True False (asciiChar isWhite) starts t++-- | The quoted form of a plain scalar whose text cannot be plain: in single+-- quotes, or in double quotes if the text has a tab or a character that+-- single quotes cannot hold. A tab in single quotes is not visible.+quotedPlain :: T.Text -> B.Builder+quotedPlain = quotedPlainLines 0 []++-- | 'quotedPlain' on the lines that start at the positions, as in+-- 'plainLines'.+quotedPlainLines :: Int -> [Int] -> T.Text -> B.Builder+quotedPlainLines indent starts t+  | T.any (== '\t') t = doubleQuotedLines indent starts t+  | otherwise =+      fromMaybe (doubleQuotedLines indent starts t) (singleQuotedLines indent starts t)++-- | A double-quoted scalar with escapes for the characters that need them.+doubleQuoted :: T.Text -> B.Builder+doubleQuoted t = "\"" <> doubleQuotedText t <> "\""++-- | A double-quoted scalar on the lines that start at the positions, as in+-- 'plainLines'. The escapes of the tabs keep them at the ends of the lines.+doubleQuotedLines :: Int -> [Int] -> T.Text -> B.Builder+doubleQuotedLines indent starts t+  | null starts = doubleQuoted t+  | otherwise =+      "\""+        <> onLines indent doubleQuotedText (flowLines True True (== ' ') starts t)+        <> "\""++-- | The text of a double-quoted scalar, with escapes for the characters that+-- need them.+doubleQuotedText :: T.Text -> B.Builder+-- The loop writes to the buffer, and copies each run of characters without+-- escapes at once. A fold of builders over the characters allocates a+-- closure for each character since text 2.1.4, whose 'T.foldr' no longer+-- fuses, and the encode benchmark of the config input allocated more. A+-- fold of builders over the runs allocated more in the render benchmark of+-- the JSON input.+doubleQuotedText = B.Builder . go+  where+    go :: T.Text -> B.Buffer %1 -> B.Buffer+    go t b = case T.break needsEscape t of+      (run, rest) -> case T.uncons rest of+        Just (c, rest') -> go rest' (escape (b B.|> run) c)+        Nothing -> b B.|> run++    needsEscape :: Char -> Bool+    needsEscape c = c == '"' || c == '\\' || not (isScalarChar c)++    escape :: B.Buffer %1 -> Char -> B.Buffer+    escape b = \case+      '"' -> b B.|> "\\\""+      '\\' -> b B.|> "\\\\"+      '\n' -> b B.|> "\\n"+      '\t' -> b B.|> "\\t"+      '\r' -> b B.|> "\\r"+      '\0' -> b B.|> "\\0"+      c+        | ord c < 16 ^ xEscapeDigits -> b B.|> "\\x" B.|> hex xEscapeDigits (ord c)+        | ord c < 16 ^ uEscapeDigits -> b B.|> "\\u" B.|> hex uEscapeDigits (ord c)+        | otherwise -> b B.|> "\\U" B.|> hex bigUEscapeDigits (ord c)++    hex :: Int -> Int -> T.Text+    hex k i = T.pack (upperHex k i)++-- | The lines of a flow scalar that start at the positions: the first line,+-- and each next line with the number of empty lines above it, or 'Nothing'+-- after an escaped line break. A line break replaces a space of the text,+-- and an empty line replaces a line break of the text. A position where the+-- style cannot start a line and keep the text joins its two lines.+--+-- The first flag allows an empty first and last line, e.g. for a quoted+-- scalar. The second flag allows escaped line breaks. The parser drops a+-- white character at the start or the end of a line.+flowLines+  :: Bool -> Bool -> (Char -> Bool) -> [Int] -> T.Text -> (T.Text, [(Maybe Int, T.Text)])+flowLines quoted escapes white starts t = case splitLines starts t of+  first : rest -> go True first rest+  [] -> (t, [])+  where+    go :: Bool -> T.Text -> [T.Text] -> (T.Text, [(Maybe Int, T.Text)])+    go isFirst a = \case+      [] -> (a, [])+      b : rest -> case lineEnd isFirst (null rest) a b of+        Just (a', end) -> let (l, ls) = go False b rest in (a', (end, l) : ls)+        Nothing -> go isFirst (join a b) rest++    -- The pieces of 'splitLines' follow each other in the array of the text,+    -- so two of them join without a copy. A copy at each join would make the+    -- time quadratic in the number of lines.+    join :: T.Text -> T.Text -> T.Text+    join (T.Text arr off len) b@(T.Text _ _ len')+      | len == 0 = b+      | otherwise = T.Text arr off (len + len')++    -- The first line without the text that the line break replaces, and the+    -- number of empty lines.+    lineEnd :: Bool -> Bool -> T.Text -> T.Text -> Maybe (T.Text, Maybe Int)+    lineEnd isFirst isLast a b+      | not startOk = Nothing+      | Just (a', ' ') <- T.unsnoc a, endOk a' = Just (a', Just 0)+      | k > 0, endOk a'' = Just (a'', Just k)+      | escapes = Just (a, Nothing)+      | otherwise = Nothing+      where+        startOk :: Bool+        startOk = case T.uncons b of+          Just (c, _) -> not (white c)+          Nothing -> quoted && isLast++        endOk :: T.Text -> Bool+        endOk x = case T.unsnoc x of+          Just (_, c) -> not (white c)+          Nothing -> quoted && isFirst++        k :: Int+        k = T.length (T.takeWhileEnd (== '\n') a)++        a'' :: T.Text+        a'' = T.dropEnd k a++-- | The flow scalar on its lines, with each line after the first one at the+-- given indentation.+onLines :: Int -> (T.Text -> B.Builder) -> (T.Text, [(Maybe Int, T.Text)]) -> B.Builder+onLines indent text (first, rest) =+  text first <> mconcat [lineBreak end <> spaces indent <> text l | (end, l) <- rest]+  where+    lineBreak :: Maybe Int -> B.Builder+    lineBreak = \case+      Just k -> B.fromText (T.replicate (k + 1) "\n")+      Nothing -> "\\\n"++-- | The text split at the positions. A position that does not come after the+-- one before it is ignored, and a position after the end of the text ends+-- the split.+splitLines :: [Int] -> T.Text -> [T.Text]+splitLines = go 0+  where+    go :: Int -> [Int] -> T.Text -> [T.Text]+    go at starts s = case starts of+      p : rest+        | p <= at -> go at rest s+        | T.compareLength s (p - at) == LT -> [s]+        | otherwise -> let (a, b) = T.splitAt (p - at) s in a : go p rest b+      [] -> [s]++-- | The header and the content lines of a literal block scalar, with the+-- content at the given indentation.+literalBlock :: Int -> T.Text -> Maybe (B.Builder, B.Builder)+literalBlock indent t = do+  (header, body, trailing) <- blockParts True t+  let content+        -- The line break of the header comes first, and each empty line+        -- below it is one line break of the text.+        | T.null body = B.fromText (T.replicate trailing "\n")+        | otherwise =+            mconcat (map (line indent) (T.splitOn "\n" body))+              <> B.fromText (T.replicate (trailing - 1) "\n")+  Just ("|" <> header, content)++-- | The header and the content lines of a folded block scalar, with the+-- content at the given indentation. It has no keep indicator. Each line of+-- the text becomes one line of the output, or several lines if the lines+-- start at the positions.+foldedBlock :: Int -> [Int] -> T.Text -> Maybe (B.Builder, B.Builder)+foldedBlock indent starts t = do+  (header, body, _) <- blockParts False t+  let (leading, rest) = span T.null (if T.null body then [] else T.splitOn "\n" body)+      content =+        mconcat (replicate (length leading) "\n")+          <> go Nothing (length leading) starts (groups rest)+  Just (">" <> header, content)+  where+    -- The lines with content, each with the number of empty lines before it.+    groups :: [T.Text] -> [(Int, T.Text)]+    groups ls = case span T.null ls of+      (_, []) -> []+      (empties, l : ls') -> (length empties, l) : groups ls'++    -- A line break between two lines that start with content folds into a+    -- space, so the output needs one empty line more there. The group starts+    -- at the offset.+    go :: Maybe T.Text -> Int -> [Int] -> [(Int, T.Text)] -> B.Builder+    go prev offset ss = \case+      [] -> mempty+      (empties, l) : ls ->+        let extra = case prev of+              Just p | not (isSpaced p) && not (isSpaced l) -> 1+              _ -> 0+            separator = case prev of+              Just _ -> mconcat (replicate (empties + extra) "\n")+              Nothing -> mempty+            lineStart = offset + empties+            lineEnd = lineStart + T.length l+            (inLine, ss') = span (< lineEnd) (dropWhile (<= lineStart) ss)+        in separator+             <> mconcat+               (map (line indent) (lineParts (map (subtract lineStart) inLine) l))+             <> go (Just l) (lineEnd + 1) ss' ls++    -- The parts of a line of the text that start at the positions. A line+    -- break replaces a space between two parts that start with content.+    lineParts :: [Int] -> T.Text -> [T.Text]+    lineParts ps l+      | null ps || isSpaced l = [l]+      | otherwise = join (splitLines ps l)+      where+        join :: [T.Text] -> [T.Text]+        join = \case+          a : b : rest+            | Just (a', ' ') <- T.unsnoc a+            , Just (c, _) <- T.uncons b+            , c /= ' ' && c /= '\t' ->+                a' : join (b : rest)+            | otherwise -> join (a <> b : rest)+          parts -> parts++    isSpaced :: T.Text -> Bool+    isSpaced l = case T.uncons l of+      Just (c, _) -> c == ' ' || c == '\t'+      Nothing -> False++-- | A block scalar with the text has the keep indicator, so the empty lines at+-- its end are its content. Without content, the clip indicator drops the+-- line breaks too.+hasKeepIndicator :: T.Text -> Bool+hasKeepIndicator t = trailing > 1 || T.null body && trailing > 0+  where+    body :: T.Text+    body = T.dropWhileEnd (== '\n') t++    trailing :: Int+    trailing = T.length t - T.length body++-- | The header of a block scalar, its content without the trailing line breaks+-- and the number of these line breaks. The flag allows the keep indicator for+-- trailing empty lines.+blockParts :: Bool -> T.Text -> Maybe (B.Builder, T.Text, Int)+blockParts allowKeep t+  | not (T.all (\c -> c == '\n' || c == '\t' || isScalarChar c) t) = Nothing+  | keep && not allowKeep = Nothing+  | otherwise = Just (indicator <> chomping, body, trailing)+  where+    keep :: Bool+    keep = hasKeepIndicator t++    body :: T.Text+    body = T.dropWhileEnd (== '\n') t++    trailing :: Int+    trailing = T.length t - T.length body++    indicator :: B.Builder+    indicator = if needsIndentIndicator t then B.fromDec indentStep else mempty++    chomping :: B.Builder+    chomping+      | trailing == 0 = "-"+      | keep = "+"+      | otherwise = mempty++-- | A block scalar with the text needs an indentation indicator, because its+-- first line with content starts with a space or a tab. YAML 1.2 does not+-- need the indicator for a tab, but libyaml rejects the block scalar without+-- it. Parsers do not agree on the meaning of the indicator at the top level,+-- so a caller there writes such a text with quotes.+needsIndentIndicator :: T.Text -> Bool+needsIndentIndicator t = case T.uncons (T.dropWhile (== '\n') t) of+  Just (c, _) -> c == ' ' || c == '\t'+  Nothing -> False++-- | A line of a block scalar. An empty line gets no indentation.+line :: Int -> T.Text -> B.Builder+line indent l+  | T.null l = "\n"+  | otherwise = "\n" <> spaces indent <> B.fromText l++-- | A tag in the shortest form that reads back as the same tag. A tag that no+-- text can hold, e.g. an empty tag, becomes the non-specific tag @!@.+--+-- A global tag that is not a valid URI needs the directive of+-- 'tagDirective' in its document.+tagText :: T.Text -> B.Builder+tagText tag+  | T.null tag = "!"+  | Just suffix <- textStripPrefix coreTagPrefix tag+  , not (T.null suffix) =+      "!!" <> shorthand suffix+  | Just suffix <- textStripPrefix "!" tag+  , not (T.null suffix) =+      "!" <> shorthand suffix+  | Just (c, suffix) <- T.uncons tag+  , not (isVerbatim tag) =+      if T.null suffix then "!" else handleText c <> shorthand suffix+  | otherwise = "!<" <> B.fromText tag <> ">"+  where+    -- The text of a tag suffix. A character that the form does not allow gets+    -- a %XX escape, which the parser decodes. So does #, which YAML allows,+    -- but libyaml, PyYAML and go-yaml reject.+    shorthand :: T.Text -> B.Builder+    shorthand =+      T.foldr+        ( \x b ->+            (if x /= '#' && asciiChar isTagChar x then B.fromChar x else percentEscape x)+              <> b+        )+        mempty++-- | The handles for the tags of the node and the nodes in it that are not+-- valid URIs, each once.+tagHandles :: Node -> [Char]+tagHandles n0 = nubOrd (go n0 [])+  where+    go :: Node -> [Char] -> [Char]+    go n acc =+      (case n.props.tag of Tag t -> maybe id (:) (tagHandle t); _ -> id) $+        case n.content of+          SequenceContent _ xs -> foldr go acc xs+          MappingContent _ kvs -> foldr (\(k, v) -> go k . go v) acc kvs+          _ -> acc++    -- The character whose handle a tag needs, if the tag needs a directive.+    tagHandle :: T.Text -> Maybe Char+    tagHandle tag = case T.uncons tag of+      Just (c, suffix)+        | c /= '!'+        , not (T.null suffix)+        , not (textIsPrefixOf coreTagPrefix tag)+        , not (isVerbatim tag) ->+            Just c+      _ -> Nothing++-- | The @%TAG@ directive of the handle for the tags that start with the+-- character, with the line break. The prefix is always an escape, because+-- e.g. a @#@ after a space starts a comment.+tagDirective :: Char -> B.Builder+tagDirective c = "%TAG " <> handleText c <> " " <> percentEscape c <> "\n"++handleText :: Char -> B.Builder+handleText c = "!t" <> B.fromText (T.pack (showHex (ord c) "")) <> "!"++-- | A global tag that a verbatim tag holds as it is. A % in a verbatim tag+-- starts an escape, and libyaml, PyYAML and go-yaml reject a #, so a tag with+-- a % or a # goes in a shorthand tag, with escapes.+isVerbatim :: T.Text -> Bool+isVerbatim tag =+  hasScheme && T.all (\c -> c /= '%' && c /= '#' && asciiChar isUriChar c) tag+  where+    hasScheme :: Bool+    hasScheme = case T.break (== ':') tag of+      (scheme, rest) -> case T.uncons scheme of+        Just (c, cs) ->+          isAscii c+            && isAlpha c+            && T.all (\x -> isAscii x && (isAlphaNum x || elem @[] x "+-.")) cs+            && not (T.null rest)+        Nothing -> False++-- | The %XX escapes of the UTF-8 bytes of a character.+percentEscape :: Char -> B.Builder+percentEscape c =+  mconcat+    [ B.fromText (T.pack ('%' : upperHex percentDigits (fromIntegral w)))+    | w <- BS.unpack (T.encodeUtf8 (T.singleton c))+    ]++-- | The number in uppercase hex digits, with zeros in front up to the given+-- number of digits.+upperHex :: Int -> Int -> String+upperHex k i = let s = map toUpper (showHex i "") in replicate (k - length s) '0' ++ s++-- | c-printable without the line breaks and the byte order mark.+isPrintable :: Char -> Bool+isPrintable c+  | c < ' ' = False+  | c <= '~' = True+  | c < '\xA0' = False+  | c == '\xFEFF' = False+  | c >= '\xD800' && c <= '\xDFFF' = False+  | c == '\xFFFE' || c == '\xFFFF' = False+  | otherwise = True++-- | A printable character that needs no escape in a scalar. YAML 1.1 reads+-- U+2028 and U+2029 as line breaks, so they get escapes too.+isScalarChar :: Char -> Bool+-- The guards for ASCII come first. Without them, the encode benchmark of+-- the long texts is slower.+isScalarChar c+  | c < ' ' = False+  | c <= '~' = True+  | otherwise = isPrintable c && c /= '\x2028' && c /= '\x2029'++spaces :: Int -> B.Builder+spaces k = B.fromText (T.replicate k " ")
+ src/Yamlet/Internal/Encoder.hs view
@@ -0,0 +1,184 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The renderer of the nodes of the encoder.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Encoder+  ( renderDocuments+  ) where++import Data.Maybe+import Data.Text qualified as T+import Data.Text.Builder.Linear qualified as B++import Yamlet.Internal.Emit+import Yamlet.Internal.Render+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils++-- | Render documents. Documents after the first one start with a @---@+-- marker. The collections of 'Yamlet.Encode.toYaml' are in the block style.+--+-- A document with comments, anchors, aliases, flow collections, scalars on+-- several lines or scalar styles that 'Yamlet.Encode.toYaml' does not create+-- goes to 'Yamlet.Syntax.renderSyntax'. Other documents go to a faster+-- renderer, which gives the same output.+renderDocuments :: [S.Node] -> T.Text+renderDocuments docs+  | all simple docs = B.runBuilder . mconcat $ zipWith document [0 :: Int ..] docs+  | otherwise = renderSyntax defaultRenderOptions (map S.document docs)+  where+    document :: Int -> S.Node -> B.Builder+    document i n+      | null handles = (if i > 0 then "---\n" else mempty) <> topLevel n+      | otherwise =+          (if i > 0 then "...\n" else mempty)+            <> foldMap tagDirective handles+            <> "---\n"+            <> topLevel n+      where+        handles :: [Char]+        handles = tagHandles n++    topLevel :: S.Node -> B.Builder+    topLevel n = case n.content of+      S.SequenceContent _ xs@(_ : _) -> tagLine n <> blockSequence 0 True xs+      S.MappingContent _ kvs@(_ : _) -> tagLine n <> blockMapping 0 True kvs+      S.ScalarContent S.Literal t+        | needsIndentIndicator t -> withTag n (doubleQuoted t) <> "\n"+      _ -> inlineValue indentStep n <> "\n"++    -- A tag of a block collection takes a line of its own.+    tagLine :: S.Node -> B.Builder+    tagLine n = case tagPrefix n of+      Just t -> t <> "\n"+      Nothing -> mempty++-- | The node has no comments, anchors, aliases and flow collections, and its+-- scalars are on one line and have the styles that 'Yamlet.Encode.toYaml'+-- creates.+simple :: S.Node -> Bool+simple n =+  null n.comments.before+    && isNothing n.comments.inline+    && null n.comments.after+    && isNothing n.props.anchor+    && n.props.tag /= S.NonSpecificTag+    && case n.content of+      S.ScalarLinesContent _ _ (_ : _) -> False+      -- The renderer gives an empty plain scalar no text.+      S.ScalarContent S.Plain t -> not (T.null t)+      S.ScalarContent S.SingleQuoted _ -> True+      S.ScalarContent S.DoubleQuoted _ -> True+      S.ScalarContent S.Literal _ -> True+      S.ScalarContent _ _ -> False+      S.SequenceContent style xs -> (style == S.Block || null xs) && all simple xs+      S.MappingContent style kvs ->+        (style == S.Block || null kvs) && all (\(k, v) -> simple k && simple v) kvs+      S.AliasContent _ -> False++-- | A block sequence of the items of a 'simple' node. The first entry does+-- not start with indentation if the sequence continues a line.+blockSequence :: Int -> Bool -> [S.Node] -> B.Builder+blockSequence indent atLineStart = mconcat . zipWith entry [0 :: Int ..]+  where+    entry :: Int -> S.Node -> B.Builder+    entry i x =+      (if i > 0 || atLineStart then spaces indent else mempty)+        <> "-"+        <> afterIndicator indent x++-- | A node after the indicator of a sequence item or an explicit entry at the+-- given indentation, with the line break. A block collection starts on the+-- line of the indicator, unless it has a tag.+afterIndicator :: Int -> S.Node -> B.Builder+afterIndicator indent x = case x.content of+  S.SequenceContent _ xs@(_ : _) ->+    collection $ blockSequence (indent + indentStep) False xs+  S.MappingContent _ kvs@(_ : _) ->+    collection $ blockMapping (indent + indentStep) False kvs+  _ -> " " <> inlineValue (indent + indentStep) x <> "\n"+  where+    collection :: B.Builder -> B.Builder+    collection body = case tagPrefix x of+      Just t -> " " <> t <> "\n" <> spaces (indent + indentStep) <> body+      Nothing -> " " <> body++-- | A block mapping of the entries of a 'simple' node. The first entry does+-- not start with indentation if the mapping continues a line.+blockMapping :: Int -> Bool -> [(S.Node, S.Node)] -> B.Builder+blockMapping indent atLineStart = mconcat . zipWith entry [0 :: Int ..]+  where+    entry :: Int -> (S.Node, S.Node) -> B.Builder+    entry i (k, v) =+      (if i > 0 || atLineStart then spaces indent else mempty) <> case implicitKey k of+        Just key -> key <> ":" <> value v+        Nothing ->+          "?"+            <> afterIndicator indent k+            <> spaces indent+            <> ":"+            <> afterIndicator indent v++    value :: S.Node -> B.Builder+    value v = case v.content of+      S.SequenceContent _ xs@(_ : _) -> tagged v <> "\n" <> blockSequence indent True xs+      S.MappingContent _ kvs@(_ : _) ->+        tagged v <> "\n" <> blockMapping (indent + indentStep) True kvs+      _ -> " " <> inlineValue (indent + indentStep) v <> "\n"++    tagged :: S.Node -> B.Builder+    tagged x = maybe mempty (" " <>) (tagPrefix x)++    -- A key that fits on one line, or 'Nothing' if it needs an explicit entry.+    implicitKey :: S.Node -> Maybe B.Builder+    implicitKey k = case k.content of+      S.ScalarContent style t+        | S.NoTag <- k.props.tag+        , style == S.Plain+        , plainSyntax False t ->+            if T.length t > maxImplicitKeyLength then Nothing else Just (B.fromText t)+        | otherwise -> fits (withTag k (scalarText style t))+      -- go-yaml v2 reads "[]: a" and "{}: a" without an error, but as an+      -- empty list or mapping, and drops the entries after them. A tag+      -- avoids that.+      S.SequenceContent _ [] | isJust (tagPrefix k) -> fits (inlineValue 0 k)+      S.MappingContent _ [] | isJust (tagPrefix k) -> fits (inlineValue 0 k)+      _ -> Nothing+      where+        fits :: B.Builder -> Maybe B.Builder+        fits key =+          if T.length (B.runBuilder key) > maxImplicitKeyLength then Nothing else Just key++-- | A scalar, or an empty collection in the flow style.+inlineValue :: Int -> S.Node -> B.Builder+inlineValue indent n = withTag n $ case n.content of+  S.SequenceContent _ _ -> "[]"+  S.MappingContent _ _ -> "{}"+  S.ScalarContent S.Literal t | Just (h, b) <- literalBlock indent t -> h <> b+  S.ScalarContent style t -> scalarText style t+  S.AliasContent _ -> mempty++-- | Prefix the tag if the node has one.+withTag :: S.Node -> B.Builder -> B.Builder+withTag n b = case tagPrefix n of+  Just t -> t <> " " <> b+  Nothing -> b++tagPrefix :: S.Node -> Maybe B.Builder+tagPrefix n = case n.props.tag of+  S.Tag t -> Just (tagText t)+  _ -> Nothing++-- | A scalar of a 'simple' node on one line.+scalarText :: S.ScalarStyle -> T.Text -> B.Builder+scalarText style t = case style of+  S.Plain+    | plainSyntax False t -> B.fromText t+    | otherwise -> quotedPlain t+  S.SingleQuoted -> quoted+  _ -> doubleQuoted t+  where+    quoted :: B.Builder+    quoted = fromMaybe (doubleQuoted t) (singleQuoted t)
+ src/Yamlet/Internal/FromYaml.hs view
@@ -0,0 +1,1646 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The class t'FromYaml', its instances and the parts of the decoder that+-- the generic instances share with it. "Yamlet.Decode" exports the public+-- parts.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.FromYaml+  ( -- * Class+    FromYaml (..)++    -- * Parser+  , Parser+  , runParser+  , runParserWithin+  , parseNode+  , failAt+  , typeMismatch+  , orElse++    -- * Scalars+  , withNull+  , withBool+  , withInt+  , withFloat+  , withScientific+  , withText+  , withName+  , oneOf++    -- * Collections+  , withSequence+  , withMapping+  , Object (..)+  , objectNode+  , objectEntries+  , objectKeys+  , lookupKey+  , parseField+  , parseFieldMaybe+  , parseFieldIfPresent+  , parseFieldDefault+  , parseFieldWith+  , parseFieldMaybeWith+  , parseFieldIfPresentWith+  , parseFieldDefaultWith+  , rejectUnknownKeys++    -- * Parts of the generic instances+  , parseItems+  , parseEntry+  , findKey+  , missingKey+  , unknownName+  , unquotedName+  , succeeds+  , withNote+  , nullNode+  ) where++import Control.Applicative+import Control.Monad+import Data.Containers.ListUtils+import Data.Fixed+import Data.Functor.Identity+import Data.Int+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Monoid qualified as Mon+import Data.Ord+import Data.Proxy+import Data.Scientific qualified as Sci+import Data.Semigroup qualified as Sem+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.Time.Calendar.Month+import Data.Time.Calendar.Quarter+import Data.Time.FromText+import Data.Tree qualified as Tree+import Data.UUID.Types qualified as UUID+import Data.Void+import Data.Word+import GHC.Real+import Numeric.Natural++import Yamlet.Internal.Compose+import Yamlet.Internal.Schema+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils+import Yamlet.Internal.View+import Yamlet.Value++-- | A parser of nodes. Its errors point to the node that the parser works on,+-- unless 'failAt' names another one.+--+-- The parser has no t'Control.Applicative.Alternative' instance. To try+-- another parser after a failure, use 'orElse'. To reject a value, fail with+-- a message that says why:+--+-- @+-- port <- parseYaml n+-- unless (port > 0 && port < 65536) $ fail "the port must be from 1 to 65535"+-- @+--+-- The applicative operators collect the errors of both parts: '<*>', '*>',+-- '<*', 'liftA2', and the functions that use them, e.g. 'traverse',+-- 'mapM' on a list and 'Data.Foldable.for_'. This parser gives the errors of+-- the unknown keys and of all fields together:+--+-- @+-- rejectUnknownKeys [\"name\", \"paths\"] o+--   *> (Config \<$> parseField o \"name\" \<*> parseField o \"paths\")+-- @+--+-- '>>=' and '>>' stop at the first error. A statement of a @do@ block also+-- stops, e.g. the check of the port above. The functions that use '>>' also+-- stop, e.g. 'Control.Monad.mapM_' and 'Control.Monad.forM_'.+--+-- The choice between them changes only the errors, never the result. With+-- @ApplicativeDo@, GHC turns the independent statements of a @do@ block that+-- ends with 'pure' into '<*>'. Then they collect errors.+newtype Parser a = Parser (S.Offset -> Result a)++-- | The errors of a parser and its value. The value of a parser with errors+-- is 'failed', so the field of the value is lazy.+--+-- '<*>' applies the values without a branch on the errors, and it joins the+-- errors apart from them. The optimizer can then combine the values of a+-- derived decoder as for a pure function, and the generic representation+-- goes away.+data Result a = Result !Errors a++-- | The errors of a parser in a tree, so that two sets of errors join in+-- constant time.+data Errors+  = NoErrors+  | -- | An error with the notes that go right after it, e.g. the first key of+    -- a duplicate key.+    OneError !S.Offset !String ![(S.Offset, String)]+  | BothErrors !Errors !Errors++bothErrors :: Errors -> Errors -> Errors+bothErrors e1 e2 = case (e1, e2) of+  (NoErrors, _) -> e2+  (_, NoErrors) -> e1+  _ -> BothErrors e1 e2+-- If GHC inlines this function into '<*>', the branches on the errors take+-- the values of the parts with them. Then the inspection test of the derived+-- decoder with 100 fields fails.+{-# NOINLINE bothErrors #-}++-- | The value of a parser with errors. Nothing reads it, because each+-- consumer of a result looks at the errors first.+failed :: a+failed = errorWithoutStackTrace "Yamlet.Decode: the value of a failed parser"++-- | A result with one error.+failure :: S.Offset -> String -> Result a+failure off msg = Result (OneError off msg []) failed++instance Functor Parser where+  fmap f (Parser g) = Parser $ \off -> case g off of+    Result e a -> Result e (f a)++-- '<*>' differs from 'ap', and '>>' differs from '*>', in the errors, but not+-- in the results.+instance Applicative Parser where+  pure a = Parser $ \_ -> Result NoErrors a+  Parser f <*> Parser g = Parser $ \off -> case f off of+    Result e1 h -> case g off of+      Result e2 a -> Result (bothErrors e1 e2) (h a)++-- A statement of a @do@ block must not run after a failed check, e.g. an+-- index into a list after the check of its length. The default of '>>' uses+-- '>>=', which stops there.+instance Monad Parser where+  Parser g >>= k = Parser $ \off -> case g off of+    Result NoErrors a -> let Parser h = k a in h off+    Result e _ -> Result e failed++instance MonadFail Parser where+  fail msg = Parser $ \off -> failure off msg++-- | Run a parser on a node. Each error is the offset of the node that caused+-- it and the message. The errors are in the order of the offsets, and equal+-- errors come only once. A note on an error comes right after it, e.g. the+-- first key of a duplicate key.+--+-- First, the function makes the checks of 'Yamlet.decodeDocument' on the+-- node, e.g. for duplicate keys. It also replaces each alias with the node+-- that the alias refers to. If a check fails, the result has only the error+-- of that check, with its notes.+runParser :: (S.Node -> Parser a) -> S.Node -> Either (NE.NonEmpty (S.Offset, String)) a+runParser f n0 = firstOfResult $ runParserWithin (aliasLimit [n0]) 0 f n0++-- | 'runParser' with the visits of the aliases as for 'prepareWithin'.+runParserWithin+  :: Int+  -> Int+  -> (S.Node -> Parser a)+  -> S.Node+  -> Either (NE.NonEmpty (S.Offset, String)) (a, Int)+runParserWithin limit added f n0 = case prepareWithin limit added n0 of+  Left err -> Left err+  Right (n, added') -> case runChecked f n of+    Result NoErrors a -> Right (a, added')+    Result e _ -> Left (NE.fromList (sortedErrors e))+  where+    -- The errors in the order of their offsets, each with its notes after it.+    -- Errors at the same offset keep their order. An error comes only once:+    -- the nodes inside an alias have the offset of the alias, so the same+    -- error in several of them repeats at that offset.+    sortedErrors :: Errors -> [(S.Offset, String)]+    sortedErrors =+      concatMap (\(off, msg, notes) -> (off, msg) : notes)+        . nubOrd+        . L.sortOn (\(off, _, _) -> off)+        . flip go []+      where+        go+          :: Errors+          -> [(S.Offset, String, [(S.Offset, String)])]+          -> [(S.Offset, String, [(S.Offset, String)])]+        go = \case+          NoErrors -> id+          OneError off msg notes -> ((off, msg, notes) :)+          BothErrors e1 e2 -> go e1 . go e2++-- | Run a parser on a node that passed 'prepareWithin'.+runChecked :: (S.Node -> Parser a) -> S.Node -> Result a+runChecked f n = let Parser g = parseNode f n in g n.offset++-- | The value of a parser on a node that passed 'prepareWithin', if it has no+-- errors.+succeeds :: (S.Node -> Parser a) -> S.Node -> Maybe a+succeeds f n = case runChecked f n of+  Result NoErrors a -> Just a+  Result _ _ -> Nothing++-- | The parser with the note after each of its errors at the offset, e.g. to+-- say how the decoder read the node of the error.+withNote :: S.Offset -> (S.Offset, String) -> Parser a -> Parser a+withNote off note (Parser g) = Parser $ \o -> case g o of+  r@(Result NoErrors _) -> r+  Result e a -> Result (addNote e) a+  where+    addNote :: Errors -> Errors+    addNote = \case+      OneError eo msg notes | eo == off -> OneError eo msg (notes ++ [note])+      BothErrors e1 e2 -> BothErrors (addNote e1) (addNote e2)+      e -> e++-- | Run a parser on a node, so that 'fail' points to the node.+parseNode :: (S.Node -> Parser a) -> S.Node -> Parser a+parseNode f n = let Parser g = f n in Parser $ \_ -> g n.offset++-- | Fail with an error that points to the given node.+failAt :: S.Node -> String -> Parser a+failAt n msg = Parser $ \_ -> failure n.offset msg++-- | Fail with an error that the node is not of the expected kind, e.g.+-- @typeMismatch "a list" n@ gives "expected a list, but got a string".+typeMismatch :: String -> S.Node -> Parser a+typeMismatch expected n = failAt n (mismatchMessage expected n)++mismatchMessage :: String -> S.Node -> String+mismatchMessage expected n = "expected " ++ expected ++ ", but got " ++ describeNode n++-- | The null node for a missing value.+nullNode :: S.Node+nullNode =+  S.Node S.noOffset S.noOffset S.noProps S.noComments (S.ScalarContent S.Plain "")++-- | Run the second parser if the first one fails. A port can be a number or+-- a name:+--+-- >>> :{+-- newtype Port = Port (Either Integer T.Text)+--   deriving stock (Show)+-- instance FromYaml Port where+--   parseYaml n =+--     Port <$> ((Left <$> withInt pure n) `orElse` (Right <$> withText pure n))+-- :}+--+-- >>> decodeText @Port "8080"+-- Right (Port (Left 8080))+--+-- >>> decodeText @Port "http"+-- Right (Port (Right "http"))+--+-- If both parsers fail, the result has only the errors of the second one:+--+-- >>> either printErrors print (decodeText @Port "[80]")+-- input.yaml:1:1: expected a string, but got a list+--   |+-- 1 | [80]+--   | ^+orElse :: Parser a -> Parser a -> Parser a+orElse (Parser g) (Parser h) = Parser $ \off -> case g off of+  r@(Result NoErrors _) -> r+  _ -> h off++infixl 3 `orElse`++----------------------------------------+-- Scalars++-- | Run the parser if the node is null.+withNull :: Parser a -> S.Node -> Parser a+withNull p = parseNode $ \n -> case view n of+  NullView -> p+  _ -> typeMismatch "null" n++-- | The value of a boolean.+withBool :: (Bool -> Parser a) -> S.Node -> Parser a+withBool f = parseNode $ \n -> case view n of+  BoolView b -> f b+  StringView t+    | S.ScalarContent S.Plain _ <- n.content+    , S.NoTag <- n.props.tag+    , isYaml11Bool t ->+        failAt n $+          "expected a boolean, but got the string "+            ++ showText t+            ++ ", which is a boolean only in YAML 1.1, use true or false"+  _ -> typeMismatch "a boolean" n++-- | The value of an integer.+withInt :: (Integer -> Parser a) -> S.Node -> Parser a+withInt f = parseNode $ \n -> case view n of+  IntView i -> f i+  _ -> typeMismatch "an integer" n++-- | The nearest double. An integer counts as a floating-point number too.+withFloat :: (Double -> Parser a) -> S.Node -> Parser a+withFloat = withRealFloat++-- | The nearest value of a floating-point type, as for 'withFloat'.+withRealFloat :: RealFloat b => (b -> Parser a) -> S.Node -> Parser a+withRealFloat f = parseNode $ \n -> case view n of+  FloatView v -> f (floatValueToRealFloat v)+  IntView i -> f (fromInteger i)+  _ -> typeMismatch "a number" n++-- | The exact value of a finite number. An integer counts too, and negative+-- zero becomes 0.+--+-- A conversion to an exact type, e.g. with 'truncate', is safe for untrusted+-- input. An integer has the digits of its text, and the decoder rejects a+-- float whose exponent in scientific notation is beyond the range from -1000+-- to 1000, also in a node that a program built.+withScientific :: (Sci.Scientific -> Parser a) -> S.Node -> Parser a+withScientific f = parseNode $ \n -> case view n of+  FloatView (Finite s) -> f s+  FloatView NegativeZero -> f 0+  IntView i -> f (Sci.scientific i 0)+  FloatView _ -> fail "expected a finite number"+  _ -> typeMismatch "a number" n++-- | The text of a string. The text is a copy, so it does not keep the input+-- alive. For a plain scalar that YAML reads as a number or a boolean, e.g.+-- @3.10@, the error suggests quotes.+withText :: (T.Text -> Parser a) -> S.Node -> Parser a+withText f = parseNode $ \n -> case view n of+  StringView t -> f $! T.copy t+  _ -> failAt n (stringMismatch n)++-- | A string that is one of the names, e.g. the tags of the constructors. For+-- another node, the error suggests quotes only if the quoted text is a name,+-- e.g. not for @null@. Otherwise it lists the names.+withName :: [T.Text] -> (T.Text -> Parser a) -> S.Node -> Parser a+withName names f = parseNode $ \n -> case view n of+  StringView t -> f t+  _ | Just msg <- unquotedName names n -> failAt n msg+  _ | null names -> failAt n "no value is accepted"+  _ -> typeMismatch ("one of: " ++ L.intercalate ", " (map T.unpack names)) n++-- | The error for a plain scalar without a tag that is one of the names, but+-- not a string, e.g. @true@. Quotes would make it the name.+unquotedName :: [T.Text] -> S.Node -> Maybe String+unquotedName names n = case n.content of+  S.ScalarContent S.Plain t+    | S.NoTag <- n.props.tag+    , t `elem` names ->+        Just (stringMismatch n)+  _ -> Nothing++-- | The value that goes with the string in the list of pairs, e.g. for names+-- that the program knows only at run time. An empty list rejects every value.+-- The errors are the same as for the constructors of an enumeration. An+-- unknown name gets the closest name or the list of names:+--+-- >>> :{+-- newtype Size = Size Int+--   deriving stock (Show)+-- instance FromYaml Size where+--   parseYaml = oneOf [("small", Size 1), ("large", Size 2)]+-- :}+--+-- >>> decodeText @Size "large"+-- Right (Size 2)+--+-- >>> either printErrors print (decodeText @Size "lage")+-- input.yaml:1:1: unknown value "lage", did you mean "large"?+--   |+-- 1 | lage+--   | ^+oneOf :: [(T.Text, a)] -> S.Node -> Parser a+oneOf choices n =+  withName names (\t -> maybe (unknownName "value" names n t) pure (lookup t choices)) n+  where+    names :: [T.Text]+    names = map fst choices++-- | The message for a node that is not a string, with the hint to quote a+-- plain number, boolean or written null.+stringMismatch :: S.Node -> String+stringMismatch n = mismatchMessage "a string" n ++ hint+  where+    hint :: String+    hint = case n.content of+      S.ScalarContent S.Plain t+        | S.NoTag <- n.props.tag+        , notString t ->+            ", quote the value, e.g. '" ++ T.unpack t ++ "'"+      _ -> ""++    notString :: T.Text -> Bool+    notString t = case view n of+      IntView _ -> True+      FloatView _ -> True+      BoolView _ -> True+      -- An empty value is more likely a forgotten value than a string.+      NullView -> not (T.null t)+      _ -> False+-- Without the pragma, the interface file has no unfolding of 'withText', so+-- other modules cannot inline it.+{-# NOINLINE stringMismatch #-}++----------------------------------------+-- Collections++-- | The items of a sequence. As for 'withMapping', the comments of the+-- sequence stay with it, not with its first item.+withSequence :: ([S.Node] -> Parser a) -> S.Node -> Parser a+withSequence f = parseNode $ \n -> case n.content of+  S.SequenceContent _ xs -> f xs+  _ -> typeMismatch "a list" n++-- | The values of the items, with the errors of all items, as with 'mapM'.+-- Unlike 'mapM', the stack does not grow with the number of items, because+-- the errors and the values are in accumulators until the end. A decoder of+-- a list is @withSequence (parseItems parseYaml)@.+parseItems :: forall a. (S.Node -> Parser a) -> [S.Node] -> Parser [a]+parseItems p xs0 = Parser $ \off -> go off NoErrors [] xs0+  where+    go :: S.Offset -> Errors -> [a] -> [S.Node] -> Result [a]+    go off !errs acc = \case+      [] -> case errs of+        NoErrors -> Result NoErrors (reverse acc)+        _ -> Result errs failed+      x : xs ->+        let Parser g = parseNode p x+        in case g off of+             Result e a -> go off (bothErrors errs e) (a : acc) xs++-- | The entries of a mapping. As for 'withText', the tag of a string key does+-- not matter, so two string keys with the same text are an error, e.g. @a@+-- and @!foo a@.+--+-- The comments of the mapping stay with it, not with its first key, e.g. a+-- comment at the top of a file. A record has no place for them.+withMapping :: (Object -> Parser a) -> S.Node -> Parser a+withMapping f = parseNode $ \n -> case n.content of+  S.MappingContent _ kvs -> case mkObject n kvs of+    (NoErrors, o) -> f o+    -- The errors of the fields come with the duplicate keys, and a field+    -- reads the value of the first key.+    (errs, o) ->+      let Parser g = f o+      in Parser $ \off -> case g off of+           Result e _ -> Result (bothErrors errs e) failed+  _ -> typeMismatch "a mapping" n+  where+    -- The object and the errors of its duplicate keys. The index has the+    -- first of equal keys.+    --+    -- A list with linear lookups is faster only for a few keys, and it saves+    -- little of the time to decode a typical record.+    mkObject :: S.Node -> [(S.Node, S.Node)] -> (Errors, Object)+    mkObject n kvs =+      case go M.empty NoErrors [] kvs of+        (index, errs, others) ->+          -- GHC does not know that the fold evaluated the index. Without the+          -- bang, it builds the object in a thunk, so that the index is+          -- evaluated only when the decoder uses the object.+          let !o =+                Object+                  { node = n+                  , entries = kvs+                  , index = index+                  , otherKeys = others+                  , duplicates = case errs of+                      NoErrors -> False+                      _ -> True+                  }+          in (errs, o)+      where+        -- The other keys are in reverse order until the end.+        go+          :: M.Map T.Text (S.Node, S.Node)+          -> Errors+          -> [(S.Node, Value)]+          -> [(S.Node, S.Node)]+          -> (M.Map T.Text (S.Node, S.Node), Errors, [(S.Node, Value)])+        go !m !errs !others = \case+          [] -> (m, errs, reverse others)+          -- With 'view' instead, GHC builds the text of each key again for the+          -- map.+          kv@(k, _) : rest -> case stringValue k of+            Just t -> case M.insertLookupWithKey (\_ _ old -> old) t kv m of+              (Just (first, _), _) ->+                go+                  m+                  ( bothErrors errs $+                      OneError+                        k.offset+                        ("duplicate key " ++ showText t)+                        [(first.offset, "the first key " ++ showText t)]+                  )+                  others+                  rest+              (Nothing, m') -> go m' errs others rest+            Nothing -> case k.content of+              S.ScalarContent style t ->+                go m errs ((k, scalarValue k.props.tag style t) : others) rest+              _ -> go m errs others rest++-- | A mapping with fast access to the values of string keys.+data Object = Object+  { node :: !S.Node+  , entries :: ![(S.Node, S.Node)]+  , index :: !(M.Map T.Text (S.Node, S.Node))+  , otherKeys :: ![(S.Node, Value)]+  -- ^ The scalar keys that are not strings, for the error of a lookup.+  , duplicates :: !Bool+  -- ^ Two string keys have the same text.+  }++-- | The node of the mapping.+objectNode :: Object -> S.Node+objectNode o = o.node++-- | The entries of the mapping in the order of the input.+objectEntries :: Object -> [(S.Node, S.Node)]+objectEntries o = o.entries++-- | The string keys of the mapping in the order of the input.+objectKeys :: Object -> [T.Text]+objectKeys o = [c | (k, _) <- o.entries, Just t <- [stringValue k], let !c = T.copy t]++-- | The value of a key, or 'Nothing' if the key is missing. As for+-- 'parseField', a key with the same text that is not a string, e.g. @404@,+-- is an error, so that its value does not go away.+lookupKey :: Object -> T.Text -> Parser (Maybe S.Node)+lookupKey o key = fmap snd <$> findKey o key++-- | The value of a key. It is an error if the key is missing.+parseField :: FromYaml a => Object -> T.Text -> Parser a+parseField = entryField parseEntry++-- | The value of a key, or 'Nothing' if the key is missing or its value is+-- null.+parseFieldMaybe :: FromYaml a => Object -> T.Text -> Parser (Maybe a)+parseFieldMaybe = entryFieldMaybe parseEntry++-- | The value of a key, or 'Nothing' if the key is missing. Unlike+-- 'parseFieldMaybe', a null value goes to the parser of the value, e.g.+-- @'Maybe' a@ gives @'Just' 'Nothing'@ for a null value.+--+-- >>> :{+-- newtype Limit = Limit (Maybe (Maybe Int))+--   deriving stock (Show)+-- instance FromYaml Limit where+--   parseYaml = withMapping $ \o -> Limit <$> parseFieldIfPresent o "limit"+-- :}+--+-- >>> decodeText @Limit "limit: null\n"+-- Right (Limit (Just Nothing))+--+-- >>> decodeText @Limit "{}"+-- Right (Limit Nothing)+parseFieldIfPresent :: FromYaml a => Object -> T.Text -> Parser (Maybe a)+parseFieldIfPresent = entryFieldIfPresent parseEntry++-- | The value of a key, or the default if the key is missing or its value is+-- null.+--+-- >>> :{+-- newtype Server = Server Int+--   deriving stock (Show)+-- instance FromYaml Server where+--   parseYaml = withMapping $ \o -> Server <$> parseFieldDefault o "port" 80+-- :}+--+-- >>> decodeText @Server "{}"+-- Right (Server 80)+--+-- >>> decodeText @Server "port: null\n"+-- Right (Server 80)+--+-- >>> decodeText @Server "port: 8080\n"+-- Right (Server 8080)+parseFieldDefault :: FromYaml a => Object -> T.Text -> a -> Parser a+parseFieldDefault o key def = fromMaybe def <$> parseFieldMaybe o key++-- | Like 'parseField', with the given parser for the value, e.g. to check a+-- value without a new type for it. The errors of the parser point to the+-- value. The parser gets only the value, so it cannot keep the comments of+-- the key, as a 'Yamlet.Commented' field does with 'parseField'.+--+-- >>> :{+-- newtype Port = Port Int+--   deriving stock (Show)+-- instance FromYaml Port where+--   parseYaml = withMapping $ \o -> Port <$> parseFieldWith number o "port"+--     where+--       number :: Node -> Parser Int+--       number = withInt $ \i ->+--         if i >= 1 && i <= 65535+--           then pure (fromInteger i)+--           else fail "expected a port from 1 to 65535"+-- :}+--+-- >>> decodeText @Port "port: 80\n"+-- Right (Port 80)+--+-- >>> either printErrors print (decodeText @Port "port: 70000\n")+-- input.yaml:1:7: port: expected a port from 1 to 65535+--   |+-- 1 | port: 70000+--   |       ^+parseFieldWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser a+parseFieldWith p = entryField (parseNode p . snd)++-- | Like 'parseFieldMaybe', with the given parser for the value, as in+-- 'parseFieldWith'. The result is 'Nothing' if the key is missing or its+-- value is null. The parser never gets a null value, so a missing key and a+-- null value mean the same.+--+-- >>> :{+-- newtype Job = Job (Maybe Int)+--   deriving stock (Show)+-- instance FromYaml Job where+--   parseYaml = withMapping $ \o -> Job <$> parseFieldMaybeWith positive o "retries"+--     where+--       positive :: Node -> Parser Int+--       positive = withInt $ \i ->+--         if i > 0 then pure (fromInteger i) else fail "expected a positive number"+-- :}+--+-- >>> decodeText @Job "{}"+-- Right (Job Nothing)+--+-- >>> decodeText @Job "retries: null\n"+-- Right (Job Nothing)+--+-- >>> decodeText @Job "retries: 3\n"+-- Right (Job (Just 3))+--+-- To give a null value to the parser, use 'parseFieldIfPresentWith'.+parseFieldMaybeWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser (Maybe a)+parseFieldMaybeWith p = entryFieldMaybe (parseNode p . snd)++-- | Like 'parseFieldIfPresent', with the given parser for the value, as in+-- 'parseFieldWith'. The result is 'Nothing' only if the key is missing.+-- A null value goes to the parser, so the parser can give it a meaning of+-- its own. Here a missing key takes the default limit, and null means no+-- limit:+--+-- >>> :{+-- data Limit = Unlimited | Limit Int+--   deriving stock (Show)+-- newtype Job = Job (Maybe Limit)+--   deriving stock (Show)+-- instance FromYaml Job where+--   parseYaml = withMapping $ \o -> Job <$> parseFieldIfPresentWith limit o "limit"+--     where+--       limit :: Node -> Parser Limit+--       limit n = case view n of+--         NullView -> pure Unlimited+--         _ -> withInt (pure . Limit . fromInteger) n+-- :}+--+-- >>> decodeText @Job "{}"+-- Right (Job Nothing)+--+-- >>> decodeText @Job "limit: null\n"+-- Right (Job (Just Unlimited))+--+-- >>> decodeText @Job "limit: 3\n"+-- Right (Job (Just (Limit 3)))+--+-- With 'parseFieldMaybeWith', the null value would give 'Nothing', the+-- same as the missing key.+parseFieldIfPresentWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser (Maybe a)+parseFieldIfPresentWith p = entryFieldIfPresent (parseNode p . snd)++-- | Like 'parseFieldDefault', with the given parser for the value, as in+-- 'parseFieldWith'. The parser never gets a null value.+--+-- >>> :{+-- newtype Job = Job Int+--   deriving stock (Show)+-- instance FromYaml Job where+--   parseYaml = withMapping $ \o -> Job <$> parseFieldDefaultWith positive o "retries" 1+--     where+--       positive :: Node -> Parser Int+--       positive = withInt $ \i ->+--         if i > 0 then pure (fromInteger i) else fail "expected a positive number"+-- :}+--+-- >>> decodeText @Job "{}"+-- Right (Job 1)+--+-- >>> decodeText @Job "retries: 3\n"+-- Right (Job 3)+parseFieldDefaultWith :: (S.Node -> Parser a) -> Object -> T.Text -> a -> Parser a+parseFieldDefaultWith p o key def = fromMaybe def <$> parseFieldMaybeWith p o key++-- | The value of a key, with the given parser for the entry.+entryField :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser a+entryField p o key = case M.lookup key o.index of+  Just entry -> p entry+  Nothing -> missingKey o key++-- | The value of a key that can be missing or null, with the given parser+-- for the entry.+entryFieldMaybe :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser (Maybe a)+entryFieldMaybe p o key =+  findKey o key >>= \case+    Just (_, v) | isNullNode v -> pure Nothing+    entry -> traverse p entry++-- | The value of a key that can be missing, with the given parser for the+-- entry.+entryFieldIfPresent+  :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser (Maybe a)+entryFieldIfPresent p o key = findKey o key >>= traverse p++-- | The value of an entry, with errors that point to the value.+parseEntry :: FromYaml a => (S.Node, S.Node) -> Parser a+parseEntry (k, v) = parseNode (parseYamlField k) v++-- | The entry of a string key, or 'Nothing' if the key is missing. A key with+-- the same text that is not a string, e.g. 404, is an error, so that its+-- value does not go away. Only the same text counts, e.g. not True for true,+-- because quotes would not make True the key true.+findKey :: Object -> T.Text -> Parser (Maybe (S.Node, S.Node))+findKey o key = case M.lookup key o.index of+  Just entry -> pure (Just entry)+  Nothing -> case L.find (sameText . fst) o.otherKeys of+    Just (k, v) ->+      failAt k $ "the key " ++ showText key ++ " is " ++ describe v ++ ", not a string"+    Nothing -> pure Nothing+  where+    sameText :: S.Node -> Bool+    sameText k = case k.content of+      S.ScalarContent _ t -> t == key+      _ -> False++-- | The error for a key that is not in the index of string keys. As for+-- 'findKey', a key with the same text that is not a string is the error+-- instead.+missingKey :: Object -> T.Text -> Parser a+missingKey o key = Parser $ \off ->+  let Parser g = findKey o key+  in case g off of+       Result NoErrors _+         | M.member "<<" o.index ->+             failure o.node.offset ("missing key " ++ showText key ++ noMergeKeys)+         | otherwise -> failure o.node.offset ("missing key " ++ showText key)+       Result e _ -> Result e failed++-- | Fail at each key that is not in the list. If a key in the list is close+-- to an unknown key, e.g. "host" to "hots", its error suggests it. Otherwise+-- the error lists the known keys. An empty list accepts only an empty+-- mapping, e.g. for a value written as @{}@.+--+-- A key that is not a string, but has the text of a known key, e.g. @true@,+-- is left to the lookup of that key, e.g. 'parseField' or 'lookupKey',+-- which reports it.+rejectUnknownKeys :: [T.Text] -> Object -> Parser ()+rejectUnknownKeys known o+  -- The index has the text of each string key, so the keys are not viewed+  -- again, which saves the allocation of their text in the benchmarks+  -- derive.*.parseYaml.generic. The index has every key if the keys are+  -- strings without duplicates.+  | M.size o.index == length o.entries+      && M.foldlWithKey' (\r k _ -> r && isKnown k) True o.index =+      pure ()+  | otherwise = go True [] o.entries+  where+    -- 'elem' is not specialized to 'T.Text' here, see the Core at -O, so it+    -- compares through the dictionary of 'Eq'.+    isKnown :: T.Text -> Bool+    isKnown t = any (== t) known++    -- The flag tells if no error listed the known keys yet. The list has the+    -- texts of the keys that a lookup reports: for each text, the first key+    -- that is not a string. The keys in a copy of an alias share one offset,+    -- so an offset cannot tell them apart.+    go :: Bool -> [T.Text] -> [(S.Node, S.Node)] -> Parser ()+    go unlisted reported = \case+      [] -> pure ()+      (k, _) : rest -> case stringValue k of+        Just t+          | isKnown t -> go unlisted reported rest+          | t == "<<" -> unknown k t noMergeKeys *> go unlisted reported rest+          | Just s <- closeName known t ->+              unknown k t (didYouMean s) *> go unlisted reported rest+          | unlisted ->+              unknown+                k+                t+                ( if null known+                    then ", the mapping must be empty"+                    else expectedOneOf known+                )+                *> go False reported rest+          | otherwise -> unknown k t "" *> go False reported rest+        _+          | S.ScalarContent _ t <- k.content+          , isKnown t+          , not (M.member t o.index)+          , not (any (== t) reported) ->+              go unlisted (t : reported) rest+          | otherwise ->+              typeMismatch "a string as the key" k *> go unlisted reported rest++    unknown :: S.Node -> T.Text -> String -> Parser ()+    unknown k t hint = failAt k $ "unknown key " ++ showText t ++ hint++-- | The error at the node for a name that is none of the known names, e.g.+-- an unknown value, with the known name that is close to it, or else all+-- known names.+unknownName :: String -> [T.Text] -> S.Node -> T.Text -> Parser a+unknownName what known n t =+  failAt n $ "unknown " ++ what ++ " " ++ showText t ++ hint+  where+    hint :: String+    hint+      | null known = ", no " ++ what ++ " is accepted"+      | otherwise = maybe (expectedOneOf known) didYouMean (closeName known t)++didYouMean :: T.Text -> String+didYouMean s = ", did you mean " ++ showText s ++ "?"++expectedOneOf :: [T.Text] -> String+expectedOneOf known = ", expected one of: " ++ L.intercalate ", " (map T.unpack known)++-- | The known name that is close to the name, e.g. "host" for "hots".+closeName :: [T.Text] -> T.Text -> Maybe T.Text+closeName known t =+  case L.sortOn+    fst+    [ (d, s)+    | s <- known+    , abs (T.length s - n) <= maxEdits+    , let d = distance (T.unpack t) (T.unpack s)+    , d <= maxEdits+    , d < n+    ] of+    (_, s) : _ -> Just s+    [] -> Nothing+  where+    n :: Int+    n = T.length t++    -- A swap of two adjacent characters, e.g. "hots" for "host", takes two+    -- edits. The distance is at least the difference of the lengths, so a+    -- long input from an attacker needs no table of distances.+    maxEdits :: Int+    maxEdits = 2++    -- The Levenshtein distance: the number of characters to insert, delete+    -- or change. After i characters of xs, the row holds the distance from+    -- them to each prefix of ys.+    distance :: String -> String -> Int+    distance xs ys = case reverse (L.foldl' nextRow [0 .. length ys] (zip [1 ..] xs)) of+      d : _ -> d+      [] -> length ys+      where+        nextRow :: [Int] -> (Int, Char) -> [Int]+        nextRow row (i, x) = scanl cell i (zip3 ys row (drop 1 row))+          where+            -- The distances to the left, diagonally above and above.+            cell :: Int -> (Char, Int, Int) -> Int+            cell left (y, diagonal, above) =+              minimum [left + 1, above + 1, diagonal + if x == y then 0 else 1]++----------------------------------------+-- Class++-- | Types that can be parsed from a node. A type with a+-- t'GHC.Generics.Generic' instance can derive the instance via+-- t'Yamlet.Generic.GenericYaml'.+--+-- An instance for a record reads a mapping with 'withMapping':+--+-- >>> :{+-- data Server = Server {host :: T.Text, port :: Int, tags :: [T.Text]}+--   deriving stock (Show)+-- instance FromYaml Server where+--   parseYaml = withMapping $ \o ->+--     rejectUnknownKeys ["host", "port", "tags"] o+--       *> ( Server+--              <$> parseField o "host"+--              <*> parseFieldDefault o "port" 80+--              <*> parseFieldDefault o "tags" []+--          )+-- :}+--+-- >>> decodeText @Server "host: example.com\ntags:\n- web\n"+-- Right (Server {host = "example.com", port = 80, tags = ["web"]})+--+-- The decoder reports the errors of all fields together:+--+-- >>> either printErrors print (decodeText @Server "hots: example.com\nport: http\n")+-- input.yaml:1:1: unknown key "hots", did you mean "host"?+--   |+-- 1 | hots: example.com+--   | ^+-- input.yaml:1:1: missing key "host"+--   |+-- 1 | hots: example.com+--   | ^+-- input.yaml:2:7: port: expected an integer, but got a string+--   |+-- 2 | port: http+--   |       ^+--+-- The instances of the library copy the texts that they keep, so a decoded+-- value does not keep the input in memory. A value from a hand-written+-- instance can keep the input while it has unevaluated parts, e.g. a lazy+-- list. Evaluate such a value, e.g. with 'Control.DeepSeq.force', to release+-- the input.+class FromYaml a where+  parseYaml :: S.Node -> Parser a++  -- | Parse a list. The instance for 'Char' parses a string instead.+  parseYamlList :: S.Node -> Parser [a]+  parseYamlList = withSequence (parseItems parseYaml)++  -- | Parse the value of a mapping entry, with its key, e.g. to keep the+  -- comments of the key as 'Yamlet.Commented' does. 'parseField' and the+  -- other lookups without a parser argument, the derived decoders and the+  -- instances for maps use it. The default ignores the key.+  parseYamlField :: S.Node -> S.Node -> Parser a+  parseYamlField _ = parseYaml++-- | The node of the syntax tree, with its styles and comments, e.g. to write+-- a part of a document back as it was written. An alias in the input gives a+-- copy of the node that it refers to.+--+-- The texts of the node are copies, so that a small part of a document does+-- not keep the whole input alive. For a whole document without a copy, use+-- 'Yamlet.Syntax.parseDocuments'.+instance FromYaml S.Node where+  parseYaml n = pure $! S.copyNode n++-- | The value with the comments of its entry, or of its node if it has no key,+-- copied like every decoded text.+instance FromYaml a => FromYaml (S.Commented a) where+  parseYaml v =+    flip S.Commented (S.copyComments v.comments)+      <$!> parseYaml (S.withComments S.noComments v)+  parseYamlField k v =+    flip+      S.Commented+      ( S.copyComments+          (S.Comments {S.before = before, S.inline = inline, S.after = v.comments.after})+      )+      <$!> parseYaml value+    where+      -- The lines above a value on the line of its key or in the flow style go+      -- above the entry, as the renderer writes them. The lines above the+      -- first entry of a block collection stay in the value, because the+      -- renderer writes them below the key.+      block :: Bool+      block = case v.content of+        S.SequenceContent S.Block (_ : _) -> True+        S.MappingContent S.Block (_ : _) -> True+        _ -> False++      above :: [S.Line]+      above = k.comments.before ++ if block then [] else v.comments.before++      -- A line has one comment at its end. With an explicit key, both nodes+      -- can have one, and the renderer writes the comment of the key above.+      before :: [S.Line]+      inline :: Maybe T.Text+      (before, inline) = case (k.comments.inline, v.comments.inline) of+        (Just kc, Just vc) -> (above ++ [S.Comment kc], Just vc)+        (kc, vc) -> (above, vc <|> kc)++      -- The value without the comments of the entry.+      value :: S.Node+      value =+        let rest =+              S.Comments+                { S.before = if block then v.comments.before else []+                , S.inline = Nothing+                , S.after = []+                }+        in S.withComments rest v++-- | The value with the offset of its node. The key of an entry goes to the+-- value inside, e.g. for a 'Yamlet.Commented' value.+instance FromYaml a => FromYaml (S.Located a) where+  parseYaml n = flip S.Located n.offset <$!> parseYaml n+  parseYamlField k n = flip S.Located n.offset <$!> parseYamlField k n++-- | The value of the node, with the tags resolved and the aliases replaced.+instance FromYaml Value where+  parseYaml n = case representPrepared n of+    -- The value is built lazily. The copy visits a node once per alias of+    -- it, as the limit of 'prepareWithin' allows.+    Right r -> pure $! copy r+    Left ((off, msg) NE.:| notes) -> Parser $ \_ -> Result (OneError off msg notes) failed+    where+      -- The value in normal form, with copies of its texts.+      copy :: Value -> Value+      copy = \case+        String t -> String (T.copy t)+        Sequence xs -> Sequence (strictMap copy xs)+        Mapping kvs -> Mapping (strictMap (\(k, v) -> strictPair (copy k) (copy v)) kvs)+        Tagged tag v -> Tagged (T.copy tag) (copy v)+        v -> v++-- | An empty list, as a tuple without elements.+instance FromYaml () where+  parseYaml = parseNode $ \n -> case view n of+    SequenceView [] -> pure ()+    _ -> typeMismatch "an empty list" n++instance FromYaml Bool where+  parseYaml = withBool pure++instance FromYaml Integer where+  parseYaml = withInt pure++instance FromYaml Natural where+  parseYaml = withInt $ \i ->+    if i < 0+      then fail "expected a non-negative integer"+      else pure (fromInteger i)++instance FromYaml Int where parseYaml = bounded+instance FromYaml Int8 where parseYaml = bounded+instance FromYaml Int16 where parseYaml = bounded+instance FromYaml Int32 where parseYaml = bounded+instance FromYaml Int64 where parseYaml = bounded+instance FromYaml Word where parseYaml = bounded+instance FromYaml Word8 where parseYaml = bounded+instance FromYaml Word16 where parseYaml = bounded+instance FromYaml Word32 where parseYaml = bounded+instance FromYaml Word64 where parseYaml = bounded++-- | An integer in the range of a bounded type.+bounded :: forall a. (Bounded a, Integral a) => S.Node -> Parser a+bounded = withInt $ \i ->+  if i < toInteger (minBound @a) || i > toInteger (maxBound @a)+    then+      fail $+        "the integer is out of the range from "+          ++ show (toInteger (minBound @a))+          ++ " to "+          ++ show (toInteger (maxBound @a))+    else pure (fromInteger i)++instance FromYaml Double where+  parseYaml = withFloat pure++instance FromYaml Sci.Scientific where+  parseYaml = withScientific pure++-- | @YYYY-MM-DD@, e.g. @2026-09-25@. The year has at most 15 digits, here and+-- in the other types with a date.+instance FromYaml Day where+  parseYaml = withIso8601 "expected a date such as 2026-09-25" parseDay++-- | @HH:MM@, with optional seconds and a fraction of a second of at most 12+-- digits, e.g. @12:30:05.25@.+instance FromYaml TimeOfDay where+  parseYaml = withIso8601 "expected a time such as 12:30:00" parseTimeOfDay++-- | A date and a time, separated by @T@ or a space, e.g.+-- @2026-09-25T12:30:00@.+instance FromYaml LocalTime where+  parseYaml =+    withIso8601 "expected a date and a time such as 2026-09-25T12:30:00" parseLocalTime++-- | A date, a time and a time zone, e.g. @2026-09-25T12:30:00+02:00@. The+-- time zone is @Z@, @+HH:MM@, @+HHMM@ or @+HH@.+instance FromYaml ZonedTime where+  parseYaml = withIso8601 zonedTimeMismatch parseZonedTime++-- | Like t'ZonedTime', converted to UTC.+instance FromYaml UTCTime where+  parseYaml = withIso8601 zonedTimeMismatch parseUTCTime++-- | A number of seconds, rounded down to a picosecond.+instance FromYaml NominalDiffTime where+  parseYaml = withScientific $ pure . secondsToNominalDiffTime . MkFixed . picoseconds++-- | A number of seconds, rounded down to a picosecond.+instance FromYaml DiffTime where+  parseYaml = withScientific $ pure . picosecondsToDiffTime . picoseconds++-- | The text form with hyphens, e.g. @123e4567-e89b-12d3-a456-426614174000@.+instance FromYaml UUID.UUID where+  parseYaml =+    withText $+      maybe (fail "expected a UUID such as 123e4567-e89b-12d3-a456-426614174000") pure+        . UUID.fromText++-- | @YYYY-MM@, e.g. @2026-09@.+instance FromYaml Month where+  parseYaml = withIso8601 "expected a month such as 2026-09" parseMonth++-- | @YYYY-qN@, e.g. @2026-q3@.+instance FromYaml Quarter where+  parseYaml = withIso8601 "expected a quarter such as 2026-q3" parseQuarter++-- | @q1@ to @q4@.+instance FromYaml QuarterOfYear where+  parseYaml = withIso8601 "expected a quarter of a year such as q3" parseQuarterOfYear++-- | The English name in any case, e.g. @monday@.+instance FromYaml DayOfWeek where+  parseYaml = withText $ \t ->+    maybe (fail "expected a day of the week such as monday") pure $+      lookup (T.toLower t) [(T.toLower (T.pack (show d)), d) | d <- [Monday .. Sunday]]++-- | A mapping with the keys @months@ and @days@, e.g. @{months: 1, days: 2}@.+instance FromYaml CalendarDiffDays where+  parseYaml = withMapping $ \o ->+    rejectUnknownKeys ["months", "days"] o+      *> (CalendarDiffDays <$> parseField o "months" <*> parseField o "days")++-- | A mapping with the keys @months@ and @time@, a number of seconds, e.g.+-- @{months: 1, time: 1.5}@.+instance FromYaml CalendarDiffTime where+  parseYaml = withMapping $ \o ->+    rejectUnknownKeys ["months", "time"] o+      *> (CalendarDiffTime <$> parseField o "months" <*> parseField o "time")++zonedTimeMismatch :: String+zonedTimeMismatch = "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"++-- | A string in an ISO 8601 format, with the same rules as aeson.+withIso8601 :: String -> (T.Text -> Either String a) -> S.Node -> Parser a+withIso8601 mismatch p = withText $ either (const (fail mismatch)) pure . p++-- | The picoseconds in a number of seconds, rounded down.+picoseconds :: Sci.Scientific -> Integer+picoseconds s+  | k >= 0 = c * 10 ^ k+  | otherwise = c `div` 10 ^ negate k+  where+    c :: Integer+    c = Sci.coefficient s++    k :: Integer+    k = toInteger (Sci.base10Exponent s) + toInteger picoDecimals++-- | The nearest float. A conversion by way of 'Double' could round twice.+instance FromYaml Float where+  parseYaml = withRealFloat pure++instance FromYaml T.Text where+  parseYaml = withText pure++instance FromYaml TL.Text where+  parseYaml = withText (pure . TL.fromStrict)++instance FromYaml Char where+  parseYaml = withText $ \t -> case T.unpack t of+    [c] -> pure c+    _ -> fail "expected a single character"+  parseYamlList = withText (pure . T.unpack)++instance FromYaml a => FromYaml [a] where+  parseYaml = parseYamlList++instance FromYaml a => FromYaml (NE.NonEmpty a) where+  parseYaml = withSequence $ \case+    [] -> fail "expected a non-empty list"+    x : xs -> (NE.:|) <$> parseNode parseYaml x <*> parseItems parseYaml xs++-- | Null is 'Nothing'. The key of an entry goes to the value inside, e.g. for+-- a 'Yamlet.Commented' value.+--+-- >>> decodeText @[Maybe Int] "- 1\n- null\n- ~\n-\n"+-- Right [Just 1,Nothing,Nothing,Nothing]+instance FromYaml a => FromYaml (Maybe a) where+  parseYaml n = case view n of+    NullView -> pure Nothing+    _ -> Just <$> parseYaml n+  parseYamlField k n = case view n of+    NullView -> pure Nothing+    _ -> Just <$> parseYamlField k n++-- | Two keys that convert to the same key, e.g. @1@ and @1.0@ for 'Double',+-- are an error.+--+-- Each key decodes with the instance of its type, so a map with+-- t'Data.Text.Text' keys rejects a key such as @404@ or @true@, because YAML+-- reads it as an integer or a boolean. Quote such a key in the input, e.g.+-- @\"404\": not found@, or use a key type that matches it, e.g. t'Int'.+--+-- >>> decodeText @(M.Map Int T.Text) "404: not found\n"+-- Right (fromList [(404,"not found")])+--+-- >>> either printErrors print (decodeText @(M.Map T.Text T.Text) "404: not found\n")+-- input.yaml:1:1: expected a string, but got an integer, quote the value, e.g. '404'+--   |+-- 1 | 404: not found+--   | ^+instance (Ord k, FromYaml k, FromYaml v) => FromYaml (M.Map k v) where+  parseYaml = uniqueEntries M.alterF M.empty++-- | Two keys that convert to the same key are an error.+instance FromYaml v => FromYaml (IM.IntMap v) where+  parseYaml = uniqueEntries IM.alterF IM.empty++-- | A list. Two elements that convert to the same value, e.g. @1@ and @1.0@+-- for 'Double', are an error.+instance (Ord a, FromYaml a) => FromYaml (Set.Set a) where+  parseYaml =+    withSequence $+      insertUnique+        id+        (parseNode parseYaml)+        id+        (Set.alterF (,True))+        Set.empty+        ("duplicate element" ++)+        ("the first element" ++)++-- | A list. Two elements that convert to the same value, e.g. @1@ and @0x1@,+-- are an error.+instance FromYaml IS.IntSet where+  parseYaml =+    withSequence $+      insertUnique+        id+        (parseNode parseYaml)+        id+        (IS.alterF (,True))+        IS.empty+        ("duplicate element" ++)+        ("the first element" ++)++-- | A map from the entries of a mapping, with the alter function and the empty+-- map of its type. Two keys that convert to the same key are an error.+uniqueEntries+  :: (Ord k, FromYaml k, FromYaml v)+  => ((Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m)) -> m -> S.Node -> Parser m+uniqueEntries alter none = parseNode $ \n -> case n.content of+  -- The index of 'withMapping' would be of no use here.+  S.MappingContent _ kvs ->+    insertUnique+      fst+      entry+      fst+      (\(k, v) -> alter (\old -> (isJust old, old <|> Just v)) k)+      none+      (\t -> "duplicate key" ++ t ++ " after conversion")+      ("the first key" ++)+      kvs+  _ -> typeMismatch "a mapping" n+  where+    entry :: (FromYaml k, FromYaml v) => (S.Node, S.Node) -> Parser (k, v)+    entry (k, v) = (,) <$> parseNode parseYaml k <*> parseEntry (k, v)++-- | Decode the items and insert them in their order, with the errors of all+-- items. Each item that is already there is an error at its node, with the+-- note at the first equal item. The message and the note get the text of+-- their scalar after a space, or nothing for a collection. The insert tells+-- if the item was there, and the key tells which items are equal.+insertUnique+  :: forall a x s c+   . Ord c+  => (a -> S.Node)+  -> (a -> Parser x)+  -> (x -> c)+  -> (x -> s -> (Bool, s))+  -> s+  -> (String -> String)+  -> (String -> String)+  -> [a]+  -> Parser s+insertUnique node item key insert start msg note xs =+  Parser $ \off -> go off start NoErrors [] [] 0 xs+  where+    -- The duplicates and the positions of the failed items are in reverse.+    -- The items in a copy of an alias share one offset, so an offset cannot+    -- tell the failed items apart.+    go :: S.Offset -> s -> Errors -> [(c, S.Node)] -> [Int] -> Int -> [a] -> Result s+    go off !acc errs dups fails !i = \case+      [] -> case (errs, dups) of+        (NoErrors, []) -> Result NoErrors acc+        _ ->+          Result+            (L.foldl' bothErrors errs (map (duplicateError (firsts off fails)) dups))+            failed+      a : rest ->+        let Parser p = item a+        in case p off of+             Result NoErrors x -> case insert x acc of+               (False, acc') -> go off acc' errs dups fails (i + 1) rest+               (True, acc') -> go off acc' errs ((key x, node a) : dups) fails (i + 1) rest+             Result e _ ->+               go off acc (bothErrors errs e) dups (i : fails) (i + 1) rest++    duplicateError :: M.Map c S.Node -> (c, S.Node) -> Errors+    duplicateError fs (c, n) =+      OneError+        n.offset+        (msg (text n))+        [(first.offset, note (text first)) | Just first <- [M.lookup c fs]]++    text :: S.Node -> String+    text = maybe "" (' ' :) . inputText++    -- A second pass finds the first items, only if there are duplicates. It+    -- skips the failed items, because an item with a duplicate inside would+    -- decode its own items twice again, which doubles the time with each+    -- level of nesting.+    firsts :: S.Offset -> [Int] -> M.Map c S.Node+    firsts off fails =+      M.fromListWith+        (\_ old -> old)+        [ (key x, node a)+        | (i, a) <- zip [0 ..] xs+        , not (i `IS.member` failedSet)+        , let Parser p = item a+        , Result NoErrors x <- [p off]+        ]+      where+        failedSet :: IS.IntSet+        failedSet = IS.fromList fails++instance FromYaml a => FromYaml (Seq.Seq a) where+  parseYaml = withSequence (fmap Seq.fromList . parseItems parseYaml)++-- | A list of the label and the subtrees, e.g. @[a, [[b, []]]]@.+instance FromYaml a => FromYaml (Tree.Tree a) where+  parseYaml = fmap (uncurry Tree.Node) . parseYaml++-- | @LT@, @EQ@ or @GT@.+instance FromYaml Ordering where+  parseYaml = withText $ \case+    "LT" -> pure LT+    "EQ" -> pure EQ+    "GT" -> pure GT+    _ -> fail "expected LT, EQ or GT"++instance FromYaml Void where+  parseYaml _ = fail "the type Void has no values"++-- | A mapping with the keys @numerator@ and @denominator@, e.g.+-- @{numerator: 1, denominator: 3}@.+instance (Integral a, FromYaml a) => FromYaml (Ratio a) where+  parseYaml = withMapping $ \o -> do+    (n, d) <-+      rejectUnknownKeys ["numerator", "denominator"] o+        *> ( (,)+               <$> parseField @a o "numerator"+               <*> parseFieldWith nonZero o "denominator"+           )+    -- The reduction happens in Integer, where the gcd is fast. For another+    -- type, the gcd takes quadratic time in the number of digits, and in a+    -- bounded type, a negation can overflow, e.g. of minBound.+    let r = toInteger n % toInteger d+        fits :: Integer -> Bool+        fits x = toInteger (fromInteger @a x) == x+    if fits (numerator r) && fits (denominator r)+      then pure (fromInteger (numerator r) :% fromInteger (denominator r))+      else fail "the fraction is out of the range of the type"+    where+      nonZero :: S.Node -> Parser a+      nonZero n = do+        d <- parseYaml n+        d <$ when (d == 0) (fail "the denominator is 0")++-- | A number that is a multiple of the step of the type, e.g. @1.25@ for+-- 'Centi'. A number with more digits after the point is an error, not a+-- rounded value.+--+-- If the resolution is not a product of 2s and 5s, e.g. 3, most multiples of+-- the step have no decimal form, so they cannot come from YAML. For such a+-- resolution, use 'Rational' instead.+instance HasResolution a => FromYaml (Fixed a) where+  parseYaml = withScientific $ \s ->+    let scaled = s * fromInteger res+    in if Sci.isInteger scaled+         then pure (MkFixed (truncate scaled))+         else fail $ "expected a multiple of " ++ step+    where+      res :: Integer+      res = resolution (Proxy @a)++      -- 'show' rounds the step to the number of digits of the resolution, e.g.+      -- 0.03 for 1/40 and 0.4 for 1/3.+      step :: String+      step = case decimalPlaces res of+        Just places ->+          Sci.formatScientific+            Sci.Fixed+            (Just places)+            (Sci.scientific (10 ^ places `div` res) (negate places))+        Nothing -> "1/" ++ show res++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Identity a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Const a b)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Down a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Min a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Max a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.First a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Last a)++-- | The value inside, or null for 'Nothing'.+deriving newtype instance FromYaml a => FromYaml (Mon.First a)++-- | The value inside, or null for 'Nothing'.+deriving newtype instance FromYaml a => FromYaml (Mon.Last a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Dual a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Sum a)++-- | The value inside.+deriving newtype instance FromYaml a => FromYaml (Sem.Product a)++-- | The value inside.+deriving newtype instance FromYaml Sem.All++-- | The value inside.+deriving newtype instance FromYaml Sem.Any++-- | A mapping with one key, @Left@ or @Right@, e.g. @{Left: 1}@.+--+-- >>> decodeText @(Either Int T.Text) "Left: 1\n"+-- Right (Left 1)+instance (FromYaml a, FromYaml b) => FromYaml (Either a b) where+  parseYaml = withMapping $ \o -> case objectEntries o of+    [(k, v)] -> case stringValue k of+      Just "Left" -> Left <$> parseEntry (k, v)+      Just "Right" -> Right <$> parseEntry (k, v)+      _ -> failAt k "expected the key Left or Right"+    _ -> fail "expected a mapping with one key, Left or Right"++instance (FromYaml a1, FromYaml a2) => FromYaml (a1, a2) where+  parseYaml = withSequence $ \case+    [a1, a2] -> (,) <$> element a1 <*> element a2+    xs -> tupleSize 2 xs++instance (FromYaml a1, FromYaml a2, FromYaml a3) => FromYaml (a1, a2, a3) where+  parseYaml = withSequence $ \case+    [a1, a2, a3] -> (,,) <$> element a1 <*> element a2 <*> element a3+    xs -> tupleSize 3 xs++instance+  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4)+  => FromYaml (a1, a2, a3, a4)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4] -> (,,,) <$> element a1 <*> element a2 <*> element a3 <*> element a4+    xs -> tupleSize 4 xs++instance+  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4, FromYaml a5)+  => FromYaml (a1, a2, a3, a4, a5)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5] ->+      (,,,,) <$> element a1 <*> element a2 <*> element a3 <*> element a4 <*> element a5+    xs -> tupleSize 5 xs++instance+  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4, FromYaml a5, FromYaml a6)+  => FromYaml (a1, a2, a3, a4, a5, a6)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5, a6] ->+      (,,,,,)+        <$> element a1+        <*> element a2+        <*> element a3+        <*> element a4+        <*> element a5+        <*> element a6+    xs -> tupleSize 6 xs++instance+  ( FromYaml a1+  , FromYaml a2+  , FromYaml a3+  , FromYaml a4+  , FromYaml a5+  , FromYaml a6+  , FromYaml a7+  )+  => FromYaml (a1, a2, a3, a4, a5, a6, a7)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5, a6, a7] ->+      (,,,,,,)+        <$> element a1+        <*> element a2+        <*> element a3+        <*> element a4+        <*> element a5+        <*> element a6+        <*> element a7+    xs -> tupleSize 7 xs++instance+  ( FromYaml a1+  , FromYaml a2+  , FromYaml a3+  , FromYaml a4+  , FromYaml a5+  , FromYaml a6+  , FromYaml a7+  , FromYaml a8+  )+  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5, a6, a7, a8] ->+      (,,,,,,,)+        <$> element a1+        <*> element a2+        <*> element a3+        <*> element a4+        <*> element a5+        <*> element a6+        <*> element a7+        <*> element a8+    xs -> tupleSize 8 xs++instance+  ( FromYaml a1+  , FromYaml a2+  , FromYaml a3+  , FromYaml a4+  , FromYaml a5+  , FromYaml a6+  , FromYaml a7+  , FromYaml a8+  , FromYaml a9+  )+  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5, a6, a7, a8, a9] ->+      (,,,,,,,,)+        <$> element a1+        <*> element a2+        <*> element a3+        <*> element a4+        <*> element a5+        <*> element a6+        <*> element a7+        <*> element a8+        <*> element a9+    xs -> tupleSize 9 xs++instance+  ( FromYaml a1+  , FromYaml a2+  , FromYaml a3+  , FromYaml a4+  , FromYaml a5+  , FromYaml a6+  , FromYaml a7+  , FromYaml a8+  , FromYaml a9+  , FromYaml a10+  )+  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+  where+  parseYaml = withSequence $ \case+    [a1, a2, a3, a4, a5, a6, a7, a8, a9, a10] ->+      (,,,,,,,,,)+        <$> element a1+        <*> element a2+        <*> element a3+        <*> element a4+        <*> element a5+        <*> element a6+        <*> element a7+        <*> element a8+        <*> element a9+        <*> element a10+    xs -> tupleSize 10 xs++-- | An element of a tuple.+element :: FromYaml a => S.Node -> Parser a+element = parseNode parseYaml++-- | The error for a list with the wrong number of elements for a tuple.+tupleSize :: Int -> [S.Node] -> Parser a+tupleSize n xs =+  fail $ "expected a list of " ++ show n ++ " elements, but got " ++ show (length xs)++-- $setup+-- >>> import Yamlet+-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")
+ src/Yamlet/Internal/Input.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Detection of the encoding of the input.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Input+  ( decodeInput+  ) where++import Data.Bits+import Data.ByteString qualified as BS+import Data.ByteString.Unsafe qualified as BS+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Data.Text.Unsafe qualified as T++import Yamlet.Error+import Yamlet.Internal.Syntax+import Yamlet.Internal.Utils++-- | Decode the bytes of a stream to text. The encoding is UTF-8, UTF-16 or+-- UTF-32, detected as the YAML specification describes.+decodeInput :: BS.ByteString -> Either Error T.Text+decodeInput bs = case map (BS.indexMaybe bs) [0 .. 3] of+  [Just 0, Just 0, Just 0xFE, Just 0xFF] -> utf32 T.decodeUtf32BEWith be32 (BS.drop 4 bs)+  [Just 0xFF, Just 0xFE, Just 0, Just 0] -> utf32 T.decodeUtf32LEWith le32 (BS.drop 4 bs)+  [Just 0xFE, Just 0xFF, _, _] -> utf16 T.decodeUtf16BEWith be16 (BS.drop 2 bs)+  [Just 0xFF, Just 0xFE, _, _] -> utf16 T.decodeUtf16LEWith le16 (BS.drop 2 bs)+  [Just 0, Just 0, Just 0, Just _] -> utf32 T.decodeUtf32BEWith be32 bs+  [Just x, Just 0, Just 0, Just 0] | x /= 0 -> utf32 T.decodeUtf32LEWith le32 bs+  Just 0 : Just _ : _ -> utf16 T.decodeUtf16BEWith be16 bs+  Just x : Just 0 : _ | x /= 0 -> utf16 T.decodeUtf16LEWith le16 bs+  _ -> utf8+  where+    utf32+      :: (T.OnDecodeError -> BS.ByteString -> T.Text)+      -> (BS.ByteString -> Int -> Int)+      -> BS.ByteString+      -> Either Error T.Text+    utf32 decodeWith unit input = checked "invalid UTF-32" decodeWith input (go 0)+      where+        go :: Int -> Int+        go i+          | i + 4 > BS.length input = i+          | isScalarValue c = go (i + 4)+          | otherwise = i+          where+            c :: Int+            c = unit input i+    -- Inlining gives a loop for each reading function. Without it, the decode+    -- of a large UTF-32 input was slower and allocated more.+    {-# INLINE utf32 #-}++    utf16+      :: (T.OnDecodeError -> BS.ByteString -> T.Text)+      -> (BS.ByteString -> Int -> Int)+      -> BS.ByteString+      -> Either Error T.Text+    utf16 decodeWith unit input = checked "invalid UTF-16" decodeWith input (go 0)+      where+        go :: Int -> Int+        go i+          | i + 2 > BS.length input = i+          | isHighSurrogate u =+              if i + 4 <= BS.length input && isLowSurrogate (unit input (i + 2))+                then go (i + 4)+                else i+          | isLowSurrogate u = i+          | otherwise = go (i + 2)+          where+            u :: Int+            u = unit input i+    -- Inlining gives a loop for each reading function. Without it, the decode+    -- of a large UTF-16 input was slower and allocated more.+    {-# INLINE utf16 #-}++    -- The code unit at the index. The callers make sure that its bytes are in+    -- the input.+    be16, le16, be32, le32 :: BS.ByteString -> Int -> Int+    be16 input i = byte input i `shiftL` 8 .|. byte input (i + 1)+    le16 input i = byte input (i + 1) `shiftL` 8 .|. byte input i+    be32 input i = be16 input i `shiftL` 16 .|. be16 input (i + 2)+    le32 input i = le16 input (i + 2) `shiftL` 16 .|. le16 input i++    byte :: BS.ByteString -> Int -> Int+    byte input i = fromIntegral (BS.unsafeIndex input i)++    -- The text, or an error at the end of the valid prefix of the given length.+    checked+      :: String+      -> (T.OnDecodeError -> BS.ByteString -> T.Text)+      -> BS.ByteString+      -> Int+      -> Either Error T.Text+    checked msg decodeWith input valid+      | valid == BS.length input = Right $ decodeWith T.lenientDecode input+      | otherwise = Left $ errorAt prefix (Offset (T.lengthWord8 prefix)) msg+      where+        prefix :: T.Text+        prefix = decodeWith T.lenientDecode (BS.take valid input)++    utf8 :: Either Error T.Text+    utf8 = case T.decodeUtf8' bs of+      Right t -> Right t+      Left _ ->+        -- The length of the longest valid prefix.+        let valid = fst (T.validateUtf8Chunk bs)+            prefix = T.decodeUtf8 (BS.take valid bs)+        in Left $ errorAt prefix (Offset valid) "invalid UTF-8"
+ src/Yamlet/Internal/Parser.hs view
@@ -0,0 +1,1992 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The parser of YAML 1.2.2 streams.+--+-- The functions follow the productions of the specification and keep their+-- names, e.g. @nsFlowNode@ implements @ns-flow-node(n,c)@. A few productions+-- are fused into loops over the bytes of the input for speed. Each production+-- is a top-level function, also if only one function uses it, so that the+-- parser reads like the grammar of the specification.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Parser+  ( parseStream++    -- * Block scalars+  , BlockLine (..)+  , foldedText+  ) where++import Control.Monad+import Data.ByteString qualified as BS+import Data.Char+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Text.Encoding qualified as T+import Data.Text.Internal qualified as T+import Data.Text.Unsafe qualified as T+import Data.Word++import Yamlet.Error+import Yamlet.Internal.Chars+import Yamlet.Internal.Comments+import Yamlet.Internal.Parser.Hints+import Yamlet.Internal.Parser.Monad+import Yamlet.Internal.Parser.Scan+import Yamlet.Internal.Syntax hiding (document)+import Yamlet.Internal.Utils++-- | A character that only some places of a stream can contain, with its+-- index.+data Restricted+  = -- | A byte order mark, with a flag that is true if the mark is at the+    -- start of a line, as 'isStartOfLine' tells.+    BomRestricted !Int !Bool+  | -- | A character that only a quoted scalar can contain.+    QuotedRestricted !Int++-- | Parse all documents of a stream.+parseStream :: T.Text -> Either Error [Document]+parseStream input@(T.Text arr off len) = case prescan of+  Left i -> Left $ invalidCharacter i+  Right (markers, restricted) -> case runParser e start (lYamlStream markers) of+    Left (ParseError i msg) -> Left $ parseError markers restricted i msg+    Left (UnexpectedParseError de i) ->+      Left $ uncurry (parseError markers restricted) (furthestError markers de i)+    Right (Just docs, _, _) ->+      let ranges = scalarRanges docs+      in case filter (not . allowed ranges) restricted of+           BomRestricted i _ : _ ->+             Left $ errorAt input (toOffset e i) "unexpected byte order mark"+           QuotedRestricted i : _ -> Left $ invalidCharacter i+           [] -> Right docs+    Right (Nothing, _, fu) ->+      Left $ uncurry (parseError markers restricted) (furthestError markers e fu)+  where+    invalidCharacter :: Int -> Error+    invalidCharacter i =+      errorAt+        input+        (toOffset e i)+        ("invalid character " ++ codePointName (T.head (slice e i e.end)))++    -- The error for the furthest failure, with the environment of its+    -- document. A tab before the failure on its line is the likely cause,+    -- unless the parser fails there also with spaces in place of the tabs:+    -- a space for each tab, or the indentation of the line above in place+    -- of the indentation with tabs.+    furthestError :: [Int] -> Env -> Int -> (Int, String)+    furthestError markers de i = case unexpected de i of+      (Just tab, _) | tabCause -> (tab, tabMessage)+      (_, other)+        | Just tab <- tabAbove+        , parsesPast+            markers+            (lineEndAt e i)+            blankStart+            (withSpaces (T.Text arr blankStart (s - blankStart)))+            s ->+            (tab, tabMessage)+        | otherwise -> other+      where+        tabCause :: Bool+        tabCause =+          parsesPast markers i s (withSpaces (T.Text arr s (i - s))) i+            || or+              [ parsesPast markers i s (T.replicate n " ") indentEnd+              | indentEnd <= i+              , isJust (firstTab e s indentEnd)+              , Just above <- [contentLineAbove e s]+              , let n = skipSpaces e above - above+              ]++        s, indentEnd :: Int+        s = lineStartAt e i+        indentEnd = skipWhites e s++        -- A blank line or a comment line with a tab can end a scalar above+        -- it, as in "|\n  a\n\t\n  b", so that the parser fails on the next+        -- line. The tab is the cause if the line parses with spaces.+        blankStart :: Int+        blankStart = maybe s (nextLineStart e) (contentLineAbove e s)++        tabAbove :: Maybe Int+        tabAbove =+          listToMaybe+            [ tab+            | l <- takeWhile (< s) (iterate (nextLineStart e) blankStart)+            , Just tab <- [firstTab e l (skipWhites e l)]+            ]++        withSpaces :: T.Text -> T.Text+        withSpaces = T.map (\c -> if c == '\t' then ' ' else c)++    -- The parser gets past the first index with the text in place of the+    -- input from the second index to the third.+    parsesPast :: [Int] -> Int -> Int -> T.Text -> Int -> Bool+    parsesPast markers target from replacement upto =+      case runParser spaced (moved start) (lYamlStream (map moved markers)) of+        Left (ParseError j _) -> j > moved target+        Left (UnexpectedParseError _ j) -> j > moved target+        Right (Nothing, _, j) -> j > moved target+        Right (Just _, _, _) -> True+      where+        T.Text _ _ replacementLen = replacement+        T.Text spacedArr spacedOff spacedLen =+          T.copy $+            T.concat+              [ T.Text arr off (from - off)+              , replacement+              , T.Text arr upto (off + len - upto)+              ]++        spaced :: Env+        spaced =+          e+            { array = spacedArr+            , base = spacedOff+            , end = spacedOff + spacedLen+            , streamEnd = spacedOff + spacedLen+            }++        -- The index in the input with the replacement.+        moved :: Int -> Int+        moved j+          | j < upto = j - off + spacedOff+          | otherwise = j - upto + spacedOff + (from - off) + replacementLen++    -- A byte order mark at the start of the line of an error is the likely+    -- cause if the parser fails before the content of the line, unless a+    -- document without a marker can start on the line. The mark can also be+    -- a character of a quoted scalar, so it is the cause only if the parser+    -- gets past the error without it.+    parseError :: [Int] -> [Restricted] -> Int -> String -> Error+    parseError markers restricted i msg+      | any (\case QuotedRestricted j -> j == i; _ -> False) restricted =+          invalidCharacter i+      | let s = lineStartAt e i+      , bomBeforeContent e s+      , i <= skipWhites e (skipBoms e s)+      , not (inPrefix s)+      , parsesPast markers i s T.empty (skipBoms e s) =+          errorAt input (toOffset e s) "unexpected byte order mark"+      | otherwise = errorAt input (toOffset e i) msg++    -- Only empty lines and comment lines are between the start of the line+    -- and the start of the stream or a @...@ marker, so the line is in the+    -- prefix of a document, which can start with a byte order mark.+    inPrefix :: Int -> Bool+    inPrefix s = maybe True (isEndMarker e . skipBoms e) (contentLineAbove e s)++    -- A byte order mark can start a line between documents, or be a+    -- character of a quoted scalar. The other restricted characters can only+    -- be characters of a quoted scalar.+    allowed :: M.Map Offset (Offset, Bool) -> Restricted -> Bool+    allowed ranges = \case+      BomRestricted i lineStart -> fromMaybe lineStart (inScalar i)+      QuotedRestricted i -> inScalar i == Just True+      where+        -- Whether the scalar that contains the index is quoted, if a scalar+        -- contains it.+        inScalar :: Int -> Maybe Bool+        inScalar i = case M.lookupLE (toOffset e i) ranges of+          Just (_, (end, quoted)) | toOffset e i < end -> Just quoted+          _ -> Nothing++    scalarRanges :: [Document] -> M.Map Offset (Offset, Bool)+    scalarRanges docs = M.fromList (foldr (\d -> ranges d.root) [] docs)+      where+        ranges :: Node -> [(Offset, (Offset, Bool))] -> [(Offset, (Offset, Bool))]+        ranges n acc = case n.content of+          ScalarContent style _ ->+            (n.offset, (n.endOffset, style == SingleQuoted || style == DoubleQuoted))+              : acc+          SequenceContent _ xs -> foldr ranges acc xs+          MappingContent _ kvs -> foldr (\(k, v) -> ranges k . ranges v) acc kvs+          AliasContent _ -> acc++    e :: Env+    e =+      Env+        { array = arr+        , base = off+        , end = off + len+        , streamEnd = off + len+        , handles = defaultHandles+        }++    start :: Int+    start = streamStart e++    -- Check that the input has only characters that YAML allows, and find+    -- the lines that start with a document marker, and the restricted+    -- characters. A document cannot contain such a line. A marker after a+    -- byte order mark does not count: a quoted scalar can contain the line,+    -- and other nodes end at the mark anyway. Return the index of an invalid+    -- character on error.+    prescan :: Either Int ([Int], [Restricted])+    prescan = go start start [start | isMarker e start] []+      where+        -- A byte order mark at index ls is at the start of a line.+        go :: Int -> Int -> [Int] -> [Restricted] -> Either Int ([Int], [Restricted])+        go i ls acc rs+          | i >= e.end = Right (reverse acc, reverse rs)+          | otherwise =+              let w = A.unsafeIndex e.array i+              in if+                   | w >= SPACE && w < DEL -> go (i + 1) ls acc rs+                   | w == LF || (w == CR && byteAt e (i + 1) /= LF) ->+                       let s = i + 1+                       in go s s (if isMarker e s then s : acc else acc) rs+                   | w == CR || w == TAB -> go (i + 1) ls acc rs+                   | w < SPACE -> Left i+                   | w == DEL -> go (i + 1) ls acc (QuotedRestricted i : rs)+                   -- C1 control characters except NEL.+                   | w == 0xC2 && i + 1 < e.end+                   , let w1 = A.unsafeIndex e.array (i + 1)+                   , w1 >= 0x80 && w1 <= 0x9F && w1 /= 0x85 ->+                       go (i + 1) ls acc (QuotedRestricted i : rs)+                   -- U+FFFE and U+FFFF.+                   | w == 0xEF && i + 2 < e.end+                   , A.unsafeIndex e.array (i + 1) == 0xBF+                   , let w2 = A.unsafeIndex e.array (i + 2)+                   , w2 == 0xBE || w2 == 0xBF ->+                       go (i + 1) ls acc (QuotedRestricted i : rs)+                   | w == 0xEF && isBom e i ->+                       let next = i + bomLength+                       in go+                            next+                            (if i == ls then next else ls)+                            acc+                            (BomRestricted i (i == ls) : rs)+                   | otherwise -> go (i + 1) ls acc rs++-- | The index after the byte order mark at the start of the input.+streamStart :: Env -> Int+streamStart e = if isBom e e.base then e.base + bomLength else e.base++----------------------------------------+-- Contexts++data Ctx = BlockOut | BlockIn | FlowOut | FlowIn | BlockKey | FlowKey+  deriving stock (Eq)++isKeyCtx :: Ctx -> Bool+isKeyCtx c = c == BlockKey || c == FlowKey++-- | ns-plain-safe(c), with 'isFlowCtx' of c as the flag. The function takes+-- the flag, not the context, so that a caller can compute it once for all the+-- bytes of a scalar.+isPlainSafe :: Bool -> Word8 -> Bool+isPlainSafe flow w = isNsChar w && not (flow && isFlowIndicator w)++-- | The flow indicators end a plain scalar in the context.+isFlowCtx :: Ctx -> Bool+isFlowCtx c = c == FlowIn || c == FlowKey++-- | in-flow(c)+inFlow :: Ctx -> Ctx+inFlow c = if isKeyCtx c then FlowKey else FlowIn++----------------------------------------+-- Scanning helpers++-- | Skip the empty lines of a flow scalar after a line break and the line+-- prefix of the next line (@l-empty(n,FLOW-IN)* s-flow-line-prefix(n)@).+-- Return the number of empty lines and the index of the content, or+-- 'Nothing' if the next line is indented less than the scalar.+flowFold :: Env -> Int -> Int -> Maybe (Int, Int)+flowFold e n = go 0+  where+    go :: Int -> Int -> Maybe (Int, Int)+    go !k i =+      let s = skipSpaces e i+          indented = s - i >= n+          w = skipWhites e s+      in if+           | indented && isBreak (byteAt e w) -> go (k + 1) (breakEnd e w)+           | not indented && isBreak (byteAt e s) -> go (k + 1) (breakEnd e s)+           | indented -> Just (k, w)+           | otherwise -> Nothing++-- | The text of a line folding with the given number of empty lines.+foldText :: Int -> T.Text+foldText = \case+  0 -> " "+  k -> T.replicate k "\n"++----------------------------------------+-- Basic structures++startOfLine :: P ()+startOfLine = do+  e <- env+  p <- pos+  guardP $ isStartOfLine e p++-- | The indicator of a block collection entry, which a character of a plain+-- scalar cannot follow, as in "- a" but not "-a".+blockIndicator :: Word8 -> P ()+blockIndicator w = do+  char w+  next <- peek+  guardP . not $ isNsChar next++-- | s-indent(n)+sIndent :: Int -> P ()+sIndent n = do+  e <- env+  p <- pos+  let q = p + max 0 n+  if skipSpacesTo e p q == q then setPos q else failure+  where+    skipSpacesTo :: Env -> Int -> Int -> Int+    skipSpacesTo e i q+      | i < q && byteAt e i == SPACE = skipSpacesTo e (i + 1) q+      | otherwise = i++-- | Count the spaces at the current position.+countSpaces :: P Int+countSpaces = do+  e <- env+  p <- pos+  pure $ skipSpaces e p - p++-- | s-separate-in-line+sSeparateInLine :: P ()+sSeparateInLine = do+  e <- env+  p <- pos+  let q = skipWhites e p+  if q > p then setPos q else startOfLine++-- | c-nb-comment-text+cNbCommentText :: P ()+cNbCommentText = do+  char HASH+  skipWhile $ \w -> w /= 0 && not (isBreak w)++-- | b-break+bBreak :: P ()+bBreak = do+  e <- env+  p <- pos+  if isBreak (byteAt e p) then setPos (breakEnd e p) else failure++-- | b-comment+bComment :: P ()+bComment = bBreak <|> atEnd+  where+    atEnd :: P ()+    atEnd = do+      e <- env+      p <- pos+      guardP $ p >= e.end++-- | s-b-comment+sBComment :: P ()+sBComment = do+  optional_ $ sSeparateInLine >> optional_ cNbCommentText+  bComment++-- | l-comment+lComment :: P ()+lComment = do+  sSeparateInLine+  optional_ cNbCommentText+  bComment++-- | s-l-comments+sLComments :: P ()+sLComments = do+  sBComment <|> startOfLine+  many_ lComment++-- | s-separate(n,c)+sSeparate :: Int -> Ctx -> P ()+sSeparate n c+  | isKeyCtx c = sSeparateInLine+  | otherwise = sSeparateLines n++-- | s-separate-lines(n)+sSeparateLines :: Int -> P ()+sSeparateLines n = (sLComments >> sFlowLinePrefix n) <|> sSeparateInLine++-- | s-flow-line-prefix(n)+sFlowLinePrefix :: Int -> P ()+sFlowLinePrefix n = do+  sIndent n+  optional_ sSeparateInLine++----------------------------------------+-- Stream++defaultHandles :: M.Map T.Text T.Text+defaultHandles = M.fromList [("!", "!"), ("!!", coreTagPrefix)]++-- | l-yaml-stream. The markers are the indices of the lines that start with+-- a document marker.+lYamlStream :: [Int] -> P [Document]+lYamlStream markers0 = do+  s <- pos+  documents markers0 True s+  where+    -- The last argument is the index where the comments of the next+    -- document start.+    documents :: [Int] -> Bool -> Int -> P [Document]+    documents markers afterEnd prefix = do+      s <- pos+      -- A byte order mark can come before a marker after a bare document.+      lDocumentPrefix+      e <- env+      p <- pos+      if+        | p >= e.end -> pure []+        | isEndMarker e p -> do+            lDocumentSuffix+            documents markers True prefix+        | isMarker e p -> document markers Nothing defaultHandles prefix+        | afterEnd && byteAt e p == PERCENT -> do+            (version, hs) <- directives+            q <- pos+            unless (isStartMarker e q) $+              throwAt q "expected a document start marker (---) after the directives"+            document markers version hs prefix+        | afterEnd -> bareDocument markers prefix+        -- A byte order mark on an empty line or a comment line ends a bare+        -- document, so it is the likely mistake.+        | Just b <- bomLine e s p -> throwAt b "unexpected byte order mark"+        | otherwise -> throwAt p "expected a document start marker (---)"++    -- The first line between the indices that starts with a byte order mark.+    bomLine :: Env -> Int -> Int -> Maybe Int+    bomLine e i j+      | i >= j = Nothing+      | isBom e i = Just i+      | otherwise = bomLine e (nextLineStart e i) j++    document :: [Int] -> Maybe YamlVersion -> M.Map T.Text T.Text -> Int -> P [Document]+    document markers version hs prefix = do+      m <- pos+      advance markerLength+      p <- pos+      e <- env+      let (limit, markers') = nextMarker e markers p+      root <-+        withEnd limit . withHandles hs $+          lBareDocument <|> (eNode <* sLComments)+      finishDocument markers' version prefix (Just m) limit root++    bareDocument :: [Int] -> Int -> P [Document]+    bareDocument markers prefix = do+      p <- pos+      e <- env+      let (limit, markers') = nextMarker e markers p+      root <-+        withEnd limit lBareDocument <|> do+          fu <- furthest+          throwUnexpected fu+      finishDocument markers' Nothing prefix Nothing limit root++    -- The end of the document that starts at the index, and the markers+    -- after it.+    nextMarker :: Env -> [Int] -> Int -> (Int, [Int])+    nextMarker e markers p = case dropWhile (<= p) markers of+      m : ms -> (m, m : ms)+      [] -> (e.end, [])++    finishDocument+      :: [Int] -> Maybe YamlVersion -> Int -> Maybe Int -> Int -> Node -> P [Document]+    finishDocument markers version prefix marker limit root = do+      withEnd limit $ many_ lComment+      e <- env+      p <- pos+      when (p < limit && not (startsPrefix e p)) $ do+        fu <- furthest+        throwUnexpected (max fu p)+      let explicitEnd = isEndMarker e p+      when explicitEnd lDocumentSuffix+      q <- pos+      -- The first empty line after the end marker ends the lines of the+      -- document.+      let gap = gapEnd e q+      rest <- documents markers explicitEnd gap+      let !(!doc, next) =+            attachComments+              e+              (prefix == streamStart e)+              (not (null rest))+              prefix+              marker+              p+              -- The lines after the last document belong to its end, also+              -- after more end markers.+              (if null rest then e.end else gap)+              Document+                { version = version+                , explicitStart = isJust marker+                , explicitEnd = explicitEnd+                , docComments = noComments+                , root = root+                }+          !rest' = linesAbove next rest+      pure (doc : rest')++-- | l-document-prefix, repeated.+lDocumentPrefix :: P ()+lDocumentPrefix = many_ $ do+  e <- env+  p <- pos+  if isBom e p then advance bomLength else lComment++-- | l-document-suffix, without the comment lines after it. They belong to the+-- next document.+lDocumentSuffix :: P ()+lDocumentSuffix = do+  advance markerLength+  e <- env+  p <- pos+  sBComment+    <|> throwAt (skipWhites e p) "unexpected content after the document end marker (...)"++-- | l-directive, repeated, with the version and the tag handles they define.+directives :: P (Maybe YamlVersion, M.Map T.Text T.Text)+directives = go Nothing defaultHandles Set.empty+  where+    go+      :: Maybe YamlVersion+      -> M.Map T.Text T.Text+      -> Set.Set T.Text+      -> P (Maybe YamlVersion, M.Map T.Text T.Text)+    go version hs defined = do+      w <- peek+      if w /= PERCENT+        then pure (version, hs)+        else do+          p <- pos+          advance 1+          name <- directiveName+          case name of+            "YAML" -> do+              when (isJust version) $+                throwAt p "duplicate %YAML directive"+              v <- yamlVersion p+              sLComments <|> throwAfter "unexpected content after the %YAML version"+              go (Just v) hs defined+            "TAG" -> do+              (handle, prefix) <- tagDirective+              when (handle `Set.member` defined) . throwAt p $+                "duplicate %TAG directive for " ++ T.unpack handle+              sLComments <|> throwAfter "unexpected content after the tag prefix"+              go version (M.insert handle prefix hs) (Set.insert handle defined)+            _ -> do+              many_ $ sSeparateInLine >> directiveParameter+              sLComments <|> throwAt p "invalid directive"+              go version hs defined++    -- Fail at the content after the white space at the position.+    throwAfter :: String -> P a+    throwAfter msg = do+      e <- env+      q <- pos+      throwAt (skipWhites e q) msg++    -- s-separate-in-line between the parts of a directive, or the error.+    separator :: String -> P ()+    separator msg = do+      w <- peek+      unless (isWhite w) $ throwAfter msg+      sSeparateInLine++    directiveName :: P T.Text+    directiveName = do+      e <- env+      p <- pos+      skipWhile isNsChar+      q <- pos+      when (q == p) $ throwAt p "expected a directive name"+      pure $ slice e p q++    directiveParameter :: P ()+    directiveParameter = do+      p <- pos+      skipWhile isNsChar+      q <- pos+      guardP (q > p)++    yamlVersion :: Int -> P YamlVersion+    yamlVersion p = do+      separator badVersion+      v <- pos+      major <- number v+      char DOT <|> throwAt v badVersion+      minor <- number v+      w' <- peek+      when (isNsChar w') $ throwAt v badVersion+      when (major /= 1) . throwAt p $+        "unsupported YAML version " ++ show major ++ "." ++ show minor+      pure $ YamlVersion major minor+      where+        badVersion :: String+        badVersion = "expected a version such as 1.2 after %YAML"++        number :: Int -> P Int+        number v = do+          e <- env+          q <- pos+          skipWhile isDecDigit+          r <- pos+          when (r == q) $ throwAt v badVersion+          maybe (throwAt p "unsupported YAML version") pure $ readVersion (slice e q r)+          where+            -- The value of the digits, or 'Nothing' beyond 'maxVersion'.+            readVersion :: T.Text -> Maybe Int+            readVersion = T.foldl' step (Just 0)++            step :: Maybe Int -> Char -> Maybe Int+            step acc c = do+              n <- acc+              let n' = n * 10 + digitToInt c+              guard (n' <= maxVersion)+              pure n'++    tagDirective :: P (T.Text, T.Text)+    tagDirective = do+      e <- env+      separator+        "expected a tag handle and a prefix after %TAG, e.g. %TAG !e! tag:example.com,2000:"+      h <- pos+      handle <- cTagHandle <|> throwAt h "invalid tag handle"+      w <- peek+      let lineEnd = w == 0 || isBreak w+      -- A named handle without its closing '!' reads as the primary handle.+      when (handle == "!" && not (lineEnd || isWhite w)) $ throwAt h "invalid tag handle"+      separator (if lineEnd then noPrefix else "expected a space after the tag handle")+      q <- pos+      first <- peek+      when (first == 0 || isBreak first || first == HASH) $ throwAt q noPrefix+      unless (first == EXCL || isTagChar first || first == PERCENT) $+        throwAt q "invalid tag prefix"+      when (first == EXCL) $ advance 1+      scan uriChars+      r <- pos+      invalidEscape r+      -- The escapes of the prefix and of the suffix of a tag can form one+      -- character, so the prefix stays encoded.+      pure (handle, slice e q r)+      where+        noPrefix :: String+        noPrefix = "expected a prefix after the tag handle, e.g. tag:example.com,2000:"++-- | c-tag-handle+cTagHandle :: P T.Text+cTagHandle = do+  e <- env+  p <- pos+  char EXCL+  named e p <|> secondary e p <|> pure "!"+  where+    named :: Env -> Int -> P T.Text+    named e p = do+      skipWhile isWordChar+      q <- pos+      guardP (q > p + 1)+      char EXCL+      slice e p <$> pos++    secondary :: Env -> Int -> P T.Text+    secondary e p = do+      char EXCL+      slice e p <$> pos++-- | Skip ns-uri-char*.+uriChars :: Env -> Int -> Int+uriChars e i+  | isUriChar (byteAt e i) = uriChars e (i + 1)+  | isPercentEscape e i = uriChars e (i + percentEscapeLength)+  | otherwise = i++percentEscapeLength :: Int+percentEscapeLength = 1 + percentDigits++isPercentEscape :: Env -> Int -> Bool+isPercentEscape e i =+  byteAt e i == PERCENT && all (isHexDigit' . byteAt e) [i + 1 .. i + percentDigits]++-- | Stop with an error if a @%@ without two hexadecimal digits after it is at+-- the index, after the valid characters of a tag.+invalidEscape :: Int -> P ()+invalidEscape i = do+  e <- env+  when (byteAt e i == PERCENT) $+    throwAt i "invalid escape in the tag, write '%' and two hexadecimal digits"++-- | l-bare-document+lBareDocument :: P Node+lBareDocument = sLBlockNode (-1) BlockIn++----------------------------------------+-- Nodes++-- | e-node+eNode :: P Node+eNode = eScalar noProps++-- | e-scalar with properties.+eScalar :: Props -> P Node+eScalar props = do+  e <- env+  p <- pos+  pure $! mkNode e p (toOffset e p) props (emptyContent e)++-- | c-ns-properties(n,c)+cNsProperties :: Int -> Ctx -> P Props+cNsProperties n c = tagFirst <|> anchorFirst+  where+    tagFirst :: P Props+    tagFirst = do+      t <- cNsTagProperty+      a <- optional $ sSeparate n c >> cNsAnchorProperty+      pure $ Props a t++    anchorFirst :: P Props+    anchorFirst = do+      a <- cNsAnchorProperty+      t <- option NoTag $ sSeparate n c >> cNsTagProperty+      pure $ Props (Just a) t++-- | c-ns-anchor-property+cNsAnchorProperty :: P T.Text+cNsAnchorProperty = do+  char AMP+  nsAnchorName++-- | ns-anchor-name+nsAnchorName :: P T.Text+nsAnchorName = do+  e <- env+  p <- pos+  skipWhile isAnchorChar+  q <- pos+  guardP (q > p)+  pure $ slice e p q++-- | c-ns-tag-property+cNsTagProperty :: P Tag+cNsTagProperty = do+  e <- env+  p <- pos+  peek >>= guardP . (== EXCL)+  w <- peekAt 1+  if w == LESS+    then verbatim e p+    else shorthand e p <|> nonSpecific+  where+    verbatim :: Env -> Int -> P Tag+    verbatim e p = do+      char EXCL+      char LESS+      q <- pos+      scan uriChars+      r <- pos+      w <- peek+      let t = slice e q r+      when (w /= GREATER || not (isLocal t || isGlobal t)) $+        throwAt p "invalid verbatim tag"+      advance 1+      case percentDecode t of+        Just decoded -> pure (Tag decoded)+        Nothing -> throwAt p "the escapes of the tag are not valid UTF-8"++    -- A local tag has a name after the "!".+    isLocal :: T.Text -> Bool+    isLocal t = case T.uncons t of+      Just ('!', rest) -> not (T.null rest)+      _ -> False++    -- A global tag is a URI, which starts with a scheme.+    isGlobal :: T.Text -> Bool+    isGlobal t = case T.uncons t of+      Just (c, rest) ->+        isAsciiLetter c && case T.uncons (T.dropWhile isSchemeChar rest) of+          Just (':', _) -> True+          _ -> False+      Nothing -> False++    isAsciiLetter :: Char -> Bool+    isAsciiLetter c = isAscii c && isAlpha c++    isSchemeChar :: Char -> Bool+    isSchemeChar c = isAscii c && (isAlphaNum c || c == '+' || c == '-' || c == '.')++    shorthand :: Env -> Int -> P Tag+    shorthand e p = do+      handle <- cTagHandle+      q <- pos+      scan tagChars+      r <- pos+      invalidEscape r+      -- Only the primary handle "!" can stand alone, as the non-specific tag.+      when (r == q && handle /= "!") $+        throwAt r ("expected the rest of the tag after " ++ T.unpack handle)+      guardP (r > q)+      case M.lookup handle e.handles of+        Just prefix -> do+          -- Each tag has its own copy of the prefix. The default prefixes+          -- are short, but a long prefix of a directive with many tags would+          -- take memory quadratic in the size of the input.+          unless (M.lookup handle defaultHandles == Just prefix) $ do+            added <- addTagBytes (T.lengthWord8 prefix)+            let limit = max minExpansion (e.streamEnd - e.base)+            when (added > limit) . throwAt p $+              "the prefixes of %TAG directives add more than "+                ++ show limit+                ++ " bytes to the tags"+          case percentDecode (prefix <> slice e q r) of+            Just t -> pure (Tag t)+            Nothing -> throwAt p "the escapes of the tag are not valid UTF-8"+        Nothing -> throwAt p $ "undefined tag handle " ++ T.unpack handle++    -- Skip ns-tag-char*.+    tagChars :: Env -> Int -> Int+    tagChars e i+      | isTagChar (byteAt e i) = tagChars e (i + 1)+      | isPercentEscape e i = tagChars e (i + percentEscapeLength)+      | otherwise = i++    -- Decode the %XX escapes of a tag, or 'Nothing' if the bytes are not valid+    -- UTF-8.+    percentDecode :: T.Text -> Maybe T.Text+    percentDecode t+      | T.any (== '%') t =+          either (const Nothing) Just . T.decodeUtf8' . BS.pack $ go (T.unpack t)+      | otherwise = Just t+      where+        go :: String -> [Word8]+        go = \case+          '%' : a : b : rest ->+            fromIntegral (digitToInt a * 16 + digitToInt b) : go rest+          c : rest -> encodeChar c ++ go rest+          [] -> []++        encodeChar :: Char -> [Word8]+        encodeChar c = case T.singleton c of+          T.Text arr _ len -> A.toList arr 0 len++    nonSpecific :: P Tag+    nonSpecific = do+      char EXCL+      pure NonSpecificTag++-- | c-ns-alias-node+cNsAliasNode :: P Node+cNsAliasNode = do+  e <- env+  p <- pos+  char STAR+  name <- nsAnchorName+  q <- pos+  pure $! mkNode e p (toOffset e q) noProps (AliasContent name)++----------------------------------------+-- Flow scalars++-- | c-double-quoted(n,c)+cDoubleQuoted :: Int -> Ctx -> Props -> P Node+cDoubleQuoted = cQuoted DoubleQuoted++-- | c-single-quoted(n,c)+cSingleQuoted :: Int -> Ctx -> Props -> P Node+cSingleQuoted = cQuoted SingleQuoted++-- | A double-quoted or a single-quoted scalar.+cQuoted :: ScalarStyle -> Int -> Ctx -> Props -> P Node+cQuoted style n c props = withScan $ \e p ->+  let double :: Bool+      double = style == DoubleQuoted++      quote :: Word8+      quote = if double then DQUOTE else SQUOTE++      name :: String+      name = if double then "double-quoted" else "single-quoted"++      go :: Int -> Int -> [T.Text] -> Lines -> Scanned Content+      go seg i acc ls = case byteAt e i of+        w+          | w == quote ->+              if not double && byteAt e (i + 1) == SQUOTE+                then go (i + 2) (i + 2) ("'" : slice e seg i : acc) ls+                else Done (i + 1) $ case ls of+                  FirstLine -> ScalarLinesContent style (finish (slice e seg i : acc)) []+                  Lines ps starts _ -> severalLines (slice e seg i : acc) ps starts+          | w == BACKSLASH && double -> backslash seg i acc ls+          | isWhite w ->+              let j = skipWhites e i+              in if isBreak (byteAt e j) then fold i j acc else go seg j acc ls+          | isBreak w -> fold i i acc+          | i >= e.end -> endOfDocument i+          | otherwise -> go seg (i + 1) acc ls+        where+          fold :: Int -> Int -> [T.Text] -> Scanned Content+          fold contentEnd brk acc'+            | isKeyCtx c = NoMatch brk+            | otherwise = case flowFold e n (breakEnd e brk) of+                Just (k, j) ->+                  go j j [] (newLine (foldText k : slice e seg contentEnd : acc') ls)+                Nothing -> badIndent brk++      backslash :: Int -> Int -> [T.Text] -> Lines -> Scanned Content+      backslash seg i acc ls+        | isBreak (byteAt e (i + 1)) =+            if isKeyCtx c+              then NoMatch i+              else case flowFold e n (breakEnd e (i + 1)) of+                Just (k, j) ->+                  go j j [] (newLine (T.replicate k "\n" : slice e seg i : acc) ls)+                Nothing -> badIndent (i + 1)+        | i + 1 >= e.end = endOfDocument i+        | otherwise = case escape e (i + 1) of+            Just (t, j) -> go j j (t : slice e seg i : acc) ls+            Nothing -> Failed i (badEscape i)++      -- The scalar reaches the end of the document at the index.+      endOfDocument :: Int -> Scanned Content+      endOfDocument i+        | isKeyCtx c = NoMatch i+        | Just m <- cutByMarker e quote = Failed m (markerInside e (name ++ " scalar"))+        | otherwise = unterminated++      unterminated :: Scanned Content+      unterminated = Failed p ("unterminated " ++ name ++ " scalar")++      -- A hex escape with digits fails only for a bad code point. Any other+      -- invalid escape likely comes from a Windows path or a regular+      -- expression, e.g. "C:\Users" or "\d+".+      badEscape :: Int -> String+      badEscape i+        | elem @[] (chr (fromIntegral (byteAt e (i + 1)))) "xuU"+        , isHexDigit (chr (fromIntegral (byteAt e (i + 2)))) =+            "invalid escape sequence"+        | otherwise =+            "invalid escape sequence, write \\\\ for a backslash or use single quotes"++      badIndent :: Int -> Scanned Content+      badIndent i+        | nextContent i >= e.end = endOfDocument i+        -- Without a closing quote, the line with a wrong indentation more+        -- likely follows a missing quote.+        | not (closingQuoteFrom e quote (nextContent i)) = unterminated+        | Just tab <- firstTab e (foldStop i) (skipWhites e (foldStop i)) =+            Failed tab tabMessage+        | otherwise =+            Failed+              (nextContent i)+              ("invalid indentation of a line in a " ++ name ++ " scalar")++      nextContent :: Int -> Int+      nextContent i = skipWhites e (skipBlankLines i)++      -- The start of the line at which 'flowFold' stops after the line break+      -- at the index. A blank line can stop it with a tab before the+      -- indentation, as in "\"a\n\t\n  b\"".+      foldStop :: Int -> Int+      foldStop i =+        let l = breakEnd e i+            s = skipSpaces e l+        in if l < e.end && (s - l >= n || isBreak (byteAt e s))+             then foldStop (lineEndAt e s)+             else l++      -- Skip the line break at the index and the blank lines after it.+      skipBlankLines :: Int -> Int+      skipBlankLines i =+        let j = skipWhites e (breakEnd e i)+        in if isBreak (byteAt e j) then skipBlankLines j else breakEnd e i++      -- Add the pieces of the current line, in reverse order, and start a new+      -- line after them.+      newLine :: [T.Text] -> Lines -> Lines+      newLine acc = \case+        FirstLine -> next [] [] 0+        Lines ps ls len -> next ps ls len+        where+          next :: [T.Text] -> [Int] -> Int -> Lines+          next ps ls len =+            let len' = len + sum (map T.length acc)+            in Lines (acc ++ ps) (len' : ls) len'++      -- The scalar from the pieces of its last line, and the pieces and the+      -- starts of the lines before it, all in reverse order.+      severalLines :: [T.Text] -> [T.Text] -> [Int] -> Content+      severalLines acc ps starts =+        ScalarLinesContent style (finish (acc ++ ps)) (reverse starts)++      finish :: [T.Text] -> T.Text+      finish = \case+        [t] -> t+        ts -> T.concat (reverse ts)+  in case go (p + 1) (p + 1) [] FirstLine of+       Done q content -> Done q (mkNode e p (toOffset e q) props content)+       NoMatch q -> NoMatch q+       Failed q msg -> Failed q msg+-- Inlining gives a loop for each style. Without it, the parse benchmark of+-- the JSON input allocates more.+{-# INLINE cQuoted #-}++-- | A document marker ends the document, and the input after it has the+-- closing byte without a pair of its own, e.g. the closing quote of a scalar+-- that the marker cuts. Return the index of the marker.+cutByMarker :: Env -> Word8 -> Maybe Int+cutByMarker e w+  | e.end < e.streamEnd, unpaired = Just e.end+  | otherwise = Nothing+  where+    unpaired :: Bool+    unpaired+      | w == RBRACKET || w == RBRACE = unmatchedClosing e w e.end e.streamEnd+      | otherwise = closingQuoteFrom e {end = e.streamEnd} w e.end++-- | The first quote from the index closes a quoted scalar with that quote.+-- Content right after the quote shows that it is not the closing quote, e.g.+-- the quote in "it's" of a plain scalar, or the opening quote of the next+-- scalar.+closingQuoteFrom :: Env -> Word8 -> Int -> Bool+closingQuoteFrom e w = go+  where+    go :: Int -> Bool+    go i+      | i >= e.end = False+      | b == w && w == SQUOTE && byteAt e (i + 1) == SQUOTE = go (i + 2)+      | b == w = canEndFlowNode e (i + 1)+      | b == BACKSLASH && w == DQUOTE = go (i + 2)+      | otherwise = go (i + 1)+      where+        b :: Word8+        b = byteAt e i++-- | A closing bracket without an opening bracket of its own is in the input+-- from the first index to the second. Content right after a closing bracket+-- shows that it is a character of a plain scalar, e.g. in "a]b".+unmatchedClosing :: Env -> Word8 -> Int -> Int -> Bool+unmatchedClosing e w from to = go 0 from+  where+    go :: Int -> Int -> Bool+    go depth i+      | i >= to = False+      | b == w && canEndFlowNode range (i + 1) = depth == 0 || go (depth - 1) (i + 1)+      | b == opening = go (depth + 1) (i + 1)+      | otherwise = go depth (i + 1)+      where+        b :: Word8+        b = A.unsafeIndex e.array i++    range :: Env+    range = e {end = to}++    opening :: Word8+    opening = if w == RBRACKET then LBRACKET else LBRACE++-- | The error for the document marker that ends the document inside the+-- node.+markerInside :: Env -> String -> String+markerInside e node =+  "unexpected '"+    ++ replicate markerLength (chr (fromIntegral (A.unsafeIndex e.array e.end)))+    ++ "' in a "+    ++ node+    ++ ", indent the line"++-- | The lines of a scalar before its current line: the pieces of their text,+-- in reverse order, the positions where they start, in reverse order, and+-- the length of the pieces.+data Lines+  = FirstLine+  | Lines ![T.Text] ![Int] !Int++-- | The positions where the lines start, from the length of the first line+-- and the separators and the texts of the next lines.+lineStarts :: Int -> [T.Text] -> [Int]+lineStarts = go []+  where+    go :: [Int] -> Int -> [T.Text] -> [Int]+    go acc !len = \case+      sep : t : rest ->+        let !start = len + T.length sep+        in go (start : acc) (start + T.length t) rest+      _ -> reverse acc++-- | Decode the escape sequence after a backslash.+escape :: Env -> Int -> Maybe (T.Text, Int)+escape e i = case chr (fromIntegral (byteAt e i)) of+  '0' -> simple '\0'+  'a' -> simple '\a'+  'b' -> simple '\b'+  't' -> simple '\t'+  '\t' -> simple '\t'+  'n' -> simple '\n'+  'v' -> simple '\v'+  'f' -> simple '\f'+  'r' -> simple '\r'+  'e' -> simple '\ESC'+  ' ' -> simple ' '+  '"' -> simple '"'+  '/' -> simple '/'+  '\\' -> simple '\\'+  'N' -> simple '\x85'+  '_' -> simple '\xA0'+  'L' -> simple '\x2028'+  'P' -> simple '\x2029'+  'x' -> codePoint xEscapeDigits+  'u' -> case hexAt (i + 1) uEscapeDigits of+    -- JSON escapes a character outside the Basic Multilingual Plane as a+    -- pair of surrogates.+    Just hi+      | isHighSurrogate hi+      , let second = i + 1 + uEscapeDigits+      , byteAt e second == BACKSLASH+      , byteAt e (second + 1) == LOWER_U+      , Just lo <- hexAt (second + 2) uEscapeDigits+      , isLowSurrogate lo ->+          fromCodePoint (fromSurrogates hi lo) (second + 2 + uEscapeDigits)+    _ -> codePoint uEscapeDigits+  'U' -> codePoint bigUEscapeDigits+  _ -> Nothing+  where+    simple :: Char -> Maybe (T.Text, Int)+    simple ch = Just (T.singleton ch, i + 1)++    codePoint :: Int -> Maybe (T.Text, Int)+    codePoint k = do+      cp <- hexAt (i + 1) k+      fromCodePoint cp (i + 1 + k)++    fromCodePoint :: Int -> Int -> Maybe (T.Text, Int)+    fromCodePoint cp next+      | isScalarValue cp = Just (T.singleton (chr cp), next)+      | otherwise = Nothing++    -- The value of k hex digits at the index.+    hexAt :: Int -> Int -> Maybe Int+    hexAt j k+      | all (isHexDigit' . byteAt e) [j .. j + k - 1] =+          Just $ foldl (\acc x -> acc * 16 + hexValue (byteAt e x)) 0 [j .. j + k - 1]+      | otherwise = Nothing++-- | ns-plain(n,c)+nsPlain :: Int -> Ctx -> Props -> P Node+nsPlain n c props = withScan $ \e p ->+  let w0 = byteAt e p+      -- A byte order mark in a plain scalar is an error after the parse, but+      -- a scalar that starts with one would take in the lines below it.+      firstOk =+        not (startsPrefix e p)+          && ( (isNsChar w0 && not (isIndicator w0) && not (isBom e p))+                 || ( (w0 == QUESTION || w0 == COLON || w0 == MINUS)+                        && isPlainSafe (isFlowCtx c) (byteAt e (p + 1))+                    )+             )+  in if not firstOk+       then NoMatch p+       else+         let q = plainLine e c (p + 1)+             first = slice e p q+             node end t ls =+               mkNode e p (toOffset e end) props (ScalarLinesContent Plain t ls)+         in if isKeyCtx c+              then Done q (node q first [])+              else case plainNextLines e n c q of+                ([], _) -> Done q (node q first [])+                (ts, r) ->+                  Done r (node r (T.concat (first : ts)) (lineStarts (T.length first) ts))++-- | The end of the plain scalar content on the current line.+plainLine :: Env -> Ctx -> Int -> Int+plainLine e c = go+  where+    go :: Int -> Int+    go i+      | isPlainSafe flow w && w /= COLON = go (i + 1)+      | w == COLON && isPlainSafe flow (byteAt e (i + 1)) = go (i + 1)+      | isWhite w =+          let j = skipWhites e i+          in if plainCharAfterWhite j then go (j + 1) else i+      | otherwise = i+      where+        w :: Word8+        w = byteAt e i++    plainCharAfterWhite :: Int -> Bool+    plainCharAfterWhite j =+      let w = byteAt e j+      in w /= HASH+           && isPlainSafe flow w+           && (w /= COLON || isPlainSafe flow (byteAt e (j + 1)))++    flow :: Bool+    flow = isFlowCtx c++-- | s-ns-plain-next-line(n,c)*. Return the text of the next lines and the+-- index after them.+plainNextLines :: Env -> Int -> Ctx -> Int -> ([T.Text], Int)+plainNextLines e n c = go+  where+    go :: Int -> ([T.Text], Int)+    go q =+      let j = skipWhites e q+      in if not (isBreak (byteAt e j))+           then ([], q)+           else case flowFold e n (breakEnd e j) of+             Just (k, t)+               | startsPlain t ->+                   let q' = plainLine e c (t + 1)+                       (ts, r) = go q'+                   in (foldText k : slice e t q' : ts, r)+             _ -> ([], q)++    startsPlain :: Int -> Bool+    startsPlain t =+      let w = byteAt e t+      in w /= HASH+           && not (startsPrefix e t)+           && isPlainSafe flow w+           && (w /= COLON || isPlainSafe flow (byteAt e (t + 1)))++    flow :: Bool+    flow = isFlowCtx c++----------------------------------------+-- Flow collections++-- | c-flow-sequence(n,c)+cFlowSequence :: Int -> Ctx -> Props -> P Node+cFlowSequence n c props = do+  e <- env+  p <- pos+  char LBRACKET+  optional_ $ sSeparate n c+  entries <- flowEntries n c' (nsFlowSeqEntry n c')+  closing c' p RBRACKET "flow sequence" entries "expected ',' or ']'"+  q <- pos+  pure $! mkNode e p (toOffset e q) props (SequenceContent Flow entries)+  where+    c' :: Ctx+    c' = inFlow c++-- | c-flow-mapping(n,c)+cFlowMapping :: Int -> Ctx -> Props -> P Node+cFlowMapping n c props = do+  e <- env+  p <- pos+  char LBRACE+  optional_ $ sSeparate n c+  entries <- flowEntries n c' (nsFlowMapEntry n c')+  closing c' p RBRACE "flow mapping" [] (expected entries)+  q <- pos+  pure $! mkNode e p (toOffset e q) props (MappingContent Flow entries)+  where+    c' :: Ctx+    c' = inFlow c++    -- After a key with no value, the most likely mistake is a missing colon,+    -- e.g. in {"a" 1}.+    expected :: [(Node, Node)] -> String+    expected entries = case reverse entries of+      (k, v) : _+        | v.content == ScalarContent Plain T.empty+        , v.props == noProps+        , v.offset == k.endOffset ->+            "expected ':', ',' or '}'"+      _ -> "expected ',' or '}'"++-- | ns-s-flow-seq-entries(n,c) and ns-s-flow-map-entries(n,c).+flowEntries :: forall a. Int -> Ctx -> P a -> P [a]+flowEntries n c entry = go []+  where+    -- Each choice ends before the next entry, so that the stack does not+    -- grow with the number of entries.+    go :: [a] -> P [a]+    go acc =+      optional entry >>= \case+        Nothing -> pure $! reverse acc+        Just x -> do+          optional_ $ sSeparate n c+          more <- (True <$ (char COMMA >> optional_ (sSeparate n c))) <|> pure False+          if more then go (x : acc) else pure $! reverse (x : acc)++-- | The closing bracket of a flow collection that starts at the index. Its+-- absence is an error unless the collection is an implicit key, which the+-- parser can try again as a value. If the collection stops at the end of a+-- line, the error points to its start, which can be far away. The nodes are+-- the entries of a flow sequence, whose last one can be a key too long for a+-- pair.+closing :: Ctx -> Int -> Word8 -> String -> [Node] -> String -> P ()+closing c start w kind entries msg = do+  e <- env+  p <- pos+  char w+    <|> if+      | c == FlowKey -> failure+      | atLineEnd e p -> case nextContent e p of+          Just (lineStart, q)+            | bomBeforeContent e lineStart ->+                throwAt lineStart "unexpected byte order mark"+            | Just tab <- firstTab e lineStart q -> throwAt tab tabMessage+            | byteAt e q == w ->+                throwAt q $+                  "'"+                    ++ [chr (fromIntegral w)]+                    ++ "' is indented too little to end the "+                    ++ kind+            | closedLater e q ->+                throwAt q ("the line is indented too little to continue the " ++ kind)+          Nothing | Just m <- cutByMarker e w -> throwAt m (markerInside e kind)+          _ -> throwAt start ("unterminated " ++ kind)+      | dash e p ->+          throwAt+            p+            "unexpected '-', a list item cannot be inside a flow collection, quote '-' if it is a string"+      | byteAt e p == COLON+      , Node {offset = Offset o} : _ <- reverse entries+      , not (fitsKey e (o + e.base) p) ->+          throwAt p keyLengthMessage+      | otherwise -> uncurry throwAt (flowError e p msg)+  where+    -- The separation after an entry goes on to the next line if the+    -- collection can continue there. If it stops at the end of a line, the+    -- document ends or the next line is indented too little.+    atLineEnd :: Env -> Int -> Bool+    atLineEnd e i+      | i >= e.end = True+      | otherwise = case byteAt e i of+          HASH -> let b = byteAt e (i - 1) in isWhite b || isBreak b+          b | isWhite b -> atLineEnd e (i + 1)+          b -> isBreak b++    -- The start of the next line with content after the line of the index,+    -- and the index of the content, unless a document marker or the end of+    -- the input comes first. A closing bracket or a tab there shows that the+    -- line is indented too little. Other content can be the next key after a+    -- missing bracket.+    nextContent :: Env -> Int -> Maybe (Int, Int)+    nextContent e i+      | i >= e.end = Nothing+      | not (isBreak (byteAt e i)) = nextContent e (i + 1)+      | otherwise =+          let s = breakEnd e i+              q = skipWhites e s+              b = byteAt e q+          in if+               | q >= e.end || isMarker e s -> Nothing+               | isBreak b || b == HASH -> nextContent e q+               | otherwise -> Just (s, q)++    -- A closing bracket without an opening bracket of its own follows in the+    -- document, so the collection likely continues there.+    closedLater :: Env -> Int -> Bool+    closedLater e q = unmatchedClosing e w q e.end++    -- A '-' that cannot start a plain scalar, e.g. "- " as in a block+    -- sequence.+    dash :: Env -> Int -> Bool+    dash e i = byteAt e i == MINUS && not (isAnchorChar (byteAt e (i + 1)))++-- | ns-flow-seq-entry(n,c)+--+-- The grammar reads a JSON-like node first as the key of a pair and then+-- again as a node. For nested flow sequences, this takes exponential time.+-- The parser reads the node only once, as a node. The node becomes a key if+-- it is on one line, it is not too long for an implicit key, and a colon+-- follows. Otherwise it stays a node, and the parser does not read it again.+nsFlowSeqEntry :: Int -> Ctx -> P Node+nsFlowSeqEntry n c = do+  e <- env+  p <- pos+  (pair e p <$!> nsFlowPair n c) <|> nodeEntry e p+  where+    pair :: Env -> Int -> (Node, Node) -> Node+    pair e p (k, v) = mkNode e p v.endOffset noProps (MappingContent Flow [(k, v)])++    nodeEntry :: Env -> Int -> P Node+    nodeEntry e p = do+      k <- nsFlowNode n c+      q <- pos+      let value = do+            optional_ sSeparateInLine+            r <- pos+            guardP $ fitsKey e p r+            cNsFlowMapAdjacentValue n c+      if isJsonNode k && fitsKey e p q && not (any (isBreak . byteAt e) [p .. q - 1])+        then (pair e p . (k,) <$!> value) <|> pure k+        else pure k++    -- The content of c-flow-json-node(n,c).+    isJsonNode :: Node -> Bool+    isJsonNode k = case k.content of+      SequenceContent Flow _ -> True+      MappingContent Flow _ -> True+      ScalarContent SingleQuoted _ -> True+      ScalarContent DoubleQuoted _ -> True+      _ -> False++-- | ns-flow-map-entry(n,c)+nsFlowMapEntry :: Int -> Ctx -> P (Node, Node)+nsFlowMapEntry n c = explicit <|> nsFlowMapImplicitEntry n c+  where+    explicit :: P (Node, Node)+    explicit = do+      char QUESTION+      sSeparate n c+      nsFlowMapExplicitEntry n c++-- | ns-flow-map-explicit-entry(n,c)+nsFlowMapExplicitEntry :: Int -> Ctx -> P (Node, Node)+nsFlowMapExplicitEntry n c =+  nsFlowMapImplicitEntry n c <|> do+    k <- eNode+    v <- eNode+    pure (k, v)++-- | ns-flow-map-implicit-entry(n,c)+nsFlowMapImplicitEntry :: Int -> Ctx -> P (Node, Node)+nsFlowMapImplicitEntry n c = yamlKeyEntry <|> cNsFlowMapEmptyKeyEntry n c <|> jsonKeyEntry+  where+    yamlKeyEntry :: P (Node, Node)+    yamlKeyEntry = do+      k <- nsFlowYamlNode n c+      v <- (optional_ (sSeparate n c) >> cNsFlowMapSeparateValue n c) <|> eNode+      pure (k, v)++    jsonKeyEntry :: P (Node, Node)+    jsonKeyEntry = do+      k <- cFlowJsonNode n c+      v <- (optional_ (sSeparate n c) >> cNsFlowMapAdjacentValue n c) <|> eNode+      pure (k, v)++-- | c-ns-flow-map-empty-key-entry(n,c)+cNsFlowMapEmptyKeyEntry :: Int -> Ctx -> P (Node, Node)+cNsFlowMapEmptyKeyEntry n c = do+  k <- eNode+  v <- cNsFlowMapSeparateValue n c+  pure (k, v)++-- | c-ns-flow-map-separate-value(n,c)+cNsFlowMapSeparateValue :: Int -> Ctx -> P Node+cNsFlowMapSeparateValue n c = do+  char COLON+  w <- peek+  guardP . not $ isPlainSafe (isFlowCtx c) w+  (sSeparate n c >> nsFlowNode n c) <|> eNode++-- | c-ns-flow-map-adjacent-value(n,c)+cNsFlowMapAdjacentValue :: Int -> Ctx -> P Node+cNsFlowMapAdjacentValue n c = do+  char COLON+  (optional_ (sSeparate n c) >> nsFlowNode n c) <|> eNode++-- | ns-flow-pair(n,c) without c-ns-flow-pair-json-key-entry(n,c), which+-- 'nsFlowSeqEntry' parses.+nsFlowPair :: Int -> Ctx -> P (Node, Node)+nsFlowPair n c = explicit <|> yamlKeyEntry <|> cNsFlowMapEmptyKeyEntry n c+  where+    explicit :: P (Node, Node)+    explicit = do+      char QUESTION+      sSeparate n c+      nsFlowMapExplicitEntry n c++    yamlKeyEntry :: P (Node, Node)+    yamlKeyEntry = do+      k <- nsSImplicitYamlKey FlowKey+      v <- cNsFlowMapSeparateValue n c+      pure (k, v)++-- | ns-s-implicit-yaml-key(c)+nsSImplicitYamlKey :: Ctx -> P Node+nsSImplicitYamlKey c = implicitKey $ nsFlowYamlNode 0 c++-- | c-s-implicit-json-key(c)+cSImplicitJsonKey :: Ctx -> P Node+cSImplicitJsonKey c = implicitKey $ cFlowJsonNode 0 c++-- | An implicit key with the separation after it. Both together are at most+-- 'maxImplicitKeyLength' characters long.+implicitKey :: P Node -> P Node+implicitKey key = do+  e <- env+  p <- pos+  k <- key+  optional_ sSeparateInLine+  q <- pos+  guardP $ fitsKey e p q+  pure k++----------------------------------------+-- Flow nodes++-- | ns-flow-yaml-node(n,c)+nsFlowYamlNode :: Int -> Ctx -> P Node+nsFlowYamlNode n c =+  peek >>= \case+    STAR -> cNsAliasNode+    w+      | w == EXCL || w == AMP -> do+          props <- cNsProperties n c+          (sSeparate n c >> nsPlain n c props) <|> empty props+      | otherwise -> nsPlain n c noProps+  where+    -- Properties before JSON-like content belong to c-flow-json-node, which+    -- ordered choice would not try after an empty node.+    empty :: Props -> P Node+    empty props = do+      notFollowedBy $ do+        optional_ $ sSeparate n c+        w <- peek+        guardP $ w == LBRACKET || w == LBRACE || w == SQUOTE || w == DQUOTE+      eScalar props++-- | c-flow-json-node(n,c)+cFlowJsonNode :: Int -> Ctx -> P Node+cFlowJsonNode n c = do+  props <- option noProps $ cNsProperties n c <* sSeparate n c+  cFlowJsonContent n c props++-- | ns-flow-node(n,c)+nsFlowNode :: Int -> Ctx -> P Node+nsFlowNode n c =+  peek >>= \case+    STAR -> cNsAliasNode+    w+      | w == EXCL || w == AMP -> do+          props <- cNsProperties n c+          (sSeparate n c >> nsFlowContent n c props) <|> eScalar props+      | otherwise -> nsFlowContent n c noProps++-- | ns-flow-content(n,c)+nsFlowContent :: Int -> Ctx -> Props -> P Node+nsFlowContent n c props =+  peek >>= \case+    LBRACKET -> cFlowSequence n c props+    LBRACE -> cFlowMapping n c props+    SQUOTE -> cSingleQuoted n c props+    DQUOTE -> cDoubleQuoted n c props+    _ -> nsPlain n c props++-- | c-flow-json-content(n,c)+cFlowJsonContent :: Int -> Ctx -> Props -> P Node+cFlowJsonContent n c props =+  peek >>= \case+    LBRACKET -> cFlowSequence n c props+    LBRACE -> cFlowMapping n c props+    SQUOTE -> cSingleQuoted n c props+    DQUOTE -> cDoubleQuoted n c props+    _ -> failure++----------------------------------------+-- Block scalars++data Chomping = Strip | Clip | Keep+  deriving stock (Eq)++-- | c-l+literal(n) and c-l+folded(n).+cLBlockScalar :: Int -> Props -> P Node+cLBlockScalar n props = do+  e <- env+  p <- pos+  indicator <- peek+  guardP $ indicator == PIPE || indicator == GREATER+  advance 1+  (chomping, explicitIndent) <- cBBlockHeader p+  q <- pos+  indent <- case explicitIndent of+    -- At the top level, n is -1. A literal reading of the specification then+    -- gives |1 no indentation, but libyaml and other parsers count from 0.+    Just m -> pure $ max 0 n + m+    Nothing -> case detectIndent e q of+      Right m -> pure m+      Left i ->+        throwAt+          i+          "a leading empty line of a block scalar has more spaces than the first non-empty line"+  let (lines_, trailing, r) = blockLines e indent q+      (text, starts) = case indicator of+        PIPE -> (literalText lines_, [])+        _ -> foldedText lines_+      value = chomp chomping (not (null lines_)) trailing text+      style = if indicator == PIPE then Literal else Folded+      -- The empty lines after the content are not part of the scalar,+      -- unless it keeps them.+      contentEnd = case (chomping, reverse lines_) of+        (Keep, _) -> r+        (_, BlockLine _ (T.Text _ o l) : _) -> o + l+        (_, []) -> q+  setPos r+  lTrailComments indent+  pure $! mkNode e p (toOffset e contentEnd) props (ScalarLinesContent style value starts)+  where+    -- Detect the content indentation of a block scalar from its first+    -- non-empty line. Return the index of a leading empty line with too many+    -- spaces on error.+    detectIndent :: Env -> Int -> Either Int Int+    detectIndent e = go 0 Nothing+      where+        go :: Int -> Maybe Int -> Int -> Either Int Int+        go maxEmpty maxAt i =+          let s = skipSpaces e i+              k = s - i+              w = byteAt e s+          in if+               | isBreak w || (s >= e.end && k > 0) ->+                   go+                     (max maxEmpty k)+                     (if k > maxEmpty then Just s else maxAt)+                     (breakEnd e s)+               | s >= e.end || k <= n -> Right (max (n + 1) (max maxEmpty 1))+               | maxEmpty > k, Just j <- maxAt -> Left j+               | otherwise -> Right k++    literalText :: [BlockLine] -> T.Text+    literalText = \case+      [] -> T.empty+      BlockLine k t : rest -> T.concat $ T.replicate k "\n" : t : concatMap line rest+      where+        line :: BlockLine -> [T.Text]+        line (BlockLine k t) = ["\n", T.replicate k "\n", t]++    -- Apply the chomping to the content of a block scalar. The end of the+    -- input counts as a line break, as in the YAML test suite.+    chomp :: Chomping -> Bool -> Int -> T.Text -> T.Text+    chomp chomping hasContent trailing text = case chomping of+      Strip -> text+      Clip+        | hasContent -> text <> "\n"+        | otherwise -> text+      Keep+        | hasContent -> text <> T.replicate (trailing + 1) "\n"+        | otherwise -> T.replicate trailing "\n"++-- | c-b-block-header(t). Return the chomping and the indentation indicator.+cBBlockHeader :: Int -> P (Chomping, Maybe Int)+cBBlockHeader p = do+  a <- peek+  b <- peekAt 1+  let (chomping, indent, k)+        | Just t <- chompingOf a, Just m <- indentOf b = (t, Just m, 2)+        | Just m <- indentOf a, Just t <- chompingOf b = (t, Just m, 2)+        | Just t <- chompingOf a = (t, Nothing, 1)+        | Just m <- indentOf a = (Clip, Just m, 1)+        | otherwise = (Clip, Nothing, 0)+  advance k+  e <- env+  q <- pos+  let content = skipWhites e q+  sBComment+    <|> if+      | isDecDigit (byteAt e q) ->+          throwAt q "the indentation indicator of a block scalar must be from 1 to 9"+      | content > q && isNsChar (byteAt e content) ->+          throwAt content "the content of a block scalar starts on the next line"+      | otherwise -> throwAt p "invalid block scalar header"+  pure (chomping, indent)+  where+    chompingOf :: Word8 -> Maybe Chomping+    chompingOf = \case+      MINUS -> Just Strip+      PLUS -> Just Keep+      _ -> Nothing++    indentOf :: Word8 -> Maybe Int+    indentOf w+      | w >= DIGIT_1 && w <= DIGIT_9 = Just (fromIntegral (w - DIGIT_0))+      | otherwise = Nothing++-- | A content line of a block scalar: the number of empty lines before it and+-- its text after the indentation.+data BlockLine = BlockLine !Int !T.Text++-- | Split the content of a block scalar into lines. Return the lines, the+-- number of empty lines after the last one and the index after them.+blockLines :: Env -> Int -> Int -> ([BlockLine], Int, Int)+blockLines e indent = go 0 []+  where+    go :: Int -> [BlockLine] -> Int -> ([BlockLine], Int, Int)+    go !empties acc i+      | i >= e.end = (reverse acc, empties, i)+      | otherwise =+          let s = skipSpacesMax i+              w = byteAt e s+          in if+               | isBreak w -> go (empties + 1) acc (breakEnd e s)+               -- Spaces at the end of the input are an empty line, as in the+               -- test JEF9/02 of the YAML test suite.+               | s >= e.end -> (reverse acc, empties + 1, s)+               -- Only a block scalar at the top level has content at the+               -- start of a line.+               | s - i == indent+               , not (startsPrefix e s) ->+                   let t = lineEndAt e s+                       acc' = BlockLine empties (slice e s t) : acc+                   in if t >= e.end+                        then (reverse acc', 0, t)+                        else go 0 acc' (breakEnd e t)+               | otherwise -> (reverse acc, empties, i)++    -- At most indent spaces.+    skipSpacesMax :: Int -> Int+    skipSpacesMax i = loop i+      where+        loop :: Int -> Int+        loop j+          | j - i < indent && byteAt e j == SPACE = loop (j + 1)+          | otherwise = j++-- | The text of a folded block scalar and the positions where its lines+-- start.+foldedText :: [BlockLine] -> (T.Text, [Int])+foldedText = \case+  [] -> (T.empty, [])+  BlockLine k t : rest ->+    let next = go (isSpaced t) rest+    in (T.concat (T.replicate k "\n" : t : next), lineStarts (k + T.length t) next)+  where+    go :: Bool -> [BlockLine] -> [T.Text]+    go prevSpaced = \case+      [] -> []+      BlockLine k t : rest ->+        let spaced = isSpaced t+            sep+              | not prevSpaced && not spaced = foldText k+              | otherwise = T.replicate (k + 1) "\n"+        in sep : t : go spaced rest++    isSpaced :: T.Text -> Bool+    isSpaced t = case T.uncons t of+      Just (ch, _) -> ch == ' ' || ch == '\t'+      Nothing -> False++-- | l-trail-comments(n)+lTrailComments :: Int -> P ()+lTrailComments n = optional_ $ do+  k <- countSpaces+  guardP (k < n)+  advance k+  cNbCommentText+  bComment+  many_ lComment++----------------------------------------+-- Block collections++-- | l+block-sequence(n)+lBlockSequence :: Int -> Props -> P Node+lBlockSequence n props = do+  k <- countSpaces+  guardP (k > n)+  advance k+  nsLCompactSequence k props++-- | c-l-block-seq-entry(n)+cLBlockSeqEntry :: Int -> P Node+cLBlockSeqEntry n = do+  blockIndicator MINUS+  sLBlockIndented n BlockIn++-- | s-l+block-indented(n,c)+sLBlockIndented :: Int -> Ctx -> P Node+sLBlockIndented n c = compact <|> sLBlockNode n c <|> (eNode <* sLComments)+  where+    compact :: P Node+    compact = do+      e <- env+      m <- countSpaces+      advance m+      p <- pos+      if mayStartEntry e p+        then+          nsLCompactSequence (n + 1 + m) noProps+            <|> nsLCompactMapping (n + 1 + m) noProps+        else nsLCompactSequence (n + 1 + m) noProps++    -- An entry of a mapping has an explicit key or a colon on its first line.+    -- A key cannot start with the indicator of a sequence entry. Without this+    -- check, each level of a nested sequence would scan the rest of the line.+    mayStartEntry :: Env -> Int -> Bool+    mayStartEntry e p+      | byteAt e p == QUESTION = True+      | byteAt e p == MINUS && not (isNsChar (byteAt e (p + 1))) = False+      | otherwise = go p+      where+        go :: Int -> Bool+        go i = case byteAt e i of+          COLON -> True+          w+            | w == 0 || isBreak w -> False+            | otherwise -> go (i + 1)++-- | ns-l-compact-sequence(n), with the properties of the node.+nsLCompactSequence :: Int -> Props -> P Node+nsLCompactSequence n props = do+  e <- env+  p <- pos+  x <- cLBlockSeqEntry n+  xs <- many $ sIndent n >> cLBlockSeqEntry n+  pure $! mkNode e p (lastOf x xs).endOffset props (SequenceContent Block (x : xs))++-- | l+block-mapping(n)+lBlockMapping :: Int -> Props -> P Node+lBlockMapping n props = do+  k <- countSpaces+  guardP (k > n)+  advance k+  nsLCompactMapping k props++-- | ns-l-block-map-entry(n)+nsLBlockMapEntry :: Int -> P (Node, Node)+nsLBlockMapEntry n = cLBlockMapExplicitEntry n <|> nsLBlockMapImplicitEntry n++-- | c-l-block-map-explicit-entry(n)+cLBlockMapExplicitEntry :: Int -> P (Node, Node)+cLBlockMapExplicitEntry n = do+  blockIndicator QUESTION+  k <- sLBlockIndented n BlockOut+  e <- env+  v <- lBlockMapExplicitValue <|> (pure $! missingValue e k)+  pure (k, v)+  where+    -- The key took the comments and the empty lines below it, so the position+    -- of the parser is after them. A value there would take them.+    missingValue :: Env -> Node -> Node+    missingValue e k =+      Node+        { offset = k.endOffset+        , endOffset = k.endOffset+        , props = noProps+        , comments = noComments+        , content = emptyContent e+        }++    lBlockMapExplicitValue :: P Node+    lBlockMapExplicitValue = do+      sIndent n+      blockIndicator COLON+      sLBlockIndented n BlockOut++-- | ns-l-block-map-implicit-entry(n)+nsLBlockMapImplicitEntry :: Int -> P (Node, Node)+nsLBlockMapImplicitEntry n = do+  k <- nsSBlockMapImplicitKey <|> eNode+  v <- cLBlockMapImplicitValue n+  pure (k, v)+  where+    nsSBlockMapImplicitKey :: P Node+    nsSBlockMapImplicitKey = cSImplicitJsonKey BlockKey <|> nsSImplicitYamlKey BlockKey++-- | c-l-block-map-implicit-value(n)+cLBlockMapImplicitValue :: Int -> P Node+cLBlockMapImplicitValue n = do+  blockIndicator COLON+  sLBlockNode n BlockOut <|> (eNode <* sLComments)++-- | ns-l-compact-mapping(n), with the properties of the node.+nsLCompactMapping :: Int -> Props -> P Node+nsLCompactMapping n props = do+  e <- env+  p <- pos+  x <- nsLBlockMapEntry n+  xs <- many $ sIndent n >> nsLBlockMapEntry n+  pure $! mkNode e p (snd (lastOf x xs)).endOffset props (MappingContent Block (x : xs))++-- | The last element of a non-empty list.+lastOf :: a -> [a] -> a+lastOf x = \case+  [] -> x+  y : ys -> lastOf y ys++----------------------------------------+-- Block nodes++-- | s-l+block-node(n,c)+sLBlockNode :: Int -> Ctx -> P Node+sLBlockNode n c = do+  e <- env+  p <- pos+  if flowOnly e p+    then sLFlowInBlock n+    else sLBlockInBlock n c <|> sLFlowInBlock n+  where+    -- Block content starts with a property, an indicator of a block scalar or+    -- the end of the line. Other content on the same line is a flow node.+    flowOnly :: Env -> Int -> Bool+    flowOnly e p =+      not (isStartOfLine e p)+        && let w = byteAt e (skipWhites e p)+           in not $+                w == 0+                  || isBreak w+                  || w == HASH+                  || w == PIPE+                  || w == GREATER+                  || w == EXCL+                  || w == AMP++-- | s-l+flow-in-block(n)+sLFlowInBlock :: Int -> P Node+sLFlowInBlock n = do+  sSeparate (n + 1) FlowOut+  node <- nsFlowNode (n + 1) FlowOut+  sLComments+  pure node++-- | s-l+block-in-block(n,c)+sLBlockInBlock :: Int -> Ctx -> P Node+sLBlockInBlock n c = sLBlockScalar n c <|> sLBlockCollection n c++-- | s-l+block-scalar(n,c)+sLBlockScalar :: Int -> Ctx -> P Node+sLBlockScalar n c = do+  sSeparate (n + 1) c+  props <- option noProps $ cNsProperties (n + 1) c <* sSeparate (n + 1) c+  cLBlockScalar n props++-- | s-l+block-collection(n,c)+sLBlockCollection :: Int -> Ctx -> P Node+sLBlockCollection n c = do+  props <- withProps <|> (sLComments >> pure noProps)+  lBlockSequence (if c == BlockOut then n - 1 else n) props <|> lBlockMapping n props+  where+    -- If both properties do not end the line, the second one can belong to+    -- the first key of the mapping.+    withProps :: P Props+    withProps = do+      sSeparate (n + 1) c+      (cNsProperties (n + 1) c <* sLComments) <|> (oneProperty <* sLComments)++    oneProperty :: P Props+    oneProperty =+      (Props Nothing <$> cNsTagProperty)+        <|> ((\a -> Props (Just a) NoTag) <$> cNsAnchorProperty)++-- | The content of an empty node.+emptyContent :: Env -> Content+-- With a constant that contains 'T.empty', the parser returns a node with+-- this content as a thunk, e.g. the value of "a:" above another key. GHC+-- sees a constructor, takes the node for a value and drops the '$!' that+-- builds it, but the node must wait for the evaluation of 'T.empty'. A+-- NOINLINE pragma on the constant prevents this on GHC 9.10, but not on GHC+-- 9.14. The heap check of the render tests finds this thunk.+emptyContent e = ScalarContent Plain (slice e e.base e.base)++-- | A node without comments from the given index to the given offset.+mkNode :: Env -> Int -> Offset -> Props -> Content -> Node+mkNode e p end props c =+  Node+    { offset = toOffset e p+    , endOffset = end+    , props = props+    , comments = noComments+    , content = c+    }
+ src/Yamlet/Internal/Parser/Hints.hs view
@@ -0,0 +1,654 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The messages of parse errors. The parser only knows the position at+-- which it failed, so these functions look at the input around it to name+-- the likely mistake, e.g. a missing colon after a key.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Parser.Hints+  ( unexpected+  , flowError+  , codePointName+  , firstTab+  , tabMessage+  , keyLengthMessage+  ) where++import Control.Monad+import Data.Char+import Data.List qualified as L+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Word+import Numeric++import Yamlet.Internal.Chars+import Yamlet.Internal.Parser.Monad+import Yamlet.Internal.Parser.Scan+import Yamlet.Internal.Utils++-- | The location and the message of the error for the furthest position at+-- which the parser failed, and a tab before the position on its line that+-- can be the cause instead, with 'tabMessage'.+unexpected :: Env -> Int -> (Maybe Int, (Int, String))+unexpected input i = (tabCause, other)+  where+    tabCause :: Maybe Int+    tabCause = case indentationTab (i - 1) Nothing of+      Nothing+        | byteAt e i == COLON && firstColonFrom contentStart ->+            firstTab e lineStart contentStart+      t -> t++    other :: (Int, String)+    other+      | Just start <- propertiesLine =+          ( start+          , "an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'"+          )+      | Just r <- blockMistake = r+      | afterComment =+          (i, "a comment ends a plain scalar, so this line cannot continue it")+      | Just colon <- aliasColon e i = (colon, aliasColonMessage)+      | otherwise = (i,) $ case byteAt e i of+          w+            | byteBefore e i == STAR && not (isAnchorChar w) ->+                "expected an alias name after '*'"+            | byteBefore e i == AMP && not (isAnchorChar w) ->+                "expected an anchor name after '&'"+            | w == 0 -> "unexpected end of input"+            | indented, Just msg <- indentationMistake -> msg+            | indented, Just msg <- mistakeIn e False i -> msg+            | indented, not alignedWithEntry -> "unexpected indentation"+            | isBreak w -> "unexpected end of line"+            | i > e.base && isBreak (byteBefore e i)+            , Just msg <- indentationMistake ->+                msg+            | w == COLON && firstColon && not (fitsKey e entryStart i) -> keyLengthMessage+            | w == COLON && multiLineKey ->+                "unexpected ':', a key must be on a single line"+            | w == COLON && firstColon && valueColon && onStartMarkerLine ->+                "unexpected ':', a mapping cannot start on the line of '---'"+            -- A colon on the first line of a key does not fail, so the scalar+            -- before this one started on a line above.+            | w == COLON+                && firstColon+                && valueColon+                && isJust (lineAbove (lineStartAt e i)) ->+                "unexpected ':', this line continues the scalar from the line above, check the indentation and the line above"+            | w == COLON && valueColon ->+                "unexpected ':', quote the value if it contains \": \""+            | itemAfterKey -> "unexpected '-', a list cannot start on the line of its key"+            | itemAfterProperty ->+                "unexpected '-', a list cannot start on the line of its anchor or tag"+            | itemAfterStartMarker ->+                "unexpected '-', a list cannot start on the line of '---'"+            | Just msg <- mistakeIn e False i -> msg+            | Just node <- endBefore -> unexpectedChar e i ++ " after the end of " ++ node+            | otherwise -> unexpectedChar e i++    e :: Env+    e = afterBoms input++    -- The node that ends before the index on its line, as in+    -- "key: "value" more".+    endBefore :: Maybe String+    endBefore+      | not (isNsChar (byteAt e i)) = Nothing+      | b == RBRACKET || b == RBRACE = Just "a flow collection"+      | (b == DQUOTE || b == SQUOTE) && j < i = Just "a quoted scalar"+      | otherwise = Nothing+      where+        j :: Int+        j = skipBackWhites e i++        b :: Word8+        b = byteBefore e j++    -- The index starts a line that looks like the continuation of a plain+    -- scalar, the closest line above that is not blank has a comment, and+    -- the content above ends with a plain scalar.+    afterComment :: Bool+    afterComment =+      i == skipSpaces e (lineStartAt e i)+        && isNsChar (byteAt e i)+        && not (isListItem i)+        && not (any isKeyColon [i .. lineEndAt e i - 1])+        && isNothing (mistakeIn e False i)+        && commentAbove (lineStartAt e i)+        && maybe False endsPlain (lineAbove (lineStartAt e i))+      where+        -- The line with the content at the index ends with a plain scalar,+        -- not with a quoted scalar, a flow collection, an alias, an anchor,+        -- a tag, an indicator or the header of a block scalar, and it is not+        -- a line of a block scalar.+        endsPlain :: Int -> Bool+        endsPlain k =+          let end = lineContentEnd e k+              start = wordStart e end+              b = byteBefore e end+              w = byteAt e start+          in end > k+               && b /= SQUOTE+               && b /= DQUOTE+               && b /= RBRACKET+               && b /= RBRACE+               && b /= COLON+               && w /= STAR+               && w /= AMP+               && w /= EXCL+               && not (end - start == 1 && (w == MINUS || w == QUESTION))+               && not (endsWithBlockHeader k)+               && not (inBlockScalar k)++        -- The closest line above that is indented less starts a block+        -- scalar.+        inBlockScalar :: Int -> Bool+        inBlockScalar k = go k+          where+            go :: Int -> Bool+            go j = case lineAbove (lineStartAt e j) of+              Nothing -> False+              Just above+                | columnOf above < columnOf k -> endsWithBlockHeader above+                | otherwise -> go above++        commentAbove :: Int -> Bool+        commentAbove start+          | start <= e.base = False+          | otherwise =+              let prev = lineStartAt e (start - 1)+                  k = skipWhites e (skipBoms e prev)+              in if isBreak (byteAt e k) then commentAbove prev else hasComment k++        -- A quoted scalar can contain " #", as in "\"x #y\"", so a quote+        -- that can close a scalar after the '#' shows that the '#' may not+        -- start a comment.+        hasComment :: Int -> Bool+        hasComment j = case L.find startsComment [j .. end - 1] of+          Just h -> not (any closingQuote [h + 1 .. end - 1])+          Nothing -> False+          where+            end :: Int+            end = lineEndAt e j++            startsComment :: Int -> Bool+            startsComment k = byteAt e k == HASH && (k == j || isWhite (byteBefore e k))++        closingQuote :: Int -> Bool+        closingQuote k =+          let b = byteAt e k in (b == SQUOTE || b == DQUOTE) && canEndFlowNode e (k + 1)++    -- The start of the line of the index if the line has only anchors and+    -- tags, as in "&anchor".+    propertiesLine :: Maybe Int+    propertiesLine =+      let start = skipSpaces e (lineStartAt e i)+      in if onlyProperties start then Just start else Nothing+      where+        onlyProperties :: Int -> Bool+        onlyProperties j =+          let b = byteAt e j+              next = skipWhites e (wordEnd j)+              b' = byteAt e next+          in (b == AMP || b == EXCL)+               && (b' == 0 || isBreak b' || b' == HASH || onlyProperties next)++        wordEnd :: Int -> Int+        wordEnd j = if isNsChar (byteAt e j) then wordEnd (j + 1) else j++    -- A key before the index that started on a line above. A key that ends+    -- here on one line does not fail.+    multiLineKey :: Bool+    multiLineKey =+      multiLineCollection+        || firstColon && (byteBefore e i == DQUOTE || byteBefore e i == SQUOTE)++    -- A flow collection ends before the index and starts on a line above.+    multiLineCollection :: Bool+    multiLineCollection =+      let b = byteBefore e i+      in (b == RBRACKET || b == RBRACE) && go (i - 2) 1 False+      where+        go :: Int -> Int -> Bool -> Bool+        go j depth crossed+          | j < e.base = False+          | c == RBRACKET || c == RBRACE = go (j - 1) (depth + 1) crossed+          | c == LBRACKET || c == LBRACE =+              if depth == 1 then crossed else go (j - 1) (depth - 1) crossed+          | otherwise = go (j - 1) depth (crossed || isBreak c)+          where+            c :: Word8+            c = byteAt e j++    onStartMarkerLine :: Bool+    onStartMarkerLine = isStartMarker e markerStart++    -- A byte order mark can come before a marker.+    markerStart :: Int+    markerStart = skipBoms e (lineStartAt e i)++    -- The start of the entry on the line, after any "- ".+    entryStart :: Int+    entryStart = skipListItems (skipSpaces e (lineStartAt e i))++    firstColon :: Bool+    firstColon = firstColonFrom entryStart++    -- No colon that ends a key is from the given index to the index of the+    -- error, other than in a flow collection.+    firstColonFrom :: Int -> Bool+    firstColonFrom start = go start 0+      where+        go :: Int -> Int -> Bool+        go j depth+          | j >= i = True+          | b == LBRACKET || b == LBRACE = go (j + 1) (depth + 1)+          | b == RBRACKET || b == RBRACE = go (j + 1) (max 0 (depth - 1))+          | depth == 0 && isKeyColon j = False+          | otherwise = go (j + 1) depth+          where+            b :: Word8+            b = byteAt e j++    -- A list item right after a key, as in "a: - b".+    itemAfterKey :: Bool+    itemAfterKey = isListItem i && byteBefore e (skipBackWhites e i) == COLON++    -- A list item right after an anchor or a tag, as in "&a - b".+    itemAfterProperty :: Bool+    itemAfterProperty =+      let j = skipBackWhites e i+          b = byteAt e (wordStart e j)+      in isListItem i && j < i && (b == AMP || b == EXCL)++    itemAfterStartMarker :: Bool+    itemAfterStartMarker =+      isListItem i+        && onStartMarkerLine+        && skipBackWhites e i == markerStart + markerLength++    -- A colon that ends a word and precedes white space, as in an unquoted+    -- value like "Error: file not found".+    valueColon :: Bool+    valueColon =+      isNsChar (byteBefore e i)+        && (let w = byteAt e (i + 1) in w == 0 || isWhite w || isBreak w)++    -- Only spaces precede the index on its line.+    indented :: Bool+    indented = i > e.base && byteBefore e i == SPACE && go (i - 1)+      where+        go :: Int -> Bool+        go j+          | j <= e.base = True+          | otherwise = case byteBefore e j of+              SPACE -> go (j - 1)+              w -> isBreak w++    -- The index is at the column of a list item or a key on a line above, so+    -- the content is the mistake, not the indentation. A line of a block+    -- scalar above is neither.+    alignedWithEntry :: Bool+    alignedWithEntry = case entryAbove (columnOf i) (lineStartAt e i) of+      Just k -> isListItem k || any isKeyColon [k .. lineContentEnd e k - 1]+      Nothing -> False++    lineStart :: Int+    lineStart = lineStartAt e i++    -- The content of the line of the index after the white space and the+    -- indicators of block entries, as in "- ? key". A plain scalar can follow+    -- a tab there, but a key cannot.+    contentStart :: Int+    contentStart = go lineStart+      where+        go :: Int -> Int+        go j =+          let k = skipWhites e j+          in if isBlockIndicator k then go (k + 1) else k++    -- The first tab in the indentation before the index, if only white space+    -- and the indicators of block entries precede the index on its line.+    indentationTab :: Int -> Maybe Int -> Maybe Int+    indentationTab j tab+      | j < e.base = tab'+      | isBlockIndicator j = indentationTab (j - 1) tab+      | otherwise = case A.unsafeIndex e.array j of+          SPACE -> indentationTab (j - 1) tab+          TAB -> indentationTab (j - 1) (Just j)+          w+            | isBreak w -> tab'+            | otherwise -> Nothing+      where+        tab' :: Maybe Int+        tab' = if byteAt e i == TAB then Just (fromMaybe i tab) else tab++    isBlockIndicator :: Int -> Bool+    isBlockIndicator j =+      let w = byteAt e j+      in (w == MINUS || w == QUESTION || w == COLON) && isWhite (byteAt e (j + 1))++    -- The error for a line of a block collection that lacks the space after+    -- "-" or the ":" after a key, if the entries above it at the same+    -- position are list items or mapping entries.+    blockMistake :: Maybe (Int, String)+    blockMistake = do+      guard $ start < stop+      k <- entryAbove column (lineStartAt e stop)+      if+        | isListItem k && byteAt e start == MINUS && stop == start + 1 ->+            Just (stop, "expected a space after '-'")+        | not (isListItem k)+            && (w == 0 || isBreak w || stop < i)+            && not (any isKeyColon [afterKey .. stop - 1]) ->+            Just $ case (keyEnd, filter tightColon [afterKey .. stop - 1]) of+              (Nothing, _) -> (start, "unterminated " ++ quotedName ++ " scalar")+              (Just end, _) | end > stop -> (stop, "a key must be on a single line")+              (_, colon : _) -> (colon + 1, "expected a space after ':'")+              (_, []) -> (stop, "expected ':' after the key")+        | otherwise -> Nothing+      where+        -- The parser fails at a comment after the content, as in "key # note".+        stop :: Int+        stop+          | byteAt e i == HASH && isWhite (byteBefore e i) = skipBackWhites e i+          | otherwise = i++        -- The index after the quoted scalar that starts the line, or the start+        -- of the line without a quote, or 'Nothing' if the scalar does not+        -- end. A colon inside the scalar does not end a key.+        keyEnd :: Maybe Int+        keyEnd+          | quote == DQUOTE || quote == SQUOTE = closing (start + 1)+          | otherwise = Just start+          where+            closing :: Int -> Maybe Int+            closing j+              | j >= e.end = Nothing+              | quote == SQUOTE && b == SQUOTE && byteAt e (j + 1) == SQUOTE =+                  closing (j + 2)+              | quote == DQUOTE && b == BACKSLASH = closing (j + 2)+              | b == quote = Just (j + 1)+              | otherwise = closing (j + 1)+              where+                b :: Word8+                b = byteAt e j++        -- The index after the key on the line.+        afterKey :: Int+        afterKey = fromMaybe stop keyEnd++        quote :: Word8+        quote = byteAt e start++        quotedName :: String+        quotedName = if quote == DQUOTE then "double-quoted" else "single-quoted"++        w :: Word8+        w = byteAt e stop++        start :: Int+        start = skipSpaces e (lineStartAt e stop)++        column :: Int+        column = start - lineStartAt e stop++        -- A colon before a word, as in "key:value", but not in "http://".+        tightColon :: Int -> Bool+        tightColon j = byteAt e j == COLON && startsWord (byteAt e (j + 1))++        startsWord :: Word8 -> Bool+        startsWord b =+          (isAsciiByte b && isAlphaNum (chr (fromIntegral b)))+            || b == SQUOTE+            || b == DQUOTE+            || b == LBRACKET+            || b == LBRACE++    -- The closest entry above the line that starts at the index, at the+    -- column. An entry can follow "- " on its line, as in "- key: value".+    entryAbove :: Int -> Int -> Maybe Int+    entryAbove column from = do+      k <- lineAbove from+      let indent = columnOf k+          entry = skipListItems k+      if+        | indent == column -> Just k+        | columnOf entry == column -> Just entry+        | indent < column -> Nothing+        | otherwise -> entryAbove column (lineStartAt e k)++    -- The error for content at the index that starts a line with a wrong+    -- indentation, if the lines above show the likely mistake: a list item+    -- among mapping entries or the other way round, or a line of a block+    -- scalar with too little indentation.+    indentationMistake :: Maybe String+    indentationMistake = go (lineStartAt e i)+      where+        column :: Int+        column = columnOf i++        -- Look at the lines above, up to the first line with less+        -- indentation.+        go :: Int -> Maybe String+        go start = do+          k <- lineAbove start+          let indent = columnOf k+          if+            | indent > column -> go (lineStartAt e k)+            | indent < column ->+                if endsWithBlockHeader k+                  then+                    Just+                      "unexpected indentation, the line has less indentation than the block scalar above it"+                  else Nothing+            | isListItem k && not (isListItem i) && not (isFlowIndicator (byteAt e i)) ->+                Just $+                  if hasKey i+                    then "unexpected key among list items"+                    else "unexpected value among list items"+            | not (isListItem k) && isListItem i ->+                Just "unexpected list item among mapping entries"+            | otherwise -> Nothing++    -- The line from the content at the index ends with the header of a block+    -- scalar, e.g. "key: |-".+    endsWithBlockHeader :: Int -> Bool+    endsWithBlockHeader k =+      let h = skipIndicators (lineContentEnd e k)+      in h > k+           && (let b = byteAt e (h - 1) in b == PIPE || b == GREATER)+           && (h - 1 == k || isWhite (byteAt e (h - 2)))+      where+        skipIndicators :: Int -> Int+        skipIndicators j =+          let b = byteBefore e j+          in if b == MINUS || b == PLUS || isDecDigit b then skipIndicators (j - 1) else j++    -- The first content of the closest line above the line that starts at the+    -- index. Blank lines and comment lines do not count.+    lineAbove :: Int -> Maybe Int+    lineAbove start = skipSpaces e . skipBoms e <$> contentLineAbove e start++    -- A byte order mark can start the first line of a document, before its+    -- indentation.+    columnOf :: Int -> Int+    columnOf j = j - skipBoms e (lineStartAt e j)++    -- The index after the "- " indicators at the index, as in "- - key: value".+    skipListItems :: Int -> Int+    skipListItems j = if isListItem j then skipListItems (skipWhites e (j + 1)) else j++    -- A colon that ends an implicit key is at the index.+    isKeyColon :: Int -> Bool+    isKeyColon j =+      byteAt e j == COLON+        && (let b = byteAt e (j + 1) in b == 0 || isWhite b || isBreak b)++    -- The line from the content at the index has a key, explicit or+    -- implicit.+    hasKey :: Int -> Bool+    hasKey j =+      (byteAt e j == QUESTION && (let b = byteAt e (j + 1) in b == 0 || isWhite b || isBreak b))+        || any isKeyColon [j .. lineContentEnd e j - 1]++    -- A block sequence entry starts at the index.+    isListItem :: Int -> Bool+    isListItem j =+      byteAt e j == MINUS+        && (let b = byteAt e (j + 1) in b == 0 || isWhite b || isBreak b)++-- | The colon that ends an alias name before the index, as in @*x: 1@. An+-- alias name can contain a colon.+aliasColon :: Env -> Int -> Maybe Int+aliasColon e i =+  let j = skipBackWhites e i+      start = wordStart e j+  in if j > start && byteBefore e j == COLON && byteAt e start == STAR+       then Just (j - 1)+       else Nothing++aliasColonMessage :: String+aliasColonMessage =+  "the name of the alias includes the ':', write a space before ':' if the alias is a key"++-- | The location and the message of the error at the index inside a flow+-- collection: a common mistake if the input there shows one, or else the+-- index and the given message.+flowError :: Env -> Int -> String -> (Int, String)+flowError e i msg = case aliasColon e i of+  Just colon -> (colon, aliasColonMessage)+  Nothing -> (i, fromMaybe msg (mistakeIn (afterBoms e) True i))++-- | The input without the byte order marks at its start. The hints look at+-- the content of the lines around an error, and the marks are not content+-- of the first line. The indices stay those of the input.+afterBoms :: Env -> Env+afterBoms e = e {base = skipBoms e e.base}++-- | The flag tells if the index is inside a flow collection.+mistakeIn :: Env -> Bool -> Int -> Maybe String+mistakeIn e flow i+  | isBom e i = Just "unexpected byte order mark"+  -- Inside a plain scalar, a '#' after other content does not stop the+  -- parser, so here it follows the end of another node, e.g. "x"#c.+  | w == HASH && isNsChar (byteBefore e i) =+      Just "unexpected '#', a comment needs a space before it"+  | w == COMMA+      && ( let b = byteBefore e (skipBack i)+           in b == COMMA || b == LBRACKET || b == LBRACE+         ) =+      Just "unexpected ',', a flow collection cannot have an empty entry"+  -- In the block style, these characters start a block scalar.+  | flow && (w == PIPE || w == GREATER) =+      Just $ unexpectedChar e i ++ ", a block scalar cannot be inside a flow collection"+  | w == STAR && not (isAnchorChar (byteAt e (i + 1))) =+      Just "expected an alias name after '*'"+  | w == STAR+      && (let b = byteAt e (wordStart e (skipBackWhites e i)) in b == AMP || b == EXCL) =+      Just "unexpected '*', an alias cannot have an anchor or a tag"+  | w == AMP && not (isAnchorChar (byteAt e (i + 1))) =+      Just "expected an anchor name after '&'"+  | afterQuote SQUOTE =+      Just $+        unexpectedChar e i+          ++ " after a single-quoted scalar, write '' for a quote inside it"+  | afterQuote DQUOTE =+      Just $+        unexpectedChar e i+          ++ " after a double-quoted scalar, write \\\" for a quote inside it"+  -- A '%' at the start of a line in the block style starts a directive.+  | not flow && w == PERCENT && isStartOfLine e i && isNsChar (byteAt e (i + 1)) =+      Just+        "unexpected '%', a directive needs '...' on a line above it to end the document"+  -- Other indicators start a node of another kind, e.g. '&' an anchor.+  | w == AT || w == GRAVE || w == PERCENT =+      Just $+        unexpectedChar e i ++ ", a plain scalar cannot start with it, quote the value"+  | otherwise = Nothing+  where+    w :: Word8+    w = byteAt e i++    -- The index after the last content before the white space and the line+    -- breaks that end at the index.+    skipBack :: Int -> Int+    skipBack j+      | isWhite (byteBefore e j) || isBreak (byteBefore e j) = skipBack (j - 1)+      | otherwise = j++    -- Content right after a quote, as in 'it's'. A plain scalar can hold a+    -- quote, so the quote closes a quoted scalar. A colon there ends a key.+    afterQuote :: Word8 -> Bool+    afterQuote q =+      byteBefore e i == q+        && isNsChar w+        && not (isFlowIndicator w)+        && w /= COLON+        && not quoteInTag++    -- A quote can be a character of a tag, as in "!'".+    quoteInTag :: Bool+    quoteInTag = byteBefore e (tagStart i) == EXCL+      where+        tagStart :: Int -> Int+        tagStart j = if isTagChar (byteBefore e j) then tagStart (j - 1) else j++-- | The index after the content of the line from the content at the index,+-- before its comment.+lineContentEnd :: Env -> Int -> Int+lineContentEnd e = skipBackWhites e . go+  where+    go :: Int -> Int+    go j+      | b == 0 || isBreak b = j+      | b == HASH && isWhite (byteBefore e j) = j+      | otherwise = go (j + 1)+      where+        b :: Word8+        b = byteAt e j++-- | The index after the last content before the white space that ends at the+-- index.+skipBackWhites :: Env -> Int -> Int+skipBackWhites e i = if isWhite (byteBefore e i) then skipBackWhites e (i - 1) else i++-- | The start of the word that ends at the index, e.g. of an anchor or an+-- alias with its indicator.+wordStart :: Env -> Int -> Int+wordStart e i = if isAnchorChar (byteBefore e i) then wordStart e (i - 1) else i++unexpectedChar :: Env -> Int -> String+unexpectedChar e i+  | isAsciiByte w = "unexpected " ++ show (chr (fromIntegral w))+  | isPrint c = "unexpected '" ++ [c] ++ "'"+  | otherwise = "unexpected " ++ codePointName c+  where+    w :: Word8+    w = byteAt e i++    c :: Char+    c = T.head (slice e i e.end)++-- | The first tab from the first index to before the second.+firstTab :: Env -> Int -> Int -> Maybe Int+firstTab e i j = L.find (\k -> byteAt e k == TAB) [i .. j - 1]++tabMessage :: String+tabMessage = "tabs cannot be used for indentation"++keyLengthMessage :: String+keyLengthMessage =+  "a key can be at most "+    ++ show maxImplicitKeyLength+    ++ " characters long, write a longer key after '? '"++-- | The code point of a character, e.g. U+0007, for a character that an error+-- cannot show.+codePointName :: Char -> String+codePointName c =+  let hex = map toUpper (showHex (ord c) "")+  in "U+" ++ replicate (4 - length hex) '0' ++ hex
+ src/Yamlet/Internal/Parser/Monad.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | A backtracking parser over the bytes of UTF-8 encoded text.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Parser.Monad+  ( -- * Parser+    P+  , Env (..)+  , ParseError (..)+  , runParser++    -- * Combinators+  , (<|>)+  , many+  , many_+  , optional+  , optional_+  , option+  , notFollowedBy++    -- * Primitives+  , env+  , pos+  , setPos+  , furthest+  , advance+  , addTagBytes+  , peek+  , peekAt+  , failure+  , guardP+  , throwAt+  , throwUnexpected+  , withEnd+  , withHandles+  , char+  , skipWhile+  , scan+  , Scanned (..)+  , withScan++    -- * Input access+  , byteAt+  , byteBefore+  , slice+  , toOffset+  ) where++import Control.Monad+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Text.Internal qualified as T+import Data.Word+import GHC.Exts (Int (I#), Int#, isTrue#, (+#), (>#))++import Yamlet.Internal.Syntax++-- | The input of the parser.+data Env = Env+  { array :: !A.Array+  , base :: !Int+  -- ^ The index of the first byte of the input.+  , end :: !Int+  -- ^ The index past the last byte that the parser can read.+  , streamEnd :: !Int+  -- ^ The index past the last byte of the input. A document ends before it+  -- at a document marker.+  , handles :: !(M.Map T.Text T.Text)+  -- ^ The tag handles of the current document.+  }++-- | An error that no backtracking can recover from: an error at the index+-- with the message, or a failure at the index in the environment, whose+-- message the caller of the parser finds.+data ParseError+  = ParseError !Int !String+  | UnexpectedParseError !Env !Int++-- | The result of a parser: a value with the new position, a failure, or an+-- error. Both the value and the failure carry the furthest position at which+-- a parser failed, the likely location of a syntax error. The value also+-- carries the bytes that the prefixes of @%TAG@ directives added to the tags,+-- see 'addTagBytes'.+type Res# a = (# (# a, Int#, Int#, Int# #) | Int# | ParseError #)++pattern OK# :: a -> Int# -> Int# -> Int# -> Res# a+pattern OK# a p f t = (# (# a, p, f, t #) | | #)++pattern Fail# :: Int# -> Res# a+pattern Fail# f = (# | f | #)++pattern Err# :: ParseError -> Res# a+pattern Err# e = (# | | e #)++{-# COMPLETE OK#, Fail#, Err# #-}++newtype P a = P (Env -> Int# -> Int# -> Int# -> Res# a)++runP :: P a -> Env -> Int# -> Int# -> Int# -> Res# a+runP (P g) = g++instance Functor P where+  fmap f (P g) = P $ \e p fu t -> case g e p fu t of+    OK# a p' fu' t' -> OK# (f a) p' fu' t'+    Fail# fu' -> Fail# fu'+    Err# err -> Err# err++instance Applicative P where+  pure a = P $ \_ p fu t -> OK# a p fu t+  (<*>) = ap+  P g *> P h = P $ \e p fu t -> case g e p fu t of+    OK# _ p' fu' t' -> h e p' fu' t'+    Fail# fu' -> Fail# fu'+    Err# err -> Err# err++  -- The default builds the result with 'fmap' and '<*>'.+  P g <* P h = P $ \e p fu t -> case g e p fu t of+    OK# a p' fu' t' -> case h e p' fu' t' of+      OK# _ p'' fu'' t'' -> OK# a p'' fu'' t''+      Fail# fu'' -> Fail# fu''+      Err# err -> Err# err+    Fail# fu' -> Fail# fu'+    Err# err -> Err# err++instance Monad P where+  P g >>= k = P $ \e p fu t -> case g e p fu t of+    OK# a p' fu' t' -> runP (k a) e p' fu' t'+    Fail# fu' -> Fail# fu'+    Err# err -> Err# err++-- | Run a parser from the given index. Return the result, the index after it+-- and the furthest failure.+runParser :: Env -> Int -> P a -> Either ParseError (Maybe a, Int, Int)+runParser e (I# p) (P g) = case g e p p 0# of+  OK# a p' fu _ -> Right (Just a, I# p', I# fu)+  Fail# fu -> Right (Nothing, I# p, I# fu)+  Err# err -> Left err++----------------------------------------+-- Combinators++infixl 3 <|>++-- | Ordered choice. Try the second parser if the first one fails.+(<|>) :: P a -> P a -> P a+P g <|> P h = P $ \e p fu t -> case g e p fu t of+  Fail# fu' -> h e p fu' t+  r -> r++-- | Zero or more times. Stop if the parser succeeds without input.+many :: P a -> P [a]+many (P g) = P $ \e p0 fu0 t0 ->+  let go acc p fu t = case g e p fu t of+        OK# a p' fu' t'+          | isTrue# (p' ># p) -> go (a : acc) p' fu' t'+          | otherwise -> OK# (reverse acc) p fu' t+        Fail# fu' -> OK# (reverse acc) p fu' t+        Err# err -> Err# err+  in go [] p0 fu0 t0++-- | Zero or more times, discard the results.+many_ :: P a -> P ()+many_ (P g) = P $ \e p0 fu0 t0 ->+  let go p fu t = case g e p fu t of+        OK# _ p' fu' t'+          | isTrue# (p' ># p) -> go p' fu' t'+          | otherwise -> OK# () p fu' t+        Fail# fu' -> OK# () p fu' t+        Err# err -> Err# err+  in go p0 fu0 t0++optional :: P a -> P (Maybe a)+optional p = (Just <$> p) <|> pure Nothing++optional_ :: P a -> P ()+optional_ p = void p <|> pure ()++option :: a -> P a -> P a+option a p = p <|> pure a++-- | Succeed without input if the parser fails. An error of the parser stays+-- an error, as in '<|>'.+notFollowedBy :: P a -> P ()+notFollowedBy (P g) = P $ \e p fu t -> case g e p fu t of+  OK# {} -> Fail# (furthestOf p fu)+  Fail# _ -> OK# () p fu t+  Err# err -> Err# err++-- | The furthest of a position where the parser failed and the furthest+-- failure so far.+furthestOf :: Int# -> Int# -> Int#+furthestOf p fu = if isTrue# (p ># fu) then p else fu++----------------------------------------+-- Primitives++env :: P Env+env = P $ \e p fu t -> OK# e p fu t++pos :: P Int+pos = P $ \_ p fu t -> OK# (I# p) p fu t++setPos :: Int -> P ()+setPos (I# p) = P $ \_ _ fu t -> OK# () p fu t++-- | The furthest position at which a parser failed so far.+furthest :: P Int+furthest = P $ \_ p fu t -> OK# (I# fu) p fu t++advance :: Int -> P ()+advance (I# n) = P $ \_ p fu t -> OK# () (p +# n) fu t++-- | Add the bytes that the prefix of a @%TAG@ directive adds to a tag, and+-- return the bytes that such prefixes added so far. A parser that fails+-- drops its bytes, so only the tags of the result count.+addTagBytes :: Int -> P Int+addTagBytes (I# n) = P $ \_ p fu t -> let t' = t +# n in OK# (I# t') p fu t'++-- | The byte at the current position, 0 at the end of the input.+peek :: P Word8+peek = P $ \e p fu t -> OK# (byteAt e (I# p)) p fu t++-- | The byte at the given distance from the current position.+peekAt :: Int -> P Word8+peekAt k = P $ \e p fu t -> OK# (byteAt e (I# p + k)) p fu t++failure :: P a+failure = P $ \_ p fu _ -> Fail# (furthestOf p fu)++guardP :: Bool -> P ()+guardP b = unless b failure++-- | Stop with an error at the given index.+throwAt :: Int -> String -> P a+throwAt i msg = P $ \_ _ _ _ -> Err# (ParseError i msg)++-- | Stop at the index, with an error whose message the caller of the parser+-- finds.+throwUnexpected :: Int -> P a+throwUnexpected i = P $ \e _ _ _ -> Err# (UnexpectedParseError e i)++-- | Run a parser that cannot read past the given index.+withEnd :: Int -> P a -> P a+withEnd end (P g) = P $ \e p fu t -> g e {end = end} p fu t++withHandles :: M.Map T.Text T.Text -> P a -> P a+withHandles hs (P g) = P $ \e p fu t -> g e {handles = hs} p fu t++char :: Word8 -> P ()+char w = P $ \e p fu t ->+  if byteAt e (I# p) == w+    then OK# () (p +# 1#) fu t+    else Fail# (furthestOf p fu)++skipWhile :: (Word8 -> Bool) -> P ()+skipWhile f = P $ \e p fu t ->+  let go i = if f (byteAt e i) then go (i + 1) else i+  in case go (I# p) of I# p' -> OK# () p' fu t++-- | The result of a scanning loop.+data Scanned a+  = -- | The value and the index after it.+    Done !Int !a+  | -- | The input does not match. The index is the location of the mismatch.+    NoMatch !Int+  | -- | An error at the index.+    Failed !Int !String++-- | Run a pure loop over the input from the current position.+withScan :: (Env -> Int -> Scanned a) -> P a+withScan f = P $ \e p fu t -> case f e (I# p) of+  Done (I# q) a -> OK# a q fu t+  NoMatch (I# q) -> Fail# (furthestOf q fu)+  Failed i msg -> Err# (ParseError i msg)++-- | Move to the index that the function computes from the current one.+scan :: (Env -> Int -> Int) -> P ()+scan f = P $ \e p fu t -> case f e (I# p) of I# p' -> OK# () p' fu t++----------------------------------------+-- Input access++byteAt :: Env -> Int -> Word8+byteAt e i+  | i < e.end = A.unsafeIndex e.array i+  | otherwise = 0++-- | The byte before the index, 0 at the start of the input.+byteBefore :: Env -> Int -> Word8+byteBefore e i+  | i > e.base = A.unsafeIndex e.array (i - 1)+  | otherwise = 0++slice :: Env -> Int -> Int -> T.Text+slice e i j+  | j > i = T.Text e.array i (j - i)+  -- With 'T.empty', GHC moves the content of an empty quoted key, e.g. in+  -- "'': x", to a constant, and builds the node of the key as a thunk that+  -- waits for the evaluation of 'T.empty'. A pragma on a copy of 'T.empty'+  -- does not prevent this. The heap check of the render tests finds this+  -- thunk.+  | otherwise = T.Text e.array i 0++toOffset :: Env -> Int -> Offset+toOffset e i = Offset (i - e.base)
+ src/Yamlet/Internal/Parser/Scan.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Scans of the input around an index, outside of the parser monad.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Parser.Scan+  ( isBom+  , skipBoms+  , skipSpaces+  , skipWhites+  , breakEnd+  , isStartOfLine+  , lineStartAt+  , previousLineStart+  , lineEndAt+  , nextLineStart+  , contentLineAbove+  , markerLength+  , isMarker+  , isStartMarker+  , isEndMarker+  , startsPrefix+  , bomBeforeContent+  , canEndFlowNode+  , fitsKey+  ) where++import Yamlet.Internal.Chars+import Yamlet.Internal.Parser.Monad+import Yamlet.Internal.Utils++isBom :: Env -> Int -> Bool+isBom e = isBomIn e.array e.end++skipBoms :: Env -> Int -> Int+skipBoms e = skipBomsIn e.array e.end++skipSpaces :: Env -> Int -> Int+skipSpaces e i = if byteAt e i == SPACE then skipSpaces e (i + 1) else i++skipWhites :: Env -> Int -> Int+skipWhites e i = if isWhite (byteAt e i) then skipWhites e (i + 1) else i++-- | The index after the line break at the index.+breakEnd :: Env -> Int -> Int+breakEnd e i+  | byteAt e i == CR && byteAt e (i + 1) == LF = i + 2+  | otherwise = i + 1++isStartOfLine :: Env -> Int -> Bool+isStartOfLine e i+  | i <= e.base = True+  | isBreak (byteBefore e i) = True+  | i - bomLength >= e.base && isBom e (i - bomLength) = isStartOfLine e (i - bomLength)+  | otherwise = False++-- | The start of the line that contains the index.+lineStartAt :: Env -> Int -> Int+lineStartAt e i+  | i > e.base && not (isBreak (byteBefore e i)) = lineStartAt e (i - 1)+  | otherwise = i++-- | The start of the line above the line that starts at the index, which is+-- not the first line.+previousLineStart :: Env -> Int -> Int+previousLineStart e i = lineStartAt e (breakStart (i - 1))+  where+    -- The start of the line break that ends at the index, e.g. of CR LF.+    breakStart :: Int -> Int+    breakStart j+      | j > e.base && byteBefore e j == CR && byteAt e j == LF = j - 1+      | otherwise = j++-- | The index of the line break that ends the line of the index, or the end+-- of the input.+lineEndAt :: Env -> Int -> Int+lineEndAt e i+  | i < e.end && not (isBreak (byteAt e i)) = lineEndAt e (i + 1)+  | otherwise = i++-- | The start of the line below the line of the index, or the end of the+-- input.+nextLineStart :: Env -> Int -> Int+nextLineStart e i = let j = lineEndAt e i in if j < e.end then breakEnd e j else j++-- | The start of the closest line above the line that starts at the index+-- with content other than a comment. Byte order marks at the start of a line+-- do not count as content.+contentLineAbove :: Env -> Int -> Maybe Int+contentLineAbove e start+  | start <= e.base = Nothing+  | otherwise =+      let prev = previousLineStart e start+          b = byteAt e (skipWhites e (skipBoms e prev))+      in if isBreak b || b == HASH then contentLineAbove e prev else Just prev++-- | The number of characters of a @---@ or @...@ marker.+markerLength :: Int+markerLength = 3++-- | A @---@ or @...@ marker at the start of a line.+isMarker :: Env -> Int -> Bool+isMarker e i =+  let w = byteAt e i+      after = byteAt e (i + markerLength)+  in (w == MINUS || w == DOT)+       && all (\j -> byteAt e (i + j) == w) [1 .. markerLength - 1]+       && (after == 0 || isWhite after || isBreak after)+       && isStartOfLine e i++-- | A @---@ marker at the start of a line.+isStartMarker :: Env -> Int -> Bool+isStartMarker e i = isMarker e i && byteAt e i == MINUS++-- | A @...@ marker at the start of a line.+isEndMarker :: Env -> Int -> Bool+isEndMarker e i = isMarker e i && byteAt e i == DOT++-- | A byte order mark at the start of a line. Outside a quoted scalar, it+-- starts the prefix of the next document, so the content of a document ends+-- before it.+startsPrefix :: Env -> Int -> Bool+startsPrefix e i = isBom e i && isStartOfLine e i++-- | Byte order marks at the index before something other than a document+-- marker or a directive. Such marks at the start of a line inside a document+-- are an error.+bomBeforeContent :: Env -> Int -> Bool+bomBeforeContent e i =+  isBom e i && let j = skipBoms e i in not (isMarker e j || byteAt e j == PERCENT)++-- | A quoted scalar or a flow collection can end before the index: white+-- space, a comment, a line break, the end of the input, a colon or the end+-- of a flow entry follows.+canEndFlowNode :: Env -> Int -> Bool+canEndFlowNode e i =+  let j = skipWhites e i+      w = byteAt e j+  in w == 0+       || isBreak w+       || w == COLON+       || w == COMMA+       || w == RBRACKET+       || w == RBRACE+       || (w == HASH && j > i)++-- | The input between the indices fits in an implicit key.+fitsKey :: Env -> Int -> Int -> Bool+fitsKey e p q =+  q - p <= maxImplicitKeyLength+    || ( q - p <= maxImplicitKeyLength * maxCharBytes+           && countChars <= maxImplicitKeyLength+       )+  where+    -- The longest UTF-8 encoding of a character.+    maxCharBytes :: Int+    maxCharBytes = 4++    countChars :: Int+    countChars =+      length+        [() | x <- [p .. q - 1], isCharStart (byteAt e x)]
+ src/Yamlet/Internal/Render.hs view
@@ -0,0 +1,1230 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Rendering of the syntax tree.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Render+  ( RenderOptions (..)+  , defaultRenderOptions+  , renderSyntax+  ) where++import Control.Applicative+import Data.Bifunctor+import Data.List qualified as L+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Set qualified as S+import Data.Text qualified as T+import Data.Text.Builder.Linear qualified as B+import GHC.Generics++import Yamlet.Internal.Chars hiding (isAnchorChar)+import Yamlet.Internal.Emit+import Yamlet.Internal.Syntax hiding (document)+import Yamlet.Internal.Utils++-- A data type, so that a later release can add an option.+{- HLINT ignore RenderOptions "Use newtype instead of data" -}++-- | The options of 'renderSyntax'.+data RenderOptions = RenderOptions+  { forceBlock :: !Bool+  -- ^ Write every non-empty collection in the block style. A collection in a+  -- key then becomes an explicit key, e.g. @? - a@.+  }+  deriving stock (Eq, Show, Generic)++-- | Keep the collection styles of the tree.+defaultRenderOptions :: RenderOptions+defaultRenderOptions =+  RenderOptions+    { forceBlock = False+    }++-- | Render documents with their comments and empty lines.+--+-- The output differs from the tree where YAML cannot hold it:+--+-- * A @---@ marker is on a line of its own, with at most a comment after+--   it.+--+-- * A scalar keeps its style if the style can hold its text, otherwise it+--   gets quotes. A block scalar that is a key or an entry of a flow+--   collection gets double quotes. A block scalar at the root gets quotes+--   in a few more cases, e.g. if its text starts with a space.+--+-- * The empty lines from the comments right after a block scalar with the+--   @+@ indicator go away, because they would become part of the scalar.+--+-- * A flow collection with comments inside becomes a block collection, so+--   that every comment has a line.+--+-- * A flow collection without comments is on one line, apart from the line+--   breaks of its multi-line scalars, so the empty lines between its entries+--   go away.+--+-- * A key of more than 1024 characters in a flow mapping becomes an explicit+--   key, e.g. @{? key : value}@, because YAML 1.1 parsers reject a longer+--   implicit key there too.+--+-- * A comment that has no place at its node moves to a place that has one,+--   e.g. the lines above the value of a key go above the key if the value+--   is on the line of the key.+--+-- * In the text of a comment, a character that YAML does not allow becomes+--   U+FFFD, and the white space at the end goes away. A line break starts a+--   new comment in a 'Yamlet.Syntax.CommentLine', and becomes a space in an+--   inline comment.+--+-- * An anchor name with a character that YAML does not allow in it, e.g. a+--   space, or that YAML 1.1 parsers read as the end of the name, e.g. @:@+--   or a line separator, becomes a new name in the anchor and in its+--   aliases. Names that only some parsers reject stay, e.g. @é@, which+--   libyaml rejects.+--+-- * A version that the parser does not support, e.g. 2.0, has no @%YAML@+--   directive.+--+-- With 'Yamlet.Syntax.forceBlock', the flow collections become block+-- collections:+--+-- >>> :{+-- case parseDocumentsText "a: [1, {b: 2}]\n" of+--   Left err -> putStrLn (prettyError "input.yaml" err)+--   Right docs ->+--     T.putStr (renderSyntax defaultRenderOptions {forceBlock = True} docs)+-- :}+-- a:+-- - 1+-- - b: 2+renderSyntax :: RenderOptions -> [Document] -> T.Text+renderSyntax opts = emptyLines . B.runBuilder . go True+  where+    -- The empty lines at the start or the end of the output go away, because+    -- the parser gives the lines there to no node. The empty lines in the+    -- content of a block scalar stay. Only the content of a block scalar+    -- with the keep indicator ends with an empty line, and the empty lines+    -- right after it go away, because they would become part of it.+    emptyLines :: T.Text -> T.Text+    emptyLines t+      | T.any (== '\0') t =+          T.unlines+            . map (\l -> if l == emptyLine then "" else l)+            . dropEnd+            . dropWhile (== emptyLine)+            . afterKeptLines+            $ T.lines t+      -- Every document ends with a line break, so the lines stay the same.+      | otherwise = t++    afterKeptLines :: [T.Text] -> [T.Text]+    afterKeptLines = \case+      a : rest | T.null a -> a : afterKeptLines (dropWhile (== emptyLine) rest)+      a : rest -> a : afterKeptLines rest+      [] -> []++    dropEnd :: [T.Text] -> [T.Text]+    dropEnd = reverse . dropWhile (== emptyLine) . reverse++    go :: Bool -> [Document] -> B.Builder+    go atStart = \case+      [] -> mempty+      doc : docs ->+        let nextLines = case docs of+              next : _ -> not (null next.docComments.before)+              [] -> False+            prepared =+              validAnchors doc {root = topLevel nextLines (commentedBlocks doc.root)}+            -- Directives need an end marker above them. The document above+            -- writes it, so that its lines go where they read back from.+            ends =+              any hasDirectives (take 1 docs)+                || writesEnd opts (not (null docs)) nextLines prepared+        in document atStart ends prepared <> go False docs++    -- A block scalar without content at the top level would take the lines+    -- below it in, also those of the next document if the flag tells that it+    -- has lines above its start marker. It gets quotes also when an end+    -- marker follows, which would end it, because the choice of the marker+    -- looks at the root with the quotes. Only the style changes.+    topLevel :: Bool -> Node -> Node+    topLevel nextLines n = case n.content of+      ScalarLinesContent style t starts+        | isBlockScalar style+        , needsIndentIndicator t+            || T.all (== '\n') t && (not (null n.comments.after) || nextLines) ->+            n {content = ScalarLinesContent DoubleQuoted t starts}+      _ -> n++    -- A document. The flags tell if it starts the stream and if it ends with+    -- a document end marker.+    document :: Bool -> Bool -> Document -> B.Builder+    document atStart ends doc =+      mconcat+        [ gap+        , lines_ 0 doc.docComments.before+        , if directives+            then+              foldMap+                ( \v ->+                    "%YAML "+                      <> B.fromUnboundedDec v.major+                      <> "."+                      <> B.fromUnboundedDec v.minor+                      <> "\n"+                )+                version+                <> foldMap tagDirective handles+            else mempty+        , body+        , if linesAboveEnd then lines_ 0 doc.docComments.after else mempty+        , if ends then "...\n" else mempty+        , if linesAboveEnd then mempty else lines_ 0 doc.docComments.after+        ]+      where+        r :: Node+        r = doc.root++        -- The lines between a flow collection root and the end marker belong+        -- to the document, as do the lines below the marker. Below the+        -- marker, an empty line would end them.+        linesAboveEnd :: Bool+        linesAboveEnd = isFlowCollection opts r && EmptyLine `elem` doc.docComments.after++        -- The end of the document above takes the comments right below it.+        -- The lines above the first entry of a block root come first too.+        gap :: B.Builder+        gap = case if null doc.docComments.before && not marker+          then aboveIndicator opts r+          else doc.docComments.before of+          Comment _ : _ -> lines_ 0 [EmptyLine]+          _ -> mempty++        handles :: [Char]+        handles = tagHandles r++        version :: Maybe YamlVersion+        version = supportedVersion doc++        directives :: Bool+        directives = isJust version || not (null handles)++        -- A document needs a start marker after another document, after+        -- directives, for a comment on the marker line, and if it is empty. A+        -- block collection without properties has no line of its own for its+        -- comment. Without the marker, the lines above a document read back+        -- as the root's. YAML 1.2 needs no marker after an end marker, but+        -- YAML 1.1 parsers do.+        marker :: Bool+        marker =+          doc.explicitStart+            || directives+            || not atStart+            || isEmpty r+            || not (null doc.docComments.before)+            || isJust doc.docComments.inline+            || (isBlock opts r && isJust r.comments.inline && isNothing propsLine)++        -- The properties of a block collection with its comment on their+        -- line, which keeps the lines above it from the first entry.+        propsLine :: Maybe B.Builder+        propsLine = case props r of+          Just p+            | isBlock opts r, Just c <- r.comments.inline -> Just (p <> comment (Just c))+          _ -> Nothing++        -- The marker line holds one comment. The comment of a block+        -- collection goes below it if the document has one too.+        (markerComment, rootLines) = case (doc.docComments.inline, r.comments.inline) of+          (dc, _) | isJust propsLine -> (dc, r.comments.before)+          (Just dc, Just rc)+            | isBlock opts r -> (Just dc, inlineLine rc : r.comments.before)+          (dc, rc) -> (dc <|> (if isBlock opts r then rc else Nothing), r.comments.before)++        startMarker :: B.Builder+        startMarker = if marker then "---" <> comment markerComment <> "\n" else mempty++        -- Below the line of the properties with a comment, the root takes the+        -- lines up to the last empty line, as below an indicator, so these+        -- lines of the first entry go above the properties. A first entry+        -- that starts below its indicator has its lines there.+        body :: B.Builder+        body+          | Just p <- propsLine =+              let (above, below) = splitAtLastEmptyLine (firstLines opts r)+              in startMarker+                   <> lines_ 0 (rootLines ++ above)+                   <> p+                   <> "\n"+                   <> lines_ 0 below+                   <> block opts 0 0 True (not (firstStartsBelow opts r)) False [] r+          | isBlock opts r =+              startMarker+                <> lines_+                  0+                  ( separated rootLines+                      ++ (if isJust (props r) then firstLines opts r else [])+                  )+                <> maybe mempty (<> "\n") (props r)+                <> block+                  opts+                  0+                  0+                  True+                  (isJust (props r) && not (firstStartsBelow opts r))+                  False+                  []+                  r+          | otherwise = scalarBody <> linesBelow 0 r++        scalarBody :: B.Builder+        scalarBody+          | isEmpty r =+              let (c, ls) = emptyRootLines doc+              in "---" <> comment c <> "\n" <> lines_ 0 ls+          | marker =+              "---"+                <> comment doc.docComments.inline+                <> "\n"+                <> lines_ 0 r.comments.before+                <> inline opts InValue indentStep r r.comments.inline+                <> "\n"+          | otherwise =+              lines_ 0 r.comments.before+                <> inline opts InValue indentStep r r.comments.inline+                <> "\n"++-- | The node with every flow collection that has a comment inside+-- in the block style, so that every comment has a line. The comments of a+-- collection in its lines above and in its inline comment fit outside a flow+-- collection.+commentedBlocks :: Node -> Node+commentedBlocks = fst . go+  where+    -- The node, and whether it or a node inside it has a comment that does+    -- not fit outside a flow collection.+    go :: Node -> (Node, Bool)+    go n = case n.content of+      SequenceContent style xs ->+        let ys = map go xs+            has = linesAfter || any inner ys+        in (n {content = SequenceContent (styleOf has style) (map fst ys)}, has)+      MappingContent style kvs ->+        let ys = map (bimap go go) kvs+            has = linesAfter || any (\(k, v) -> inner k || inner v) ys+        in ( n {content = MappingContent (styleOf has style) (map (bimap fst fst) ys)}+           , has+           )+      _ -> (n, linesAfter)+      where+        linesAfter :: Bool+        linesAfter = hasCommentLine n.comments.after++    inner :: (Node, Bool) -> Bool+    inner (x, has) = hasCommentLine x.comments.before || isJust x.comments.inline || has++    styleOf :: Bool -> CollectionStyle -> CollectionStyle+    styleOf has style = if has then Block else style++-- | The document with anchor names that read back. A name that an anchor+-- cannot have becomes a name that no other anchor of the document has, in+-- its anchors and in its aliases.+validAnchors :: Document -> Document+validAnchors doc+  | all isAnchorName names = doc+  | otherwise = doc {root = rename doc.root}+  where+    names :: [T.Text]+    names = collect doc.root []++    collect :: Node -> [T.Text] -> [T.Text]+    collect n acc =+      maybe id (:) n.props.anchor $ case n.content of+        AliasContent a -> a : acc+        SequenceContent _ xs -> foldr collect acc xs+        MappingContent _ kvs -> foldr (\(k, v) -> collect k . collect v) acc kvs+        ScalarContent _ _ -> acc++    newNames :: M.Map T.Text T.Text+    newNames =+      (\(_, _, m) -> m) $+        L.foldl' add (S.fromList (filter isAnchorName names), M.empty, M.empty) names++    -- The state has the used names, the next suffix to try for each base, and+    -- the new names. A suffix below the next one is used already, so the+    -- search does not try it again.+    add+      :: (S.Set T.Text, M.Map T.Text Int, M.Map T.Text T.Text)+      -> T.Text+      -> (S.Set T.Text, M.Map T.Text Int, M.Map T.Text T.Text)+    add (used, next, m) a+      | isAnchorName a || M.member a m = (used, next, m)+      | otherwise =+          let base =+                if T.null a+                  then "anchor"+                  else T.map (\c -> if isAnchorChar c then c else '_') a+              (new, i) = fresh used base (M.findWithDefault firstSuffix base next)+          in (S.insert new used, M.insert base i next, M.insert a new m)++    -- The name without a suffix is the first one, so the suffixes start at 2.+    firstSuffix :: Int+    firstSuffix = 2++    -- The free name and the next suffix to try.+    fresh :: S.Set T.Text -> T.Text -> Int -> (T.Text, Int)+    fresh used base i+      | S.notMember base used = (base, i)+      | S.notMember candidate used = (candidate, i + 1)+      | otherwise = fresh used base (i + 1)+      where+        candidate :: T.Text+        candidate = base <> "_" <> T.pack (show i)++    rename :: Node -> Node+    rename n =+      n+        { props = n.props {anchor = newName <$> n.props.anchor}+        , content = case n.content of+            AliasContent a -> AliasContent (newName a)+            SequenceContent style xs -> SequenceContent style (map rename xs)+            MappingContent style kvs ->+              MappingContent style (map (bimap rename rename) kvs)+            c -> c+        }++    newName :: T.Text -> T.Text+    newName a = M.findWithDefault a a newNames++    isAnchorName :: T.Text -> Bool+    isAnchorName a = not (T.null a) && T.all isAnchorChar a++    -- libyaml, PyYAML and go-yaml v2 end an anchor name at ':' and '?' and+    -- read the rest as content, without an error.+    isAnchorChar :: Char -> Bool+    isAnchorChar c =+      isScalarChar c+        && c /= ' '+        && c /= ':'+        && c /= '?'+        && not (asciiChar isFlowIndicator c)++-- | The version of the document if the parser accepts it. The parser+-- rejects the other versions.+supportedVersion :: Document -> Maybe YamlVersion+supportedVersion doc = case doc.version of+  Just v | v.major == 1, v.minor >= 0, v.minor <= maxVersion -> Just v+  _ -> Nothing++-- | The document starts with directives: a version or a tag handle.+hasDirectives :: Document -> Bool+hasDirectives doc = isJust (supportedVersion doc) || not (null (tagHandles doc.root))++-- | The document ends with a @...@ marker. The flags tell if another+-- document follows and if it has lines above its start marker.+--+-- Without the marker, the lines at the end of the document read back as the+-- root's, unless the root is a flow collection. Before the next document,+-- an empty line at the end of the root, or below a flow collection root,+-- would end the lines of the document, and a literal block scalar with the+-- keep indicator at the end would take the empty line above the lines of the+-- next document in.+writesEnd :: RenderOptions -> Bool -> Bool -> Document -> Bool+writesEnd opts next nextLines doc =+  doc.explicitEnd+    || not (null doc.docComments.after) && not (isFlowCollection opts doc.root)+    || next && commentBelowEmptyLine endLines+    || nextLines && endsWithKeep doc.root+  where+    -- The lines at the end of the root, which read back as its last lines,+    -- or the lines of the document below a flow collection root. The lines+    -- of an empty root are all below its start marker.+    endLines :: [Line]+    endLines+      | isEmpty doc.root = snd (emptyRootLines doc) ++ doc.root.comments.after+      | isFlowCollection opts doc.root = doc.docComments.after+      | otherwise = linesAtEnd doc.root++    -- The lines at the end of the node and of the nodes that end it. The+    -- lines after the last key go below the entry if the value is not a block+    -- collection, as in 'entryComments'.+    linesAtEnd :: Node -> [Line]+    linesAtEnd n = inner ++ n.comments.after+      where+        inner :: [Line]+        inner = case n.content of+          SequenceContent _ xs | isBlock opts n, x : _ <- reverse xs -> linesAtEnd x+          MappingContent _ kvs+            | isBlock opts n+            , (k, v) : _ <- reverse kvs -> case entryComments opts k v of+                (_, _, below) | not (isBlock opts v) -> below ++ linesAtEnd v+                _ -> linesAtEnd v+          _ -> []++    -- A comment line below the scalar ends its content.+    endsWithKeep :: Node -> Bool+    endsWithKeep n+      | hasCommentLine n.comments.after = False+      | otherwise = case n.content of+          ScalarContent Literal t -> isJust (literalBlock 0 t) && hasKeepIndicator t+          SequenceContent _ xs | isBlock opts n, x : _ <- reverse xs -> endsWithKeep x+          MappingContent _ kvs+            | isBlock opts n, (_, v) : _ <- reverse kvs -> endsWithKeep v+          _ -> False++-- | The comment on the start marker line of a document with an empty root,+-- and the lines below the marker, without the lines at the end of the root.+-- The marker line holds one comment, so the comment of the root goes below+-- it if the document has one too.+emptyRootLines :: Document -> (Maybe T.Text, [Line])+emptyRootLines doc = case (doc.docComments.inline, doc.root.comments.inline) of+  (Just dc, Just rc) -> (Just dc, doc.root.comments.before ++ [inlineLine rc])+  (dc, rc) -> (dc <|> rc, doc.root.comments.before)++-- | The lines have a comment below an empty line.+commentBelowEmptyLine :: [Line] -> Bool+commentBelowEmptyLine ls = case dropWhile (/= EmptyLine) ls of+  _ : rest -> hasCommentLine rest+  [] -> False++-- | A collection that the renderer writes in the flow style.+isFlowCollection :: RenderOptions -> Node -> Bool+isFlowCollection opts n = case n.content of+  SequenceContent {} -> not (isBlock opts n)+  MappingContent {} -> not (isBlock opts n)+  _ -> False++-- | The entries of a block collection at the given indentation, and the lines+-- after them at the given column. The first entry does not start with+-- indentation if the collection continues a line, and the lines above it are+-- not written if the caller wrote them already. The second flag tells if the+-- caller wrote the lines of the first entries of the chain that starts with+-- the first entry, as in @indicatorLines@. The given lines go to the first+-- entry if it starts below its indicator.+block+  :: RenderOptions -> Int -> Int -> Bool -> Bool -> Bool -> [Line] -> Node -> B.Builder+block opts indent afterColumn atLineStart hoisted chainWritten carried n =+  case n.content of+    SequenceContent _ xs ->+      mconcat (zipWith item [0 :: Int ..] xs) <> lines_ afterColumn n.comments.after+    MappingContent _ kvs ->+      mconcat (zipWith entry [0 :: Int ..] kvs) <> lines_ afterColumn n.comments.after+    _ -> mempty+  where+    start :: Int -> [Line] -> B.Builder+    start i ls+      | i == 0 && not atLineStart = mempty+      | i == 0 && hoisted = spaces indent+      | otherwise = lines_ indent ls <> spaces indent++    -- Without the second case, the tuple of 'indicatorLines' makes the render+    -- benchmark of the config input allocate more.+    item :: Int -> Node -> B.Builder+    item i x+      | startsBelow opts x =+          let (above, below, rest, written) =+                indicatorLines (i == 0) (if i == 0 then carried else []) x+          in start i above+               <> "-"+               <> after opts indent (indent + indentStep) written below rest x+      | otherwise =+          start i (aboveIndicator opts x)+            <> "-"+            <> after opts indent (indent + indentStep) False [] [] x++    entry :: Int -> (Node, Node) -> B.Builder+    entry i (k, v) = case implicitKey opts k of+      Just key ->+        let (above, lineComment, below) = entryComments opts k v+        in start i above <> key <> ":" <> value v lineComment below+      Nothing ->+        let (keyAbove, keyBelow, keyRest, keyWritten) =+              indicatorLines (i == 0) (if i == 0 then carried else []) k+            (valueAbove, valueBelow, valueRest, valueWritten) = indicatorLines False [] v+        in start i keyAbove+             <> "?"+             <> after opts indent indent keyWritten keyBelow keyRest k+             <> lines_ indent valueAbove+             <> spaces indent+             <> ":"+             <> after+               opts+               indent+               (indent + indentStep)+               valueWritten+               valueBelow+               valueRest+               v++    -- The lines above the indicator of a sequence item or an explicit entry,+    -- the lines below it, and the lines for the first entry of a block+    -- collection that starts below its indicator. The flag is set for the+    -- first entry of a collection, and the given lines come first.+    --+    -- The parser gives the lines above and below the indicator of a block+    -- collection that starts below it to the collection up to the last empty+    -- line, and the rest to its first entry. A comment on the line of the+    -- indicator keeps the lines above it from the first entry. Above the+    -- indicator of a first entry, the collection around it takes the lines+    -- up to the last empty line. So the lines of the collection after the+    -- last empty line go above the indicator if it has a comment and nothing+    -- else takes them there. Otherwise an empty line after them keeps them+    -- from the first entry, above the indicator of a later entry and below+    -- the indicator of a first entry. Without lines of the collection, the+    -- given lines go to its first entry.+    --+    -- The lines of the first entry also read back the same above the+    -- indicator, if they have no empty line and no node between them and the+    -- indicator has lines of its own or a comment on the line of its+    -- indicator. Then they go there, at the start of a line, so that the+    -- lines above a list item with an anchor stay above it. Through a chain+    -- of first entries that start below their indicators they go above the+    -- first indicator, and the last flag of the result tells the chain that+    -- they are written.+    indicatorLines :: Bool -> [Line] -> Node -> ([Line], [Line], [Line], Bool)+    indicatorLines isFirst given x+      | startsBelow opts x =+          let ls = given ++ x.comments.before+              lineStart = atLineStart && not hoisted && not chainWritten+              aboveFirst = isFirst && null ls && lineStart+          in if+               | firstStartsBelow opts x ->+                   let (own, rest) = splitAtLastEmptyLine ls+                       lifted = liftable (firstEntryOf x >>= chainLines opts)+                   in if+                        | isFirst && chainWritten -> ([], own, rest, True)+                        | aboveFirst, Just ls' <- lifted -> (ls', [], [], True)+                        | not isFirst+                        , Just ls' <- lifted ->+                            (separated ls ++ ls', [], [], True)+                        | null x.comments.before -> ([], own, rest, False)+                        | isJust x.comments.inline+                        , not isFirst || null own && lineStart ->+                            (ls, [], [], False)+                        | isFirst -> ([], separated ls, [], False)+                        | otherwise -> (separated ls, [], [], False)+               | isFirst && chainWritten -> ([], separated ls, [], False)+               | aboveFirst+               , Just ls' <- liftable (Just (firstLines opts x)) ->+                   (ls', [], [], False)+               -- An empty line above the indicator would give the lines up to+               -- it to the collection around, and one below it would give them+               -- to this collection.+               | isFirst+               , isJust x.comments.inline+               , lineStart+               , EmptyLine `notElem` ls ++ firstLines opts x ->+                   (ls, firstLines opts x, [], False)+               | isFirst -> ([], separated ls ++ firstLines opts x, [], False)+               | isJust x.comments.inline ->+                   let (above, below) = splitAtLastEmptyLine (firstLines opts x)+                   in (ls ++ above, below, [], False)+               | otherwise -> (ls ++ firstLines opts x, [], [], False)+      | otherwise = (aboveIndicator opts x, [], [], False)+      where+        liftable :: Maybe [Line] -> Maybe [Line]+        liftable = \case+          Just ls'+            | isNothing x.comments.inline+            , not (null ls')+            , EmptyLine `notElem` ls' ->+                Just ls'+          _ -> Nothing++    -- The value of a mapping entry after the colon with the comment of the+    -- line, and the line break. The lines go between the key and a block+    -- collection, or below the entry, indented deeper than the key, where+    -- the lines after the value go too.+    value :: Node -> Maybe T.Text -> [Line] -> B.Builder+    value v lineComment extra+      | isBlock opts v =+          -- Without the bang, the render benchmark of the config input+          -- allocates more.+          let !column = case v.content of+                -- A sequence without indentation has no column of its own for+                -- the lines after its last item: a block collection or a block+                -- scalar as the last item takes in every line that is deeper+                -- than the key.+                SequenceContent _ xs+                  | not (hasCommentLine v.comments.after) || not (endsWithBlock xs) ->+                      indent+                _ -> indent + indentStep+          in header+               <> lines_ column below+               <> block opts column (indent + indentStep) True False False rest v+      | isEmpty v = comment lineComment <> "\n" <> entryBelow+      | otherwise =+          " "+            <> inline opts InValue (indent + indentStep) v lineComment+            <> "\n"+            <> entryBelow+      where+        -- The lines after a block scalar end it at the column of the key.+        -- Without the first case, the render benchmark of the config input+        -- allocates more.+        entryBelow :: B.Builder+        entryBelow+          | null extra && null v.comments.after = mempty+          | otherwise =+              let column = if isBlockScalarNode v then indent else indent + indentStep+              in lines_ column extra <> linesBelow column v++        header :: B.Builder+        header = maybe mempty (" " <>) (props v) <> comment lineComment <> "\n"++        -- The value takes the lines below the key as in 'indicatorLines'.+        below, rest :: [Line]+        (below, rest)+          | firstStartsBelow opts v = splitAtLastEmptyLine (extra ++ v.comments.before)+          | otherwise = (separated (extra ++ v.comments.before), [])++        endsWithBlock :: [Node] -> Bool+        endsWithBlock xs = case reverse xs of+          x : _ -> isBlockScalarNode x || isBlock opts x+          [] -> False++-- 'after' stays at top level, although 'block' is its only caller. In the+-- where clause of 'block', it made the render benchmark of the config input+-- allocate more.++-- | A node after the indicator of a sequence item or an explicit entry, with+-- the line break, and the lines below the indicator and the lines for the+-- first entry from @indicatorLines@, with its flag for the lines of the+-- chain. A block collection starts on the same line if it can. The lines+-- after a scalar go at the given column.+after :: RenderOptions -> Int -> Int -> Bool -> [Line] -> [Line] -> Node -> B.Builder+after opts indent column chainWritten below rest n+  | isBlock opts n =+      if startsBelow opts n+        then+          maybe mempty (" " <>) (props n)+            <> comment n.comments.inline+            <> "\n"+            <> lines_ (indent + indentStep) below+            <> block+              opts+              (indent + indentStep)+              (indent + indentStep)+              True+              (not (firstStartsBelow opts n))+              chainWritten+              rest+              n+        else+          " "+            <> block+              opts+              (indent + indentStep)+              (indent + indentStep)+              False+              True+              False+              []+              n+  | isEmpty n = comment n.comments.inline <> "\n" <> linesBelow column n+  | otherwise =+      let column' = if isBlockScalarNode n then indent else column+      in " "+           <> inline opts InValue (indent + indentStep) n n.comments.inline+           <> "\n"+           <> linesBelow column' n++-- | The lines of a block collection that go directly above its first entry.+-- The parser gives the lines there to the entry, so the lines of the+-- collection end with an empty line.+separated :: [Line] -> [Line]+separated ls = case reverse ls of+  [] -> []+  EmptyLine : _ -> ls+  _ -> ls ++ [EmptyLine]++-- | The lines above an indicator of a node that does not start below it. The+-- lines above the first entry of a block collection after the indicator go+-- there too.+aboveIndicator :: RenderOptions -> Node -> [Line]+aboveIndicator opts x =+  x.comments.before ++ if isBlock opts x then firstLines opts x else []++-- | The lines above the first entry of a collection, unless the entry starts+-- below its indicator and has the lines there.+firstLines :: RenderOptions -> Node -> [Line]+firstLines opts x+  | firstStartsBelow opts x = []+  | otherwise = case x.content of+      SequenceContent _ (y : _) -> aboveIndicator opts y+      MappingContent _ ((k, v) : _) -> case implicitKey opts k of+        Just _ -> let (above, _, _) = entryComments opts k v in above+        Nothing -> aboveIndicator opts k+      _ -> []++-- | The lines above the first entry at the end of a chain of first entries+-- that start below their indicators, from the node at its start, or 'Nothing'+-- if a node of the chain has lines of its own or a comment on the line of+-- its indicator.+chainLines :: RenderOptions -> Node -> Maybe [Line]+chainLines opts x+  | not (null x.comments.before) || isJust x.comments.inline = Nothing+  | firstStartsBelow opts x = firstEntryOf x >>= chainLines opts+  | otherwise = Just (firstLines opts x)++-- | The first item of a sequence, or the first key of a mapping.+firstEntryOf :: Node -> Maybe Node+firstEntryOf x = case x.content of+  SequenceContent _ (y : _) -> Just y+  MappingContent _ ((k, _) : _) -> Just k+  _ -> Nothing++-- | A block collection starts on the line after its indicator if it has+-- properties or a comment on the line of the indicator, or if the lines of+-- its first entry from 'firstLines' do not end with an empty line. A+-- collection on the line of its indicator takes every line above the+-- indicator, so these lines would read back as its own, or as those of a+-- collection around it. Below the indicator, the lines after the last empty+-- line go to the first entry.+--+-- The check looks at the lines of the first entry before it asks whether the+-- entry starts below its indicator. Most entries have no lines, so the check+-- does not follow a long chain of first entries from each of them, which+-- would make the time quadratic in the length of the chain. It follows the+-- chain only through entries with lines, and the output has these lines at+-- the indentation of their depth, so it is quadratic in that length too.+startsBelow :: RenderOptions -> Node -> Bool+startsBelow opts x+  | not (isBlock opts x) = False+  | isJust (props x) || isJust x.comments.inline = True+  | otherwise = case x.content of+      -- A first key without comments has no lines above it. Without the+      -- case, the check for an implicit key in 'belowIndicator' makes the+      -- render benchmark of the config input allocate more.+      MappingContent _ ((k, v) : _)+        | k.comments == noComments+        , v.comments == noComments+        , not (isBlock opts k) ->+            False+      _ -> fst (belowIndicator opts x)++-- | 'startsBelow' and whether 'firstLines' is empty. Both depend on the same+-- facts about the first entry, and with a separate check for each, the time+-- would be exponential in the length of a chain of first entries.+belowIndicator :: RenderOptions -> Node -> (Bool, Bool)+belowIndicator opts x =+  ( isBlock opts x && (isJust (props x) || isJust x.comments.inline || firstHasLines)+  , noFirstLines+  )+  where+    firstHasLines, noFirstLines :: Bool+    (firstHasLines, noFirstLines) = case x.content of+      SequenceContent _ (y : _) -> entry y y.comments.before+      MappingContent _ ((k, v) : _) -> case implicitKey opts k of+        Just _ ->+          let (above, _, _) = entryComments opts k v in (endsWithLine above, null above)+        Nothing -> entry k k.comments.before+      _ -> (False, True)++    -- Whether the lines of the entry and those of its first entry, as in+    -- 'aboveIndicator', end with a line other than an empty line, and whether+    -- there are none. The lines of an entry that starts below its indicator+    -- stay there. The lines of its first entry end with an empty line if it+    -- has any, because otherwise the entry would start below its indicator.+    entry :: Node -> [Line] -> (Bool, Bool)+    entry y ls =+      let (below, none) = if isBlock opts y then belowIndicator opts y else (False, True)+      in (endsWithLine ls && not below && none, below || null ls && none)++    endsWithLine :: [Line] -> Bool+    endsWithLine ls = case reverse ls of+      l : _ -> l /= EmptyLine+      [] -> False++-- | The first entry of a collection starts below its indicator.+firstStartsBelow :: RenderOptions -> Node -> Bool+firstStartsBelow opts x = case x.content of+  SequenceContent _ (y : _) -> startsBelow opts y+  MappingContent _ ((k, _) : _) -> startsBelow opts k+  _ -> False++-- | The lines up to the last empty line, and the lines after it.+splitAtLastEmptyLine :: [Line] -> ([Line], [Line])+splitAtLastEmptyLine ls =+  let (rest, own) = break (== EmptyLine) (reverse ls)+  in (reverse own, reverse rest)++-- | The lines above an entry with an implicit key, the comment on its line+-- and the lines below the key. A line holds one comment. If the value is on+-- the line of the key, the lines above the value and the comment of the key+-- go above the entry. Otherwise the comment of the value goes below the key.+--+-- A scalar key has no place for the lines after it, so they go below the+-- key: between the key and a block collection value, or below the entry, as+-- in @value@. They read back as the lines of the value. Below a block scalar+-- they would be part of the scalar, and below a flow collection they would+-- read back as the lines of the next entry, so they go above the entry.+entryComments :: RenderOptions -> Node -> Node -> ([Line], Maybe T.Text, [Line])+entryComments opts k v+  | isBlock opts v = case (k.comments.inline, v.comments.inline) of+      (Just kc, Just vc) -> (k.comments.before, Just kc, keyAfter ++ [inlineLine vc])+      (kc, vc) -> (k.comments.before, kc <|> vc, keyAfter)+  -- For a scalar value, only the place of the lines after the key differs.+  | not (isScalarLike v) || not (null keyAfter) && isBlockScalarNode v =+      case (k.comments.inline, v.comments.inline) of+        (Just kc, Just vc) ->+          ( k.comments.before ++ keyAfter ++ v.comments.before ++ [inlineLine kc]+          , Just vc+          , []+          )+        (kc, vc) -> (k.comments.before ++ keyAfter ++ v.comments.before, vc <|> kc, [])+  | otherwise = case (k.comments.inline, v.comments.inline) of+      (Just kc, Just vc) ->+        (k.comments.before ++ v.comments.before ++ [inlineLine kc], Just vc, keyAfter)+      (kc, vc) -> (k.comments.before ++ v.comments.before, vc <|> kc, keyAfter)+  where+    keyAfter :: [Line]+    keyAfter+      | isScalarLike k = k.comments.after+      | otherwise = []++-- | A scalar that the renderer writes in the literal or the folded style. A+-- text that a block scalar cannot hold goes in double quotes.+isBlockScalarNode :: Node -> Bool+isBlockScalarNode n = case n.content of+  ScalarContent Literal t -> isJust (literalBlock 0 t)+  ScalarContent Folded t -> isJust (foldedBlock 0 [] t)+  _ -> False++-- | A scalar or an alias.+isScalarLike :: Node -> Bool+isScalarLike n = case n.content of+  SequenceContent {} -> False+  MappingContent {} -> False+  _ -> True++-- | Where an inline node is. A scalar in a key is on one line.+data Position = InValue | InKey | InFlow | InFlowKey+  deriving stock (Eq)++-- | A node with the given comment at the end of its last line. The lines of+-- a scalar after the first one are at the given indentation.+inline :: RenderOptions -> Position -> Int -> Node -> Maybe T.Text -> B.Builder+inline opts pos indent n lineComment = case n.content of+  AliasContent name -> "*" <> B.fromText name <> comment lineComment+  ScalarLinesContent style t starts+    | isBlockScalar style && pos == InValue -> withProps (blockScalar style t starts)+  _ -> withProps content_ <> comment lineComment+  where+    withProps :: B.Builder -> B.Builder+    withProps b = case props n of+      Just p+        | isEmpty' -> p+        | otherwise -> p <> " " <> b+      Nothing -> b++    isEmpty' :: Bool+    isEmpty' = case n.content of+      ScalarContent Plain t -> T.null t+      _ -> False++    -- The comment goes on the line of the header.+    blockScalar :: ScalarStyle -> T.Text -> [Int] -> B.Builder+    blockScalar style t starts = case style of+      Literal | Just (h, b) <- literalBlock indent t -> h <> comment lineComment <> b+      Folded | Just (h, b) <- foldedBlock indent starts t -> h <> comment lineComment <> b+      _ -> doubleQuotedLines indent starts t <> comment lineComment++    content_ :: B.Builder+    content_ = case n.content of+      ScalarLinesContent style t starts -> scalar (if inKey then [] else starts) style t+      SequenceContent _ []+        | hasEndLines n ->+            "[\n" <> lines_ indent (fst (bracketLines n)) <> spaces indent <> "]"+      MappingContent _ []+        | hasEndLines n ->+            "{\n" <> lines_ indent (fst (bracketLines n)) <> spaces indent <> "}"+      SequenceContent _ xs -> "[" <> commas (map (flowValue . flowItem) xs) <> "]"+      MappingContent _ kvs -> "{" <> commas (map flowEntry kvs) <> "}"+      AliasContent {} -> mempty++    inKey :: Bool+    inKey = pos == InKey || pos == InFlowKey++    -- The items of a flow collection in a key are in the key too.+    itemPos :: Position+    itemPos = if inKey then InFlowKey else InFlow++    -- An empty scalar cannot be an item of a flow sequence.+    flowItem :: Node -> Node+    flowItem x = case x.content of+      ScalarContent Plain ""+        | Props Nothing NoTag <- x.props ->+            x {props = Props Nothing (Tag (coreTagPrefix <> "null"))}+      _ -> x++    -- YAML 1.2 allows an implicit key of any length in a flow mapping, but+    -- libyaml and PyYAML reject one as long as in a block mapping. YAML 1.1+    -- parsers also reject an empty implicit key, and a colon right before+    -- the end of the entry.+    flowEntry :: (Node, Node) -> B.Builder+    flowEntry (k, v)+      | fits && not (isEmpty k) =+          mconcat+            [ key+            , if endsWithName k then " : " else ": "+            , flowValue v+            ]+      -- libyaml rejects an explicit key with a colon but no value.+      | otherwise =+          mconcat+            [ "? "+            , key+            , if+                | isEmpty v -> afterTag k+                | isEmpty k -> ": " <> flowValue v+                | otherwise -> " : " <> flowValue v+            ]+      where+        -- The key is rendered at most once, so that a key inside a key does+        -- not double the time with each level.+        fits :: Bool+        key :: B.Builder+        (fits, key) = case (k.props, k.content) of+          -- A short scalar without properties fits even in two quotes with+          -- each character as the longest escape, \U and its digits.+          (Props Nothing NoTag, ScalarContent _ t)+            | T.compareLength t ((maxImplicitKeyLength - 2) `div` (2 + bigUEscapeDigits)) /= GT ->+                (True, rendered)+          _+            | longerThan maxImplicitKeyLength k -> (False, rendered)+            | otherwise ->+                let t = B.runBuilder rendered+                    -- The space before the colon after a name is part of+                    -- the key for the limit.+                    limit = maxImplicitKeyLength - (if endsWithName k then 1 else 0)+                in (T.compareLength t limit /= GT, B.fromText t)++        rendered :: B.Builder+        rendered = inline opts InFlowKey indent k Nothing++    flowValue :: Node -> B.Builder+    flowValue x = inline opts itemPos indent x Nothing <> afterTag x++    -- YAML 1.1 parsers read a comma or a bracket right after a tag as part+    -- of the tag.+    afterTag :: Node -> B.Builder+    afterTag x = case x.content of+      ScalarContent Plain t | T.null t, x.props.tag /= NoTag -> " "+      _ -> mempty++    commas :: [B.Builder] -> B.Builder+    commas = \case+      [] -> mempty+      b : bs -> b <> mconcat (map (", " <>) bs)++    -- A scalar in its style, or in a style that can hold its text, on the+    -- lines that start at the positions. The lines after the first one are at+    -- the indentation.+    scalar :: [Int] -> ScalarStyle -> T.Text -> B.Builder+    scalar starts style t = case style of+      Plain+        | T.null t -> mempty+        | null starts -> if plainSyntax inFlow t then B.fromText t else quotedPlain t+        | Just b <- plainLines inFlow indent starts t -> b+        | otherwise -> quotedPlainLines indent starts t+      SingleQuoted ->+        fromMaybe (doubleQuotedLines indent starts t) (singleQuotedLines indent starts t)+      _ -> doubleQuotedLines indent starts t+      where+        inFlow :: Bool+        inFlow = pos == InFlow || pos == InFlowKey++-- | The node in a flow key has more characters than the limit. The count is+-- a lower bound, so that it needs no rendering: a character for each node+-- inside, at least that of a bracket, a comma or a colon, and the characters+-- of the scalars, the anchors, the aliases and the tags, each tag as if it+-- were a core tag written with !!. The count stops at the limit, so a node+-- inside many keys does not add time to each of them.+longerThan :: Int -> Node -> Bool+longerThan limit n0 = go (limit + 1) [n0] < 0+  where+    -- The characters left before the limit, after the nodes.+    go :: Int -> [Node] -> Int+    go left = \case+      _ | left < 0 -> left+      [] -> left+      n : rest -> case n.content of+        ScalarContent _ t -> go (own n - upTo left t) rest+        AliasContent name -> go (left - 1 - upTo left name) rest+        SequenceContent _ xs -> go (own n) (xs ++ rest)+        MappingContent _ kvs -> go (own n) (concatMap (\(k, v) -> [k, v]) kvs ++ rest)+        where+          own :: Node -> Int+          own x = left - 1 - maybe 0 (upTo left) x.props.anchor - tagChars x.props.tag++          tagChars :: Tag -> Int+          tagChars = \case+            Tag t -> max 0 (upTo (left + coreShortening) t - coreShortening)+            _ -> 0++    -- The length of the text, up to one past the count.+    upTo :: Int -> T.Text -> Int+    upTo count t = T.length (T.take (count + 1) t)++    -- A core tag loses its prefix and gains !!.+    coreShortening :: Int+    coreShortening = T.length coreTagPrefix - 2++-- | A key on one line, or 'Nothing' if it needs an explicit entry.+implicitKey :: RenderOptions -> Node -> Maybe B.Builder+implicitKey opts k+  | isBlock opts k = Nothing+  | isEmpty k = Nothing+  -- go-yaml v2 reads "[]: a" and "{}: a" without an error, but as an empty+  -- list or mapping, and drops the entries after them. An anchor or a tag+  -- avoids that.+  | Props Nothing NoTag <- k.props, isEmptyCollection = Nothing+  -- An empty collection with lines inside is on several lines.+  | hasEndLines k, not (isScalarLike k) = Nothing+  | T.length key > maxImplicitKeyLength = Nothing+  | otherwise = Just (B.fromText key)+  where+    key :: T.Text+    key = case (k.props, k.content) of+      (Props Nothing NoTag, ScalarContent Plain t) | plainSyntax False t -> t+      _ ->+        B.runBuilder $+          inline opts InKey 0 k Nothing <> if endsWithName k then " " else mempty++    isEmptyCollection :: Bool+    isEmptyCollection = case k.content of+      SequenceContent _ [] -> True+      MappingContent _ [] -> True+      _ -> False++-- | The node is a collection that the renderer writes in the block style.+isBlock :: RenderOptions -> Node -> Bool+isBlock opts n = case n.content of+  SequenceContent style (_ : _) -> style == Block || opts.forceBlock+  MappingContent style (_ : _) -> style == Block || opts.forceBlock+  _ -> False++-- | The node has comments at its end, which go between the brackets of an+-- empty collection and below a scalar or an alias.+hasEndLines :: Node -> Bool+hasEndLines n = case n.content of+  SequenceContent _ (_ : _) -> False+  MappingContent _ (_ : _) -> False+  _ -> hasCommentLine n.comments.after++-- | The lines have a comment, not only empty lines.+hasCommentLine :: [Line] -> Bool+hasCommentLine = any (/= EmptyLine)++-- | The lines at the end of a scalar or an alias at the given indentation.+-- They cannot be deeper, because a block scalar would take them in.+linesBelow :: Int -> Node -> B.Builder+linesBelow indent n = case n.content of+  ScalarContent {} -> lines_ indent n.comments.after+  AliasContent {} -> lines_ indent n.comments.after+  SequenceContent _ [] -> lines_ indent (snd (bracketLines n))+  MappingContent _ [] -> lines_ indent (snd (bracketLines n))+  _ -> mempty++-- | The lines of an empty flow collection inside its brackets, and the+-- empty lines at their end, which go below the collection. The parser gives+-- the empty lines before a closing bracket to the node below.+bracketLines :: Node -> ([Line], [Line])+bracketLines n+  | hasEndLines n =+      let (empties, rest) = span (== EmptyLine) (reverse n.comments.after)+      in (reverse rest, empties)+  | otherwise = ([], n.comments.after)++-- | The node is an empty plain scalar without properties.+isEmpty :: Node -> Bool+isEmpty n = case (n.props, n.content) of+  (Props Nothing NoTag, ScalarContent Plain t) -> T.null t+  _ -> False++-- | The node ends with an alias, an anchor or a tag. A colon right after it+-- would be part of the name.+endsWithName :: Node -> Bool+endsWithName n = case n.content of+  AliasContent {} -> True+  ScalarContent Plain t -> T.null t && (isJust n.props.anchor || n.props.tag /= NoTag)+  _ -> False++-- | The anchor and the tag of a node.+props :: Node -> Maybe B.Builder+props n = case n.content of+  AliasContent {} -> Nothing+  _ -> case (anchor, tag) of+    (Nothing, Nothing) -> Nothing+    (Just a, Nothing) -> Just a+    (Nothing, Just t) -> Just t+    (Just a, Just t) -> Just (a <> " " <> t)+  where+    anchor :: Maybe B.Builder+    anchor = ("&" <>) . B.fromText <$> n.props.anchor++    tag :: Maybe B.Builder+    tag = case n.props.tag of+      NoTag -> Nothing+      NonSpecificTag -> Just "!"+      Tag t -> Just (tagText t)++-- | A comment at the end of a line.+comment :: Maybe T.Text -> B.Builder+comment = \case+  Nothing -> mempty+  Just t -> " #" <> text (T.stripEnd (printable (breaksAsSpaces t)))+  where+    text :: T.Text -> B.Builder+    text t = if T.null t then mempty else " " <> B.fromText t++-- | An inline comment on a line of its own. It stays one comment, as at the+-- end of a line.+inlineLine :: T.Text -> Line+inlineLine = Comment . breaksAsSpaces++breaksAsSpaces :: T.Text -> T.Text+breaksAsSpaces = T.map $ \c -> if isCommentBreak c then ' ' else c++-- | Lines of comments at the given indentation.+lines_ :: Int -> [Line] -> B.Builder+lines_ indent = mconcat . map line+  where+    line :: Line -> B.Builder+    line = \case+      EmptyLine -> B.fromText emptyLine <> "\n"+      CommentLine n t ->+        let hashes = B.fromText (T.replicate (max 1 n) "#")+        in mconcat . map (commentLine hashes) $+             T.split isCommentBreak (T.replace "\r\n" "\n" (printable t))++    -- The parser drops the white space at the end of a comment.+    commentLine :: B.Builder -> T.Text -> B.Builder+    commentLine hashes l+      | T.null (T.stripEnd l) = spaces indent <> hashes <> "\n"+      | otherwise = spaces indent <> hashes <> " " <> B.fromText (T.stripEnd l) <> "\n"++-- | The mark of an empty line from the comments. The output has no other NUL+-- character.+emptyLine :: T.Text+emptyLine = "\0"++-- | The text of a comment with a replacement for the characters that YAML+-- does not allow.+printable :: T.Text -> T.Text+printable = T.map $ \c ->+  if c == '\t' || isCommentBreak c || isPrintable c then c else '\xFFFD'++-- | A line break in the text of a comment. YAML 1.1 reads U+0085, U+2028 and+-- U+2029 as line breaks, so the rest of a comment after one of them would+-- read as data.+isCommentBreak :: Char -> Bool+isCommentBreak c = c == '\n' || c == '\r' || c == '\x85' || c == '\x2028' || c == '\x2029'++-- $setup+-- >>> import Data.Text.IO qualified as T+-- >>> import Yamlet.Error+-- >>> import Yamlet.Syntax
+ src/Yamlet/Internal/Schema.hs view
@@ -0,0 +1,492 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The core schema of YAML 1.2.2.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Schema+  ( resolvePlain+  , resolveTagged+  , resolvePlainExact+  , resolveTaggedExact+  , startsNumber+  , isPlainString+  , isPlainSafe+  , isPlainPortable+  , isYaml11Bool+  , isYaml11NonString+  , isYaml11Timestamp+  , exponentOutOfRange+  ) where++import Control.Monad+import Data.Bifunctor+import Data.Char+import Data.Maybe+import Data.Scientific qualified as Sci+import Data.Text qualified as T+import Data.Time.Calendar++import Yamlet.Internal.Emit+import Yamlet.Internal.Utils+import Yamlet.Value++-- | The value of a plain scalar without a tag. Not every such scalar is a+-- string, e.g. @null@, @true@, @12@, @0x1F@ and @1.5e3@ are not. Quoted and+-- block scalars are always strings.+--+-- A float whose exponent in scientific notation is beyond the range from+-- -1000 to 1000, e.g. @1e1001@, @10e1000@ or @1e-1001@, becomes infinity+-- or zero, as a double does. The decoders reject such a number, because its+-- value is not exact.+--+-- >>> map resolvePlain ["", "true", "0x1F", "1.5e3", ".inf", "yes", "9.10.3"]+-- [Null,Bool True,Int 31,Float (Finite 1500.0),Float Infinity,String "yes",String "9.10.3"]+resolvePlain :: T.Text -> Value+resolvePlain = either id id . resolvePlainExact++-- | The value of a scalar with the given resolved tag, e.g.+-- @tag:yaml.org,2002:int@. Return 'Nothing' if the text is not valid for a+-- tag of the core schema. A scalar with another tag is a string.+--+-- A float beyond the limit becomes infinity or zero, as in 'resolvePlain'.+--+-- >>> [resolveTagged floatTag "1", resolveTagged intTag "abc", resolveTagged seqTag "x", resolveTagged "!point" "1"]+-- [Just (Float (Finite 1.0)),Nothing,Nothing,Just (String "1")]+resolveTagged :: T.Text -> T.Text -> Maybe Value+resolveTagged tag t = either id id <$> resolveTaggedExact tag t++-- | The value of a plain scalar, 'Left' if the value is not exact.+resolvePlainExact :: T.Text -> Either Value Value+resolvePlainExact t = case T.uncons t of+  Nothing -> Right Null+  Just (c, _)+    | c == '~' || c == 'n' || c == 'N' -> Right $ if isNull t then Null else String t+    | c == 't' || c == 'T' || c == 'f' || c == 'F' ->+        Right $ maybe (String t) Bool (readBool t)+    | startsNumber c -> case readInt t of+        Just i -> Right (Int i)+        Nothing -> maybe (Right (String t)) (bimap Float Float) (readFloat t)+    | otherwise -> Right (String t)++-- | A plain scalar that starts with the character can be a number. Only such+-- a scalar can have a value that is not exact.+startsNumber :: Char -> Bool+startsNumber c = isDigit c || c == '-' || c == '+' || c == '.'++-- | The value of a scalar with a tag, 'Left' if the value is not exact.+resolveTaggedExact :: T.Text -> T.Text -> Maybe (Either Value Value)+resolveTaggedExact tag t+  | tag == strTag = Just . Right $ String t+  | tag == nullTag = if isNull t then Just (Right Null) else Nothing+  | tag == boolTag = Right . Bool <$> readBool t+  | tag == intTag = Right . Int <$> readInt t+  | tag == floatTag = bimap Float Float <$> readFloat t+  | tag == seqTag || tag == mapTag = Nothing+  | otherwise = Just . Right $ String t++-- | A plain scalar with the text is a string, e.g. @9.10.3@ is a string, but+-- @9.10@ and @true@ are not. The check ignores the syntax, so e.g. @a: b@+-- passes. For both checks, use 'isPlainSafe'.+--+-- >>> map isPlainString ["9.10.3", "9.10", "true", "a: b"]+-- [True,False,False,True]+isPlainString :: T.Text -> Bool+isPlainString t = case resolvePlain t of+  String _ -> True+  _ -> False++-- | The string reads back as the same string if it is a plain scalar in the+-- block style, as a value or as a key. A key without @?@ must also have at+-- most 1024 characters, which the check does not count. In a flow collection+-- the characters @,[]{}@ need quotes too, so the check does not apply there.+--+-- >>> map isPlainSafe ["a:b", "a: b", "- a", "a #b", "9.10"]+-- [True,False,False,False,False]+isPlainSafe :: T.Text -> Bool+isPlainSafe t = plainSyntax False t && isPlainString t++-- | As 'isPlainSafe', and common YAML 1.1 parsers also read the plain scalar+-- as a string, e.g. not @yes@ as a boolean or @12:30@ as a number. The+-- encoder writes a string without quotes only if it passes this check.+--+-- >>> map isPlainPortable ["a:b", "yes", "12:30", "2024-01-01", "9.10.3"]+-- [True,False,False,False,True]+isPlainPortable :: T.Text -> Bool+isPlainPortable t = isPlainSafe t && not (isYaml11NonString t)++isNull :: T.Text -> Bool+isNull t = T.null t || t == "~" || t == "null" || t == "Null" || t == "NULL"++readBool :: T.Text -> Maybe Bool+readBool = \case+  "true" -> Just True+  "True" -> Just True+  "TRUE" -> Just True+  "false" -> Just False+  "False" -> Just False+  "FALSE" -> Just False+  _ -> Nothing++-- | A word that YAML 1.1 reads as a boolean, but YAML 1.2 as a string, e.g.+-- @yes@ or @off@.+isYaml11Bool :: T.Text -> Bool+isYaml11Bool t =+  t `elem` ["y", "Y", "yes", "Yes", "YES", "on", "On", "ON"]+    || t `elem` ["n", "N", "no", "No", "NO", "off", "Off", "OFF"]++-- | A common YAML 1.1 parser reads a plain scalar with the text as a value+-- that is not a string, e.g. the boolean @yes@, the base-60 number @12:30@ or+-- the date @2024-01-01@. The patterns cover what PyYAML, Ruby's Psych and+-- go-yaml v2, which Kubernetes uses, accept. The YAML 1.1 types themselves+-- are not enough: the parsers accept more, e.g. @1,000@ in Psych and @0X1F@ in+-- go-yaml v2, and the type of floats accepts too much, e.g. @1.2.3@.+isYaml11NonString :: T.Text -> Bool+isYaml11NonString t = case T.uncons t of+  Nothing -> True+  Just (c, _)+    -- A symbol in Psych, which its safe loader rejects.+    | c == ':' -> T.compareLength t 1 == GT+    | isDigit c || c == '-' || c == '+' || c == '.' ->+        matches (alt [int, float, timestamp]) t || matches goNumber (T.filter (/= '_') t)+    -- Psych merges a quoted << too, only !!str << stays a key there.+    | otherwise ->+        t `elem` ["y", "Y", "n", "N", "~", "<<", "="]+          -- Psych ignores the case of these words.+          || ( T.compareLength t 5 /= GT+                 && T.toLower t `elem` ["yes", "no", "true", "false", "on", "off", "null"]+             )+  where+    matches :: (T.Text -> [T.Text]) -> T.Text -> Bool+    matches m s = any T.null (m s)++    int :: T.Text -> [T.Text]+    int =+      sign+        >=> alt+          [ str "0b" >=> some (separatorOr (`elem` ['0', '1']))+          , one (== '0') >=> some (separatorOr isOctDigit)+          , one (== '0')+          , nonZero >=> many (separatorOr isDigit)+          , str "0x" >=> some (separatorOr isHexDigit)+          , digit >=> many (underscoreOr isDigit) >=> sexagesimal+          ]++    float :: T.Text -> [T.Text]+    float =+      sign+        >=> alt+          [ digit+              >=> many (separatorOr isDigit)+              >=> one (== '.')+              >=> many (underscoreOr isDigit)+              >=> opt exponentPart+          , one (== '.') >=> some (underscoreOr isDigit) >=> opt exponentPart+          , one (== '.') >=> exponentPart+          , digit+              >=> many (underscoreOr isDigit)+              >=> sexagesimal+              >=> one (== '.')+              >=> many (underscoreOr isDigit)+          , one (== '.') >=> caseless "inf"+          , one (== '.') >=> caseless "nan"+          ]++    timestamp :: T.Text -> [T.Text]+    timestamp =+      alt+        [ digits 4 >=> one (== '-') >=> oneOrTwoDigits >=> one (== '-') >=> oneOrTwoDigits+        , opt (one (== '-'))+            >=> digits 4+            >=> one (== '-')+            >=> oneOrTwoDigits+            >=> one (== '-')+            >=> oneOrTwoDigits+            >=> alt [one (`elem` ['T', 't']), some blank]+            >=> oneOrTwoDigits+            >=> one (== ':')+            >=> digits 2+            >=> one (== ':')+            >=> digits 2+            >=> opt (one (== '.') >=> many digit)+            >=> opt+              ( many blank+                  >=> alt+                    [ one (== 'Z')+                    , one (`elem` ['+', '-'])+                        >=> oneOrTwoDigits+                        >=> opt (opt (one (== ':')) >=> digits 2)+                    ]+              )+        ]++    -- The numbers of go-yaml v2, which removes the underscores first: the+    -- integers of Go, a float whose dot and sign of the exponent are+    -- optional, and a binary integer with its sign after "0b", e.g. 0b-1.+    goNumber :: T.Text -> [T.Text]+    goNumber =+      alt+        [ sign+            >=> alt+              [ one (== '0')+                  >=> one (`elem` ['x', 'X'])+                  >=> some (one isHexDigit)+              , one (== '0')+                  >=> one (`elem` ['o', 'O'])+                  >=> some (one isOctDigit)+              , one (== '0')+                  >=> one (`elem` ['b', 'B'])+                  >=> some (one (`elem` ['0', '1']))+              , alt+                  [ one (== '.') >=> some digit+                  , some digit >=> opt (one (== '.') >=> many digit)+                  ]+                  >=> opt+                    ( one (`elem` ['e', 'E'])+                        >=> opt (one (`elem` ['+', '-']))+                        >=> some digit+                    )+              ]+        , str "0b" >=> one (`elem` ['+', '-']) >=> some (one (`elem` ['0', '1']))+        ]++    -- Each matcher gives the rests of the text after all its possible+    -- matches, so the patterns backtrack as the regular expressions of the+    -- parsers do and each one matches its regular expression. A parser such as+    -- attoparsec does not backtrack into an optional or repeated part, e.g.+    -- [0-5]?[0-9] would take the 5 of 1:5 and then find no digit.+    one :: (Char -> Bool) -> T.Text -> [T.Text]+    one p s = case T.uncons s of+      Just (x, rest) | p x -> [rest]+      _ -> []++    str :: T.Text -> T.Text -> [T.Text]+    str prefix s = maybe [] pure (textStripPrefix prefix s)++    alt :: [T.Text -> [T.Text]] -> T.Text -> [T.Text]+    alt ms s = concatMap ($ s) ms++    opt :: (T.Text -> [T.Text]) -> T.Text -> [T.Text]+    opt m s = s : m s++    -- The rests of each step go in front of the rests that follow, because+    -- s : (m s >>= many m) appends once per step and takes quadratic time.+    many :: (T.Text -> [T.Text]) -> T.Text -> [T.Text]+    many m s0 = go s0 []+      where+        go :: T.Text -> [T.Text] -> [T.Text]+        go s rests = s : foldr go rests (m s)++    some :: (T.Text -> [T.Text]) -> T.Text -> [T.Text]+    some m = m >=> many m++    sign :: T.Text -> [T.Text]+    sign = opt (one (`elem` ['+', '-']))++    digit :: T.Text -> [T.Text]+    digit = one isDigit++    digits :: Int -> T.Text -> [T.Text]+    digits k = foldr (>=>) pure (replicate k digit)++    oneOrTwoDigits :: T.Text -> [T.Text]+    oneOrTwoDigits = digit >=> opt digit++    nonZero :: T.Text -> [T.Text]+    nonZero = one (\x -> isDigit x && x /= '0')++    underscoreOr :: (Char -> Bool) -> T.Text -> [T.Text]+    underscoreOr p = one (\x -> x == '_' || p x)++    -- Psych also allows commas in numbers, e.g. 1,000.+    separatorOr :: (Char -> Bool) -> T.Text -> [T.Text]+    separatorOr p = one (\x -> x == '_' || x == ',' || p x)++    caseless :: T.Text -> T.Text -> [T.Text]+    caseless w s =+      [rest | let (prefix, rest) = T.splitAt (T.length w) s, T.toLower prefix == w]++    sexagesimal :: T.Text -> [T.Text]+    sexagesimal = some (one (== ':') >=> opt (one (`elem` ['0' .. '5'])) >=> digit)++    exponentPart :: T.Text -> [T.Text]+    exponentPart = one (`elem` ['e', 'E']) >=> one (`elem` ['+', '-']) >=> some digit++    blank :: T.Text -> [T.Text]+    blank = one (`elem` [' ', '\t'])++-- | A common YAML 1.1 parser reads a plain scalar with the text as a+-- timestamp and can build it. PyYAML has the years from 1 to 9999 of Python,+-- and it rejects the hour 24, a leap second and a time zone of 24 hours.+-- Psych reads the hour 24 and a leap second as a later time.+--+-- >>> map isYaml11Timestamp ["2024-01-01", "2024-01-01T12:30:00Z", "0000-01-01", "2016-12-31T23:59:60Z", "12:30"]+-- [True,True,False,False,False]+isYaml11Timestamp :: T.Text -> Bool+isYaml11Timestamp t =+  isYaml11NonString t && case T.splitOn "-" date of+    [y, m, d]+      | T.length y == 4+      , all (\ds -> not (T.null ds) && T.all isDigit ds) [y, m, d] ->+          let year = digitsValue 10 y+          in year >= 1+               && year <= 9999+               && isJust (fromGregorianValid year (number m) (number d))+               && validTime (T.dropWhile isTimeSeparator rest)+    _ -> False+  where+    (date, rest) = T.break isTimeSeparator t++    isTimeSeparator :: Char -> Bool+    isTimeSeparator c = c == 'T' || c == 't' || c == ' ' || c == '\t'++    number :: T.Text -> Int+    number = fromInteger . digitsValue 10++    -- The time, with the hours, the minutes and the seconds of the pattern of+    -- 'isYaml11NonString'.+    validTime :: T.Text -> Bool+    validTime s+      | T.null s = True+      | otherwise = case T.splitOn ":" (T.takeWhile (\c -> isDigit c || c == ':') s) of+          h : _ : sec : _ ->+            number h < 24+              && number (T.take 2 sec) < 60+              && validZone+                (T.dropWhile (\c -> isDigit c || c `elem` [':', '.', ' ', '\t']) s)+          _ -> False++    -- The hours of a zone are the digits before the last two, unless the+    -- zone has a colon or at most two digits.+    validZone :: T.Text -> Bool+    validZone z = case T.uncons z of+      Just (c, offset)+        | c == '+' || c == '-' ->+            let hours = T.takeWhile isDigit offset+                h = if T.compareLength hours 2 == GT then T.dropEnd 2 hours else hours+            in number h < 24+      _ -> True++-- | [-+]?[0-9]+, 0o[0-7]+ or 0x[0-9a-fA-F]+.+readInt :: T.Text -> Maybe Integer+readInt t+  | Just ds <- textStripPrefix "0o" t = digits 8 isOctDigit ds+  | Just ds <- textStripPrefix "0x" t = digits 16 isHexDigit ds+  | Just ds <- textStripPrefix "-" t = negate <$> digits 10 isDigit ds+  | Just ds <- textStripPrefix "+" t = digits 10 isDigit ds+  | otherwise = digits 10 isDigit t+  where+    digits :: Integer -> (Char -> Bool) -> T.Text -> Maybe Integer+    digits radix valid ds+      | not (T.null ds) && T.all valid ds = Just $ digitsValue radix ds+      | otherwise = Nothing++-- | The value of the digits in the radix. A multiplication for each digit+-- takes quadratic time in the number of digits, so the halves of a long text+-- are read apart.+digitsValue :: Integer -> T.Text -> Integer+digitsValue radix t0 = go (T.length t0) t0+  where+    go :: Int -> T.Text -> Integer+    go n t+      | n <= maxFoldDigits =+          T.foldl' (\acc d -> acc * radix + toInteger (digitToInt d)) 0 t+      | otherwise =+          let k = n `div` 2+              (hi, lo) = T.splitAt (n - k) t+          in go (n - k) hi * radix ^ k + go k lo++    -- Up to about 20 digits, one fold is faster than a split, measured with+    -- GHC 9.10.3 for numbers from 60 to 100000 digits.+    maxFoldDigits :: Int+    maxFoldDigits = 20++-- | The limit of the exponent of a float in scientific notation, i.e. the+-- exponent of its first digit that is not zero. The limit applies to the+-- value, not to the text, so every value that the decoder gives reads back+-- after the encoder writes it.+--+-- A t'Data.Scientific.Scientific' keeps the exponent apart from the+-- coefficient, but its conversion to an 'Integer', e.g. with 'truncate',+-- computes every digit. With this limit, the integer has at most 1001+-- digits. Without a limit, a short input such as @1e999999999@ gives an+-- integer of about 400 MiB. The limit covers the whole range of 'Double',+-- from about 5e-324 to 1.8e308.+maxExponent :: Integer+maxExponent = 1000++-- | The error for a number beyond 'maxExponent'.+exponentOutOfRange :: String+exponentOutOfRange =+  "the exponent of the number is out of the range from "+    ++ show (negate maxExponent)+    ++ " to "+    ++ show maxExponent++-- | [-+]?(\.[0-9]+|[0-9]+(\.[0-9]*)?)([eE][-+]?[0-9]+)?, [-+]?\.inf or \.nan+-- in one of three capitalizations. The value is 'Left' if it is not exact.+readFloat :: T.Text -> Maybe (Either FloatValue FloatValue)+readFloat t0 = case t0 of+  ".nan" -> Just (Right NaN)+  ".NaN" -> Just (Right NaN)+  ".NAN" -> Just (Right NaN)+  _ -> case T.uncons t0 of+    Just ('-', t) -> bimap negateFloat negateFloat <$> unsigned t+    Just ('+', t) -> unsigned t+    _ -> unsigned t0+  where+    unsigned :: T.Text -> Maybe (Either FloatValue FloatValue)+    unsigned t+      | t == ".inf" || t == ".Inf" || t == ".INF" = Just (Right Infinity)+      | otherwise =+          let (int, rest) = T.span isDigit t+              (frac, rest') = case T.uncons rest of+                Just ('.', r) -> T.span isDigit r+                _ -> ("", rest)+              hasDot = textIsPrefixOf "." rest+          in if+               | T.null int && T.null frac -> Nothing+               | not (T.null int) || hasDot -> do+                   ex <- exponent_ rest'+                   Just $ decimal (int <> frac) (ex - toInteger (T.length frac))+               | otherwise -> Nothing++    -- The decimal digits times a power of 10, with the exponent that the text+    -- of the float has. A value beyond the limit of 'maxExponent' gives+    -- infinity or zero, which are not exact.+    decimal :: T.Text -> Integer -> Either FloatValue FloatValue+    decimal ds e+      | c == 0 = Right (Finite 0)+      | abs leading > maxExponent = Left (if leading > 0 then Infinity else Finite 0)+      | otherwise = Right $ Finite (Sci.scientific c (fromInteger e))+      where+        -- The exponent of the first digit that is not zero.+        leading :: Integer+        leading = e + toInteger (T.length (T.dropWhile (== '0') ds)) - 1++        c :: Integer+        c = digitsValue 10 ds++    negateFloat :: FloatValue -> FloatValue+    negateFloat = \case+      Finite s+        | s == 0 -> NegativeZero+        | otherwise -> Finite (negate s)+      NegativeZero -> Finite 0+      Infinity -> NegativeInfinity+      NegativeInfinity -> Infinity+      NaN -> NaN++    exponent_ :: T.Text -> Maybe Integer+    exponent_ t = case T.uncons t of+      Nothing -> Just 0+      Just (e, r)+        | e == 'e' || e == 'E' ->+            let (sign, ds) = case T.uncons r of+                  Just ('-', d) -> (negate, d)+                  Just ('+', d) -> (id, d)+                  _ -> (id, r)+            in if not (T.null ds) && T.all isDigit ds+                 then Just . sign $ digitsValue 10 ds+                 else Nothing+        | otherwise -> Nothing
+ src/Yamlet/Internal/Syntax.hs view
@@ -0,0 +1,523 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | The types of the syntax tree.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Syntax+  ( -- * Documents+    Document (..)+  , YamlVersion (..)+  , document++    -- * Nodes+  , Node (..)+  , Content (.., ScalarContent)+  , Props (..)+  , noProps+  , Tag (..)+  , ScalarStyle (..)+  , isBlockScalar+  , CollectionStyle (..)++    -- ** Construction+  , contentNode+  , scalarNode+  , plainNode+  , sequenceNode+  , mappingNode++    -- * Comments+  , Comments (..)+  , noComments+  , withComments+  , Commented (..)+  , Line (.., Comment)++    -- * Positions+  , Offset (..)+  , noOffset+  , Located (..)++    -- * Copies+  , copyDocument+  , copyNode+  , copyComments+  ) where++import Control.DeepSeq+import Data.Text qualified as T+import GHC.Generics++import Yamlet.Internal.Utils++-- | A document of a YAML stream.+data Document = Document+  { version :: !(Maybe YamlVersion)+  -- ^ The version from the @%YAML@ directive.+  , explicitStart :: !Bool+  -- ^ The document starts with a @---@ marker.+  , explicitEnd :: !Bool+  -- ^ The document ends with a @...@ marker.+  , docComments :: !Comments+  -- ^ The lines before the directives or the @---@ marker, the comment on the+  -- line of the marker and the lines at the end of the document: below the+  -- @...@ marker, or below a flow collection root.+  , root :: !Node+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The version of YAML that a document declares.+data YamlVersion = YamlVersion+  { major :: !Int+  , minor :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A document with the given root, without directives, markers and comments.+document :: Node -> Document+document n =+  Document+    { version = Nothing+    , explicitStart = False+    , explicitEnd = False+    , docComments = noComments+    , root = n+    }++-- | A node of a document.+data Node = Node+  { offset :: !Offset+  -- ^ The position of the first character of the content.+  , endOffset :: !Offset+  -- ^ The position after the last character of the content.+  , props :: !Props+  , comments :: !Comments+  , content :: !Content+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The content of a node.+data Content+  = -- | A scalar with the positions in its text where the source continues on+    -- a new line. A position counts the characters from the start of the+    -- text, and the positions are in ascending order. The parser gives them+    -- for the plain, quoted and folded styles, which join the lines of the+    -- source, so that the renderer can write the text on the same lines. The+    -- renderer ignores a position where the style of the output cannot start+    -- a new line and keep the text.+    ScalarLinesContent !ScalarStyle !T.Text ![Int]+  | SequenceContent !CollectionStyle ![Node]+  | MappingContent !CollectionStyle ![(Node, Node)]+  | -- | An alias, with the name of its anchor. An alias has no properties.+    AliasContent !T.Text+  deriving stock (Eq, Show, Generic)++-- | A scalar without positions of new lines. As a pattern, it matches every+-- scalar and ignores its positions.+pattern ScalarContent :: ScalarStyle -> T.Text -> Content+pattern ScalarContent style t <- ScalarLinesContent style t _+  where+    ScalarContent style t = ScalarLinesContent style t []++{-# COMPLETE ScalarContent, SequenceContent, MappingContent, AliasContent #-}++-- The instances of the sum types are written by hand, because GHC does not+-- always remove the generic representation of a sum type. A strict field of+-- a type without lazy parts, e.g. a text, is already in normal form.+instance NFData Content where+  rnf = \case+    ScalarLinesContent _ _ ls -> rnf ls+    SequenceContent _ xs -> rnf xs+    MappingContent _ kvs -> rnf kvs+    AliasContent _ -> ()++-- | The properties of a node.+data Props = Props+  { anchor :: !(Maybe T.Text)+  , tag :: !Tag+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | No anchor and no tag.+noProps :: Props+noProps = Props Nothing NoTag++-- | The tag of a node after the tag handles are expanded.+data Tag+  = -- | The node has no tag.+    NoTag+  | -- | The @!@ tag.+    NonSpecificTag+  | -- | A specific tag, e.g. @tag:yaml.org,2002:str@ for @!!str@. YAML has+    -- no syntax for the empty tag or a tag of one character, e.g. @x@ or+    -- @!@. The renderer writes such a tag as @!@, which reads back as+    -- 'NonSpecificTag'.+    Tag !T.Text+  deriving stock (Eq, Ord, Show, Generic)++instance NFData Tag where+  rnf = rwhnf++-- | The style of a scalar: without quotes, in single or double quotes, or a+-- literal (@|@) or folded (@>@) block scalar.+data ScalarStyle+  = Plain+  | SingleQuoted+  | DoubleQuoted+  | Literal+  | Folded+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++instance NFData ScalarStyle where+  rnf = rwhnf++-- | The literal or the folded style.+isBlockScalar :: ScalarStyle -> Bool+isBlockScalar s = s == Literal || s == Folded++-- | The style of a collection: with indentation, or with brackets and commas.+data CollectionStyle+  = Block+  | Flow+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++instance NFData CollectionStyle where+  rnf = rwhnf++-- | A node with the given content, without properties and comments.+contentNode :: Content -> Node+contentNode c =+  Node+    { offset = noOffset+    , endOffset = noOffset+    , props = noProps+    , comments = noComments+    , content = c+    }++-- | A scalar in the given style. 'Yamlet.Syntax.renderSyntax' uses quotes if+-- the style cannot hold the text, and for a block scalar that is a key or an+-- entry of a flow collection.+--+-- >>> T.putStr (renderSyntax defaultRenderOptions [document (mappingNode [(plainNode "key", scalarNode Plain "a: b")])])+-- key: 'a: b'+scalarNode :: ScalarStyle -> T.Text -> Node+scalarNode style = contentNode . ScalarContent style++-- | A plain scalar.+plainNode :: T.Text -> Node+plainNode = scalarNode Plain++-- | A block sequence.+sequenceNode :: [Node] -> Node+sequenceNode = contentNode . SequenceContent Block++-- | A block mapping.+mappingNode :: [(Node, Node)] -> Node+mappingNode = contentNode . MappingContent Block++-- | The comments and the empty lines that belong to a node.+data Comments = Comments+  { before :: ![Line]+  -- ^ The lines above the node.+  , inline :: !(Maybe T.Text)+  -- ^ The comment at the end of the line where the node ends, or of the+  -- first line of a block collection or a block scalar. The renderer+  -- writes each line break in it as a space. The line breaks are the+  -- characters that 'CommentLine' lists.+  , after :: ![Line]+  -- ^ The lines below the node: after the last entry of a collection,+  -- between the brackets of an empty collection, or below a scalar or an+  -- alias in a block collection or at the root. The section+  -- [Comments]("Yamlet.Syntax#comments") gives the rules. The renderer+  -- writes such lines below any node.+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | No comments and no empty lines.+noComments :: Comments+noComments = Comments {before = [], inline = Nothing, after = []}++-- | The node with the comments in place of its own. A record update of the+-- field is ambiguous where t'Commented' is in scope.+withComments :: Comments -> Node -> Node+withComments c n =+  Node+    { offset = n.offset+    , endOffset = n.endOffset+    , props = n.props+    , comments = c+    , content = n.content+    }++-- | A value with the comments of its mapping entry:+--+-- * 'Yamlet.Syntax.before': the lines above the entry,+--+-- * 'Yamlet.Syntax.inline': the comment at the end of the line of the key,+--   or of the line where a value on several lines ends,+--+-- * 'Yamlet.Syntax.after': the lines after the value, e.g. after the last+--   entry of a collection.+--+-- A t'Commented' value of a mapping entry has the comments of the entry. A+-- block list or mapping under the key has its own comments: the lines below+-- the key up to the last empty line above its first entry. A t'Commented'+-- value inside the first one keeps them, so a type that keeps both nests two+-- t'Commented' values:+--+-- >>> input = "# The CI jobs.\njobs:\n  # Run on every push.\n\n  # Check the formatting.\n  - lint\n"+--+-- >>> T.putStr input+-- # The CI jobs.+-- jobs:+--   # Run on every push.+-- <BLANKLINE>+--   # Check the formatting.+--   - lint+--+-- >>> Right entries = decodeText @(M.Map T.Text (Commented (Commented [Commented T.Text]))) input+-- >>> Just jobs = M.lookup "jobs" entries+--+-- >>> jobs.comments+-- Comments {before = [Comment "The CI jobs."], inline = Nothing, after = []}+--+-- >>> jobs.value.comments+-- Comments {before = [Comment "Run on every push.",EmptyLine], inline = Nothing, after = []}+--+-- >>> map (.comments) jobs.value.value+-- [Comments {before = [Comment "Check the formatting."], inline = Nothing, after = []}]+--+-- A value without a key, e.g. an item of a list, has the comments of its+-- node. The comments of a list or a mapping stay with it, not with its first+-- item or key: the lines up to the last empty line above its first entry, and+-- the comment on its first line, e.g. after its tag. A t'Commented' value of+-- the whole list or mapping keeps them.+--+-- By the rules in [Comments]("Yamlet.Syntax#comments"), some lines read+-- back with a change:+--+-- * The lines after a text of several lines, which the encoder writes as a+--   block scalar, read back as the lines above the next entry. After the+--   last entry, they belong to the end of the collection around the entry.+--+-- * The lines above a list or a mapping without a key can get an empty line+--   below them, e.g. at the top level. The empty line reads back as the last+--   of these lines.+--+-- * The lines above the first item of a list or the first key of a mapping+--   that end with an empty line read back as the lines of the list or the+--   mapping. A t'Commented' list or mapping keeps them. Under a key, the+--   inner of two nested t'Commented' values keeps them, as above. Otherwise+--   they are lost.+--+-- A comment is lost if its node has no place for it, i.e. if the node does+-- not decode into a node or a t'Commented' value:+--+-- * the comments of a key without a Haskell field, e.g. the tag of a+--   constructor;+--+-- * a comment at the end of a nested mapping, unless the field that holds+--   the mapping is t'Commented', because a record has no place for the end+--   of its mapping;+--+-- * the comments of a record's mapping above its first key, e.g. a comment+--   at the top of a file above an empty line;+--+-- * the comments of the key for a type such as+--   @data Name = Name (Commented Text)@ that derives its instances through+--   'Generic', because a derived instance for one constructor with one field+--   without a name does not give the key of its entry to the value inside.+--   Declare such a type as a newtype and derive its instances with+--   @deriving newtype@, which gives the key to the value.+--+-- In a map, use t'Commented' on the key or on the value, not on both. With+-- both, the decoder gives the comments of the key to both, and the encoder+-- writes only those of the value, so a change to the comments of the key is+-- lost.+--+-- A change of the value keeps the comments:+--+-- >>> input = "# The port.\nport: 80 # the default\n"+--+-- >>> :{+-- either printErrors (T.putStr . encodeText . M.map (fmap (+ 1))) $+--   decodeText @(M.Map T.Text (Commented Int)) input+-- :}+-- # The port.+-- port: 81 # the default+--+-- The order compares the values first and then the comments, e.g. in a set.+data Commented a = Commented+  { value :: !a+  , comments :: !Comments+  }+  -- The derived order compares the fields in this order.+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)+  deriving anyclass (NFData)++-- | A value with the offset of its node, e.g. for the error of a check that+-- runs after the decode. The encoder writes only the value.+--+-- 'Yamlet.Error.documentErrors' turns the offsets into errors with lines,+-- columns and paths. It needs the text and the document of the decode, so+-- decode with 'Yamlet.decodeWithDocument'. Here the check gives an offset and+-- a message for each problem:+--+-- >>> input = "paths:\n- src\n- /etc\n"+--+-- >>> :{+-- case decodeWithDocument @(M.Map T.Text [Located T.Text]) input of+--   Right (config, doc) ->+--     let errs =+--           [ (p.offset, "the path is outside the repository")+--           | p <- concat (M.elems config)+--           , "/" `T.isPrefixOf` p.value+--           ]+--     in printErrors (documentErrors input doc errs)+--   Left errs -> printErrors errs+-- :}+-- input.yaml:3:3: paths[1]: the path is outside the repository+--   |+-- 3 | - /etc+--   |   ^+--+-- A value that no node gives, e.g. a value of 'Yamlet.Generic.yamlDefault',+-- has 'noOffset'. Its error has no position, and 'Yamlet.Error.prettyError'+-- prints only the file and the message. A value inside an alias has the+-- offset of the alias, i.e. of the place where the document uses the value.+--+-- Two equal values at different places are not equal as t'Located' values,+-- e.g. a set keeps both. The equality and the order compare the values first+-- and then the offsets. To compare only the values, e.g. in a test, use the+-- field @value@.+data Located a = Located+  { value :: !a+  , offset :: !Offset+  }+  -- The derived order compares the fields in this order.+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic)+  deriving anyclass (NFData)++-- | A line of comments.+data Line+  = EmptyLine+  | -- | The number of @#@ characters at the start of the comment, e.g. 2 for+    -- @## Section@, and the text after them, without the one space after the+    -- @#@ characters and without the white space at its end. The renderer+    -- writes a count below 1 as 1. It writes a text with line breaks as+    -- several comment lines with the same @#@ characters, and the parser+    -- reads them back as several comments. U+0085, U+2028 and U+2029 count as+    -- line breaks here, because YAML 1.1 reads them as line breaks.+    --+    -- The comment at the end of a line in t'Comments' is a text without a+    -- count. It keeps the @#@ characters after the first one in its text.+    CommentLine !Int !T.Text+  deriving stock (Eq, Ord, Generic)++-- | A comment with one @#@. As a pattern, it matches every comment and+-- ignores the number of @#@ characters.+pattern Comment :: T.Text -> Line+pattern Comment t <- CommentLine _ t+  where+    Comment t = CommentLine 1 t++{-# COMPLETE EmptyLine, Comment #-}++-- A comment with one @#@ shows as 'Comment', as a program usually writes it.+instance Show Line where+  showsPrec d = \case+    EmptyLine -> showString "EmptyLine"+    CommentLine 1 t -> showParen (d > 10) $ showString "Comment " . showsPrec 11 t+    CommentLine n t ->+      showParen (d > 10) $+        showString "CommentLine " . showsPrec 11 n . showChar ' ' . showsPrec 11 t++instance NFData Line where+  rnf = rwhnf++-- | The offset of a byte in the input text, in its UTF-8 encoding. For an+-- input in UTF-16 or UTF-32, the offset counts the bytes of the text after+-- 'Yamlet.Syntax.decodeInput', not the bytes of the input.+newtype Offset = Offset Int+  deriving stock (Generic)+  deriving newtype (Eq, Ord, Show, NFData)++-- | The offset of a node that does not come from an input.+noOffset :: Offset+noOffset = Offset (-1)++-- | Copy every text of a document, so that the document does not keep the+-- input alive.+copyDocument :: Document -> Document+copyDocument doc =+  doc+    { docComments = copyComments doc.docComments+    , root = copyNode doc.root+    }++-- | Copy every text of a node, so that the node does not keep the input+-- alive.+copyNode :: Node -> Node+copyNode n =+  n+    { props = case n.props of+        -- Most nodes share one empty value, which a copy would duplicate.+        Props Nothing (Tag t) -> Props Nothing (Tag (T.copy t))+        Props Nothing _ -> n.props+        Props anchor tag ->+          Props+            { anchor = copyMaybe anchor+            , tag = case tag of+                Tag t -> Tag (T.copy t)+                t -> t+            }+    , comments = case n.comments of+        -- Most nodes share one empty value. GHC returns the result of+        -- 'copyComments' unboxed, so the caller would build a new one.+        c@(Comments [] Nothing []) -> c+        c -> copyComments c+    , content = case n.content of+        ScalarLinesContent style t ls -> ScalarLinesContent style (T.copy t) ls+        SequenceContent style xs -> SequenceContent style (strictMap copyNode xs)+        MappingContent style kvs ->+          MappingContent+            style+            (strictMap (\(k, v) -> strictPair (copyNode k) (copyNode v)) kvs)+        AliasContent name -> AliasContent (T.copy name)+    }++copyComments :: Comments -> Comments+copyComments c = case c of+  Comments [] Nothing [] -> c+  _ ->+    Comments+      { before = strictMap copyLine c.before+      , inline = copyMaybe c.inline+      , after = strictMap copyLine c.after+      }+  where+    copyLine :: Line -> Line+    copyLine = \case+      CommentLine n t -> CommentLine n (T.copy t)+      EmptyLine -> EmptyLine++-- | A copy without a thunk, which would keep the original text alive.+copyMaybe :: Maybe T.Text -> Maybe T.Text+copyMaybe = \case+  Just t -> Just $! T.copy t+  Nothing -> Nothing++-- $setup+-- >>> import Data.Map.Strict qualified as M+-- >>> import Data.Text.IO qualified as T+-- >>> import Yamlet+-- >>> import Yamlet.Syntax+-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")
+ src/Yamlet/Internal/ToYaml.hs view
@@ -0,0 +1,686 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The class t'ToYaml', its instances and the parts of the encoder that the+-- generic instances share with it. "Yamlet.Encode" exports the public parts.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.ToYaml+  ( -- * Class+    ToYaml (..)+  , (.=)+  , mapping++    -- * Parts of the generic instances+  , string+  , scalar+  ) where++import Control.Applicative+import Data.Fixed+import Data.Foldable+import Data.Functor.Identity+import Data.Int+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Monoid qualified as Mon+import Data.Ord+import Data.Proxy+import Data.Ratio+import Data.Scientific qualified as Sci+import Data.Semigroup qualified as Sem+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Builder.Linear qualified as B+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TLB+import Data.Time+import Data.Time.Calendar.Month+import Data.Time.Calendar.Quarter+import Data.Time.ToText+import Data.Tree qualified as Tree+import Data.UUID.Types qualified as UUID+import Data.Void+import Data.Word+import Math.NumberTheory.Logarithms+import Numeric.Natural++import Yamlet.Internal.Schema+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils+import Yamlet.Value++----------------------------------------+-- Class++-- | Types that can be converted to a node. A type with a+-- t'GHC.Generics.Generic' instance can derive the instance via+-- t'Yamlet.Generic.GenericYaml'.+--+-- An instance for a record writes a mapping with 'mapping' and '.=':+--+-- >>> :{+-- data Server = Server {host :: T.Text, port :: Int, tags :: [T.Text]}+-- instance ToYaml Server where+--   toYaml s = mapping ["host" .= s.host, "port" .= s.port, "tags" .= s.tags]+-- :}+--+-- >>> T.putStr (encodeText (Server "example.com" 80 ["web", "yes"]))+-- host: example.com+-- port: 80+-- tags:+-- - web+-- - 'yes'+--+-- The string @yes@ gets quotes, because YAML 1.1 parsers read it as a+-- boolean.+class ToYaml a where+  toYaml :: a -> S.Node++  -- | Convert a list. The instance for 'Char' creates a string instead.+  toYamlList :: [a] -> S.Node+  toYamlList = S.sequenceNode . map toYaml++  -- | Convert the value of a mapping entry, with the node of its key, e.g. to+  -- put comments on the key as 'Yamlet.Commented' does. '.=', the derived+  -- encoders and the instances for maps use it. The default returns the key+  -- unchanged.+  toYamlField :: S.Node -> a -> (S.Node, S.Node)+  toYamlField k v = (k, toYaml v)++-- | An entry of a mapping with a string key.+(.=) :: ToYaml a => T.Text -> a -> (S.Node, S.Node)+key .= v = toYamlField (string key) v++infixr 8 .=++-- | A mapping with the entries in the given order. A mapping with two equal+-- keys does not read back.+mapping :: [(S.Node, S.Node)] -> S.Node+mapping = S.mappingNode++instance ToYaml S.Node where toYaml = id+instance ToYaml Value where toYaml = toSyntax++-- | The value with the comments of its entry. The lines above and the comment+-- of the first line go on the key, or on the value without a key. A key+-- keeps its own lines above, or its own comment, if the value has none. The+-- lines after the value replace its own.+instance ToYaml a => ToYaml (S.Commented a) where+  toYaml c =+    let v = withLinesAfter c.comments.after (toYaml c.value)+        vc = v.comments+    in S.withComments+         vc+           { S.before = c.comments.before ++ vc.before+           , S.inline = c.comments.inline <|> vc.inline+           }+         v+  toYamlField k c = (key, withLinesAfter c.comments.after (toYaml c.value))+    where+      -- In the syntax tree, the comments of an entry are on its key. The+      -- decoder gives them to the value too, because a key is not always a+      -- Haskell value. E.g. in+      --+      --   # c1+      --   permissions: # c2+      --     contents: read+      --+      -- a record field permissions :: Commented Node gets c1 and c2, and the+      -- encoder puts them back on the key.+      --+      -- A key that is a Haskell value gets them as well. E.g. in "a: 1 # c"+      -- decoded as Map (Commented Text) (Commented Int), the key and the+      -- value both have c. Comments that add up would be written twice, so+      -- those of the value replace those of the key.+      --+      -- A key keeps its own comments if the value has none, e.g. in a map+      -- that a program built with a comment only on the key.+      key :: S.Node+      key =+        S.withComments+          k.comments+            { S.before = if null c.comments.before then k.comments.before else c.comments.before+            , S.inline = c.comments.inline <|> k.comments.inline+            }+          k++-- | The value alone. The key of an entry goes to the value inside, e.g. for a+-- 'Yamlet.Commented' value.+instance ToYaml a => ToYaml (S.Located a) where+  toYaml l = toYaml l.value+  toYamlField k l = toYamlField k l.value++-- | The node with the given lines after it in place of its own, if the lines+-- are not empty.+withLinesAfter :: [S.Line] -> S.Node -> S.Node+withLinesAfter ls v+  | null ls = v+  | otherwise = S.withComments v.comments {S.after = ls} v++-- | An empty list, as a tuple without elements.+instance ToYaml () where toYaml _ = S.sequenceNode []++instance ToYaml Bool where toYaml = scalar . Bool+instance ToYaml Integer where toYaml = scalar . Int+instance ToYaml Natural where toYaml = integral+instance ToYaml Int where toYaml = integral+instance ToYaml Int8 where toYaml = integral+instance ToYaml Int16 where toYaml = integral+instance ToYaml Int32 where toYaml = integral+instance ToYaml Int64 where toYaml = integral+instance ToYaml Word where toYaml = integral+instance ToYaml Word8 where toYaml = integral+instance ToYaml Word16 where toYaml = integral+instance ToYaml Word32 where toYaml = integral+instance ToYaml Word64 where toYaml = integral++integral :: Integral a => a -> S.Node+integral = scalar . Int . toInteger++-- | Decimal notation from 10^-6 up to 10^21, as JavaScript writes numbers,+-- and exponential notation otherwise. The text always has a dot, so that it+-- reads back as a float. A value that is not a number or is infinite is+-- @.nan@, @.inf@ or @-.inf@.+--+-- >>> T.putStr (encodeText [12, 0.01, 1.5e-7, 2.0e21, 0 / 0, -1 / 0 :: Double])+-- - 12.0+-- - 0.01+-- - 1.5e-7+-- - 2.0e+21+-- - .nan+-- - -.inf+instance ToYaml Double where toYaml = scalar . Float . realFloatToFloatValue++instance ToYaml Float where toYaml = scalar . Float . realFloatToFloatValue++-- | A value whose exponent in scientific notation is beyond the range from+-- -1000 to 1000, e.g. @1e1001@, does not read back, see 'Finite'.+instance ToYaml Sci.Scientific where toYaml = scalar . Float . Finite++-- | The decoder accepts a year of at most 15 digits, so a larger year, e.g.+-- @10^15@, does not read back.+instance ToYaml Day where toYaml = timestamp buildDay++instance ToYaml TimeOfDay where toYaml = iso8601 timeOfDay++-- | The decoder accepts a year of at most 15 digits, so a larger year does+-- not read back.+instance ToYaml LocalTime where toYaml = timestamp localTime++-- | The decoder accepts an offset of less than 24 hours, so a larger offset,+-- e.g. @+25:00@, does not read back. Neither does a year of more than 15+-- digits.+instance ToYaml ZonedTime where+  toYaml = timestamp (\(ZonedTime t z) -> localTime t <> buildTimeZone z)++-- | The decoder accepts a year of at most 15 digits, so a larger year does+-- not read back.+instance ToYaml UTCTime where+  toYaml =+    timestamp (\(UTCTime d s) -> localTime (LocalTime d (timeToTimeOfDay s)) <> "Z")++-- | The time of day without the trailing zeros of the fraction, e.g.+-- @12:30:15.5@, as in aeson. text-iso8601 writes the fraction in groups of+-- three digits.+timeOfDay :: TimeOfDay -> TLB.Builder+timeOfDay (TimeOfDay h m (MkFixed ps)) =+  buildTimeOfDay (TimeOfDay h m (MkFixed (ps - frac))) <> fraction+  where+    frac :: Integer+    frac = ps `rem` (10 ^ picoDecimals)++    fraction :: TLB.Builder+    fraction+      | frac == 0 = mempty+      | otherwise =+          "."+            <> TLB.fromText+              ( T.dropWhileEnd+                  (== '0')+                  (T.justifyRight picoDecimals '0' (T.pack (show frac)))+              )++localTime :: LocalTime -> TLB.Builder+localTime (LocalTime d t) = buildDay d <> "T" <> timeOfDay t++-- | A number of seconds. A value whose exponent in scientific notation is+-- beyond the range from -1000 to 1000, e.g. @10^1001@ seconds, does not read+-- back, see 'Finite'.+instance ToYaml NominalDiffTime where+  toYaml d = let MkFixed ps = nominalDiffTimeToSeconds d in seconds ps++-- | A number of seconds. A value whose exponent in scientific notation is+-- beyond the range from -1000 to 1000, e.g. @10^1001@ seconds, does not read+-- back, see 'Finite'.+instance ToYaml DiffTime where+  toYaml = seconds . diffTimeToPicoseconds++-- | The seconds of a number of picoseconds.+seconds :: Integer -> S.Node+seconds ps = scalar (Float (Finite (Sci.scientific ps (negate picoDecimals))))++-- | The text form with hyphens, e.g. @123e4567-e89b-12d3-a456-426614174000@.+instance ToYaml UUID.UUID where toYaml = scalar . String . UUID.toText++-- | The decoder accepts a year of at most 15 digits, so a larger year does+-- not read back.+instance ToYaml Month where toYaml = iso8601 buildMonth++-- | The decoder accepts a year of at most 15 digits, so a larger year does+-- not read back.+instance ToYaml Quarter where toYaml = iso8601 buildQuarter++instance ToYaml QuarterOfYear where toYaml = iso8601 buildQuarterOfYear++-- | A string in an ISO 8601 format, the same as in aeson.+iso8601 :: (a -> TLB.Builder) -> a -> S.Node+iso8601 build = scalar . String . TL.toStrict . TLB.toLazyText . build++-- | Like 'iso8601', but plain if YAML 1.1 reads the text as a timestamp,+-- because the value is one.+timestamp :: (a -> TLB.Builder) -> a -> S.Node+timestamp build x+  | isPlainString t && (isYaml11Timestamp t || not (isYaml11NonString t)) = S.plainNode t+  | otherwise = string t+  where+    t :: T.Text+    t = TL.toStrict (TLB.toLazyText (build x))++-- | The English name in lowercase, e.g. @monday@.+instance ToYaml DayOfWeek where+  toYaml = scalar . String . T.toLower . T.pack . show++-- | A mapping with the keys @months@ and @days@, e.g. @{months: 1, days: 2}@.+instance ToYaml CalendarDiffDays where+  toYaml d = mapping ["months" .= cdMonths d, "days" .= cdDays d]++-- | A mapping with the keys @months@ and @time@, a number of seconds, e.g.+-- @{months: 1, time: 1.5}@.+instance ToYaml CalendarDiffTime where+  toYaml d = mapping ["months" .= ctMonths d, "time" .= ctTime d]++instance ToYaml T.Text where toYaml = scalar . String+instance ToYaml TL.Text where toYaml = scalar . String . TL.toStrict++-- | A string of the character, and a t'String' as a string. A surrogate code+-- point, which t'Data.Text.Text' cannot hold, becomes U+FFFD, so it does not+-- read back.+instance ToYaml Char where+  toYaml = scalar . String . T.singleton+  toYamlList = scalar . String . T.pack++instance ToYaml a => ToYaml [a] where+  toYaml = toYamlList++instance ToYaml a => ToYaml (NE.NonEmpty a) where+  toYaml = items . NE.toList++-- | 'Nothing' is null. @'Just' 'Nothing'@ is null too, so it reads back as+-- 'Nothing', as in aeson. The key of an entry goes to the value inside, e.g.+-- for a 'Yamlet.Commented' value.+instance ToYaml a => ToYaml (Maybe a) where+  toYaml = maybe (scalar Null) toYaml+  toYamlField k = maybe (k, scalar Null) (toYamlField k)++-- | Two keys that give equal nodes give a mapping that does not read back,+-- e.g. 'Nothing' and @'Just' 'Nothing'@, two NaN values, or two v'Mapping'+-- values with the same entries in a different order.+instance (ToYaml k, ToYaml v) => ToYaml (M.Map k v) where+  toYaml m = mapping [toYamlField (toYaml k) v | (k, v) <- M.toList m]++instance ToYaml v => ToYaml (IM.IntMap v) where+  toYaml m = mapping [toYamlField (toYaml k) v | (k, v) <- IM.toList m]++-- | A list in ascending order.+instance ToYaml a => ToYaml (Set.Set a) where+  toYaml = items . Set.toAscList++-- | A list in ascending order.+instance ToYaml IS.IntSet where+  toYaml = toYaml . IS.toAscList++instance ToYaml a => ToYaml (Seq.Seq a) where+  toYaml = items . toList++-- | A sequence of the items. Unlike a list, it is never a string, e.g. for+-- items of type 'Char', because only t'String' is text.+items :: ToYaml a => [a] -> S.Node+items = S.sequenceNode . map toYaml++-- | A list of the label and the subtrees, e.g. @[a, [[b, []]]]@.+instance ToYaml a => ToYaml (Tree.Tree a) where+  toYaml t = toYaml (Tree.rootLabel t, Tree.subForest t)++-- | @LT@, @EQ@ or @GT@.+instance ToYaml Ordering where+  toYaml = scalar . String . T.pack . show++instance ToYaml Void where+  toYaml = absurd++-- | A mapping with the keys @numerator@ and @denominator@, e.g.+-- @{numerator: 1, denominator: 3}@.+instance (Integral a, ToYaml a) => ToYaml (Ratio a) where+  toYaml r = mapping ["numerator" .= numerator r, "denominator" .= denominator r]++-- | A number. If the resolution is not a product of 2s and 5s, e.g. 3, a value+-- can have no exact decimal form. It then becomes the nearest number with as+-- many digits after the point as the resolution has, which does not read back.+-- For such a resolution, use 'Rational' instead.+--+-- A value whose exponent in scientific notation is beyond the range from+-- -1000 to 1000, e.g. @10^1001@, does not read back, see 'Finite'.+instance HasResolution a => ToYaml (Fixed a) where+  toYaml (MkFixed n) = scalar . Float . Finite $ case decimalPlaces res of+    Just places -> Sci.scientific (n * (10 ^ places `div` res)) (negate places)+    Nothing -> Sci.scientific (round (n * 10 ^ digits % res)) (negate digits)+    where+      res :: Integer+      res = resolution (Proxy @a)++      digits :: Int+      digits = integerLog10 res + 1++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Identity a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Const a b)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Down a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Min a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Max a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.First a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Last a)++-- | The value inside, or null for 'Nothing'.+deriving newtype instance ToYaml a => ToYaml (Mon.First a)++-- | The value inside, or null for 'Nothing'.+deriving newtype instance ToYaml a => ToYaml (Mon.Last a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Dual a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Sum a)++-- | The value inside.+deriving newtype instance ToYaml a => ToYaml (Sem.Product a)++-- | The value inside.+deriving newtype instance ToYaml Sem.All++-- | The value inside.+deriving newtype instance ToYaml Sem.Any++-- | A mapping with one key, @Left@ or @Right@, e.g. @{Left: 1}@.+instance (ToYaml a, ToYaml b) => ToYaml (Either a b) where+  toYaml = \case+    Left a -> mapping ["Left" .= a]+    Right b -> mapping ["Right" .= b]++instance (ToYaml a1, ToYaml a2) => ToYaml (a1, a2) where+  toYaml (a1, a2) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      ]++instance (ToYaml a1, ToYaml a2, ToYaml a3) => ToYaml (a1, a2, a3) where+  toYaml (a1, a2, a3) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      ]++instance (ToYaml a1, ToYaml a2, ToYaml a3, ToYaml a4) => ToYaml (a1, a2, a3, a4) where+  toYaml (a1, a2, a3, a4) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      ]++instance+  (ToYaml a1, ToYaml a2, ToYaml a3, ToYaml a4, ToYaml a5)+  => ToYaml (a1, a2, a3, a4, a5)+  where+  toYaml (a1, a2, a3, a4, a5) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      ]++instance+  (ToYaml a1, ToYaml a2, ToYaml a3, ToYaml a4, ToYaml a5, ToYaml a6)+  => ToYaml (a1, a2, a3, a4, a5, a6)+  where+  toYaml (a1, a2, a3, a4, a5, a6) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      , toYaml a6+      ]++instance+  (ToYaml a1, ToYaml a2, ToYaml a3, ToYaml a4, ToYaml a5, ToYaml a6, ToYaml a7)+  => ToYaml (a1, a2, a3, a4, a5, a6, a7)+  where+  toYaml (a1, a2, a3, a4, a5, a6, a7) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      , toYaml a6+      , toYaml a7+      ]++instance+  (ToYaml a1, ToYaml a2, ToYaml a3, ToYaml a4, ToYaml a5, ToYaml a6, ToYaml a7, ToYaml a8)+  => ToYaml (a1, a2, a3, a4, a5, a6, a7, a8)+  where+  toYaml (a1, a2, a3, a4, a5, a6, a7, a8) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      , toYaml a6+      , toYaml a7+      , toYaml a8+      ]++instance+  ( ToYaml a1+  , ToYaml a2+  , ToYaml a3+  , ToYaml a4+  , ToYaml a5+  , ToYaml a6+  , ToYaml a7+  , ToYaml a8+  , ToYaml a9+  )+  => ToYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9)+  where+  toYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      , toYaml a6+      , toYaml a7+      , toYaml a8+      , toYaml a9+      ]++instance+  ( ToYaml a1+  , ToYaml a2+  , ToYaml a3+  , ToYaml a4+  , ToYaml a5+  , ToYaml a6+  , ToYaml a7+  , ToYaml a8+  , ToYaml a9+  , ToYaml a10+  )+  => ToYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)+  where+  toYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) =+    S.sequenceNode+      [ toYaml a1+      , toYaml a2+      , toYaml a3+      , toYaml a4+      , toYaml a5+      , toYaml a6+      , toYaml a7+      , toYaml a8+      , toYaml a9+      , toYaml a10+      ]++----------------------------------------+-- Nodes++-- | The node of a value.+toSyntax :: Value -> S.Node+toSyntax = \case+  Sequence xs -> S.sequenceNode (map toSyntax xs)+  Mapping kvs -> S.mappingNode [(toSyntax k, toSyntax v) | (k, v) <- kvs]+  Tagged tag v+    | T.compareLength tag 1 == GT -> (toSyntax v) {S.props = S.Props Nothing (S.Tag tag)}+    -- YAML has no syntax for such a tag. The non-specific tag ! would make+    -- the value a string in YAML 1.2, but not in YAML 1.1 parsers.+    | otherwise -> toSyntax v+  v -> scalar v++-- | A scalar in a style that reads back as the value. For a collection or a+-- tagged value, use 'toSyntax'.+scalar :: Value -> S.Node+scalar = \case+  String t -> string t+  v -> S.plainNode (plainText v)++-- | A string as a literal block scalar if it has a line break. A text of+-- only line breaks is in double quotes, because quotes are easier to read+-- than empty lines. Otherwise it is a plain scalar if the schema reads the+-- text as a string, and in single quotes if not. The renderer puts a plain+-- scalar in quotes if its text cannot be plain, e.g. @a: b@. It uses double+-- quotes for a text with a tab or a character that single quotes cannot+-- hold.+--+-- A text that YAML 1.1 reads as another type, e.g. @yes@ or @12:30@, is in+-- quotes too, because many parsers still follow YAML 1.1.+string :: T.Text -> S.Node+string t+  | T.all (== '\n') t, not (T.null t) = S.scalarNode S.DoubleQuoted t+  | T.any (== '\n') t = S.scalarNode S.Literal t+  | isPlainString t && not (isYaml11NonString t) = S.plainNode t+  | otherwise = S.scalarNode S.SingleQuoted t++-- | The text of a scalar value without quotes.+plainText :: Value -> T.Text+plainText = \case+  Null -> "null"+  Bool b -> if b then "true" else "false"+  Int i -> T.pack (show i)+  Float (Finite s) -> finite s+  Float Infinity -> ".inf"+  Float NegativeZero -> "-0.0"+  Float NegativeInfinity -> "-.inf"+  Float NaN -> ".nan"+  String t -> t+  Sequence _ -> "[]"+  Mapping _ -> "{}"+  Tagged _ v -> plainText v+  where+    -- Decimal notation for the exponents from 'minDecimal' to 'maxDecimal',+    -- and exponential notation for other numbers. The text always has a dot,+    -- so the number reads back as a float, not as an integer.+    -- The exponent of Sci.formatScientific overflows close to the upper limit+    -- of Int.+    finite :: Sci.Scientific -> T.Text+    finite s = case T.uncons digits of+      Nothing -> "0.0"+      Just (d, rest)+        | ex >= minDecimal && ex < 0 ->+            T.concat [sign, "0.", T.replicate (fromInteger (negate ex - 1)) "0", digits]+        | ex >= 0 && ex <= maxDecimal ->+            let (int, frac) = T.splitAt integerDigits digits+            in T.concat [sign, T.justifyLeft integerDigits '0' int, ".", orZero frac]+        -- YAML 1.1 reads an exponent without a sign as a string.+        | otherwise ->+            T.concat+              [ sign+              , T.singleton d+              , "."+              , orZero rest+              , if ex < 0 then "e" else "e+"+              , decimal ex+              ]+      where+        c :: Integer+        c = Sci.coefficient s++        written :: T.Text+        written = decimal (abs c)++        digits :: T.Text+        digits = T.dropWhileEnd (== '0') written++        -- The exponent of the first digit.+        ex :: Integer+        ex = toInteger (Sci.base10Exponent s) + toInteger (T.length written) - 1++        integerDigits :: Int+        integerDigits = fromInteger ex + 1++        sign :: T.Text+        sign = if c < 0 then "-" else ""++        orZero :: T.Text -> T.Text+        orZero t = if T.null t then "0" else t++        decimal :: Integer -> T.Text+        decimal = B.runBuilder . B.fromUnboundedDec++        -- The exponents of the first digit that Number::toString of+        -- ECMAScript writes in decimal notation, for the numbers from 10^-6+        -- up to 10^21. JSON.stringify uses the same notation.+        minDecimal, maxDecimal :: Integer+        minDecimal = -6+        maxDecimal = 20++-- $setup+-- >>> import Data.Text.IO qualified as T+-- >>> import Yamlet
+ src/Yamlet/Internal/Utils.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Helpers for the other modules.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.Utils+  ( textStripPrefix+  , textIsPrefixOf+  , maxImplicitKeyLength+  , maxVersion+  , minExpansion+  , coreTagPrefix+  , picoDecimals+  , decimalPlaces+  , isHighSurrogate+  , isLowSurrogate+  , fromSurrogates+  , isScalarValue+  , xEscapeDigits+  , uEscapeDigits+  , bigUEscapeDigits+  , percentDigits+  , showText+  , strictPair+  , strictMap+  , firstOfResult+  ) where++import Data.Char+import Data.Fixed+import Data.Proxy+import Data.Text qualified as T+import Math.NumberTheory.Logarithms+import Numeric++#if !MIN_VERSION_text(2,1,4)+import Data.Text.Internal qualified as T+#endif++-- | 'Data.Text.stripPrefix'. Before text 2.1.4, 'Data.Text.stripPrefix'+-- compares the texts as streams of characters and allocates for each+-- character. For these versions this is the code of text 2.1.4, which+-- compares the UTF-8 bytes.+textStripPrefix :: T.Text -> T.Text -> Maybe T.Text+#if MIN_VERSION_text(2,1,4)+textStripPrefix = T.stripPrefix+#else+textStripPrefix p@(T.Text _arr _off plen) t@(T.Text arr off len)+  | textIsPrefixOf p t = Just $! T.text arr (off + plen) (len - plen)+  | otherwise = Nothing+#endif++-- | 'Data.Text.isPrefixOf', with the code of text 2.1.4 as in+-- 'textStripPrefix'.+textIsPrefixOf :: T.Text -> T.Text -> Bool+#if MIN_VERSION_text(2,1,4)+textIsPrefixOf = T.isPrefixOf+#else+textIsPrefixOf a@(T.Text _aArr _aOff aLen) b@(T.Text bArr bOff bLen) =+  d >= 0 && a == b'+  where+    d :: Int+    d = bLen - aLen++    b' :: T.Text+    b'+      | d == 0 = b+      | otherwise = T.Text bArr bOff aLen+#endif++-- | The largest number of characters of an implicit key, from the YAML 1.2.2+-- specification.+maxImplicitKeyLength :: Int+maxImplicitKeyLength = 1024++-- | The largest number in a version of a @%YAML@ directive.+--+-- Without a limit, the largest number depends on the size of Int, which+-- differs between architectures. The limit is far above any version of YAML,+-- and a number below it times 10 fits in 32 bits.+maxVersion :: Int+maxVersion = 1000000++-- | The size that an expansion of a small input can always add: the visits+-- that aliases add to a traversal, or the bytes that the prefixes of @%TAG@+-- directives add to the tags. A larger input can add as much as it has.+--+-- A traversal of 100000 nodes takes about 5 ms and 6 MB, measured with a+-- copy of the nodes. go-yaml allows about 400000 nodes from aliases in a+-- small document.+minExpansion :: Int+minExpansion = 100000++-- | The prefix of the tags of the core schema, and of the @!!@ handle.+coreTagPrefix :: T.Text+coreTagPrefix = "tag:yaml.org,2002:"++-- | The number of decimal places of 'Pico', the resolution of the durations of+-- the time library.+picoDecimals :: Int+picoDecimals = integerLog10 (resolution (Proxy @E12))++-- | The number of decimal places of 1/n, or 'Nothing' if 1/n has no finite+-- decimal form. It has one if n is 2^a * 5^b, and then it needs max a b+-- places.+decimalPlaces :: Integer -> Maybe Int+decimalPlaces n = if rest == 1 then Just (max twos fives) else Nothing+  where+    twos, fives :: Int+    afterTwos, rest :: Integer+    (twos, afterTwos) = factors 2 n+    (fives, rest) = factors 5 afterTwos++    -- The number of factors p of x, and x without them.+    factors :: Integer -> Integer -> (Int, Integer)+    factors p = go 0+      where+        go :: Int -> Integer -> (Int, Integer)+        go i x = case x `quotRem` p of+          (q, 0) | x /= 0 -> go (i + 1) q+          _ -> (i, x)++-- | The first code unit of a surrogate pair of UTF-16.+isHighSurrogate :: Int -> Bool+isHighSurrogate u = u >= 0xD800 && u <= 0xDBFF++-- | The second code unit of a surrogate pair of UTF-16.+isLowSurrogate :: Int -> Bool+isLowSurrogate u = u >= 0xDC00 && u <= 0xDFFF++-- | The code point of a surrogate pair, by the formula of UTF-16.+fromSurrogates :: Int -> Int -> Int+fromSurrogates hi lo = 0x10000 + (hi - 0xD800) * 0x400 + (lo - 0xDC00)++-- | A code point that a character can have: in the range of Unicode, and not a+-- surrogate.+isScalarValue :: Int -> Bool+isScalarValue c =+  c >= 0 && c <= ord maxBound && not (isHighSurrogate c || isLowSurrogate c)++-- | The number of hex digits of the @\\x@, @\\u@ and @\\U@ escapes of a+-- double-quoted scalar.+xEscapeDigits, uEscapeDigits, bigUEscapeDigits :: Int+xEscapeDigits = 2+uEscapeDigits = 4+bigUEscapeDigits = 8++-- | The number of hex digits of a @%XX@ escape in a tag.+percentDigits :: Int+percentDigits = 2++-- | The text in double quotes for a message, with the escapes of a+-- double-quoted scalar for a quote, a backslash and a character that does+-- not print, so that the message stays on one line. Unlike 'show', it keeps+-- the other characters that are not ASCII, e.g. @"zażółć"@.+showText :: T.Text -> String+showText t = '"' : concatMap escape (T.unpack t) ++ "\""+  where+    escape :: Char -> String+    escape c+      | c == '"' || c == '\\' = ['\\', c]+      | c == '\n' = "\\n"+      | c == '\r' = "\\r"+      | c == '\t' = "\\t"+      | isPrint c = [c]+      | ord c < 16 ^ xEscapeDigits = hex 'x' xEscapeDigits+      | ord c < 16 ^ uEscapeDigits = hex 'u' uEscapeDigits+      | otherwise = hex 'U' bigUEscapeDigits+      where+        hex :: Char -> Int -> String+        hex p width =+          let h = showHex (ord c) ""+          in '\\' : p : replicate (width - length h) '0' ++ h++-- | A pair with both components evaluated.+strictPair :: a -> b -> (a, b)+strictPair !a !b = (a, b)++-- | 'map' with the spine and the elements of the result evaluated. The+-- results are in reverse until the end, so that the stack does not grow with+-- the length of the list.+strictMap :: forall a b. (a -> b) -> [a] -> [b]+strictMap f = go []+  where+    go :: [b] -> [a] -> [b]+    go acc = \case+      [] -> reverse acc+      x : xs -> let !y = f x in go (y : acc) xs++-- | The first component of a pair in a result. Unlike @'fmap' 'fst'@, it+-- gives no selector thunk inside the result.+firstOfResult :: Either e (a, b) -> Either e a+firstOfResult = \case+  Left e -> Left e+  Right (a, _) -> Right a
+ src/Yamlet/Internal/View.hs view
@@ -0,0 +1,109 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | The values of the nodes of a syntax tree.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Yamlet.Internal.View+  ( View (..)+  , view+  , scalarValue+  , describeNode+  , isNullNode+  , stringValue+  , inputText+  ) where++import Data.Maybe+import Data.Text qualified as T+import GHC.Generics++import Yamlet.Internal.Schema+import Yamlet.Internal.Syntax qualified as S+import Yamlet.Internal.Utils+import Yamlet.Value++-- | The value of a node with its tag resolved. The items and the entries of a+-- collection stay nodes of the syntax tree. A tag that the schema does not+-- know does not matter, e.g. @!secret abc@ is a string.+data View+  = NullView+  | BoolView !Bool+  | IntView !Integer+  | FloatView !FloatValue+  | StringView !T.Text+  | SequenceView ![S.Node]+  | MappingView ![(S.Node, S.Node)]+  | -- | An alias, e.g. in a node from 'Yamlet.Syntax.parseDocuments'.+    -- 'Yamlet.Decode.runParser' replaces the aliases, so a parser never sees+    -- one.+    AliasView !T.Text+  deriving stock (Eq, Show, Generic)++-- | The view of a node.+view :: S.Node -> View+view n = case n.content of+  S.ScalarContent style t -> case scalarValue n.props.tag style t of+    Null -> NullView+    Bool b -> BoolView b+    Int i -> IntView i+    Float f -> FloatView f+    _ -> StringView t+  S.SequenceContent _ xs -> SequenceView xs+  S.MappingContent _ kvs -> MappingView kvs+  S.AliasContent name -> AliasView name+-- GHC does not inline it without the pragma. Inlined, a match on the view+-- allocates no view. Without it, the decode benchmarks and the parseYaml+-- benchmarks of the derived instances allocated more.+{-# INLINE view #-}++-- | The value of a scalar with the tag and the style, without the tag.+scalarValue :: S.Tag -> S.ScalarStyle -> T.Text -> Value+scalarValue tag style t = case tag of+  S.NoTag+    | style == S.Plain -> resolvePlain t+    | otherwise -> String t+  S.NonSpecificTag -> String t+  -- 'Yamlet.Decode.runParser' rejects a value that is not valid for its tag.+  S.Tag tag' -> fromMaybe (String t) (resolveTagged tag' t)+-- Inlined, it saves little of the allocation of a decoder in the decode+-- benchmarks, but each match on 'view' gets a copy of it, and a small+-- instance grows much.+{-# NOINLINE scalarValue #-}++-- | The kind of a node in plain words, e.g. "a list".+--+-- >>> map describeNode <$> decodeText @[Node] "- [1, 2]\n- 3.5\n- ~\n- !!str 12\n"+-- Right ["a list","a floating-point number","null","a string"]+describeNode :: S.Node -> String+describeNode n = case n.content of+  S.ScalarContent style t -> describe (scalarValue n.props.tag style t)+  S.SequenceContent _ _ -> "a list"+  S.MappingContent _ _ -> "a mapping"+  S.AliasContent _ -> "an alias"++-- | The node is null.+isNullNode :: S.Node -> Bool+isNullNode n = case view n of+  NullView -> True+  _ -> False++-- | The text of a string node.+stringValue :: S.Node -> Maybe T.Text+stringValue n = case view n of+  StringView t -> Just t+  _ -> Nothing++-- | A key or an item as the input writes it, for an error: a string in+-- quotes, an alias with its @*@ and another scalar as it is. A collection+-- and an empty scalar have no text.+inputText :: S.Node -> Maybe String+inputText n = case n.content of+  S.AliasContent name -> Just ('*' : T.unpack name)+  S.ScalarContent _ t+    | Just s <- stringValue n -> Just (showText s)+    | not (T.null t) -> Just (T.unpack t)+  _ -> Nothing++-- $setup+-- >>> import Yamlet
+ src/Yamlet/Schema.hs view
@@ -0,0 +1,14 @@+-- | The core schema of YAML 1.2.2: the rules that give a scalar its value.+--+-- A decoder applies these rules to every scalar. A program that writes YAML+-- can use them to check how a plain scalar reads back, e.g. @9.10@ is a+-- number, not a string.+module Yamlet.Schema+  ( resolvePlain+  , resolveTagged+  , isPlainString+  , isPlainSafe+  , isPlainPortable+  ) where++import Yamlet.Internal.Schema
+ src/Yamlet/Syntax.hs view
@@ -0,0 +1,555 @@+-- | The representation of a YAML stream that keeps every detail of the+-- presentation: the styles of scalars and collections, the lines of+-- scalars, anchors, aliases, unresolved tags, comments and empty lines. The+-- t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml' classes read and+-- write the nodes of this tree.+--+-- Most texts in the tree share the memory of the input, so a node keeps the+-- whole input alive. To keep a text longer than the tree, copy it with+-- 'Data.Text.copy', or copy the whole tree with 'copyDocument'. Copy only+-- what the program keeps: a copy of a whole tree usually needs more memory+-- than the input it frees.+--+-- A document that the renderer writes back keeps its comments, empty lines+-- and styles:+--+-- >>> input = "# The server.\nhost: localhost # only local\n\nports: [80, 443]\n"+--+-- >>> :{+-- case parseDocumentsText input of+--   Left err -> putStrLn (prettyError "input.yaml" err)+--   Right docs -> T.putStr (renderSyntax defaultRenderOptions docs)+-- :}+-- # The server.+-- host: localhost # only local+-- <BLANKLINE>+-- ports: [80, 443]+--+-- The section [Comments]("Yamlet.Syntax#comments") gives the rules that+-- decide the node of each comment.+module Yamlet.Syntax+  ( -- * Parsing+    parseDocuments+  , parseDocumentsText+  , decodeInput+  , copyDocument+  , copyNode++    -- * Rendering+  , renderSyntax+  , RenderOptions (..)+  , defaultRenderOptions++    -- * Documents+  , Document (..)+  , YamlVersion (..)+  , document++    -- * Nodes+  , Node (..)+  , Content (..)+  , Props (..)+  , noProps+  , Tag (..)+  , ScalarStyle (..)+  , CollectionStyle (..)++    -- ** Construction+  , contentNode+  , scalarNode+  , plainNode+  , foldedNode+  , sequenceNode+  , mappingNode++    -- * Positions+  , Offset (..)+  , noOffset++    -- * Comments+    -- $comments+  , Comments (..)+  , noComments+  , withComments+  , Line (..)++    -- ** Lines above a node+    -- $linesAbove++    -- ** Comments at the end of a line+    -- $endOfLine++    -- ** Lines at the end of a collection+    -- $endOfCollection++    -- ** Documents+    -- $documents++    -- ** Empty lines+    -- $emptyLines+  ) where++import Data.ByteString qualified as BS+import Data.Text qualified as T++import Yamlet.Error+import Yamlet.Internal.Input+import Yamlet.Internal.Parser+import Yamlet.Internal.Render+import Yamlet.Internal.Syntax++-- | Parse the documents of a stream. The encoding is UTF-8, UTF-16 or UTF-32,+-- detected as the YAML specification describes.+--+-- 'errorAt' and 'Yamlet.decodeDocument' need the text of the input. To report+-- errors with the lines of the input, decode the input with 'decodeInput' and+-- parse it with 'parseDocumentsText'.+parseDocuments :: BS.ByteString -> Either Error [Document]+parseDocuments bs = decodeInput bs >>= parseStream++-- | Parse the documents of a stream.+--+-- >>> length <$> parseDocumentsText "a\n---\nb\n"+-- Right 2+parseDocumentsText :: T.Text -> Either Error [Document]+parseDocumentsText = parseStream++-- | A folded block scalar (@>-@) with the given lines. The empty lines at the+-- end are dropped, because @>-@ strips them.+--+-- >>> T.putStr (renderSyntax defaultRenderOptions [document (mappingNode [(plainNode "options", foldedNode ["--health-cmd pg_isready", "--health-interval 5s"])])])+-- options: >-+--   --health-cmd pg_isready+--   --health-interval 5s+foldedNode :: [T.Text] -> Node+foldedNode ls = contentNode (ScalarLinesContent Folded t starts)+  where+    (t, starts) = foldedText (contentLines 0 ls)++    -- The lines with content, each with the number of empty lines above it.+    contentLines :: Int -> [T.Text] -> [BlockLine]+    contentLines !empties = \case+      [] -> []+      l : rest+        | T.null l -> contentLines (empties + 1) rest+        | otherwise -> BlockLine empties l : contentLines 0 rest++-- $comments+-- #comments#+-- The parser gives each comment to one node or document, and the renderer+-- writes it back at that place. A stream without documents, e.g. a stream of+-- only comments, has no such place. The parser drops its comments.+--+-- In the examples below, @printComments@ parses a text and prints each node+-- that has comments, with its path and the fields of t'Comments'. The key and+-- the value of an entry have the same path, with @(key)@ or @(value)@ after+-- it.++-- $linesAbove+-- A comment on a line of its own belongs to the node below it. Above the+-- first entry of a block collection, the lines up to the last empty line+-- belong to the collection, e.g. a comment at the top of a file.+--+-- >>> input = "# The server.\n\n# The host.\nhost: localhost\n# The port.\nport: 80\n"+--+-- >>> T.putStr input+-- # The server.+-- <BLANKLINE>+-- # The host.+-- host: localhost+-- # The port.+-- port: 80+--+-- >>> printComments input+-- root before: [Comment "The server.",EmptyLine]+-- root.host (key) before: [Comment "The host."]+-- root.port (key) before: [Comment "The port."]+--+-- A block collection after @- @ on the same line keeps all the lines above+-- it, so that a comment above an item belongs to the item.+--+-- >>> input = "# The first server.\n- host: localhost\n# The second server.\n- host: example.com\n"+--+-- >>> T.putStr input+-- # The first server.+-- - host: localhost+-- # The second server.+-- - host: example.com+--+-- >>> printComments input+-- root[0] before: [Comment "The first server."]+-- root[1] before: [Comment "The second server."]+--+-- The rules in the sections below give some of these lines to a document or+-- to the end of a collection instead, e.g. @# a@ and @# b@ below. The node+-- below still gets @# c@.+--+-- >>> input = "# a\n---\nserver:\n  host: localhost\n  # b\n# c\nuser: admin\n"+--+-- >>> T.putStr input+-- # a+-- ---+-- server:+--   host: localhost+--   # b+-- # c+-- user: admin+--+-- >>> printComments input+-- document before: [Comment "a"]+-- root.server (value) after: [Comment "b"]+-- root.user (key) before: [Comment "c"]++-- $endOfLine+-- A comment at the end of a line belongs to the node that ends last before+-- it on that line, if only spaces, a colon or a comma come between them.+-- E.g. the value gets the comment in @key: value # comment@. In+-- @key: # comment@, the key gets it if the value starts on a later line.+-- Otherwise the value is empty and ends after the colon, so it gets the+-- comment. A comment on the line of a block scalar header belongs to the+-- block scalar.+--+-- >>> input = "host: localhost # a\nports: # b\n- 80\nproxy: # c\ntext: | # d\n  Hello.\n"+--+-- >>> T.putStr input+-- host: localhost # a+-- ports: # b+-- - 80+-- proxy: # c+-- text: | # d+--   Hello.+--+-- >>> printComments input+-- root.host (value) inline: "a"+-- root.ports (key) inline: "b"+-- root.proxy (value) inline: "c"+-- root.text (value) inline: "d"+--+-- A comment at the end of a line that the rule above does not give to a+-- node, e.g. after @- @, belongs to the node below it. If that node also has+-- a comment at the end of its line, the first comment becomes a line above+-- the node, e.g. @# c@ below.+--+-- >>> input = "- # a\n  host: localhost # b\n- # c\n  'a string' # d\n"+--+-- >>> T.putStr input+-- - # a+--   host: localhost # b+-- - # c+--   'a string' # d+--+-- >>> printComments input+-- root[0] inline: "a"+-- root[0].host (value) inline: "b"+-- root[1] before: [Comment "c"]+-- root[1] inline: "d"+--+-- The same holds for a comment after the tag of a block collection.+--+-- >>> input = "server: !!map # a\n  host: localhost\n"+--+-- >>> T.putStr input+-- server: !!map # a+--   host: localhost+--+-- >>> printComments input+-- root.server (value) inline: "a"+--+-- On the line of the @---@ marker, the document gets such a comment.+--+-- >>> input = "--- !!map # a\nhost: localhost\n"+--+-- >>> T.putStr input+-- --- !!map # a+-- host: localhost+--+-- >>> printComments input+-- document inline: "a"++-- $endOfCollection+-- A comment below a scalar or an alias in a block collection belongs to the+-- end of that node if it is indented deeper than the key or the @-@ of its+-- entry. Below the last item of a list without indentation, it belongs to+-- the end of the list, by the rule below.+--+-- >>> input = "host: localhost\n  # a\n# b\nports:\n- 80\n  # c\n# d\n- 443\n  # e\n# f\nuser: admin\n"+--+-- >>> T.putStr input+-- host: localhost+--   # a+-- # b+-- ports:+-- - 80+--   # c+-- # d+-- - 443+--   # e+-- # f+-- user: admin+--+-- >>> printComments input+-- root.host (value) after: [Comment "a"]+-- root.ports (key) before: [Comment "b"]+-- root.ports (value) after: [Comment "e"]+-- root.ports[0] after: [Comment "c"]+-- root.ports[1] before: [Comment "d"]+-- root.user (key) before: [Comment "f"]+--+-- Below a block scalar, such a line is part of the scalar if it is indented+-- as deep as the content. Otherwise it belongs to the node below. E.g.+-- @# a@ below is a line of the text, and @user@ gets @# b@.+--+-- >>> input = "text: |\n    Hello.\n    # a\n  # b\nuser: admin\n"+--+-- >>> T.putStr input+-- text: |+--     Hello.+--     # a+--   # b+-- user: admin+--+-- >>> printComments input+-- root.user (key) before: [Comment "b"]+--+-- Thus the text has no place for the lines after a block scalar. They read+-- back as the lines of the node below, or of the end of an outer collection.+--+-- Below a scalar or an alias key after @?@, such a line belongs to the value:+-- as a line above it if the @:@ of the value follows, and as a line after it+-- if the key has no value. A list or a mapping as the key keeps it. E.g. the+-- value of @a@ gets @# b@ above it, the empty value of @e@ gets @# f@ after+-- it, and the list key gets @# d@.+--+-- >>> input = "? a\n  # b\n: x\n? e\n  # f\n? - c\n  # d\n: y\n"+--+-- >>> T.putStr input+-- ? a+--   # b+-- : x+-- ? e+--   # f+-- ? - c+--   # d+-- : y+--+-- >>> printComments input+-- root.a (value) before: [Comment "b"]+-- root.e (value) after: [Comment "f"]+-- root.? (key) after: [Comment "d"]+--+-- Thus the text has no place for the lines after a scalar or an alias key.+-- They read back as lines of the value.+--+-- A comment after the last entry of a block collection belongs to the end of+-- the collection if it is indented at least as deep as the entries, and+-- deeper than the key of the collection. Otherwise it belongs to the node+-- below it, or to the end of an outer collection if no node is below it.+--+-- >>> input = "server:\n  ports:\n  - 80\n  # a\n  # b\n# c\nuser: admin\n"+--+-- >>> T.putStr input+-- server:+--   ports:+--   - 80+--   # a+--   # b+-- # c+-- user: admin+--+-- >>> printComments input+-- root.server (value) after: [Comment "a",Comment "b"]+-- root.user (key) before: [Comment "c"]+--+-- A comment before the closing bracket of a flow collection belongs to the+-- end of the collection.+--+-- >>> input = "ports: [80, 443,\n  # a\n  ]\n"+--+-- >>> T.putStr input+-- ports: [80, 443,+--   # a+--   ]+--+-- >>> printComments input+-- root.ports (value) after: [Comment "a"]++-- $documents+-- The optional @---@ marker starts a document, and the optional @...@ marker+-- ends it. The lines above the directives or the @---@ marker belong to the+-- document. So do the comment on the line of the @...@ marker and the lines+-- below it. Without the markers, the root gets these lines.+--+-- A comment on the line of the @---@ marker belongs to the document, unless+-- the rule for comments at the end of a line gives it to a node.+--+-- >>> input = "# a\n--- # b\n# c\n\nentry: value\n\n# e\n...\n# f\n"+--+-- >>> T.putStr input+-- # a+-- --- # b+-- # c+-- <BLANKLINE>+-- entry: value+-- <BLANKLINE>+-- # e+-- ...+-- # f+--+-- >>> printComments input+-- document before: [Comment "a"]+-- document inline: "b"+-- root before: [Comment "c",EmptyLine]+-- root after: [EmptyLine,Comment "e"]+-- document after: [Comment "f"]+--+-- Between two documents, the first empty line below the @...@ marker ends+-- the lines of the first document. The empty line and the lines below it+-- belong to the second document: to the lines above its @---@ marker, or to+-- its root without the marker.+--+-- >>> input = "x: 1\n...\n# a\n\n# b\n---\ny: 2\n"+--+-- >>> T.putStr input+-- x: 1+-- ...+-- # a+-- <BLANKLINE>+-- # b+-- ---+-- y: 2+--+-- >>> printComments input+-- document after: [Comment "a"]+-- next document+-- document before: [EmptyLine,Comment "b"]+--+-- Without the @...@ marker, the first empty line below the root ends the+-- lines of the root in the same way.+--+-- >>> input = "x: 1\n# a\n\n# b\n---\ny: 2\n"+--+-- >>> T.putStr input+-- x: 1+-- # a+-- <BLANKLINE>+-- # b+-- ---+-- y: 2+--+-- >>> printComments input+-- root after: [Comment "a"]+-- next document+-- document before: [EmptyLine,Comment "b"]+--+-- The lines of a flow collection are between its brackets, so the lines+-- below a flow collection root belong to the document, also without the+-- @...@ marker.+--+-- >>> input = "[80, 443]\n# a\n"+--+-- >>> T.putStr input+-- [80, 443]+-- # a+--+-- >>> printComments input+-- document after: [Comment "a"]+--+-- The renderer writes the markers and the empty lines that these rules+-- need, so that the lines read back at the same places. One exception: the+-- empty lines at the end of a document can read back as the lines of the+-- next document.++-- $emptyLines+-- Empty lines go with the node below them, or with the end of the document.+-- Thus, if a program removes an entry, the gap below the entry stays.+--+-- >>> input = "server:\n  host: localhost\n  # The end of the server.\n\nuser: admin\n"+--+-- >>> T.putStr input+-- server:+--   host: localhost+--   # The end of the server.+-- <BLANKLINE>+-- user: admin+--+-- >>> printComments input+-- root.server (value) after: [Comment "The end of the server."]+-- root.user (key) before: [EmptyLine]+--+-- Empty lines above a comment go with the comment. Each empty line is a+-- line of its own.+--+-- >>> input = "host: localhost\n\n\n# The port.\nport: 80\n\nuser: admin\n"+--+-- >>> T.putStr input+-- host: localhost+-- <BLANKLINE>+-- <BLANKLINE>+-- # The port.+-- port: 80+-- <BLANKLINE>+-- user: admin+--+-- >>> printComments input+-- root.port (key) before: [EmptyLine,EmptyLine,Comment "The port."]+-- root.user (key) before: [EmptyLine]+--+-- One place is an exception. Above the first entry of a block collection,+-- the last empty line stays with the collection. If the lines of a block+-- collection do not end with an empty line, e.g. lines that a program added,+-- the renderer can write one below them, so that they read back as the lines+-- of the collection. The added empty line reads back as their last line.+--+-- >>> input = "# The file.\n\nhost: localhost\n"+--+-- >>> T.putStr input+-- # The file.+-- <BLANKLINE>+-- host: localhost+--+-- >>> printComments input+-- root before: [Comment "The file.",EmptyLine]++-- $setup+-- >>> import Data.Text.IO qualified as T+--+-- >>> :{+-- printComments :: T.Text -> IO ()+-- printComments input = either print docs (parseDocumentsText input)+--   where+--     docs :: [Document] -> IO ()+--     docs = \case+--       d : ds -> doc d >> mapM_ (\d' -> putStrLn "next document" >> doc d') ds+--       [] -> pure ()+--     doc :: Document -> IO ()+--     doc d = do+--       report "document" d.docComments {after = []}+--       node "root" "" d.root+--       report "document" noComments {after = d.docComments.after}+--     node :: String -> String -> Node -> IO ()+--     node path role n = do+--       report (path <> role) n.comments+--       case n.content of+--         SequenceContent _ items ->+--           sequence_+--             [ node (path <> "[" <> show i <> "]") "" item+--             | (i, item) <- zip [0 :: Int ..] items+--             ]+--         MappingContent _ entries ->+--           sequence_+--             [ node (path <> "." <> name k) " (key)" k+--                 >> node (path <> "." <> name k) " (value)" v+--             | (k, v) <- entries+--             ]+--         _ -> pure ()+--     name :: Node -> String+--     name k = case k.content of+--       ScalarContent _ t -> T.unpack t+--       _ -> "?"+--     report :: String -> Comments -> IO ()+--     report path c =+--       mapM_ putStrLn $+--         [path <> " before: " <> show c.before | not (null c.before)]+--           <> [path <> " inline: " <> show t | Just t <- [c.inline]]+--           <> [path <> " after: " <> show c.after | not (null c.after)]+-- :}
+ src/Yamlet/Value.hs view
@@ -0,0 +1,233 @@+-- | The values of YAML documents: the content with resolved tags, without the+-- styles, comments and positions of the syntax tree.+--+-- A 'Value' has t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml'+-- instances, e.g. to read a document whose structure a program does not+-- know:+--+-- >>> decodeText @Value "!point {x: 1, y: 2.5}\n"+-- Right (Tagged "!point" (Mapping [(String "x",Int 1),(String "y",Float (Finite 2.5))]))+--+-- An alias becomes a copy of the value that it refers to:+--+-- >>> decodeText @Value "base: &b [1, 2]\ncopy: *b\n"+-- Right (Mapping [(String "base",Sequence [Int 1,Int 2]),(String "copy",Sequence [Int 1,Int 2])])+--+-- A small input with many aliases can give a large value. To prevent this,+-- the decoder limits the aliases. Each node and each character of a scalar,+-- a tag or an anchor counts as one unit. The aliases can add 100000 units to+-- a document. For a document with more units, they can add as many units as+-- the document has.+-- The documents of a stream share the limit, as if they were one document.+-- A document beyond the limit is an error.+module Yamlet.Value+  ( -- * Values+    Value (..)+  , FloatValue (..)+  , floatValueToRealFloat+  , realFloatToFloatValue+  , describe++    -- * Tags+  , valueTag+  , nullTag+  , boolTag+  , intTag+  , floatTag+  , strTag+  , seqTag+  , mapTag+  ) where++import Control.DeepSeq+import Data.Scientific qualified as Sci+import Data.Text qualified as T+import GHC.Generics++import Yamlet.Internal.Utils++-- | The value of a node.+--+-- 'Eq' and 'Ord' compare the entries of mappings in order, so two mappings+-- with the same entries in a different order are not equal, unlike in YAML.+data Value+  = Null+  | Bool !Bool+  | Int !Integer+  | Float !FloatValue+  | String !T.Text+  | Sequence ![Value]+  | -- | The entries of a mapping in the order of the input. The keys are+    -- unique. The encoder does not check this for a mapping that a program+    -- builds, and a mapping with two equal keys does not read back. Keys are+    -- equal as in YAML, e.g. two mappings with the same entries in a+    -- different order are equal keys.+    Mapping ![(Value, Value)]+  | -- | A value with a tag that is not the tag of the core schema for it,+    -- e.g. @!point {x: 1}@. A scalar with a tag that the schema does not+    -- know is a v'String' inside, e.g. @!secret abc@.+    --+    -- The encoder writes the tag. Some values read back with a change:+    --+    -- * A value with its own tag of the core schema reads back without+    --   'Tagged', e.g. @Tagged intTag (Int 1)@ as @Int 1@.+    --+    -- * A value that does not fit a tag of the core schema does not read+    --   back, e.g. a v'String' with 'intTag'.+    --+    -- * A scalar other than a v'String' with a tag that the schema does not+    --   know reads back as a v'String', e.g. @Tagged "!x" (Int 5)@ as+    --   @Tagged "!x" (String "5")@.+    --+    -- * YAML has no syntax for the empty tag or a tag of one character, e.g.+    --   @x@ or @!@. The encoder drops such a tag, e.g. @Tagged "" (Int 1)@+    --   reads back as @Int 1@.+    --+    -- * A node has one tag, so the encoder writes only the outermost tag that+    --   it does not drop, e.g. @Tagged "!a" (Tagged "!b" (Sequence []))@+    --   reads back as @Tagged "!a" (Sequence [])@.+    Tagged !T.Text !Value+  deriving stock (Eq, Ord, Show, Generic)++-- The instances of the sum types are written by hand, because GHC does not+-- always remove the generic representation of a sum type. A strict field of+-- a type without lazy parts, e.g. a text, is already in normal form.+instance NFData Value where+  rnf = \case+    Null -> ()+    Bool _ -> ()+    Int _ -> ()+    Float _ -> ()+    String _ -> ()+    Sequence xs -> rnf xs+    Mapping kvs -> rnf kvs+    Tagged _ v -> rnf v++-- | The value of a floating-point number. A finite value is exact, e.g. @0.1@+-- is exactly one tenth.+--+-- Arithmetic on a t'Data.Scientific.Scientific' with a huge exponent, e.g.+-- @1e1000000000@, can use all memory. Convert a value from an untrusted input+-- with 'floatValueToRealFloat' or with the bounded conversions of+-- "Data.Scientific".+data FloatValue+  = -- | A finite value other than negative zero.+    --+    -- The encoder writes a value whose exponent in scientific notation is+    -- beyond the range from -1000 to 1000, e.g. @1.0e+1001@, but the decoder+    -- rejects it. The decoder never gives such a value, and a 'Double' is+    -- always in the range.+    Finite !Sci.Scientific+  | -- | Negative zero, e.g. @-0.0@, which a t'Data.Scientific.Scientific'+    -- cannot hold.+    NegativeZero+  | Infinity+  | NegativeInfinity+  | NaN+  deriving stock (Eq, Ord, Show, Generic)++instance NFData FloatValue where+  rnf = rwhnf++-- | The nearest value of a floating-point type, e.g. 'Double', infinite if+-- the value is out of its range. The decimal converts to the type directly,+-- so it is rounded once, e.g. a t'Float' does not go by way of a 'Double'.+--+-- >>> map (floatValueToRealFloat @Double) [Finite 0.1, Finite 1e400, NegativeZero]+-- [0.1,Infinity,-0.0]+floatValueToRealFloat :: RealFloat a => FloatValue -> a+floatValueToRealFloat = \case+  Finite s -> Sci.toRealFloat s+  NegativeZero -> -0+  Infinity -> 1 / 0+  NegativeInfinity -> -(1 / 0)+  NaN -> 0 / 0+-- With INLINEABLE, GHC specializes the function at the type of a caller in+-- another module, also the conversion of "Data.Scientific" inside it, as a+-- probe with a newtype of Double showed. The specializations are for the+-- types of the instances of the library. Without them, the decode benchmarks+-- of the config and the JSON input allocate more.+{-# INLINEABLE floatValueToRealFloat #-}+{-# SPECIALIZE floatValueToRealFloat :: FloatValue -> Double #-}+{-# SPECIALIZE floatValueToRealFloat :: FloatValue -> Float #-}++-- | The value of a floating-point number, e.g. a 'Double'. A finite number+-- becomes the shortest decimal that reads back as the same number, e.g.+-- @0.1@.+--+-- >>> map (realFloatToFloatValue @Double) [0.1, -0, 1 / 0]+-- [Finite 0.1,NegativeZero,Infinity]+realFloatToFloatValue :: RealFloat a => a -> FloatValue+realFloatToFloatValue d+  | isNaN d = NaN+  | isInfinite d = if d > 0 then Infinity else NegativeInfinity+  | isNegativeZero d = NegativeZero+  | otherwise = Finite (Sci.fromFloatDigits d)+-- As for 'floatValueToRealFloat'. Without the specializations, the encode+-- benchmarks of the config and the JSON input are slower and allocate more.+{-# INLINEABLE realFloatToFloatValue #-}+{-# SPECIALIZE realFloatToFloatValue :: Double -> FloatValue #-}+{-# SPECIALIZE realFloatToFloatValue :: Float -> FloatValue #-}++-- | The kind of a value in plain words, for error messages, e.g. "a list".+-- The tag of 'Tagged' does not change it.+--+-- >>> describe (Tagged "!point" (Mapping []))+-- "a mapping"+describe :: Value -> String+describe = \case+  Null -> "null"+  Bool _ -> "a boolean"+  Int _ -> "an integer"+  Float _ -> "a floating-point number"+  String _ -> "a string"+  Sequence _ -> "a list"+  Mapping _ -> "a mapping"+  Tagged _ v -> describe v++-- | The tag of a value: the tag of 'Tagged', or else the tag of the core+-- schema, e.g. 'intTag' for an v'Int'.+--+-- >>> map valueTag [Int 1, Tagged "!point" (Mapping [])]+-- ["tag:yaml.org,2002:int","!point"]+valueTag :: Value -> T.Text+valueTag = \case+  Null -> nullTag+  Bool _ -> boolTag+  Int _ -> intTag+  Float _ -> floatTag+  String _ -> strTag+  Sequence _ -> seqTag+  Mapping _ -> mapTag+  Tagged tag _ -> tag++-- | @tag:yaml.org,2002:null@.+nullTag :: T.Text+nullTag = coreTagPrefix <> "null"++-- | @tag:yaml.org,2002:bool@.+boolTag :: T.Text+boolTag = coreTagPrefix <> "bool"++-- | @tag:yaml.org,2002:int@.+intTag :: T.Text+intTag = coreTagPrefix <> "int"++-- | @tag:yaml.org,2002:float@.+floatTag :: T.Text+floatTag = coreTagPrefix <> "float"++-- | @tag:yaml.org,2002:str@.+strTag :: T.Text+strTag = coreTagPrefix <> "str"++-- | @tag:yaml.org,2002:seq@.+seqTag :: T.Text+seqTag = coreTagPrefix <> "seq"++-- | @tag:yaml.org,2002:map@.+mapTag :: T.Text+mapTag = coreTagPrefix <> "map"++-- $setup+-- >>> import Yamlet
+ tests/Main.hs view
@@ -0,0 +1,26 @@+module Main (main) where++import Test.Tasty++import Yamlet.Test.Decode+import Yamlet.Test.Encode+import Yamlet.Test.Generic+import Yamlet.Test.Inspection+import Yamlet.Test.Render+import Yamlet.Test.TypeError+import Yamlet.Test.YamlTestSuite++main :: IO ()+main = do+  suite <- testSuiteTests+  defaultMain $+    testGroup+      "yamlet"+      [ decodeTests+      , encodeTests+      , genericTests+      , inspectionTests+      , renderTests+      , typeErrorTests+      , suite+      ]
+ tests/Retention.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+-- Full laziness would float the input out of the action of a check into the+-- list of checks, which keeps it alive.+{-# OPTIONS_GHC -fno-full-laziness #-}++-- | The checks run without tasty. In a test of tasty, a major collection at+-- times kept the input of a decode alive although no value referred to it,+-- also after the value was dropped, and ghc-debug found no path from the+-- roots to the input.+module Main (main) where++import Control.Exception+import Control.Monad+import Data.Functor.Const+import Data.Functor.Identity+import Data.IORef+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Monoid qualified as Mon+import Data.Ord+import Data.Ratio+import Data.Semigroup qualified as Sem+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Array qualified as A+import Data.Text.Internal qualified as T+import Data.Text.Lazy qualified as TL+import Data.Time+import Data.Tree qualified as Tree+import GHC.Exts (mkWeakNoFinalizer#)+import GHC.Generics+import GHC.IO+import GHC.Weak+import System.Exit+import System.IO+import System.Mem++import Yamlet+import Yamlet.Test.Helpers.Thunks++-- | Run the checks, and fail if one of them fails.+main :: IO ()+main = do+  failures <- fmap catMaybes . forM checks $ \(Check name act) -> do+    result <- act+    putStrLn $ name ++ ": " ++ maybe "OK" (const "FAIL") result+    pure $ (\msg -> name ++ ": " ++ msg) <$> result+  unless (null failures) $ do+    mapM_ (hPutStrLn stderr) failures+    exitFailure++-- | A check with its name. The action returns the message of a failure.+data Check = Check String (IO (Maybe String))++-- | A decoded value does not keep the input alive, for every instance of the+-- library, and neither do the errors of a failed decode. A text that refers+-- to the input keeps all of it, e.g. a slice of it, or a thunk that would+-- copy a slice.+checks :: [Check]+checks =+  [ Check "input without a value" $ do+      input <- evaluate (T.copy "a")+      weak <- weakArray input+      performMajorGC+      kept <- isJust <$> deRefWeak weak+      pure $ if kept then Just "the check keeps the input alive" else Nothing+  , retains @T.Text "Text" "a"+  , retains @TL.Text "lazy Text" "a"+  , retains @String "String" "a"+  , retains @(Maybe T.Text) "Maybe" "a"+  , retains @[T.Text] "list" "- a\n- b"+  , retains @(NE.NonEmpty T.Text) "NonEmpty" "- a\n- b"+  , retains @(Seq.Seq T.Text) "Seq" "- a\n- b"+  , retains @(Set.Set T.Text) "Set" "- a\n- b"+  , retains @(Tree.Tree T.Text) "Tree" "[a, []]"+  , retains @(M.Map T.Text T.Text) "Map" "a: b"+  , retains @(M.Map T.Text [T.Text]) "Map of lists" "a: [b]"+  , retains @(IM.IntMap T.Text) "IntMap" "1: b"+  , retains @IS.IntSet "IntSet" "[1, 2]"+  , retains @(T.Text, T.Text) "pair" "[a, b]"+  , retains @(T.Text, T.Text, T.Text) "triple" "[a, b, c]"+  , retains @(T.Text, T.Text, T.Text, T.Text) "quadruple" "[a, b, c, d]"+  , retains @(Either T.Text Int) "Left" "Left: a"+  , retains @(Either Int T.Text) "Right" "Right: a"+  , retains @[Commented T.Text] "Commented" "- a # c"+  , retains @[Located T.Text] "Located" "- a"+  , retains @[Identity T.Text] "Identity" "- a"+  , retains @[Const T.Text ()] "Const" "- a"+  , retains @[Down T.Text] "Down" "- a"+  , retains @[Sem.Min T.Text] "Min" "- a"+  , retains @[Sem.Max T.Text] "Max" "- a"+  , retains @[Sem.First T.Text] "Semigroup First" "- a"+  , retains @[Sem.Last T.Text] "Semigroup Last" "- a"+  , retains @[Mon.First T.Text] "Monoid First" "- a"+  , retains @[Mon.Last T.Text] "Monoid Last" "- a"+  , retains @[Sem.Dual T.Text] "Dual" "- a"+  , retains @[Sem.Sum Int] "Sum" "- 1"+  , retains @[Sem.Product Int] "Product" "- 1"+  , retains @[Sem.All] "All" "- true"+  , retains @[Sem.Any] "Any" "- true"+  , retains @[Ratio Int] "Ratio" "- {numerator: 1, denominator: 2}"+  , retains @[()] "unit" "- []"+  , retains @[Ordering] "Ordering" "- LT"+  , retains @[Day] "Day" "- 2026-01-01"+  , retains @[Value] "Value" "- !x {a: !y b}"+  , retains @[Node] "Node" "- !x {a: &y b} # c"+  , retains @Keys "objectKeys" "a: 1\nb: 2"+  , retains @[Choice] "oneOf" "- small"+  , retains @[Fields] "field lookups" "- a: x\n  b: y\n  c: [z]"+  , retains @[Mode] "enumeration" "- Development"+  , retains @[Endpoint] "record" "- host: a\n  tags: [b]"+  , retains @[Endpoint] "record with a default" "- tags: [b]"+  , retains @[Wrapped] "newtype" "- a"+  , retains @[Shape] "tagged record" "- tag: Circle\n  label: a"+  , retains @[Shape] "tagged constructor without fields" "- tag: Dot"+  , retains @[Move] "tagged contents" "- tag: Named\n  contents: a"+  , retains @[Step] "flat contents" "- tag: Ahead\n  name: a"+  , retains @[Figure] "single field record" "- Round:\n    label: a"+  , retains @[Figure] "single field contents" "- Sign: a"+  , errorRetains @(M.Map T.Text T.Text) "error with a key in the path" "k: [1]"+  , errorRetains @(T.Text, M.Map T.Text T.Text)+      "error with an alias in the path"+      "- &a k\n- *a : [1]"+  , errorRetains @Closed "error with a key in the message" "title: a\nhots: 1"+  ]++-- | The array of the input is garbage while the value is alive. A weak+-- pointer tells, unlike the size of the heap.+retains :: forall a. FromYaml a => String -> T.Text -> Check+retains name doc = Check name $ do+  -- A copy, because the array of a literal is never garbage.+  input <- evaluate (T.copy doc)+  weak <- weakArray input+  case decodeText @a input of+    Left errs -> pure (Just (show errs))+    Right v -> do+      ref <- newIORef v+      performMajorGC+      kept <- isJust <$> deRefWeak weak+      failure <-+        if kept+          then Just <$> (keptAlive "the value" weak =<< readIORef ref)+          else pure Nothing+      _ <- evaluate =<< readIORef ref+      pure failure++-- | The array of the input is garbage while the errors of a failed decode+-- are alive.+errorRetains :: forall a. FromYaml a => String -> T.Text -> Check+errorRetains name doc = Check name $ do+  input <- evaluate (T.copy doc)+  weak <- weakArray input+  case decodeText @a input of+    Left errs -> do+      -- An error in weak head normal form has no thunks that keep the input.+      mapM_ evaluate errs+      ref <- newIORef errs+      performMajorGC+      kept <- isJust <$> deRefWeak weak+      failure <-+        if kept+          then Just <$> (keptAlive "the errors" weak =<< readIORef ref)+          else pure Nothing+      _ <- evaluate =<< readIORef ref+      pure failure+    Right _ -> pure (Just "the decode succeeded")++-- | The message for a value that keeps the input alive, with what tells a+-- leak from the state of the runtime: whether a second collection frees the+-- input while the value is still alive, and the thunks in the value. The+-- failure is rare, so the message has to tell all there is.+keptAlive :: String -> Weak () -> a -> IO String+keptAlive what weak x = do+  ts <- thunks x+  performMajorGC+  still <- isJust <$> deRefWeak weak+  _ <- evaluate x+  pure $+    what+      ++ " keeps the input alive; after a second collection, the input is "+      ++ (if still then "still alive" else "gone")+      ++ "; thunks in the value: "+      ++ (if null ts then "none" else L.intercalate ", " ts)++-- | A weak pointer to the array of the text. A slice of the text shares the+-- array, so the weak pointer is empty only if no text of the array is alive.+weakArray :: T.Text -> IO (Weak ())+weakArray (T.Text (A.ByteArray arr) _ _) = IO $ \s -> case mkWeakNoFinalizer# arr () s of+  (# s', w #) -> (# s', Weak w #)++data Mode = Development | Production+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml) via GenericYaml Mode++data Endpoint = Endpoint {host :: T.Text, tags :: [T.Text]}+  deriving stock (Generic)+  deriving (FromYaml) via GenericYaml Endpoint++instance GenericYamlOptions Endpoint where+  yamlDefault = Just (Endpoint "localhost" [])++newtype Wrapped = Wrapped T.Text+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml) via GenericYaml Wrapped++data Shape = Circle {label :: T.Text} | Dot+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml) via GenericYaml Shape++data Move = Named T.Text | Stop+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml) via GenericYaml Move++newtype Inner = Inner {name :: T.Text}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml) via GenericYaml Inner++data Step = Ahead Inner | Halt+  deriving stock (Generic)+  deriving (FromYaml) via GenericYaml Step++instance GenericYamlOptions Step where+  type SumEncoding Step = TaggedFlat++data Figure = Round {label :: T.Text} | Sign T.Text+  deriving stock (Generic)+  deriving (FromYaml) via GenericYaml Figure++instance GenericYamlOptions Figure where+  type SumEncoding Figure = SingleField++newtype Closed = Closed {title :: T.Text}+  deriving stock (Generic)+  deriving (FromYaml) via GenericYaml Closed++instance GenericYamlOptions Closed where+  yamlOptions = defaultYamlOptions {rejectUnknownFields = True}++newtype Keys = Keys [T.Text]++-- The list is lazy, and its unevaluated rest would keep the object.+instance FromYaml Keys where+  parseYaml = withMapping $ \o ->+    let keys = objectKeys o in length keys `seq` pure (Keys keys)++newtype Choice = Choice Int++instance FromYaml Choice where+  parseYaml = oneOf [("small", Choice 1), ("large", Choice 2)]++data Fields = Fields (Maybe T.Text) T.Text (Maybe [T.Text])++instance FromYaml Fields where+  parseYaml = withMapping $ \o ->+    Fields+      <$> parseFieldMaybe o "a"+      <*> parseFieldDefault o "b" "x"+      <*> parseFieldIfPresent o "c"
+ tests/Yamlet/Test/Decode.hs view
@@ -0,0 +1,22 @@+module Yamlet.Test.Decode (decodeTests) where++import Test.Tasty++import Yamlet.Test.Decode.Errors+import Yamlet.Test.Decode.Input+import Yamlet.Test.Decode.Limits+import Yamlet.Test.Decode.Scalars+import Yamlet.Test.Decode.SyntaxErrors+import Yamlet.Test.Decode.Values++decodeTests :: TestTree+decodeTests =+  testGroup+    "decode"+    [ scalarTests+    , valueTests+    , inputTests+    , limitTests+    , syntaxErrorTests+    , errorTests+    ]
+ tests/Yamlet/Test/Decode/Errors.hs view
@@ -0,0 +1,836 @@+module Yamlet.Test.Decode.Errors+  ( errorTests+  ) where++import Control.Monad+import Data.Bifunctor+import Data.ByteString qualified as BS+import Data.Fixed+import Data.Foldable+import Data.Int+import Data.IntSet qualified as IS+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Ratio+import Data.Scientific qualified as Sci+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time+import Data.UUID.Types qualified as UUID+import Data.Void+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding (Fixed)++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Decode.Helpers+import Yamlet.Test.Helpers++errorTests :: TestTree+errorTests =+  testGroup+    "errors"+    [ testCase "types" test_typeErrors+    , testCase "keys" test_keyErrors+    , testCase "collected" test_collectedErrors+    , testCase "pretty" test_prettyError+    , testCase "paths" test_errorPaths+    , testProperty "locations of several errors" prop_errorsAt+    , testCase "paths of several errors" test_nodePaths+    ]++-- | A value written as an empty mapping.+data EmptyDir = EmptyDir+  deriving stock (Eq, Show)++instance FromYaml EmptyDir where+  parseYaml = withMapping $ \o -> EmptyDir <$ rejectUnknownKeys [] o++newtype IntOrText = IntOrText (Either Integer T.Text)+  deriving stock (Eq, Show)++instance FromYaml IntOrText where+  parseYaml n =+    IntOrText+      <$> ((Left <$> withInt pure n) `orElse` (Right <$> withText pure n))++-- | A choice from a list that the program found empty.+newtype Profile = Profile Int+  deriving stock (Eq, Show)++instance FromYaml Profile where+  parseYaml = oneOf []++test_typeErrors :: Assertion+test_typeErrors = do+  assertEqual+    "first alternative"+    (Right (IntOrText (Left 1)))+    (decodeText "1")+  assertEqual+    "second alternative"+    (Right (IntOrText (Right "a")))+    (decodeText "a")+  assertEqual+    "error of the second alternative"+    (Just (1, 1, "expected a string, but got a boolean, quote the value, e.g. 'true'"))+    (errorOf (decodeText @IntOrText "true"))+  assertEqual+    "known name"+    (Right (Size 2))+    (decodeText "large")+  assertEqual+    "close name"+    (Just (1, 1, "unknown value \"lage\", did you mean \"large\"?"))+    (errorOf (decodeText @Size "lage"))+  assertEqual+    "other name"+    (Just (1, 1, "unknown value \"medium\", expected one of: small, large, 10"))+    (errorOf (decodeText @Size "medium"))+  assertEqual+    "plain name that is not a string"+    (Just (1, 1, "expected a string, but got an integer, quote the value, e.g. '10'"))+    (errorOf (decodeText @Size "10"))+  assertEqual+    "collection"+    (Just (1, 1, "expected one of: small, large, 10, but got a list"))+    (errorOf (decodeText @Size "[small]"))+  assertEqual+    "name without names"+    (Just (1, 1, "unknown value \"dev\", no value is accepted"))+    (errorOf (decodeText @Profile "dev"))+  assertEqual+    "collection without names"+    (Just (1, 1, "no value is accepted"))+    (errorOf (decodeText @Profile "[dev]"))+  assertEqual+    "pair"+    (Just (1, 1, "expected a list of 2 elements, but got 1"))+    (errorOf (decodeText @(Int, Int) "[1]"))+  assertEqual+    "triple"+    (Just (1, 1, "expected a list of 3 elements, but got 4"))+    (errorOf (decodeText @(Int, Int, Int) "[1, 2, 3, 4]"))+  assertEqual+    "unit from null"+    (Just (1, 1, "expected an empty list, but got null"))+    (errorOf (decodeText @() "null"))+  assertEqual+    "unit from a list with items"+    (Just (1, 1, "expected an empty list, but got a list"))+    (errorOf (decodeText @() "[1]"))+  assertEqual+    "second document"+    (Just (3, 1, "expected a single document, but got a second one"))+    (errorOf (decodeText @T.Text "a\n---\nb\n"))+  assertEqual+    "YAML 1.1 boolean"+    ( Just+        ( 1+        , 1+        , "expected a boolean, but got the string \"yes\", which is a boolean only in YAML 1.1, use true or false"+        )+    )+    (errorOf (decodeText @Bool "yes"))+  assertEqual+    "quoted YAML 1.1 boolean"+    (Just (1, 1, "expected a boolean, but got a string"))+    (errorOf (decodeText @Bool "'yes'"))+  assertEqual+    "YAML 1.1 boolean with a string tag"+    (Just (1, 7, "expected a boolean, but got a string"))+    (errorOf (decodeText @Bool "!!str yes"))+  assertEqual+    "YAML 1.1 boolean with a tag"+    ( Just+        ( 1+        , 11+        , "invalid value for the tag !!bool, \"off\" is a boolean only in YAML 1.1"+        )+    )+    (errorOf (decodeAllText @Value "a: !!bool off\n"))+  assertEqual+    "list instead of string"+    (Just (1, 7, "expected a string, but got a list"))+    (errorOf (decodeText @Config "name: [a]\n"))+  assertEqual+    "number instead of list"+    (Just (2, 8, "expected a list, but got an integer"))+    (errorOf (decodeText @Config "name: x\npaths: 42\n"))+  assertEqual+    "element of a list"+    (Just (2, 12, "expected a string, but got a boolean, quote the value, e.g. 'true'"))+    (errorOf (decodeText @Config "name: x\npaths: [a, true]\n"))+  assertEqual+    "float instead of string"+    ( Just+        ( 1+        , 1+        , "expected a string, but got a floating-point number, quote the value, e.g. '9.10'"+        )+    )+    (errorOf (decodeText @T.Text "9.10"))+  assertEqual+    "integer instead of string"+    (Just (1, 1, "expected a string, but got an integer, quote the value, e.g. '007'"))+    (errorOf (decodeText @T.Text "007"))+  assertEqual+    "empty value instead of string"+    (Just (1, 6, "expected a string, but got null"))+    (errorOf (decodeText @Config "name:\n"))+  assertEqual+    "null instead of string"+    (Just (1, 1, "expected a string, but got null, quote the value, e.g. 'null'"))+    (errorOf (decodeText @T.Text "null"))+  assertEqual+    "tilde instead of string"+    (Just (1, 1, "expected a string, but got null, quote the value, e.g. '~'"))+    (errorOf (decodeText @T.Text "~"))+  assertEqual+    "tagged integer instead of string"+    (Just (1, 7, "expected a string, but got an integer"))+    (errorOf (decodeText @T.Text "!!int 5"))+  assertEqual+    "out of range"+    (Just (1, 1, "the integer is out of the range from -128 to 127"))+    (errorOf (decodeText @Int8 "300"))+  assertEqual+    "custom failure"+    (Just (1, 5, "not a vowel"))+    (errorOf (decodeText @[Vowel] "[a, x]"))+  assertEqual+    "ordering"+    (Just (1, 1, "expected LT, EQ or GT"))+    (errorOf (decodeText @Ordering "lt"))+  assertEqual+    "uppercase UUID"+    (Right (UUID.fromWords 0x123e4567 0xe89b12d3 0xa4564266 0x14174000))+    (decodeText "123E4567-E89B-12D3-A456-426614174000")+  assertEqual+    "invalid UUID"+    (Just (1, 1, "expected a UUID such as 123e4567-e89b-12d3-a456-426614174000"))+    (errorOf (decodeText @UUID.UUID "123e4567e89b12d3a456426614174000"))+  assertEqual+    "void"+    (Just (1, 1, "the type Void has no values"))+    (errorOf (decodeText @Void "a"))+  assertEqual+    "zero denominator"+    (Just (1, 29, "the denominator is 0"))+    (errorOf (decodeText @Rational "{numerator: 1, denominator: 0}"))+  assertEqual+    "negative denominator"+    (Right (negate 1 % 2))+    (decodeText @Rational "{numerator: 2, denominator: -4}")+  assertEqual+    "negation of minBound"+    (Just (1, 1, "the fraction is out of the range of the type"))+    . errorOf+    $ decodeText @(Ratio Int) "{numerator: -9223372036854775808, denominator: -1}"+  assertEqual+    "minBound as the denominator"+    (Just (1, 1, "the fraction is out of the range of the type"))+    . errorOf+    $ decodeText @(Ratio Int) "{numerator: 1, denominator: -9223372036854775808}"+  assertEqual+    "minBound reduced"+    (Right (negate 4611686018427387904 % 1))+    (decodeText @(Ratio Int) "{numerator: -9223372036854775808, denominator: 2}")+  assertEqual+    "fixed from an integer"+    (Right 3)+    (decodeText @Centi "3")+  assertEqual+    "fixed with fewer digits"+    (Right 1.5)+    (decodeText @Centi "1.5")+  assertEqual+    "fixed with an exponent"+    (Right 120)+    (decodeText @Centi "1.2e2")+  assertEqual+    "fixed with too many digits"+    (Just (1, 1, "expected a multiple of 0.01"))+    (errorOf (decodeText @Centi "1.239"))+  assertEqual+    "fixed of whole numbers"+    (Just (1, 1, "expected a multiple of 1"))+    (errorOf (decodeText @Uni "1.5"))+  assertEqual+    "largest fixed"+    (Right (10 ^ (1000 :: Int)))+    (decodeText @Centi "1e1000")+  assertEqual+    "resolution of 2s and 5s"+    (Right (MkFixed 7))+    (decodeText @(Fixed Fortieths) "0.175")+  assertEqual+    "step of a resolution of 2s and 5s"+    (Just (1, 1, "expected a multiple of 0.025"))+    (errorOf (decodeText @(Fixed Fortieths) "0.01"))+  assertEqual+    "whole number for a resolution without a decimal form"+    (Right (MkFixed 6))+    (decodeText @(Fixed Thirds) "2")+  assertEqual+    "step of a resolution without a decimal form"+    (Just (1, 1, "expected a multiple of 1/3"))+    (errorOf (decodeText @(Fixed Thirds) "0.7"))+  assertEqual+    "fixed with a huge exponent"+    (Left "the exponent of the number is out of the range from -1000 to 1000")+    . first (snd . NE.head)+    $ runParser+      (parseYaml @Centi)+      (toYaml (Float (Finite (Sci.scientific 1 maxBound))))+  assertEqual+    "zero fixed with a huge exponent"+    (Right 0)+    (runParser (parseYaml @Centi) (toYaml (Float (Finite (Sci.scientific 0 maxBound)))))++newtype Vowel = Vowel Char++instance FromYaml Vowel where+  parseYaml = withText $ \t -> case T.unpack t of+    [c] | elem @[] c "aeiou" -> pure (Vowel c)+    _ -> fail "not a vowel"++-- | The applicative operators collect the errors of both parts, and '>>=' and+-- '>>' stop at the first error.+test_collectedErrors :: Assertion+test_collectedErrors = do+  assertEqual+    "fields"+    [ (1, 7, "expected a string, but got a list")+    , (2, 8, "expected a list, but got an integer")+    , (3, 7, "expected an integer, but got a string")+    ]+    (errorsOf (decodeText @Config "name: [x]\npaths: 1\njobs: x\n"))+  assertEqual+    "unknown keys"+    [ (2, 1, "unknown key \"job\", did you mean \"jobs\"?")+    , (3, 1, "unknown key \"bogus\", expected one of: name, paths, jobs")+    ]+    (errorsOf (decodeText @Config "name: x\njob: 1\nbogus: 2\n"))+  assertEqual+    "unknown keys that are not ASCII or do not print"+    [ (2, 1, "unknown key \"zażółć\", expected one of: name, paths, jobs")+    , (3, 1, "unknown key \"tab\\there\\x01\"")+    ]+    (errorsOf (decodeText @Config "name: x\nzażółć: 1\n\"tab\\there\\x01\": 2\n"))+  assertEqual+    "list of the known keys once"+    [ (2, 1, "unknown key \"foo\", expected one of: name, paths, jobs")+    , (3, 1, "unknown key \"bar\"")+    , (4, 1, "unknown key \"job\", did you mean \"jobs\"?")+    ]+    (errorsOf (decodeText @Config "name: x\nfoo: 1\nbar: 2\njob: 3\n"))+  assertEqual+    "no known keys"+    (Right EmptyDir)+    (decodeText @EmptyDir "{}")+  assertEqual+    "unknown keys without known keys"+    [(1, 1, "unknown key \"a\", the mapping must be empty"), (2, 1, "unknown key \"b\"")]+    (errorsOf (decodeText @EmptyDir "a: 1\nb: 2\n"))+  assertEqual+    "statement of a do block"+    [(2, 1, "unknown key \"bogus\", expected one of: name, paths, jobs")]+    (errorsOf (decodeText @Config "name: [x]\nbogus: 1\n"))+  assertEqual+    "items of a list"+    [ (1, 5, "expected an integer, but got a string")+    , (1, 11, "expected an integer, but got a string")+    ]+    (errorsOf (decodeText @[Int] "[1, x, 2, y]"))+  assertEqual+    "keys and values of a map"+    [ (1, 5, "expected an integer, but got a string")+    , (1, 8, "expected a string, but got an integer, quote the value, e.g. '1'")+    , (1, 17, "expected an integer, but got a string")+    ]+    (errorsOf (decodeText @(M.Map T.Text Int) "{a: x, 1: 2, b: y}"))+  assertEqual+    "fields of a fraction"+    [ (1, 12, "expected an integer, but got a string")+    , (2, 14, "expected an integer, but got a string")+    , (3, 1, "unknown key \"extra\", expected one of: numerator, denominator")+    ]+    (errorsOf (decodeText @Rational "numerator: x\ndenominator: y\nextra: 1\n"))+  assertEqual+    "fields of a calendar difference"+    [ (1, 9, "expected an integer, but got a string")+    , (2, 7, "expected an integer, but got a string")+    , (3, 1, "unknown key \"weeks\", expected one of: months, days")+    ]+    (errorsOf (decodeText @CalendarDiffDays "months: x\ndays: y\nweeks: 1\n"))+  assertEqual+    "duplicate keys of a map"+    [ (1, 8, "duplicate key 1.0 after conversion")+    , (1, 2, "the first key 1")+    , (1, 22, "duplicate key 2.0 after conversion")+    , (1, 16, "the first key 2")+    ]+    (errorsOf (decodeText @(M.Map Double T.Text) "{1: a, 1.0: b, 2: c, 2.0: d}"))+  assertEqual+    "duplicate elements of a set"+    [ (1, 5, "duplicate element 1.0")+    , (1, 2, "the first element 1")+    , (1, 13, "duplicate element 2.0")+    , (1, 10, "the first element 2")+    ]+    (errorsOf (decodeText @(Set.Set Double) "[1, 1.0, 2, 2.0]"))+  assertEqual+    "elements of a set"+    [ (1, 2, "expected a number, but got a string")+    , (1, 5, "expected a number, but got a string")+    ]+    (errorsOf (decodeText @(Set.Set Double) "[x, y]"))+  assertEqual+    "duplicate and invalid elements of a set"+    [ (1, 5, "duplicate element 1.0")+    , (1, 2, "the first element 1")+    , (1, 10, "expected a number, but got a string")+    ]+    (errorsOf (decodeText @(Set.Set Double) "[1, 1.0, x]"))+  assertEqual+    "duplicate and invalid elements of a set in a copy of an alias"+    [ (1, 11, "expected an integer, but got a string")+    , (1, 14, "duplicate element 1")+    , (1, 8, "the first element 1")+    , (2, 4, "expected an integer, but got a string")+    , (2, 4, "duplicate element 1")+    , (2, 4, "the first element 1")+    ]+    ( errorsOf+        (decodeText @(M.Map T.Text (Set.Set Int)) "a: &s [1, x, 1]\nb: *s\n")+    )+  assertEqual+    "duplicate elements of an int set"+    [ (1, 5, "duplicate element 0x1")+    , (1, 2, "the first element 1")+    , (1, 10, "duplicate element 1")+    , (1, 2, "the first element 1")+    ]+    (errorsOf (decodeText @IS.IntSet "[1, 0x1, 1]"))+  let count :: (S.Node -> Parser ()) -> Int+      count p =+        either+          (error . show)+          (either length (const 0) . runParser p)+          (decodeText @Node "[x, y]")+      item :: S.Node -> Parser Int+      item = parseNode parseYaml+      pair :: (Parser Int -> Parser Int -> Parser r) -> S.Node -> Parser ()+      pair op = withSequence $ \case+        [a, b] -> void (op (item a) (item b))+        _ -> fail "expected two items"+  assertEqual+    "traverse"+    2+    (count (withSequence (void . traverse item)))+  assertEqual+    "traverse_"+    2+    (count (withSequence (traverse_ item)))+  assertEqual+    "mapM_"+    1+    (count (withSequence (mapM_ item)))+  assertEqual+    "<*>"+    2+    (count (pair (\a b -> (,) <$> a <*> b)))+  assertEqual+    "*>"+    2+    (count (pair (*>)))+  assertEqual+    "<*"+    2+    (count (pair (<*)))+  assertEqual+    ">>"+    1+    (count (pair (>>)))+  assertEqual+    ">>="+    1+    (count (pair (\a b -> a >>= const b)))++test_keyErrors :: Assertion+test_keyErrors = do+  -- Every node of an alias has the offset of the alias, so an error at the+  -- value of a merge key cannot tell the value from the nodes inside it.+  let merged = "base: &b\n  x: 1\nc:\n  <<: *b\n"+  assertEqual+    "value of a merge key"+    (Just (4, 7, "expected an integer, but got a mapping"))+    (errorOf (decodeText @(M.Map T.Text (M.Map T.Text Int)) merged))+  assertEqual+    "unknown merge key"+    (Just (4, 3, "unknown key \"<<\", merge keys are not supported"))+    (errorOf (decodeText @[Config] "- &b\n  name: x\n  jobs: 2\n- <<: *b\n"))+  assertEqual+    "key missing next to a merge key"+    (Right (Left (pure (Offset 0, "missing key \"x\", merge keys are not supported"))))+    $ runParser (withMapping (\o -> parseField @Int o "x"))+      <$> decodeText @Node "<<: {x: 1}\n"+  assertEqual+    "two merge keys"+    ( Just+        ( (4, 3, "duplicate key \"<<\", merge keys are not supported")+        , (3, 3, "the first key \"<<\"")+        )+    )+    (errorWithNote (decodeAllText @Value "a: &a {x: 1}\nb:\n  <<: *a\n  <<: *a\n"))+  assertEqual+    "missing key"+    (Just (1, 1, "missing key \"name\""))+    (errorOf (decodeText @Config "jobs: 1\n"))+  assertEqual+    "unknown key"+    (Just (2, 1, "unknown key \"other\", expected one of: name, paths, jobs"))+    (errorOf (decodeText @Config "name: x\nother: 1\n"))+  assertEqual+    "key that is not a string"+    (Just (2, 1, "expected a string as the key, but got an integer"))+    (errorOf (decodeText @Config "name: x\n1: y\n"))+  assertEqual+    "unknown key close to a known one"+    (Just (2, 1, "unknown key \"job\", did you mean \"jobs\"?"))+    (errorOf (decodeText @Config "name: x\njob: 1\n"))+  let lookupError :: T.Text -> T.Text -> Maybe String+      lookupError key input =+        let parser = withMapping $ \o -> parseField @T.Text o key+        in case runParser parser <$> decodeText input of+             Right (Left ((_, msg) NE.:| [])) -> Just msg+             _ -> Nothing+  assertEqual+    "integer key"+    (Just "the key \"404\" is an integer, not a string")+    (lookupError "404" "200: ok\n404: not found\n")+  assertEqual+    "boolean key"+    (Just "the key \"true\" is a boolean, not a string")+    (lookupError "true" "true: 1\n")+  assertEqual+    "empty null key"+    (Just "the key \"\" is null, not a string")+    (lookupError "" "? \n: 1\n")+  assertEqual+    "string key that is missing"+    (Just "missing key \"a\"")+    (lookupError "a" "b: 1\n")+  let lookupResult :: T.Text -> T.Text -> Either [String] (Maybe Value)+      lookupResult key input =+        either (Left . map (.message) . toList) id $ do+          v <- decodeText input+          pure+            . first (map snd . toList)+            . runParser+              ( withMapping $ \o ->+                  rejectUnknownKeys [key] o *> (traverse parseYaml =<< lookupKey o key)+              )+            $ v+  assertEqual+    "lookup of a key"+    (Right (Just (String "not found")))+    (lookupResult "404" "'404': not found\n")+  assertEqual+    "lookup of a missing key"+    (Right Nothing)+    (lookupResult "404" "{}\n")+  assertEqual+    "lookup of a key that is not a string, with the unknown keys rejected"+    (Left ["the key \"404\" is an integer, not a string"])+    (lookupResult "404" "404: not found\n")+  let rejecting :: Node -> Parser (Maybe T.Text)+      rejecting = withMapping $ \o ->+        rejectUnknownKeys ["404"] o *> parseFieldMaybe o "404"+  assertEqual+    "keys that are not strings in a copy of an alias"+    ( Right+        ( Left+            [ "expected a string as the key, but got a boolean"+            , "the key \"404\" is an integer, not a string"+            ]+        )+    )+    ( first (map snd . toList)+        . runParser (withMapping $ \o -> parseFieldWith rejecting o "b")+        <$> decodeText "a: &m {404: x, true: y}\nb: *m\n"+    )+  assertEqual+    "key that is not a string with the value of the key"+    (Just "missing key \"3.10\"")+    (lookupError "3.10" "3.1: x\n")+  assertEqual+    "known key with the value of a key that is not a string"+    ( Right+        ( Left+            [ "expected a string as the key, but got a floating-point number"+            , "missing key \"3.10\""+            ]+        )+    )+    ( first (map snd . toList)+        . runParser+          (withMapping $ \o -> rejectUnknownKeys ["3.10"] o *> parseField @T.Text o "3.10")+        <$> decodeText "3.1: x\n"+    )+  let withKeys :: [T.Text] -> T.Text+      withKeys ks = T.unlines $ map (<> ": 1") ks+  assertEqual+    "duplicate key"+    (Just ((3, 1, "duplicate key \"a\""), (1, 1, "the first key \"a\"")))+    (errorWithNote (decodeAllText @Value "a: 1\nb: 2\na: 3\n"))+  assertEqual+    "duplicate key with another text"+    ( Just+        ( (2, 1, "duplicate key ~, the same value as the first key")+        , (1, 1, "the first key null")+        )+    )+    (errorWithNote (decodeAllText @Value "null: 1\n~: 2\n"))+  assertEqual+    "duplicate string key with a tag"+    (Just ((2, 4, "duplicate key \"1\""), (1, 4, "the first key \"1\"")))+    (errorWithNote (decodeAllText @Value "!t 1: a\n!t 1: b\n"))+  assertEqual+    "duplicate among many scalar keys"+    (Just ((21, 1, "duplicate key \"k1\""), (1, 1, "the first key \"k1\"")))+    . errorWithNote+    . decodeAllText @Value+    $ T.unlines [T.pack ("k" ++ show i ++ ": 1") | i <- [1 .. 20 :: Int] ++ [1]]+  assertEqual+    "duplicate scalar key after a collection key"+    (Just ((3, 1, "duplicate key \"a\""), (1, 1, "the first key \"a\"")))+    (errorWithNote (decodeAllText @Value (withKeys ["a", "[b]", "a"])))+  assertEqual+    "duplicate collection key"+    (Just ((2, 1, "duplicate key"), (1, 1, "the first key")))+    (errorWithNote (decodeAllText @Value (withKeys ["{c: [d]}", "{c: [d]}"])))+  assertEqual+    "duplicate mapping key in another order"+    (Just ((2, 1, "duplicate key"), (1, 1, "the first key")))+    (errorWithNote (decodeAllText @Value (withKeys ["{a: 1, b: 2}", "{b: 2, a: 1}"])))++-- | A decoder error has the path to its node.+test_errorPaths :: Assertion+test_errorPaths = do+  check+    "nested key"+    (Right "hlint.version")+    (decodeText @(M.Map T.Text (M.Map T.Text T.Text)) "hlint:\n  version: 1\n")+  check+    "indices"+    (Right "[1][1]")+    (decodeText @[[Int]] "- [1]\n- [2, x]\n")+  -- The mapping and its first key start at the same place.+  check+    "missing key"+    (Right "[1]")+    (decodeText @[Config] "- name: x\n- jobs: 2\n")+  check+    "unknown key"+    (Right "[0]")+    (decodeText @[Config] "- name: x\n  bogus: 1\n")+  check+    "key in quotes"+    (Right "\"a.b\".c")+    (decodeText @(M.Map T.Text (M.Map T.Text Int)) "\"a.b\":\n  c: x\n")+  check+    "key with escapes"+    (Right "\"a\\nb\\t\\\"\\x07\\u2028\\U000e0001\"")+    (decodeText @(M.Map T.Text Int) "\"a\\nb\\t\\\"\\a\\L\\U000E0001\": x\n")+  check+    "inside a key"+    (Right "a")+    (decodeText @(M.Map T.Text (M.Map [Int] Int)) "a:\n  ? [1, x]\n  : 1\n")+  check+    "inside a key at the root"+    (Right "")+    (decodeText @(M.Map (M.Map T.Text Int) Int) "? {port: x}\n: 1\n")+  check+    "in the value of a collection key"+    (Right "?[1]")+    (decodeText @(M.Map [Int] [Int]) "? [1, 2]\n: [3, y]\n")+  check+    "string key ?"+    (Right "\"?\"[1]")+    (decodeText @(M.Map T.Text [Int]) "'?': [3, y]\n")+  check+    "alias key"+    (Right "*a[1]")+    (decodeText @(M.Map Value [Int]) "m: [&a 1]\n*a : [3, y]\n")+  check+    "string key like an alias"+    (Right "\"*a\"[1]")+    (decodeText @(M.Map T.Text [Int]) "'*a': [3, y]\n")+  assertEqual+    "path elements"+    (Left [CollectionKey, Index 1])+    $ first+      (pathElements . (.path) . NE.head)+      (decodeText @(M.Map [Int] [Int]) "? [1, 2]\n: [3, y]\n")+  check+    "empty value at the end of its key"+    (Right "a")+    (decodeText @(M.Map T.Text Int) "{a}")+  check+    "empty value at the end of an explicit key"+    (Right "a")+    (decodeText @(M.Map T.Text Int) "? a")+  check+    "empty key"+    (Right "")+    (decodeText @(M.Map Int Int) ": 1\n")+  check+    "duplicate key"+    (Right "a")+    (decodeText @Value "a:\n  b: 1\n  b: 2\n")+  check+    "root"+    (Right "")+    (decodeText @Int "x")+  let key = S.plainNode "a"+  check+    "built node"+    (Right "")+    (decodeDocument @(M.Map T.Text Int) "" (S.document (S.mappingNode [(key, key)])))+  where+    check :: String -> Either String String -> Either (NE.NonEmpty Error) a -> Assertion+    check preface expected r =+      assertEqual+        preface+        expected+        (either (Right . renderPath . (.path) . NE.head) (const (Left "no error")) r)++-- | 'errorsAt' gives the errors of 'errorAt', also for several errors on one+-- line and for offsets in any order.+prop_errorsAt :: Property+prop_errorsAt =+  forAll (T.pack <$> listOf (elements "ab \n\r\xFEFF\x17C\x1F600")) $ \input ->+    forAll (listOf (choose (-1, BS.length (T.encodeUtf8 input) + 1))) $ \offs ->+      let errs = [(Offset o, show o) | o <- offs]+      in errorsAt input errs === map (uncurry (errorAt input)) errs++-- | 'nodePaths' gives the paths of 'nodePath' for every offset of a document.+test_nodePaths :: Assertion+test_nodePaths = do+  let input = "a:\n  - [b, {c: d}]\n  - ? [e]\n    : f\nb: &x {g: h}\nc: *x\n"+  case S.parseDocumentsText input of+    Right [doc] -> do+      let offs = map Offset [-1 .. T.length input + 1]+      assertEqual+        "in order"+        (map (`nodePath` doc.root) offs)+        (nodePaths offs doc.root)+      assertEqual+        "in reverse"+        (map (`nodePath` doc.root) (reverse offs))+        (nodePaths (reverse offs) doc.root)+    r -> assertFailure (show r)++test_prettyError :: Assertion+test_prettyError = do+  case decodeText @Config "name: x\npaths: 42\n" of+    Left errs ->+      assertEqual+        "rendered"+        [expected]+        (map (prettyError "config.yaml") (NE.toList errs))+    Right _ -> assertFailure "expected an error"+  let longLine = "a: " <> T.replicate 100 "x" <> ": " <> T.replicate 100 "y" <> "\n"+  case decodeAllText @Value longLine of+    Left errs ->+      assertEqual+        "long line"+        [expectedLong]+        (map (prettyError "long.yaml") (NE.toList errs))+    Right _ -> assertFailure "expected an error"+  forM_ ([0 .. 90] ++ [160, 161, 170]) $ \n -> do+    let input = "\xFEFFk\n\xFEFF" <> T.pack (take n (cycle "aé\t€\x1F600")) <> "\r\nz"+        starts =+          [ i+          | (i, w) <- zip [0 ..] (BS.unpack (T.encodeUtf8 input))+          , w < 0x80 || w >= 0xC0+          ]+    forM_ starts $ \i -> do+      let err = errorAt input (Offset i) "m"+      assertEqual+        ("excerpt of a line of " ++ show n ++ " characters at " ++ show i)+        (excerpt err)+        (drop 1 (lines (prettyError "f" err)))+  case decodeText @(M.Map T.Text Int) "e\x301\&e\x301: x\n" of+    Left errs ->+      assertEqual+        "caret after combining marks"+        [["  | " ++ replicate 4 ' ' ++ "^"]]+        (map (drop 3 . lines . prettyError "f") (NE.toList errs))+    Right _ -> assertFailure "expected an error"+  case decodeText @Value "a: \"\ESC[2J\x7F\"\n" of+    Left errs ->+      assertEqual+        "C0 control character and DEL"+        [["1 | a: \"\x241B[2J\x2421\"", "  | " ++ replicate 4 ' ' ++ "^"]]+        (map (drop 2 . lines . prettyError "f") (NE.toList errs))+    Right _ -> assertFailure "expected an error"+  case decodeText @(M.Map T.Text Int) "k: a\x85\&b\n" of+    Left errs ->+      assertEqual+        "C1 control character"+        [["1 | k: a\xFFFD\&b", "  | " ++ replicate 3 ' ' ++ "^"]]+        (map (drop 2 . lines . prettyError "f") (NE.toList errs))+    Right _ -> assertFailure "expected an error"+  where+    -- The excerpt and the caret from a scan of the whole line.+    excerpt :: Error -> [String]+    excerpt err =+      [ "  |"+      , show err.location.line ++ " | " ++ shown+      , "  | " ++ map (\c -> if c == '\t' then '\t' else ' ') (take before shown) ++ "^"+      ]+      where+        full :: String+        full = T.unpack err.sourceLine++        start :: Int+        start = max 0 (min (err.location.column - 1 - 40) (length full - 80))++        shown :: String+        shown+          | length full <= 80 = full+          | otherwise =+              (if start > 0 then "..." else "")+                ++ take 80 (drop start full)+                ++ (if start + 80 < length full then "..." else "")++        before :: Int+        before+          | length full <= 80 = err.location.column - 1+          | otherwise = (if start > 0 then 3 else 0) + err.location.column - 1 - start++    expectedLong :: String+    expectedLong =+      L.intercalate+        "\n"+        [ "long.yaml:1:104: unexpected ':', quote the value if it contains \": \""+        , "  |"+        , "1 | ..." ++ replicate 40 'x' ++ ": " ++ replicate 38 'y' ++ "..."+        , "  | " ++ replicate 43 ' ' ++ "^"+        ]++    expected :: String+    expected =+      L.intercalate+        "\n"+        [ "config.yaml:2:8: paths: expected a list, but got an integer"+        , "  |"+        , "2 | paths: 42"+        , "  |        ^"+        ]
+ tests/Yamlet/Test/Decode/Helpers.hs view
@@ -0,0 +1,43 @@+-- | The helpers that several decoder test modules use.+module Yamlet.Test.Decode.Helpers+  ( Config (..)+  , Size (..)+  , errorWithNote+  ) where++import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T++import Yamlet+import Yamlet.Test.Helpers++data Config = Config+  { name :: T.Text+  , paths :: [FilePath]+  , jobs :: Int+  }+  deriving stock (Eq, Show)++instance FromYaml Config where+  parseYaml = withMapping $ \o -> do+    rejectUnknownKeys ["name", "paths", "jobs"] o+    Config+      <$> parseField o "name"+      <*> parseFieldDefault o "paths" []+      <*> parseFieldDefault o "jobs" 1++-- | The line, the column and the message of the only error and of its note.+errorWithNote+  :: Either (NE.NonEmpty Error) a -> Maybe ((Int, Int, String), (Int, Int, String))+errorWithNote = \case+  Left (err NE.:| [note]) -> Just (errorPlace err, errorPlace note)+  Left errs ->+    error $+      "expected an error and a note, but got " ++ show (map (.message) (NE.toList errs))+  Right _ -> Nothing++newtype Size = Size Int+  deriving stock (Eq, Show)++instance FromYaml Size where+  parseYaml = oneOf [("small", Size 1), ("large", Size 2), ("10", Size 10)]
+ tests/Yamlet/Test/Decode/Input.hs view
@@ -0,0 +1,412 @@+-- | The bytes before parsing: the Unicode encodings, byte order marks, an+-- empty stream, and the file functions.+module Yamlet.Test.Decode.Input+  ( inputTests+  ) where++import Control.Exception+import Data.Bifunctor+import Data.ByteString qualified as BS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import System.Directory+import System.IO+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Helpers++inputTests :: TestTree+inputTests =+  testGroup+    "input"+    [ testCase "empty stream" test_emptyStream+    , testCase "encodings" test_encodings+    , testCase "byte order marks" test_byteOrderMarks+    , testCase "files" test_files+    ]++-- | The file functions write UTF-8 and read back what they wrote.+test_files :: Assertion+test_files = do+  dir <- getTemporaryDirectory+  (path, h) <- openTempFile dir "yamlet.yaml"+  hClose h+  flip finally (removeFile path) $ do+    let value = M.fromList @T.Text @T.Text [("name", "zażółć")]+    encodeFile path value+    bytes <- BS.readFile path+    assertEqual+      "UTF-8"+      (T.encodeUtf8 "name: zażółć\n")+      bytes+    decoded <- decodeFile path+    assertEqual+      "document"+      (Right value)+      decoded+    encodeAllFile @Int path [1, 2]+    documents <- decodeAllFile @Int path+    assertEqual+      "documents"+      (Right [1, 2])+      documents++test_emptyStream :: Assertion+test_emptyStream = do+  assertEqual+    "null"+    (Right Nothing)+    (decodeText @(Maybe Int) "# nothing\n")+  assertEqual+    "all"+    (Right [])+    (decodeAllText @Int "")++test_encodings :: Assertion+test_encodings = do+  let text = "key: zażółć \x1F600\n" :: T.Text+  assertEqual+    "UTF-8 with BOM"+    (Right text)+    (decodeInput ("\xEF\xBB\xBF" <> T.encodeUtf8 text) >>= stripBom)+  assertEqual+    "UTF-16LE"+    (Right text)+    (decodeInput (T.encodeUtf16LE text))+  assertEqual+    "UTF-16BE"+    (Right text)+    (decodeInput (T.encodeUtf16BE text))+  assertEqual+    "UTF-32LE"+    (Right text)+    (decodeInput (T.encodeUtf32LE text))+  assertEqual+    "UTF-32BE"+    (Right text)+    (decodeInput (T.encodeUtf32BE text))+  case decodeInput "a: b\n\xFF\n" of+    Left err ->+      assertEqual+        "invalid UTF-8"+        (2, 1)+        (err.location.line, err.location.column)+    Right _ -> assertFailure "expected an error"+  let stream = "a: 1\n---\n- b\n" :: T.Text+  case S.parseDocumentsText stream of+    Right docs -> do+      assertEqual+        "documents of the stream"+        2+        (length docs)+      assertEqual+        "documents parsed from UTF-16LE"+        (Right docs)+        (S.parseDocuments (T.encodeUtf16LE stream))+    Left err -> assertFailure (show err)+  case S.parseDocuments "a: b\n\xFF\n" of+    Left err ->+      assertEqual+        "documents parsed from invalid UTF-8"+        (2, 1, "invalid UTF-8")+        (err.location.line, err.location.column, err.message)+    Right _ -> assertFailure "expected an error"+  let invalid :: String -> T.Text -> BS.ByteString -> Assertion+      invalid preface msg bytes =+        assertEqual+          preface+          (Just (2, 3, T.unpack msg))+          (errorOf (first pure (decodeInput bytes)))+  invalid+    "lone surrogate in UTF-16LE"+    "invalid UTF-16"+    (T.encodeUtf16LE "a\nbc" <> "\x00\xD8" <> "d\0")+  invalid+    "odd length of UTF-16BE"+    "invalid UTF-16"+    (T.encodeUtf16BE "a\nbc" <> "\0")+  invalid+    "surrogate in UTF-32BE"+    "invalid UTF-32"+    (T.encodeUtf32BE "a\nbc" <> "\0\0\xDC\0")+  invalid+    "code point beyond Unicode in UTF-32LE"+    "invalid UTF-32"+    (T.encodeUtf32LE "a\nbc" <> "\0\0\x11\0")+  invalid+    "incomplete character in UTF-8"+    "invalid UTF-8"+    ("a\nbc" <> "\xE2\x82")+  invalid+    "surrogate in UTF-8"+    "invalid UTF-8"+    ("a\nbc" <> "\xED\xA0\x80" <> "d")+  let column :: String -> Int -> BS.ByteString -> Assertion+      column preface expected bytes =+        assertEqual+          preface+          (Just expected)+          ((\(_, c, _) -> c) <$> errorOf (decode @Value bytes))+  column+    "error after a UTF-8 BOM"+    1+    "\xEF\xBB\xBF]"+  column+    "error after a UTF-16 BOM"+    1+    "\xFF\xFE]\0"+  column+    "invalid UTF-8 after a BOM"+    2+    "\xEF\xBB\xBF\&b\xFF"+  column+    "error after a BOM between documents"+    1+    "a\n...\n\xEF\xBB\xBF]"+  column+    "error after two BOMs"+    1+    "\xEF\xBB\xBF\xEF\xBB\xBF]"+  column+    "error after two BOMs before a marker"+    5+    "a\n\xEF\xBB\xBF\xEF\xBB\xBF--- ]"+  let errorAfterBom :: String -> (Int, Int, String) -> T.Text -> Assertion+      errorAfterBom preface expected input =+        assertEqual+          preface+          (Just expected)+          (errorOf (decodeAllText @Value input))+  errorAfterBom+    "error after a BOM after an end marker"+    (3, 5, "unexpected ':', quote the value if it contains \": \"")+    "a\n...\n\xFEFF\&b: x: y\n"+  errorAfterBom+    "error after a BOM and a comment after an end marker"+    (4, 4, "unterminated flow sequence")+    "a\n...\n\xFEFF# c\n\xFEFF\&b: [\n"+  errorAfterBom+    "error after a second BOM at the start"+    (1, 4, "unterminated flow sequence")+    "\xFEFF\xFEFF\&a: [\n"+  errorAfterBom+    "BOM at the end of a line"+    (1, 6, "unexpected byte order mark")+    "key: \xFEFF\n  sub: x\n"+  errorAfterBom+    "BOM at the end of a line in a flow sequence"+    (1, 2, "unexpected byte order mark")+    "[\xFEFF\nfoo: bar\n]\n"+  errorAfterBom+    "mapping after a BOM and a marker"+    (3, 6, "unexpected ':', a mapping cannot start on the line of '---'")+    "a\n...\n\xFEFF--- c: d\n"+  errorAfterBom+    "list after a BOM and a marker"+    (3, 5, "unexpected '-', a list cannot start on the line of '---'")+    "a\n...\n\xFEFF--- - c\n"+  errorAfterBom+    "tab below a BOM and a comment"+    (2, 2, "unexpected '%', a plain scalar cannot start with it, quote the value")+    "\xFEFF# c\n\t%x\n"+  assertEqual+    "source line after a BOM"+    (Left "]")+    $ either+      (Left . (.sourceLine) . NE.head)+      (const (Right ()))+      (decode @Value "\xEF\xBB\xBF]")+  assertEqual+    "source line at the line feed of a CRLF"+    "a: 1"+    (errorAt "a: 1\r\nb: 2\n" (Offset 5) "message").sourceLine+  where+    stripBom :: T.Text -> Either Error T.Text+    stripBom = Right . T.dropWhile (== '\xFEFF')++test_byteOrderMarks :: Assertion+test_byteOrderMarks = do+  let documents :: String -> [T.Text] -> T.Text -> Assertion+      documents preface expected input =+        assertEqual+          preface+          (Right expected)+          (decodeAllText input)+  documents+    "BOM before a marker after a scalar"+    ["a", "b"]+    "a\n\xFEFF--- b\n"+  assertEqual+    "BOM before a marker after a mapping"+    (Right [Mapping [(String "a", Int 1)], String "b"])+    (decodeAllText @Value "a: 1\n\xFEFF--- b\n")+  documents+    "BOM after an end marker"+    ["a", "b"]+    "a\n...\n\xFEFF# c\n\xFEFF\&b\n"+  documents+    "BOM in a quoted scalar"+    ["a\xFEFF", "b\xFEFF"]+    "--- \"a\xFEFF\"\n--- 'b\xFEFF'\n"+  assertEqual+    "error after a BOM in a quoted scalar"+    (Just (2, 1, "invalid escape sequence, write \\\\ for a backslash or use single quotes"))+    (errorOf (decodeAllText @Value "\"a\n\xFEFF\\q\"\n"))+  assertEqual+    "error below a BOM that starts a document"+    (Just (4, 1, "unexpected key among list items"))+    (errorOf (decodeAllText @Value "x\n...\n\xFEFF- a\nb: c\n"))+  let bom :: String -> (Int, Int) -> T.Text -> Assertion+      bom preface (l, c) input =+        assertEqual+          preface+          (Just (l, c, "unexpected byte order mark"))+          (errorOf (decodeAllText @Value input))+  bom+    "BOM at the start of a key"+    (2, 1)+    "a: 1\n\xFEFF b: 2\n"+  bom+    "BOM at the start of a value"+    (1, 6)+    "key: \xFEFFvalue\n"+  bom+    "BOM in a plain scalar"+    (1, 5)+    "a: x\xFEFFy\n"+  bom+    "BOM in a block scalar"+    (2, 3)+    "a: |\n  \xFEFFx\n"+  bom+    "BOM before a key"+    (2, 1)+    "a: b\n\xFEFF\&c: d\n"+  bom+    "BOM before a list item"+    (2, 1)+    "- a\n\xFEFF- b\n"+  bom+    "BOM before an indented value"+    (2, 1)+    "a:\n\xFEFF  b\n"+  assertEqual+    "BOM before a comment after a mapping"+    (Right [Mapping [(String "a", String "b")]])+    (decodeAllText @Value "a: b\n\xFEFF#c\n")+  documents+    "BOM before a comment after a scalar"+    ["a"]+    "a\n\xFEFF# c\n"+  documents+    "BOM at the end after a scalar"+    ["a"]+    "a\n\xFEFF"+  assertEqual+    "BOM at the end after a marker"+    (Right [Null])+    (decodeAllText @Value "---\n\xFEFF")+  bom+    "BOM before a scalar after a scalar"+    (2, 1)+    "a\n\xFEFF\&b\n"+  bom+    "BOM in a flow sequence"+    (2, 1)+    "a: [x,\n\xFEFF y]\n"+  bom+    "BOM in a flow mapping"+    (2, 1)+    "a: {x: 1,\n\xFEFF\&y: 2}\n"+  bom+    "BOM before a closing bracket"+    (2, 1)+    "a: [x,\n\xFEFF]\n"+  bom+    "BOM before a comment inside a mapping"+    (2, 1)+    "a: 1\n\xFEFF# c\nb: 2\n"+  bom+    "BOM on an empty line inside a mapping"+    (2, 1)+    "a: 1\n\xFEFF\nb: 2\n"+  bom+    "BOM before a comment inside a list"+    (3, 1)+    "a:\n  - 1\n\xFEFF  # c\n  - 2\n"+  bom+    "second BOM line inside a mapping"+    (3, 1)+    "a: 1\n# c\n\xFEFF# d\n\xFEFF\nb: 2\n"+  let errorAfter :: String -> (Int, Int, String) -> T.Text -> Assertion+      errorAfter preface expected input =+        assertEqual+          preface+          (Just expected)+          (errorOf (decodeAllText @Value input))+  errorAfter+    "error after a BOM in a double-quoted scalar"+    (2, 4, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "\"x\n\xFEFFy\" @\n"+  errorAfter+    "error after a BOM in a single-quoted scalar"+    (2, 4, "unexpected 'z' after the end of a quoted scalar")+    "'x\n\xFEFFy' z\n"+  errorAfter+    "error after a BOM in a flow sequence"+    (2, 5, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "[\"x\n\xFEFFy\", @]\n"+  assertEqual+    "BOM before a marker after an unterminated flow sequence"+    (Just (1, 4, "unterminated flow sequence"))+    (errorOf (decodeAllText @Value "a: [x,\n\xFEFF---\nb\n"))+  documents+    "BOM before a start marker in a double-quoted scalar"+    ["a \xFEFF--- "]+    "\"a\n\xFEFF---\n\"\n"+  documents+    "BOM before an end marker in a single-quoted scalar"+    ["a \xFEFF... b"]+    "'a\n\xFEFF... b'\n"+  documents+    "two BOMs before a marker"+    ["a", "b"]+    "a\n\xFEFF\xFEFF--- b\n"+  documents+    "two BOMs before a marker after an end marker"+    ["a", "b"]+    "--- a\n...\n\xFEFF\xFEFF--- b\n"+  documents+    "two BOMs before a marker after a block scalar"+    ["x\n", "b"]+    "--- |\n x\n\xFEFF\xFEFF--- b\n"+  documents+    "BOM before a marker after a literal at the top level"+    ["x\n", "b"]+    "--- |\nx\n\xFEFF--- b\n"+  documents+    "BOM before a marker after a folded at the top level"+    ["x y\n", "b"]+    "--- >\nx\ny\n\xFEFF--- b\n"+  documents+    "BOM before a comment after a literal at the top level"+    ["x\n"]+    "--- |\nx\n\xFEFF# c\n"+  documents+    "BOM before a marker as the first line of a literal"+    ["", "b"]+    "--- |\n\xFEFF--- b\n"+  -- The time to check a run of BOMs is linear in its length.+  documents+    "many BOMs at the start"+    ["a"]+    (T.replicate 400000 "\xFEFF" <> "a\n")+  documents+    "many BOMs after an end marker"+    ["a", "b"]+    ("a\n...\n" <> T.replicate 400000 "\xFEFF" <> "b\n")
+ tests/Yamlet/Test/Decode/Limits.hs view
@@ -0,0 +1,492 @@+-- | Large inputs: deep nesting, many keys or errors, long scalars, and the+-- expansion of aliases and tag prefixes. Decoding stays linear in the size of+-- the input, or a limit stops it.+module Yamlet.Test.Decode.Limits+  ( limitTests+  ) where++import Data.Either+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Ratio+import Data.Scientific qualified as Sci+import Data.Set qualified as Set+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Decode.Helpers+import Yamlet.Test.Helpers++limitTests :: TestTree+limitTests =+  testGroup+    "limits"+    [ slow $ testCase "nesting" test_nesting+    , slow $ testCase "many keys" test_manyKeys+    , slow $ testCase "nested duplicates" test_nestedDuplicates+    , slow $ testCase "alias keys" test_aliasKeys+    , slow $ testCase "alias limit" test_aliasLimit+    , testCase "tag prefix limit" test_tagPrefixLimit+    , slow $ testCase "long numbers" test_longNumbers+    , -- 0.2 s with the check of the lengths, 8 s without it.+      localOption (mkTimeout 2000000) $+        testCase "long unknown names" test_longUnknownNames+    , slow $ testCase "many errors" test_manyErrors+    , slow $ testCase "deep errors" test_deepErrors+    ]++-- | The time to parse nested flow sequences is linear in the depth.+test_nesting :: Assertion+test_nesting = do+  let nested :: Int -> T.Text -> T.Text+      nested d t = T.replicate d "[" <> t <> T.replicate d "]"+      depth :: Value -> Int+      depth = \case+        Sequence [x] -> 1 + depth x+        Mapping [(k, _)] -> depth k+        _ -> 0+  assertEqual+    "sequences"+    (Right 100000)+    (depth <$> decodeText (nested 100000 "x"))+  assertEqual+    "key"+    (Right 101)+    (depth <$> decodeText ("[" <> nested 100 "x" <> ": y]"))+  assertBool "key on two lines" (isLeft (decodeText @Value "[[a,\n b]: c]"))+  -- A flow sequence at the start of a line is first tried as a key.+  assertEqual+    "on two lines"+    (Right 40)+    (depth <$> decodeText (nested 40 "x\n"))+  assertEqual+    "block sequences on a long line"+    (Right 40000)+    (depth <$> decodeText (T.replicate 40000 "- " <> T.replicate 1000000 "x"))+  assertEqual+    "block sequences on a line with a comment below"+    (Right 200000)+    (depth <$> decodeText (T.replicate 200000 "- " <> "x\n\n# c\n"))+  assertEqual+    "block sequences on an indented line with a comment above"+    (Right 400000)+    $ depth+      <$> decodeText+        ("# c\n" <> T.replicate 400000 " " <> T.replicate 400000 "- " <> "x\n")+  assertEqual+    "block sequences with empty lines below"+    (Right 20000)+    (depth <$> decodeText (T.replicate 20000 "- " <> "x\n" <> T.replicate 20000 "\n"))+  assertEqual+    "flow sequences with empty lines inside"+    (Right 20000)+    (depth <$> decodeText (nested 20000 ("x" <> T.replicate 20000 "\n")))++-- | The check for duplicate keys compares keys with aliases correctly.+test_aliasKeys :: Assertion+test_aliasKeys = do+  let check+        :: String+        -> Maybe ((Int, Int, String), (Int, Int, String))+        -> T.Text+        -> Assertion+      check preface expected keys =+        assertEqual+          preface+          expected+          (errorWithNote (decodeAllText @Value (laughs 3 <> keys)))+  check+    "different keys"+    Nothing+    "? *a3\n: 1\n? [*a2, 1]\n: 2\n? [*a2, 2]\n: 3\n"+  check+    "duplicate key"+    (Just ((7, 3, "duplicate key"), (5, 3, "the first key")))+    "? [*a3, 1]\n: 1\n? [*a3, 1]\n: 2\n"+  check+    "duplicate alias key"+    (Just ((7, 3, "duplicate key *a3"), (5, 3, "the first key *a3")))+    "? *a3\n: 1\n? *a3\n: 2\n"+  -- Keys from two separate chains of anchors are equal only after an+  -- expansion to 2^12 items.+  let chains :: T.Text -> T.Text -> T.Text+      chains x y =+        T.unlines $+          ["- &a0 [" <> x <> "]", "- &b0 [" <> y <> "]"]+            ++ [ T.pack+                   ("- &" ++ c : show i ++ " [*" ++ c : show (i - 1) ++ ", *" ++ c : show (i - 1) ++ "]")+               | i <- [1 .. 12 :: Int]+               , c <- "ab"+               ]+            ++ ["- ? *a12", "  : 1", "  ? *b12", "  : 2"]+  assertEqual+    "equal chains"+    ( Just+        ( (29, 5, "duplicate key *b12, the same value as the first key")+        , (27, 5, "the first key *a12")+        )+    )+    (errorWithNote (decodeAllText @Value (chains "x" "x")))+  assertEqual+    "different chains"+    Nothing+    (errorWithNote (decodeAllText @Value (chains "x" "y")))++-- | Aliases can add 100000 visits to a traversal of a small document, and as+-- many visits as the document has to a large one. Each node and each+-- character of its scalar, tag and anchor is a visit.+test_aliasLimit :: Assertion+test_aliasLimit = do+  assertEqual+    "small expansion"+    Nothing+    (errorOf (decodeAllText @Value (laughs 3)))+  assertEqual+    "exponential expansion"+    (Just (5, 25, "the aliases add more than 100000 nodes and characters"))+    (errorOf (decodeAllText @Value (laughs 9)))+  let items = T.intercalate ", " (replicate 200000 "x")+      copies :: Int -> T.Text+      copies k = T.unlines ("- &a [" <> items <> "]" : replicate k "- *a")+  assertEqual+    "large document with one copy"+    Nothing+    (errorOf (decodeAllText @Value (copies 1)))+  assertEqual+    "large document with two copies"+    (Just (3, 3, "the aliases add more than 400005 nodes and characters"))+    (errorOf (decodeAllText @Value (copies 2)))+  let long = T.replicate 100000 "x"+      textCopies :: Int -> T.Text+      textCopies k = T.unlines ("- &a " <> long : replicate k "- *a")+  assertEqual+    "long scalar with one copy"+    Nothing+    (errorOf (decodeAllText @Value (textCopies 1)))+  assertEqual+    "long scalar with many copies"+    (Just (3, 3, "the aliases add more than 101003 nodes and characters"))+    (errorOf (decodeAllText @Value (textCopies 1000)))+  let tagCopies :: Int -> T.Text+      tagCopies k = T.unlines ("- &a !" <> long <> " x" : replicate k "- *a")+  assertEqual+    "long tag with one copy"+    Nothing+    (errorOf (decodeAllText @Value (tagCopies 1)))+  assertEqual+    "long tag with many copies"+    (Just (3, 3, "the aliases add more than 101005 nodes and characters"))+    (errorOf (decodeAllText @Value (tagCopies 1000)))+  let anchorCopies :: Int -> T.Text+      anchorCopies k = T.unlines ("- &a [&" <> long <> " x]" : replicate k "- *a")+  assertEqual+    "long anchor inside with one copy"+    Nothing+    (errorOf (decodeAllText @S.Node (anchorCopies 1)))+  assertEqual+    "long anchor inside with many copies"+    (Just (3, 3, "the aliases add more than 101005 nodes and characters"))+    (errorOf (decodeAllText @S.Node (anchorCopies 1000)))+  -- The documents of a stream share the limit.+  let stream :: Int -> T.Text+      stream k = T.concat (replicate k ("---\n" <> laughs 3))+  assertEqual+    "four documents of a stream"+    Nothing+    (errorOf (decodeAllText @Value (stream 4)))+  assertEqual+    "five documents of a stream"+    (Just (25, 15, "the aliases add more than 100000 nodes and characters"))+    (errorOf (decodeAllText @Value (stream 5)))+  assertEqual+    "five documents of a stream with one document expected"+    (Just (25, 15, "the aliases add more than 100000 nodes and characters"))+    (errorOf (decodeText @Value (stream 5)))+  case S.parseDocumentsText (stream 5) of+    Right docs -> do+      assertEqual+        "five parsed documents"+        (Just (25, 15, "the aliases add more than 100000 nodes and characters"))+        (errorOf (decodeDocuments @Value (stream 5) docs))+      assertEqual+        "a parsed document on its own"+        Nothing+        (errorOf (traverse (decodeDocument @Value (stream 5)) docs))+    Left err -> assertFailure (show err)++-- | The prefixes of %TAG directives can add 100000 bytes to the tags of a+-- small input, and as many bytes as the input has to a large one.+test_tagPrefixLimit :: Assertion+test_tagPrefixLimit = do+  let uses :: T.Text -> Int -> T.Text+      uses prefix k = T.unlines ("%TAG !e! " <> prefix : "---" : replicate k "- !e!a 1")+  assertEqual+    "short prefix"+    Nothing+    (errorOf (decodeText @[Value] (uses "tag:x:" 1000)))+  let long = "tag:" <> T.replicate 100000 "x" <> ":"+  assertEqual+    "long prefix with one use"+    Nothing+    (errorOf (decodeText @[Value] (uses long 1)))+  assertEqual+    "long prefix with two uses"+    ( Just+        ( 4+        , 3+        , "the prefixes of %TAG directives add more than 100037 bytes to the tags"+        )+    )+    (errorOf (decodeText @[Value] (uses long 2)))+  -- Each tag adds 18 bytes, more than the 10 bytes of its line.+  assertEqual+    "default prefix"+    Nothing+    (errorOf (decodeText @[T.Text] (T.unlines (replicate 20000 "- !!str a"))))++-- | Anchors a0 to ak, where each anchor after a0 has ten aliases to the one+-- before it, and the alias *ak expands to about 10^(k+1) nodes.+laughs :: Int -> T.Text+laughs k =+  T.unlines $+    "a0: &a0 [x, x, x, x, x, x, x, x, x, x]"+      : [ T.pack $+            "a"+              ++ show i+              ++ ": &a"+              ++ show i+              ++ " ["+              ++ L.intercalate ", " (replicate 10 ("*a" ++ show (i - 1)))+              ++ "]"+        | i <- [1 .. k]+        ]++-- | The time to read a number is not quadratic in the number of its digits.+test_longNumbers :: Assertion+test_longNumbers = do+  let nines :: Int -> T.Text+      nines k = T.replicate k "9"+  assertEqual+    "integer"+    (Right (10 ^ (1000000 :: Int) - 1))+    (decodeText @Integer (nines 1000000))+  assertEqual+    "hexadecimal"+    (Right (16 ^ (100 :: Int) - 1))+    (decodeText @Integer ("0x" <> T.replicate 100 "f"))+  assertEqual+    "octal"+    (Right (8 ^ (100 :: Int) - 1))+    (decodeText @Integer ("0o" <> T.replicate 100 "7"))+  assertEqual+    "float"+    (Right (Float (Finite (Sci.scientific (10 ^ (1000000 :: Int) - 1) (-999999)))))+    (decodeText @Value ("9." <> nines 999999))+  assertEqual+    "exponent"+    ( Just+        ( 1+        , 1+        , "the exponent of the number is out of the range from -1000 to 1000, quote the value if it is a string, e.g. '1e"+            ++ T.unpack (nines 1000000)+            ++ "'"+        )+    )+    (errorOf (decodeText @Value ("1e" <> nines 1000000)))+  let zeros = T.replicate 300000 "0"+  assertEqual+    "trailing zeros"+    ( Just+        (+          ( 1+          , 600018+          , "duplicate key 0.1" ++ T.unpack zeros ++ "0, the same value as the first key"+          )+        , (1, 2, "the first key 0.1" ++ T.unpack zeros)+        )+    )+    . errorWithNote+    . decodeAllText @Value+    $ "{0.1" <> zeros <> ": a, 0.5" <> zeros <> ": b, 0.1" <> zeros <> "0: c}"+  -- The gcd of a reduction takes quadratic time for most types.+  let big = 3 ^ (1000000 :: Int) :: Integer+  assertEqual+    "fraction"+    (Right big)+    $ numerator+      <$> decodeText @Rational+        ( "{numerator: "+            <> T.pack (show big)+            <> ", denominator: "+            <> T.pack (show @Integer (7 ^ (600000 :: Int)))+            <> "}"+        )+  assertEqual+    "float with a long integer part"+    (Right (Float (Finite (Sci.scientific (10 ^ (1000000 :: Int) - 1) (-999000)))))+    (decodeText @Value (nines 1000 <> "." <> nines 999000))++-- | The search for a close known name does not compute the distance of a+-- long unknown name to each known name.+test_longUnknownNames :: Assertion+test_longUnknownNames = do+  let name = T.replicate 1000000 "a"+  assertEqual+    "value"+    (Just (1, 1, "unknown value " ++ show name ++ ", expected one of: small, large, 10"))+    (errorOf (decodeText @Size name))+  assertEqual+    "key"+    (Just (2, 3, "unknown key " ++ show name ++ ", expected one of: name, paths, jobs"))+    (errorOf (decodeText @Config ("name: x\n? " <> name <> "\n: 1\n")))++-- | The time of the check for duplicate keys is not quadratic in the number+-- of keys.+test_manyKeys :: Assertion+test_manyKeys = do+  let keys :: [T.Text]+      keys = [T.pack ("k" ++ show i) | i <- [1 .. 30000 :: Int]]+      count :: [T.Text] -> Either (NE.NonEmpty Error) Int+      count ks = length . entries <$> decodeText @Value (T.unlines (map (<> ": 1") ks))+  assertEqual+    "one collection key"+    (Right 30001)+    (count ("[c]" : keys))+  assertEqual+    "collection keys"+    (Right 30000)+    (count (map (\k -> "[" <> k <> "]") keys))+  assertEqual+    "mapping keys"+    (Right 30000)+    (count (map (\k -> "{a: " <> k <> "}") keys))+  let large = "{" <> T.intercalate ", " (map (<> ": 1") keys) <> "}"+  assertEqual+    "large equal keys"+    (Just ((3, 3, "duplicate key"), (1, 3, "the first key")))+    . errorWithNote+    $ decodeAllText @Value ("? " <> large <> "\n: 1\n? " <> large <> "\n: 2\n")+  let deep = nestedKey 14 "0"+  assertEqual+    "nested equal keys"+    (Just ((3, 3, "duplicate key"), (1, 3, "the first key")))+    . errorWithNote+    $ decodeAllText @Value ("? " <> deep <> "\n: 1\n? " <> deep <> "\n: 2\n")+  where+    -- Two mappings as keys that differ only in their last value.+    nestedKey :: Int -> T.Text -> T.Text+    nestedKey d v+      | d == 0 = v+      | otherwise =+          "{"+            <> nestedKey (d - 1) "0"+            <> ": 1, "+            <> nestedKey (d - 1) "1"+            <> ": "+            <> v+            <> "}"++    entries :: Value -> [(Value, Value)]+    entries = \case+      Mapping kvs -> kvs+      _ -> []++newtype NestedMap = NestedMap (M.Map T.Text NestedMap)+  deriving newtype (FromYaml)++newtype NestedSet = NestedSet (Set.Set NestedSet)+  deriving stock (Eq, Ord)+  deriving newtype (FromYaml)++-- | The time of the check for duplicates is linear in the depth of+-- collections that each have a duplicate.+test_nestedDuplicates :: Assertion+test_nestedDuplicates = do+  let depth = 1000+      maps :: Int -> T.Text+      maps d+        | d == 0 = "{}"+        | otherwise = "{a: {}, !x a: {}, b: " <> maps (d - 1) <> "}"+      sets :: Int -> T.Text+      sets d+        | d == 0 = "[[[]]]"+        | otherwise = "[[], [], " <> sets (d - 1) <> "]"+  assertEqual+    "maps"+    ( concat+        (replicate depth ["duplicate key \"a\" after conversion", "the first key \"a\""])+    )+    (map (\(_, _, msg) -> msg) (errorsOf (decodeText @NestedMap (maps depth))))+  assertEqual+    "sets"+    (concat (replicate depth ["duplicate element", "the first element"]))+    (map (\(_, _, msg) -> msg) (errorsOf (decodeText @NestedSet (sets depth))))++-- | The time to locate errors and to find their paths is linear in the number+-- of errors, also for errors on one line.+test_manyErrors :: Assertion+test_manyErrors = do+  let n = 100000 :: Int+  check+    "flow"+    ("[" <> T.intercalate ", " (replicate n "x") <> "]")+    (\i -> 1 + 3 * i)+    (\i -> (1, 2 + 3 * i))+  check+    "block"+    (T.concat (replicate n "- x\n"))+    (\i -> 2 + 4 * i)+    (\i -> (i + 1, 3))+  where+    check :: String -> T.Text -> (Int -> Int) -> (Int -> (Int, Int)) -> Assertion+    check preface input offset location = case S.parseDocumentsText input of+      Right [doc] -> do+        let n = length (items doc.root)+            offs = [Offset (offset i) | i <- [0 .. n - 1]]+            errs = errorsAt input [(o, "e") | o <- offs]+        assertEqual+          (preface ++ ", locations")+          [location i | i <- [0 .. n - 1]]+          [(err.location.line, err.location.column) | err <- errs]+        -- The time to render an error does not depend on the length of its+        -- line.+        assertEqual+          (preface ++ ", rendered")+          n+          (length (filter (elem '^') (map (prettyError "f") errs)))+        assertEqual+          (preface ++ ", paths")+          [[Index i] | i <- [0 .. n - 1]]+          (map pathElements (nodePaths offs doc.root))+      _ -> assertFailure "expected one document"++    items :: S.Node -> [S.Node]+    items node = case node.content of+      S.SequenceContent _ xs -> xs+      _ -> []++newtype NestedList = NestedList [NestedList]+  deriving newtype (FromYaml)++-- | The time and the memory of the paths of many errors deep in a document+-- are linear in its size.+test_deepErrors :: Assertion+test_deepErrors = do+  let n = 20000+      input =+        T.replicate n "[" <> T.intercalate ", " (replicate n "x") <> T.replicate n "]"+  case decodeText @NestedList input of+    Left errs -> do+      assertEqual+        "errors"+        n+        (length errs)+      assertEqual+        "depth"+        n+        (length (pathElements (NE.last errs).path))+    Right _ -> assertFailure "expected errors"
+ tests/Yamlet/Test/Decode/Scalars.hs view
@@ -0,0 +1,403 @@+module Yamlet.Test.Decode.Scalars+  ( scalarTests+  ) where++import Control.Monad+import Data.Bifunctor+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Scientific qualified as Sci+import Data.Text qualified as T+import Data.Time+import Data.Time.Calendar.Month+import Data.Time.Calendar.Quarter+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Yamlet+import Yamlet.Schema+import Yamlet.Test.Helpers++scalarTests :: TestTree+scalarTests =+  testGroup+    "scalars"+    [ testCase "core schema" test_coreSchema+    , testProperty "floats" prop_floats+    , testCase "exact floats" test_exactFloats+    , testCase "plain scalars" test_plainSafe+    , testCase "values" test_values+    , testCase "block scalars" test_blockScalars+    , slow $ testCase "time" test_time+    ]++test_coreSchema :: Assertion+test_coreSchema = do+  case decodeText @[Value]+    "[null, ~, '', true, False, 12, -0, 0o17, 0x1f, 1.5, -.inf, .nan, 1e3, +12, .5, a, '1']" of+    Left err -> assertFailure (show err)+    Right ns ->+      assertEqual+        "values"+        [ Null+        , Null+        , String ""+        , Bool True+        , Bool False+        , Int 12+        , Int 0+        , Int 15+        , Int 31+        , Float (Finite 1.5)+        , Float NegativeInfinity+        , Float NaN+        , Float (Finite 1000)+        , Int 12+        , Float (Finite 0.5)+        , String "a"+        , String "1"+        ]+        ns++test_plainSafe :: Assertion+test_plainSafe = do+  assertBool "word with a dash" $ isPlainSafe "dist-newstyle"+  assertBool "colon without a space" $ isPlainSafe "a:b"+  assertBool "flow indicators" $ isPlainSafe "a, [b]"+  assertBool "number" . not $ isPlainSafe "9.10"+  assertBool "boolean" . not $ isPlainSafe "true"+  assertBool "empty" . not $ isPlainSafe ""+  assertBool "colon and a space" . not $ isPlainSafe "a: b"+  assertBool "comment" . not $ isPlainSafe "a #b"+  assertBool "indicator" . not $ isPlainSafe "*a"+  assertBool "line break" . not $ isPlainSafe "a\nb"+  assertBool "string" $ isPlainString "9.10.3"+  assertBool "string with a colon and a space" $ isPlainString "a: b"+  assertBool "string number" . not $ isPlainString "9.10"+  assertBool "string null" . not $ isPlainString "~"++-- | A decimal number resolves to its exact value, and 'withFloat' gives the+-- same double as 'read'.+prop_floats :: Property+prop_floats = forAll genDecimal $ \s ->+  resolvePlain (T.pack s)+    === Float (Finite (read s))+    .&&. decodeText @Double (T.pack s)+      === Right (read s)+  where+    genDecimal :: Gen String+    genDecimal = do+      int <- digits+      frac <- digits+      ex <- oneof [pure "", ("e" ++) . show <$> choose @Int (-30, 30)]+      pure $ int ++ "." ++ frac ++ ex++    digits :: Gen String+    digits = do+      k <- choose (1, 20)+      vectorOf k (elements ['0' .. '9'])++test_exactFloats :: Assertion+test_exactFloats = do+  assertEqual+    "one tenth"+    (Right (Sci.scientific 1 (-1)))+    (decodeText @Sci.Scientific "0.1")+  assertEqual+    "more digits than a double holds"+    (Right (Sci.scientific 12345678901234567890123 (-3)))+    (decodeText @Sci.Scientific "12345678901234567890.123")+  assertEqual+    "integer as a scientific"+    (Right (Sci.scientific 42 0))+    (decodeText @Sci.Scientific "42")+  assertEqual+    "largest exponent"+    (Right (Sci.scientific 99 999))+    (decodeText @Sci.Scientific "9.9e1000")+  assertEqual+    "smallest exponent"+    (Right (Sci.scientific 15 (-1001)))+    (decodeText @Sci.Scientific "1.5e-1000")+  assertEqual+    "large exponent as a double"+    (Right (1 / 0))+    (decodeText @Double "1e1000")+  -- 1 + 2^-24 + 2^-60 is nearest to the float 1 + 2^-23, but the nearest+  -- double is 1 + 2^-24, a tie between two floats that rounds to 1.+  assertEqual+    "float without double rounding"+    (Right (1 + 2 ^^ (-23 :: Int)))+    (decodeText @Float "1.000000059604644776257986737988403547205962240695953369140625")+  let numbers =+        [ "1e1001"+        , "10e1000"+        , "0.1e-1000"+        , "1" <> T.replicate 1001 "0" <> ".0"+        , "1e99999999999999999999"+        , "11e9223372036854775807"+        ]+  forM_ numbers $ \number ->+    assertEqual+      ("exponent beyond the limit in " ++ show number)+      ( Just+          ( 1+          , 2+          , "the exponent of the number is out of the range from -1000 to 1000, quote the value if it is a string, e.g. '"+              ++ T.unpack number+              ++ "'"+          )+      )+      (errorOf (decodeText @Sci.Scientific ("[" <> number <> "]")))+  assertEqual+    "exponent beyond the limit for a string"+    ( Just+        ( 1+        , 9+        , "the exponent of the number is out of the range from -1000 to 1000, quote the value if it is a string, e.g. '61e9540'"+        )+    )+    (errorOf (decodeText @(M.Map T.Text T.Text) "gitsha: 61e9540"))+  assertEqual+    "exponent beyond the limit with a tag"+    (Just (1, 9, "the exponent of the number is out of the range from -1000 to 1000"))+    (errorOf (decodeText @Double "!!float 1e-99999999999999999999"))+  assertEqual+    "exponent beyond the limit in the text, value within it"+    (Right (Sci.scientific 1 997))+    (decodeText @Sci.Scientific "0.0001e1001")+  assertEqual+    "exponent beyond the limit in the schema"+    [Float Infinity, Float (Finite 0), Float (Finite 0)]+    (map resolvePlain ["1e1001", "1e-1001", "0e99999999999999999999"])+  assertEqual+    "zero with an exponent beyond the limit"+    (Right 0)+    (decodeText @Double "0e99999999999999999999")+  assertEqual+    "negative zero"+    (Right [Float NegativeZero, Float NegativeZero, Float (Finite 0), Int 0])+    (decodeText @[Value] "[-0.0, !!float -0, 0.0, -0]")+  assertEqual+    "integer with a float tag"+    (Right 12)+    (decodeText @Double "!!float 12")+  forM_ ["0x10", "0o10"] $ \t ->+    assertEqual+      ("integer in another base with a float tag, " ++ show t)+      (Just (1, 9, "invalid value for the tag !!float"))+      (errorOf (decodeText @Double ("!!float " <> t)))+  assertEqual+    "negative zero as a double"+    (Right True)+    (isNegativeZero <$> decodeText @Double "-0.0")+  assertEqual+    "negative zero as a scientific"+    (Right 0)+    (decodeText @Sci.Scientific "-0.0")+  assertEqual+    "negative and positive zero keys"+    (Right [Float (Finite 0), Float NegativeZero])+    $ (\case Mapping kvs -> map fst kvs; v -> [v])+      <$> decodeText @Value "{0.0: a, -0.0: b}"+  assertEqual+    "infinity as a scientific"+    (Just (1, 1, "expected a finite number"))+    (errorOf (decodeText @Sci.Scientific ".inf"))++-- | Edge cases of block scalars that the specification leaves unclear.+test_blockScalars :: Assertion+test_blockScalars = do+  -- libyaml and the JavaScript package yaml give the same result.+  assertEqual+    "indentation indicator at the top level"+    (Right " a\n")+    (decodeText @T.Text "--- |1\n  a\n")+  assertEqual+    "indentation indicator without a marker"+    (Right " a\n")+    (decodeText @T.Text "|2\n   a\n")+  -- The end of the input ends a last line of spaces, as in the test JEF9/02+  -- of the YAML test suite.+  assertEqual+    "keep with spaces at the end"+    (Right "a\n\n")+    (decodeText @T.Text "|+\n  a\n  ")+  assertEqual+    "keep with an empty line and spaces at the end"+    (Right "a\n\n\n")+    (decodeText @T.Text "|+\n  a\n\n  ")+  assertEqual+    "keep with a line break at the end"+    (Right "a\n\n")+    (decodeText @T.Text "|+\n  a\n  \n")++test_values :: Assertion+test_values = do+  assertEqual+    "mapping"+    (Right (Mapping [(String "a", Sequence [Int 1, Int 2])]))+    (decodeText @Value "a: [1, 2]")+  assertEqual+    "tags"+    ( Right $+        Sequence+          [ Tagged "!point" (Mapping [(String "x", Int 1)])+          , Tagged "!secret" (String "abc")+          , Int 1+          ]+    )+    (decodeText @Value "- !point {x: 1}\n- !secret abc\n- !!int 1\n")++test_time :: Assertion+test_time = do+  assertEqual+    "day"+    (Right (fromGregorian 2026 9 25))+    (decodeText "2026-09-25")+  assertEqual+    "invalid day"+    (Just (1, 1, "expected a date such as 2026-09-25"))+    (errorOf (decodeText @Day "2026-02-30"))+  assertEqual+    "invalid month"+    (Just (1, 1, "expected a month such as 2026-09"))+    (errorOf (decodeText @Month "2026-13"))+  assertEqual+    "uppercase quarter"+    (Right (YearQuarter 2026 Q3))+    (decodeText "2026-Q3")+  assertEqual+    "invalid quarter"+    (Just (1, 1, "expected a quarter such as 2026-q3"))+    (errorOf (decodeText @Quarter "2026-q5"))+  assertEqual+    "day of the week in another case"+    (Right Friday)+    (decodeText "FriDay")+  assertEqual+    "invalid day of the week"+    (Just (1, 1, "expected a day of the week such as monday"))+    (errorOf (decodeText @DayOfWeek "mon"))+  assertEqual+    "unknown key of calendar days"+    (Just (1, 22, "unknown key \"weeks\", expected one of: months, days"))+    (errorOf (decodeText @CalendarDiffDays "{months: 1, days: 2, weeks: 3}"))+  assertEqual+    "short year"+    (Just (1, 1, "expected a date such as 2026-09-25"))+    (errorOf (decodeText @Day "26-09-25"))+  assertEqual+    "time without seconds"+    (Right (TimeOfDay 12 30 0))+    (decodeText "12:30")+  assertEqual+    "time with a fraction"+    (Right (TimeOfDay 12 30 5.25))+    (decodeText "12:30:05.25")+  assertEqual+    "fraction of 13 digits"+    (Just (1, 1, "expected a time such as 12:30:00"))+    (errorOf (decodeText @TimeOfDay "12:30:05.1234567890123"))+  assertEqual+    "end of a day"+    (Right (TimeOfDay 24 0 0))+    (decodeText "24:00")+  assertEqual+    "invalid time"+    (Just (1, 1, "expected a time such as 12:30:00"))+    (errorOf (decodeText @TimeOfDay "24:01"))+  let noon = LocalTime (fromGregorian 2026 9 25) (TimeOfDay 12 30 0)+  assertEqual+    "local time with T"+    (Right noon)+    (decodeText "2026-09-25T12:30:00")+  assertEqual+    "local time with a space"+    (Right noon)+    (decodeText "2026-09-25 12:30")+  let utcNoon = UTCTime (fromGregorian 2026 9 25) (12 * 3600 + 30 * 60)+  assertEqual+    "UTC time"+    (Right utcNoon)+    (decodeText "2026-09-25T12:30:00Z")+  assertEqual+    "UTC time from an offset"+    (Right utcNoon)+    (decodeText "2026-09-25T14:30:00+02:00")+  assertEqual+    "offset without a colon"+    (Right utcNoon)+    (decodeText "2026-09-25T14:30:00+0200")+  assertEqual+    "space before an offset"+    (Just (1, 1, "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"))+    (errorOf (decodeText @UTCTime "2026-09-25T14:30:00 +02:00"))+  assertEqual+    "offset in hours"+    (Right utcNoon)+    (decodeText "2026-09-25T10:30:00-02")+  assertEqual+    "lowercase separator"+    (Just (1, 1, "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"))+    (errorOf (decodeText @UTCTime "2026-09-25t12:30:00Z"))+  assertEqual+    "lowercase zone"+    (Just (1, 1, "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"))+    (errorOf (decodeText @UTCTime "2026-09-25T12:30:00z"))+  assertEqual+    "large offset"+    (Right utcNoon)+    (decodeText "2026-09-26T12:29:00+23:59")+  assertEqual+    "offset beyond a day"+    (Just (1, 1, "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"))+    (errorOf (decodeText @UTCTime "2026-09-25T12:30:00+24:00"))+  assertEqual+    "time without a time zone"+    (Just (1, 1, "expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"))+    (errorOf (decodeText @UTCTime "2026-09-25T12:30:00"))+  assertEqual+    "zoned time"+    (Right (noon, 120))+    $ (\z -> (zonedTimeToLocalTime z, timeZoneMinutes (zonedTimeZone z)))+      <$> decodeText "2026-09-25T12:30:00+02:00"+  assertEqual+    "duration"+    (Right 1.5)+    (decodeText @NominalDiffTime "1.5")+  assertEqual+    "whole duration"+    (Right 60)+    (decodeText @DiffTime "60")+  assertEqual+    "picosecond"+    (Right (picosecondsToDiffTime 1))+    (decodeText "1e-12")+  assertEqual+    "tiny duration"+    (Right 0)+    (decodeText @DiffTime "1e-1000")+  assertEqual+    "largest duration"+    (Right (10 ^ (1000 :: Int)))+    (decodeText @NominalDiffTime "1e1000")+  assertEqual+    "integer duration beyond the limit of floats"+    (Right (10 ^ (1001 :: Int)))+    (decodeText @NominalDiffTime ("1" <> T.replicate 1001 "0"))+  forM_ [minBound, maxBound - 11, maxBound] $ \ex ->+    assertEqual+      ("duration with the exponent " ++ show ex)+      (Left "the exponent of the number is out of the range from -1000 to 1000")+      . first (snd . NE.head)+      $ runParser+        (parseYaml @NominalDiffTime)+        (toYaml (Float (Finite (Sci.scientific 1 ex))))+  assertEqual+    "zero duration with a large exponent"+    (Right 0)+    $ runParser+      (parseYaml @DiffTime)+      (toYaml (Float (Finite (Sci.scientific 0 maxBound))))
+ tests/Yamlet/Test/Decode/SyntaxErrors.hs view
@@ -0,0 +1,830 @@+module Yamlet.Test.Decode.SyntaxErrors+  ( syntaxErrorTests+  ) where++import Control.Monad+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Helpers++syntaxErrorTests :: TestTree+syntaxErrorTests =+  testGroup+    "syntax errors"+    [ testCase "syntax" test_syntaxErrors+    , testCase "directives and tags" test_directiveErrors+    ]++test_syntaxErrors :: Assertion+test_syntaxErrors = do+  let check :: String -> (Int, Int, String) -> T.Text -> Assertion+      check preface expected input =+        assertEqual+          preface+          (Just expected)+          (errorOf (decodeAllText @Value input))+  check+    "bad indentation"+    (3, 2, "unexpected indentation")+    "a:\n  b: 1\n c: 2\n"+  check+    "indicator at the indentation of a key"+    (3, 3, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "dependencies:\n  typescript: ^5.0.0\n  @types/node: ^20.0.0\n"+  check+    "indicator on an indented first line"+    (1, 3, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "  @b: c\n"+  check+    "bracket at the indentation of a list item"+    (3, 3, "unexpected ']'")+    "a:\n  - b\n  ]\n"+  -- The BOM at the start of the input is not content of the first line.+  forM_+    [+      ( "colon in an alias"+      ,+        ( 1+        , 3+        , "the name of the alias includes the ':', write a space before ':' if the alias is a key"+        )+      , "*x: 1"+      )+    ,+      ( "properties on their own line"+      ,+        ( 1+        , 1+        , "an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'"+        )+      , "&a &b"+      )+    , ("tab before a key", (1, 1, "tabs cannot be used for indentation"), "\tx: y")+    ,+      ( "mapping on the start marker line"+      , (1, 6, "unexpected ':', a mapping cannot start on the line of '---'")+      , "--- a: b"+      )+    , ("key among list items", (2, 1, "unexpected key among list items"), "- a\nb: 1")+    , ("list item without a space", (2, 2, "expected a space after '-'"), "- a\n-b")+    ]+    $ \(preface, expected, input) -> do+      check+        preface+        expected+        input+      check+        (preface ++ " after a BOM")+        expected+        ("\xFEFF" <> input)+  check+    "line after a comment below a plain scalar"+    (3, 3, "a comment ends a plain scalar, so this line cannot continue it")+    "a: x\n# c\n  y\n"+  forM_+    [ ("literal scalar", 4, "a: |\n  x\n# c\n  y\n")+    , ("single-quoted scalar", 3, "a: 'x'\n# c\n  y\n")+    , ("flow sequence", 3, "a: [x]\n# c\n  y\n")+    , ("alias", 3, "a: *x\n# c\n  y\n")+    ]+    $ \(node, line, input) ->+      check+        ("line after a comment below a " ++ node)+        (line, 3, "unexpected indentation")+        input+  forM_+    [ ("double-quoted scalar", 2, "a: \"x #y\"\n  b\n")+    , ("single-quoted scalar", 2, "a: 'see #3'\n  b\n")+    , ("quoted scalar in a flow sequence", 2, "a: [x, \"y #z\"]\n  b\n")+    , ("multi-line quoted scalar", 3, "a: \"x\n  y #z\"\n  b\n")+    ]+    $ \(node, line, input) ->+      check+        ("line below a '#' in a " ++ node)+        (line, 3, "unexpected indentation")+        input+  check+    "line after a comment with a quote"+    (2, 3, "a comment ends a plain scalar, so this line cannot continue it")+    "a: x # it's\n  b\n"+  forM_+    [ ("list item", "- # c\nfoo\n")+    , ("list item with an anchor", "- &x # c\nfoo\n")+    , ("list item with a tag", "- !t # c\nfoo\n")+    ]+    $ \(node, input) ->+      check+        ("line after a comment on an empty " ++ node)+        (2, 1, "unexpected value among list items")+        input+  check+    "line after a comment below the header of a block scalar"+    ( 3+    , 3+    , "unexpected indentation, the line has less indentation than the block scalar above it"+    )+    "a: |\n# c\n  y\n"+  check+    "mapping in a plain scalar"+    (1, 11, "unexpected ':', quote the value if it contains \": \"")+    "key: value: other\n"+  check+    "content after a quoted value"+    (1, 14, "unexpected 't' after the end of a quoted scalar")+    "key: \"value\" trailing\n"+  check+    "content after a flow value"+    (1, 12, "unexpected 'i' after the end of a flow collection")+    "x: { y: z }in: valid\n"+  check+    "letter beyond ASCII"+    (1, 4, "unexpected 'é' after the end of a flow collection")+    "[a]é\n"+  check+    "character that cannot be shown"+    (1, 4, "unexpected U+200B after the end of a flow collection")+    "[a]\x200B\n"+  check+    "comment line in a plain scalar"+    (3, 3, "a comment ends a plain scalar, so this line cannot continue it")+    "key: word1\n#  xxx\n  word2\n"+  check+    "comment at the end of a line of a plain scalar"+    (2, 1, "a comment ends a plain scalar, so this line cannot continue it")+    "word1  # comment\nword2\n"+  check+    "directive after a comment"+    ( 3+    , 1+    , "unexpected '%', a directive needs '...' on a line above it to end the document"+    )+    "---\nscalar1 # comment\n%YAML 1.2\n---\nscalar2\n"+  check+    "directive after a mapping"+    ( 2+    , 1+    , "unexpected '%', a directive needs '...' on a line above it to end the document"+    )+    "a: 1\n%YAML 1.2\n---\nb: 2\n"+  check+    "percent sign at the start of a line in a flow sequence"+    (2, 1, "unexpected '%', a plain scalar cannot start with it, quote the value")+    "[a,\n%x]\n"+  check+    "anchor on its own line in a sequence"+    ( 2+    , 1+    , "an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'"+    )+    "- item1\n&node\n- item2\n"+  check+    "tag on its own line after a key"+    ( 2+    , 1+    , "an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'"+    )+    "key: &x\n!!map\n  a: b\n"+  check+    "flow key on two lines"+    (2, 2, "unexpected ':', a key must be on a single line")+    "[23\n]: 42\n"+  check+    "quoted key on two lines"+    (2, 3, "a key must be on a single line")+    "a: 1\n\"c\n d\": 1\n"+  check+    "mapping on the line of the document marker"+    (1, 9, "unexpected ':', a mapping cannot start on the line of '---'")+    "--- key1: value1\n    key2: value2\n"+  check+    "key indented under a value"+    ( 2+    , 4+    , "unexpected ':', this line continues the scalar from the line above, check the indentation and the line above"+    )+    "a: 1\n  b: 2\n"+  check+    "missing closing quote"+    (1, 7, "unterminated double-quoted scalar")+    "name: \"abc\nnext: value\n"+  check+    "badly indented quoted line"+    (2, 1, "invalid indentation of a line in a single-quoted scalar")+    "name: 'abc\nnext'\n"+  check+    "missing closing quote before a quoted value"+    (1, 7, "unterminated double-quoted scalar")+    "name: \"web\nimage: \"nginx:1.25\"\n"+  check+    "missing closing quote before a single-quoted value"+    (1, 7, "unterminated single-quoted scalar")+    "name: 'web\nimage: 'nginx:1.25'\n"+  check+    "badly indented quoted line before the closing quote"+    (2, 1, "invalid indentation of a line in a double-quoted scalar")+    "key: \"first line\nsecond line\nthird line\"\n"+  check+    "badly indented quoted line before an escaped quote"+    (2, 1, "invalid indentation of a line in a double-quoted scalar")+    "key: \"first\nsay \\\"hi\\\" now\"\n"+  check+    "badly indented quoted line before a doubled quote"+    (2, 1, "invalid indentation of a line in a single-quoted scalar")+    "key: 'first\nit''s here'\n"+  check+    "missing colon"+    (2, 4, "expected ':' after the key")+    "a: 1\nb 2\nc: 3\n"+  check+    "missing colon in a list item"+    (2, 8, "expected ':' after the key")+    "- key: value\n  other\n"+  check+    "missing colon before a comment"+    (2, 10, "expected ':' after the key")+    "name: x\nport 8080 # default\n"+  check+    "missing colon after a key before a comment"+    (2, 5, "expected ':' after the key")+    "name: x\nport # default\n"+  check+    "missing colon after a quoted key with a colon"+    (2, 7, "expected ':' after the key")+    "a: 1\n\"b: 2\"\n"+  check+    "missing colon after a key with an escaped quote"+    (2, 10, "expected ':' after the key")+    "a: 1\n\"b\\\"c: d\"\n"+  check+    "unterminated quoted key with a colon"+    (2, 1, "unterminated double-quoted scalar")+    "a: 1\n\"b: 2\n"+  check+    "unterminated single-quoted key"+    (3, 3, "unterminated single-quoted scalar")+    "env:\n  NAME: x\n  'it''s\n"+  check+    "missing space after a colon"+    (2, 3, "expected a space after ':'")+    "a: 1\nb:2\n"+  check+    "line that has its colon"+    (2, 5, "expected an alias name after '*'")+    "a: 1\nb: *\n"+  check+    "anchor without a name"+    (1, 5, "expected an anchor name after '&'")+    "a: & 1\n"+  check+    "alias with an anchor"+    (2, 7, "unexpected '*', an alias cannot have an anchor or a tag")+    "a: &x 1\nb: &y *x\n"+  check+    "alias with a tag in a flow sequence"+    (1, 11, "unexpected '*', an alias cannot have an anchor or a tag")+    "[&x a, !t *x]\n"+  check+    "colon after an alias"+    ( 2+    , 3+    , "the name of the alias includes the ':', write a space before ':' if the alias is a key"+    )+    "a: &x 1\n*x: 2\n"+  forM_ [("flow mapping", "{*a: b}\n"), ("flow sequence", "[*a: b]\n")] $ \(node, input) ->+    check+      ("colon after an alias in a " ++ node)+      ( 1+      , 4+      , "the name of the alias includes the ':', write a space before ':' if the alias is a key"+      )+      input+  check+    "alias without a name in a flow sequence"+    (1, 2, "expected an alias name after '*'")+    "[*, a]\n"+  check+    "tab indentation"+    (2, 1, "tabs cannot be used for indentation")+    "a:\n\tb: 1\n"+  check+    "tab after spaces before a key"+    (2, 3, "tabs cannot be used for indentation")+    "a:\n  \tb: c\n"+  check+    "tab before a scalar continuation"+    (2, 1, "tabs cannot be used for indentation")+    "a: 1\n\t@\n"+  -- A space in place of the tab fails too, but the indentation of the line+  -- above does not.+  check+    "tab before a second key"+    (3, 1, "tabs cannot be used for indentation")+    "a:\n  b: 1\n\tc: 2\n"+  check+    "tab before a second item"+    (3, 1, "tabs cannot be used for indentation")+    "a:\n  - 1\n\t- 2\n"+  check+    "tab below a comment"+    (5, 1, "tabs cannot be used for indentation")+    "a:\n  b: 1\n  # c\n\n\tc: 2\n"+  check+    "tab on a blank line of a block scalar"+    (3, 1, "tabs cannot be used for indentation")+    "a: |\n  x\n\t\n  y\n"+  check+    "tab before a comment below a block scalar"+    (3, 1, "tabs cannot be used for indentation")+    "a: |\n  x\n\t# c\nb: 1\n"+  check+    "tab on a blank line of a plain scalar"+    (2, 1, "tabs cannot be used for indentation")+    "a: b\n\t\n c\n"+  check+    "tab on a blank line above a line indented too much"+    (3, 3, "unexpected indentation")+    "a: 1\n\t\n  b: 2\n"+  check+    "tab after a list item indicator"+    (3, 3, "tabs cannot be used for indentation")+    "x:\n- a\n- \tb: c\n"+  check+    "tab right after a list item indicator"+    (1, 2, "tabs cannot be used for indentation")+    "-\tname: x\n"+  check+    "tab after an explicit key indicator"+    (2, 3, "tabs cannot be used for indentation")+    "x: 1\n? \ta: b\n"+  check+    "tab after a value indicator"+    (2, 2, "tabs cannot be used for indentation")+    "? a\n:\tb: c\n"+  -- With a space in place of the tab, the parser fails at the same place.+  check+    "tab before a list after a key"+    (1, 6, "unexpected '-', a list cannot start on the line of its key")+    "key:\t- a\n"+  -- With spaces in place of the tab, the parser fails at the same place.+  check+    "tab before an indicator"+    (1, 2, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "\t@\n"+  check+    "tab before a bracket"+    (1, 2, "unexpected ']'")+    "\t]\n"+  check+    "tab after an end marker"+    (3, 2, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "a\n...\n\t@\n"+  check+    "content after spaces after an end marker"+    (2, 7, "unexpected content after the document end marker (...)")+    "--- a\n...   x\n"+  check+    "unterminated string"+    (1, 6, "unterminated double-quoted scalar")+    "key: \"abc\n"+  check+    "flow sequence before a key"+    (1, 6, "unterminated flow sequence")+    "key: [a, b\nc: d\n"+  check+    "flow sequence at the end"+    (1, 6, "unterminated flow sequence")+    "key: [a, b\n"+  check+    "flow sequence before a comment"+    (1, 6, "unterminated flow sequence")+    "key: [a, b # c\nd: e\n"+  check+    "flow sequence before a key with a flow sequence"+    (1, 6, "unterminated flow sequence")+    "key: [a, b\nc: [d]\n"+  check+    "flow sequence on a line indented too little"+    (2, 1, "the line is indented too little to continue the flow sequence")+    "a: [b,\nc]\n"+  check+    "flow mapping on lines indented too little"+    (2, 1, "the line is indented too little to continue the flow mapping")+    "a: {x: 1,\ny: 2,\n  z: 3}\n"+  check+    "closing bracket indented too little"+    (4, 1, "']' is indented too little to end the flow sequence")+    "key: [\n  a,\n  b\n]\n"+  check+    "closing brace after a comment line"+    (3, 1, "'}' is indented too little to end the flow mapping")+    "key: {\n  # c\n}\n"+  check+    "tab in a flow sequence"+    (2, 1, "tabs cannot be used for indentation")+    "a: [\n\tb\n]\n"+  check+    "tab in a double-quoted scalar"+    (2, 1, "tabs cannot be used for indentation")+    "a: \"x\n\ty\"\n"+  check+    "tab after a blank line in a single-quoted scalar"+    (3, 1, "tabs cannot be used for indentation")+    "a: 'x\n\n\ty'\n"+  check+    "tab on a blank line of a double-quoted scalar"+    (2, 1, "tabs cannot be used for indentation")+    "a: \"x\n\t\n y\"\n"+  check+    "block scalar in a flow sequence"+    (1, 2, "unexpected '|', a block scalar cannot be inside a flow collection")+    "[|\n  x\n]\n"+  check+    "block scalar indicator after a quoted scalar"+    (1, 8, "unexpected '|' after the end of a quoted scalar")+    "a: 'x' |\n"+  check+    "block scalar indicator after a flow collection"+    (1, 8, "unexpected '|' after the end of a flow collection")+    "a: [x] |\n"+  check+    "block scalar indicator at the start of a line"+    (2, 1, "unexpected '|'")+    "a: b\n| x\n"+  check+    "dash in a flow sequence"+    ( 1+    , 2+    , "unexpected '-', a list item cannot be inside a flow collection, quote '-' if it is a string"+    )+    "[-]\n"+  check+    "empty flow entry"+    (1, 4, "unexpected ',', a flow collection cannot have an empty entry")+    "[1,,2]\n"+  check+    "content after a flow sequence"+    (1, 14, "expected ',' or ']'")+    "key: [a, \"b\" c]\n"+  check+    "flow mapping at the end"+    (1, 1, "unterminated flow mapping")+    "{\"a\": 1,\n \"b\": 2\n"+  check+    "flow mapping before a marker"+    (1, 1, "unterminated flow mapping")+    "{a: 1\n---\nb\n"+  check+    "start marker in a double-quoted scalar"+    (2, 1, "unexpected '---' in a double-quoted scalar, indent the line")+    "a: \"x\n---\n  y\"\n"+  check+    "end marker in a single-quoted scalar"+    (2, 1, "unexpected '...' in a single-quoted scalar, indent the line")+    "a: 'x\n...\n  y'\n"+  check+    "start marker in a flow sequence"+    (2, 1, "unexpected '---' in a flow sequence, indent the line")+    "a: [x,\n---\n  y]\n"+  check+    "end marker in a flow mapping"+    (2, 1, "unexpected '...' in a flow mapping, indent the line")+    "a: {x: 1,\n...\n  y: 2}\n"+  check+    "flow sequence before a document with its own"+    (1, 7, "unterminated flow sequence")+    "args: [a, b\n---\nargs: [c]\n"+  check+    "flow mapping before a document with its own"+    (1, 7, "unterminated flow mapping")+    "args: {a: b\n---\nx: {c: d}\n"+  forM_+    [ ("flow sequence", "flow sequence", "a: [x, y\nb: a]b\n")+    , ("flow mapping", "flow mapping", "a: {x: 1\nb: a}b\n")+    , ("flow sequence before a document", "flow sequence", "a: [x,\n---\nb: a]b\n")+    ]+    $ \(name, node, input) ->+      check+        (name ++ " with a bracket in a plain scalar below")+        (1, 4, "unterminated " ++ node)+        input+  check+    "double-quoted scalar before a document with its own"+    (1, 7, "unterminated double-quoted scalar")+    "name: \"web\n---\nname: \"db\"\n"+  check+    "single-quoted scalar before a document with its own"+    (1, 7, "unterminated single-quoted scalar")+    "name: 'web\n---\nname: 'it''s'\n"+  check+    "single-quoted scalar before a document with a quote in a plain scalar"+    (1, 4, "unterminated single-quoted scalar")+    "a: 'oops\n---\nb: it's here\n"+  check+    "escaped quote after a marker"+    (2, 1, "unexpected '---' in a double-quoted scalar, indent the line")+    "a: \"x\n---\n  y \\\"z\"\n"+  check+    "start marker after a missing quote"+    (1, 4, "unterminated double-quoted scalar")+    "a: \"x\n---\nb: c\n"+  check+    "missing colon in a flow mapping"+    (1, 6, "expected ':', ',' or '}'")+    "{\"a\" 1}"+  check+    "missing comma after a value"+    (1, 12, "expected ',' or '}'")+    "{\"a\": 1 \"b\": 2}"+  check+    "quote in a single-quoted scalar"+    (1, 10, "unexpected 's' after a single-quoted scalar, write '' for a quote inside it")+    "msg: 'it's here'\n"+  check+    "quote in a tag"+    (1, 6, "unexpected '!'")+    "&b !'!str ' x '\n"+  check+    "quote in a double-quoted scalar"+    ( 1+    , 12+    , "unexpected 'h' after a double-quoted scalar, write \\\" for a quote inside it"+    )+    "msg: \"say \"hi\"\"\n"+  check+    "quote in a quoted scalar in a flow sequence"+    ( 1+    , 5+    , "unexpected 'b' after a double-quoted scalar, write \\\" for a quote inside it"+    )+    "[\"a\"b]\n"+  check+    "comment after a quote"+    (1, 7, "unexpected '#', a comment needs a space before it")+    "a: \"x\"#c\n"+  check+    "comment after a flow sequence"+    (1, 7, "unexpected '#', a comment needs a space before it")+    "a: [1]#c\n"+  check+    "reserved indicator"+    (1, 7, "unexpected '@', a plain scalar cannot start with it, quote the value")+    "user: @admin\n"+  check+    "reserved indicator in a flow sequence"+    (1, 5, "unexpected '`', a plain scalar cannot start with it, quote the value")+    "[a, `b`]\n"+  check+    "key among indented list items after a comment"+    (5, 3, "unexpected key among list items")+    "a:\n  - x\n\n  # c\n  b: 1\n"+  check+    "explicit key among list items"+    (2, 1, "unexpected key among list items")+    "- a\n? b\n"+  check+    "value among indented list items"+    (3, 3, "unexpected value among list items")+    "a:\n  - x\n  y\n"+  check+    "list item among keys"+    (3, 3, "unexpected list item among mapping entries")+    "a:\n  b: 1\n  - x\n"+  check+    "list item among top keys"+    (2, 1, "unexpected list item among mapping entries")+    "a: 1\n- b\n"+  check+    "brace after a list item"+    (2, 1, "unexpected '}'")+    "- a\n}\n"+  check+    "text after a block scalar header"+    (1, 6, "the content of a block scalar starts on the next line")+    "s: | text\n"+  check+    "zero indentation indicator"+    (1, 5, "the indentation indicator of a block scalar must be from 1 to 9")+    "s: |0\n  x\n"+  check+    "long key"+    (1, 1103, "a key can be at most 1024 characters long, write a longer key after '? '")+    ("\"" <> T.replicate 1100 "k" <> "\": 1\n")+  check+    "long flow mapping as a key"+    (1, 1106, "a key can be at most 1024 characters long, write a longer key after '? '")+    ("{a: " <> T.replicate 1100 "k" <> "}: 1\n")+  check+    "spaces after a key count toward its length"+    (1, 1026, "a key can be at most 1024 characters long, write a longer key after '? '")+    ("a" <> T.replicate 1024 " " <> ": 1\n")+  check+    "spaces after a key in a flow sequence"+    (1, 1029, "a key can be at most 1024 characters long, write a longer key after '? '")+    ("['a'" <> T.replicate 1024 " " <> ": 1]\n")+  check+    "long key in a flow sequence"+    (1, 1030, "a key can be at most 1024 characters long, write a longer key after '? '")+    ("[a, " <> T.replicate 1025 "k" <> ": v]\n")+  check+    "list on the line of its anchor"+    (1, 9, "unexpected '-', a list cannot start on the line of its anchor or tag")+    "&anchor - sequence entry\n"+  check+    "list on the line of its key"+    (1, 4, "unexpected '-', a list cannot start on the line of its key")+    "a: - b\n"+  check+    "list on the line of a start marker"+    (1, 5, "unexpected '-', a list cannot start on the line of '---'")+    "--- - a\n"+  check+    "line of a block scalar"+    ( 3+    , 3+    , "unexpected indentation, the line has less indentation than the block scalar above it"+    )+    "s: >- # folded\n    line1\n  line2\n"+  check+    "invalid escape"+    (1, 8, "invalid escape sequence, write \\\\ for a backslash or use single quotes")+    "key: \"a\\qb\"\n"+  check+    "Windows path"+    (1, 10, "invalid escape sequence, write \\\\ for a backslash or use single quotes")+    "path: \"C:\\Users\\me\"\n"+  check+    "undefined alias"+    (2, 4, "undefined alias *x")+    "a: 1\nb: *x\n"+  check+    "invalid character"+    (1, 4, "invalid character U+0001")+    "a: \x01\n"+  check+    "backslash at the end of the input"+    (1, 4, "unterminated double-quoted scalar")+    "a: \"b\\"+  check+    "backslash at the end of a key"+    (1, 2, "unterminated double-quoted scalar")+    "[\"a\\"+  check+    "noncharacter U+FFFE"+    (1, 4, "invalid character U+FFFE")+    "a: \xFFFE\n"+  check+    "noncharacter U+FFFF"+    (1, 5, "invalid character U+FFFF")+    "a: b\xFFFF\n"+  check+    "delete in a plain scalar"+    (1, 5, "invalid character U+007F")+    "a: x\DELy\n"+  check+    "delete at the start of a line"+    (1, 1, "invalid character U+007F")+    "\DEL\n"+  check+    "C1 control character in a comment"+    (1, 9, "invalid character U+0080")+    "a: b # c\x80\n"+  check+    "C1 control character in a tag"+    (1, 6, "invalid character U+0080")+    "a: !x\x80 1\n"+  check+    "noncharacter in a block scalar"+    (2, 4, "invalid character U+FFFF")+    "a: |\n  x\xFFFF\n"+  check+    "C1 control character after a quoted one"+    (2, 4, "invalid character U+0080")+    "- \"\x80\"\n- b\x80\n"+  check+    "byte order mark before a C1 control character"+    (1, 5, "unexpected byte order mark")+    "a: x\xFEFF\x80\n"++test_directiveErrors :: Assertion+test_directiveErrors = do+  let check :: String -> (Int, Int, String) -> T.Text -> Assertion+      check preface expected input =+        assertEqual+          preface+          (Just expected)+          (errorOf (decodeAllText @Value input))+  check+    "undefined tag handle"+    (1, 1, "undefined tag handle !e!")+    "!e!foo bar\n"+  check+    "unsupported version"+    (1, 1, "unsupported YAML version 2.0")+    "%YAML 2.0\n--- a\n"+  check+    "version without a minor number"+    (1, 7, "expected a version such as 1.2 after %YAML")+    "%YAML 1\n--- a\n"+  check+    "content after the version"+    (1, 11, "unexpected content after the %YAML version")+    "%YAML 1.2 x\n--- a\n"+  check+    "tag directive without a prefix"+    (1, 9, "expected a prefix after the tag handle, e.g. tag:example.com,2000:")+    "%TAG !e!\n--- a\n"+  check+    "invalid tag handle"+    (1, 6, "invalid tag handle")+    "%TAG e tag:x,2000:\n--- a\n"+  check+    "tag handle without its closing !"+    (1, 6, "invalid tag handle")+    "%TAG !e tag:x,2000:\n--- a\n"+  check+    "tag handle with an invalid character"+    (1, 6, "invalid tag handle")+    "%TAG !e_x! tag:x,2000:\n--- a\n"+  check+    "tag handle before the prefix without a space"+    (1, 9, "expected a space after the tag handle")+    "%TAG !e!tag:x,2000:\n--- a\n"+  check+    "version beyond the limit"+    (1, 1, "unsupported YAML version")+    "%YAML 1000001.2\n--- a\n"+  check+    "minor version beyond the limit"+    (1, 1, "unsupported YAML version")+    "%YAML 1.1000001\n--- a\n"+  check+    "version beyond Int"+    (1, 1, "unsupported YAML version")+    "%YAML 18446744073709551617.2\n--- a\n"+  check+    "minor version beyond Int"+    (1, 1, "unsupported YAML version")+    ("%YAML 1." <> T.replicate 100000 "9" <> "\n--- a\n")+  assertEqual+    "minor version at the limit"+    (Right [Just (S.YamlVersion 1 1000000)])+    (map (.version) <$> S.parseDocumentsText "%YAML 1.1000000\n--- a\n")+  assertEqual+    "version with leading zeros"+    (Right [Just (S.YamlVersion 1 2)])+    (map (.version) <$> S.parseDocumentsText "%YAML 001.0002\n--- a\n")+  check+    "verbatim tag without a name"+    (1, 1, "invalid verbatim tag")+    "!<!> a\n"+  check+    "verbatim tag without a scheme"+    (1, 1, "invalid verbatim tag")+    "!<$:?> a\n"+  check+    "empty verbatim tag"+    (1, 1, "invalid verbatim tag")+    "!<> a\n"+  let badEscape = "invalid escape in the tag, write '%' and two hexadecimal digits"+  check+    "escape without digits in a tag"+    (1, 6, badEscape)+    "x: !a%zz b\n"+  check+    "escape with one digit in a tag"+    (1, 6, badEscape)+    "x: !a%4 b\n"+  check+    "escape without digits in a tag prefix"+    (1, 8, badEscape)+    "%TAG ! %\xE9\n--- a\n"+  check+    "secondary handle without a suffix"+    (1, 6, "expected the rest of the tag after !!")+    "a: !! z\n"+  check+    "invalid UTF-8 in a tag"+    (1, 1, "the escapes of the tag are not valid UTF-8")+    "!!str%FF a\n"+  assertEqual+    "character from the escapes of the prefix and the suffix"+    (Right ["tag:\xE9"])+    $ map (\d -> case d.root.props.tag of S.Tag t -> t; _ -> "")+      <$> S.parseDocumentsText "%TAG !e! tag:%C3\n--- !e!%A9 a\n"+  assertEqual+    "valid verbatim tags"+    (Right ["!bar", "tag:yaml.org,2002:str"])+    (map valueTag <$> decodeText @[Value] "[!<!bar> a, !<tag:yaml.org,2002:str> b]")+  assertEqual+    "escapes of verbatim tags"+    (Right ["!foo!", "tag:example.com,2000:\xE9"])+    $ map valueTag+      <$> decodeText @[Value] "[!<!foo%21> a, !<tag:example.com,2000:%C3%A9> b]"+  check+    "invalid UTF-8 in a verbatim tag"+    (1, 1, "the escapes of the tag are not valid UTF-8")+    "!<!a%FF> b\n"
+ tests/Yamlet/Test/Decode/Values.hs view
@@ -0,0 +1,519 @@+-- | Decoding into the types of the library and of the user with the+-- functions of the parser, and the decoded values: their locations, and that+-- they hold no thunks and no slices of the input.+module Yamlet.Test.Decode.Values+  ( valueTests+  ) where++import Control.Exception+import Data.Bifunctor+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Internal qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Internal.Parser.Monad qualified as P+import Yamlet.Syntax qualified as S+import Yamlet.Test.Decode.Helpers+import Yamlet.Test.Helpers+import Yamlet.Test.Helpers.Thunks++valueTests :: TestTree+valueTests =+  testGroup+    "values"+    [ testCase "record" test_record+    , testCase "notFollowedBy" test_notFollowedBy+    , testCase "containers" test_containers+    , testCase "copies" test_copies+    , testCase "JSON" test_json+    , testCase "aliases" test_aliases+    , testCase "optional keys" test_optionalKeys+    , testCase "located values" test_located+    , testCase "syntax tree" test_syntaxTree+    , testCase "no thunks" test_noThunks+    ]++-- | The decoders of the types that the library defines return values without+-- thunks.+test_noThunks :: Assertion+test_noThunks = do+  check "value" (decodeText @Value input)+  check "node" (decodeText @S.Node input)+  check "commented values" (decodeText @(M.Map Value (Commented Value)) input)+  check "located values" (decodeText @(M.Map Value (Located Value)) input)+  check "value with its document" (decodeWithDocument @Value input)+  where+    input :: T.Text+    input =+      T.unlines+        [ "# The anchor."+        , "a: &x [1, 2.5, -.inf, \"s\"] # the list"+        , "b: *x"+        , "? [k, 1]"+        , ": {n: null, t: true, !custom tag: !custom v}"+        , "c: |"+        , "  text"+        ]++    check :: String -> Either (NE.NonEmpty Error) a -> Assertion+    check preface = \case+      Right x -> thunks x >>= assertEqual preface []+      Left errs -> assertFailure (preface ++ ": " ++ show errs)++-- | An error inside 'P.notFollowedBy' is not lost.+test_notFollowedBy :: Assertion+test_notFollowedBy = do+  let T.Text arr off len = "a"+      e =+        P.Env+          { P.array = arr+          , P.base = off+          , P.end = off + len+          , P.streamEnd = off + len+          , P.handles = M.empty+          }+  case P.runParser e off (P.notFollowedBy (P.throwAt off "boom")) of+    Left (P.ParseError _ msg) ->+      assertEqual+        "message"+        "boom"+        msg+    Left (P.UnexpectedParseError _ _) -> assertFailure "expected an error with a message"+    Right _ -> assertFailure "expected an error"++test_containers :: Assertion+test_containers = do+  assertEqual+    "set"+    (Right (Set.fromList [1, 2, 3]))+    (decodeText @(Set.Set Int) "[3, 1, 2]")+  assertEqual+    "set with a duplicate"+    (Just ((1, 5, "duplicate element 1.0"), (1, 2, "the first element 1")))+    (errorWithNote (decodeText @(Set.Set Double) "[1, 1.0]"))+  assertEqual+    "set with an equal element"+    (Just ((1, 5, "duplicate element 1"), (1, 2, "the first element 1")))+    (errorWithNote (decodeText @(Set.Set Int) "[1, 1]"))+  assertEqual+    "int map"+    (Right (IM.fromList [(1, "a"), (2, "b")]))+    (decodeText @(IM.IntMap T.Text) "{2: b, 1: a}")+  assertEqual+    "int map with a duplicate key"+    ( Just+        ( (1, 8, "duplicate key 0x1, the same value as the first key")+        , (1, 2, "the first key 1")+        )+    )+    (errorWithNote (decodeText @(IM.IntMap T.Text) "{1: a, 0x1: b}"))+  assertEqual+    "int set"+    (Right (IS.fromList [1, 2, 3]))+    (decodeText @IS.IntSet "[3, 1, 2]")+  assertEqual+    "int set with a duplicate"+    (Just ((1, 5, "duplicate element 0x1"), (1, 2, "the first element 1")))+    (errorWithNote (decodeText @IS.IntSet "[1, 0x1]"))+  assertEqual+    "sequence"+    (Right (Seq.fromList [1, 2]))+    (decodeText @(Seq.Seq Int) "[1, 2]")+  assertEqual+    "left"+    (Right (Left 1))+    (decodeText @(Either Int T.Text) "{Left: 1}")+  assertEqual+    "right"+    (Right (Right "a"))+    (decodeText @(Either Int T.Text) "{Right: a}")+  assertEqual+    "either with another key"+    (Just (1, 2, "expected the key Left or Right"))+    (errorOf (decodeText @(Either Int Int) "{Up: 1}"))+  assertEqual+    "either with two keys"+    (Just (1, 1, "expected a mapping with one key, Left or Right"))+    (errorOf (decodeText @(Either Int Int) "{Left: 1, Right: 2}"))+  assertEqual+    "tuple of 4"+    (Right (1, 'a', True, "b"))+    (decodeText @(Int, Char, Bool, T.Text) "[1, a, true, b]")+  assertEqual+    "tuple of 10"+    (Right (1, 2, 3, 4, 5, 6, 7, 8, 9, 10))+    $ decodeText @(Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)+      "[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"+  assertEqual+    "tuple of 10 with the wrong size"+    (Just (1, 1, "expected a list of 10 elements, but got 1"))+    (errorOf (decodeText @(Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) "[1]"))++test_record :: Assertion+test_record = do+  assertEqual+    "full"+    (Right Config {name = "x", paths = ["a", "b"], jobs = 4})+    (decodeText "name: x\npaths: [a, b]\njobs: 4\n")+  assertEqual+    "defaults"+    (Right Config {name = "x", paths = [], jobs = 1})+    (decodeText "name: x\npaths:\n")+  assertEqual+    "keys of a map that convert to the same key"+    (Just ((2, 1, "duplicate key 1.0 after conversion"), (1, 1, "the first key 1")))+    (errorWithNote (decodeText @(M.Map Double Int) "1: 1\n1.0: 2\n"))+  assertEqual+    "string keys with the same text"+    (Just ((2, 6, "duplicate key \"name\""), (1, 1, "the first key \"name\"")))+    (errorWithNote (decodeText @Config "name: x\n!foo name: y\n"))+  assertEqual+    "duplicate keys that are not ASCII"+    (Just ((2, 1, "duplicate key \"ż\""), (1, 1, "the first key \"ż\"")))+    (errorWithNote (decodeText @Value "ż: 1\nż: 2\n"))+  assertEqual+    "several string keys with the same text and a bad field"+    [ (2, 1, "duplicate key \"name\"")+    , (1, 6, "the first key \"name\"")+    , (3, 7, "expected an integer, but got a string")+    , (4, 6, "duplicate key \"jobs\"")+    , (3, 1, "the first key \"jobs\"")+    ]+    (errorsOf (decodeText @Config "!foo name: x\nname: y\njobs: z\n!foo jobs: 4\n"))++-- | Decoded texts and error lines do not point into the input.+test_copies :: Assertion+test_copies = do+  case decodeText @(M.Map T.Text T.Text) "key: value\nother: text\n" of+    Left err -> assertFailure (show err)+    Right m -> assertBool "texts are copies" $ all isCopy (M.keys m ++ M.elems m)+  case decodeText @Int "a: 1\nb: [\n" of+    Left errs ->+      assertBool "the source line is a copy" $ all (isCopy . (.sourceLine)) errs+    Right _ -> assertFailure "expected an error"+  case S.parseDocumentsText "key: &a value\nother: *a\n" of+    Left err -> assertFailure (show err)+    Right docs ->+      assertBool "syntax texts are copies" $+        all (all isCopy . texts . (.root) . S.copyDocument) docs+  case decodeText @(M.Map T.Text Node) "key: value\nother: [a, &x b] # c\n" of+    Left err -> assertFailure (show err)+    Right m ->+      assertBool "texts of kept nodes are copies" $ all (all isCopy . texts) (M.elems m)+  case decodeText @Value "a: !x [b, !y c]\n" of+    Left err -> assertFailure (show err)+    Right v -> assertBool "texts of values are copies" $ all isCopy (valueTexts v)+  -- A lazy copy would keep the input alive until the program forces it.+  case decodeText @[T.Text] "- a\n- b\n" of+    Left err -> assertFailure (show err)+    Right xs -> do+      _ <- evaluate (length xs)+      mapM thunks xs >>= assertEqual "items of a list are copies, not thunks" [] . concat+  case S.parseDocumentsText "a: 1\nb: 2\n" of+    Right [doc]+      | Right keys <- runParser (withMapping (pure . objectKeys)) doc.root -> do+          _ <- evaluate (length keys)+          mapM thunks keys+            >>= assertEqual "keys of an object are copies, not thunks" [] . concat+    _ -> assertFailure "expected the keys of the mapping"+  where+    -- A copy starts at the beginning of its own array.+    isCopy :: T.Text -> Bool+    isCopy (T.Text _ off _) = off == 0++    texts :: S.Node -> [T.Text]+    texts n = case n.content of+      S.ScalarContent _ t -> t : maybe [] pure n.props.anchor+      S.SequenceContent _ xs -> concatMap texts xs+      S.MappingContent _ kvs -> concatMap (\(k, v) -> texts k ++ texts v) kvs+      S.AliasContent name -> [name]++    valueTexts :: Value -> [T.Text]+    valueTexts = \case+      String t -> [t]+      Sequence xs -> concatMap valueTexts xs+      Mapping kvs -> concatMap (\(k, v) -> valueTexts k ++ valueTexts v) kvs+      Tagged tag v -> tag : valueTexts v+      _ -> []++-- | JSON is valid YAML, including the escapes that JSON encoders write.+test_json :: Assertion+test_json = do+  assertEqual+    "document"+    (Right (M.fromList [("a", [1.5, -2e3]), ("b\tc", [])]))+    (decodeText @(M.Map T.Text [Double]) "{\"a\":[1.5,-2E3],\n\t\"b\\tc\": []}")+  assertEqual+    "characters beyond C0 that only quoted scalars can contain"+    (Right (M.fromList [("k\x9F", ["x\DEL", "\x80", "\xFFFE\xFFFF", "'\DEL'"])]))+    $ decodeText @(M.Map T.Text [T.Text])+      "{\"k\x9F\": [\"x\DEL\", \"\x80\", \"\xFFFE\xFFFF\", '''\DEL''']}"+  assertEqual+    "surrogate pair"+    (Right ["\x1F600", "a\x10000z"])+    (decodeText @[T.Text] "[\"\\ud83d\\ude00\", \"a\\uD800\\uDC00z\"]")+  assertEqual+    "lone high surrogate"+    (Just (1, 3, "invalid escape sequence"))+    (errorOf (decodeText @[T.Text] "[\"\\ud83d\"]"))+  assertEqual+    "high surrogate without a low one"+    (Just (1, 3, "invalid escape sequence"))+    (errorOf (decodeText @[T.Text] "[\"\\ud83d\\u0041\"]"))+  assertEqual+    "lone low surrogate"+    (Just (1, 3, "invalid escape sequence"))+    (errorOf (decodeText @[T.Text] "[\"\\ude00\"]"))++test_aliases :: Assertion+test_aliases = do+  assertEqual+    "map"+    (Right (M.fromList [("a", [1, 2]), ("b", [1, 2])]))+    (decodeText @(M.Map T.Text [Int]) "a: &x [1, 2]\nb: *x\n")+  assertEqual+    "anchor before a string with a less-than sign"+    (Right (M.fromList [("a", "<x"), ("b", "<x")]))+    (decodeText @(M.Map T.Text T.Text) "a: &x \"<x\"\nb: *x\n")+  assertEqual+    "anchor inside a node with the same anchor"+    (Right (Sequence [Sequence [Int 1], Int 1]))+    (decodeText @Value "- &a [&a 1]\n- *a\n")+  assertEqual+    "anchor inside a node with the same anchor, typed"+    (Right ([1], 1))+    (decodeText @([Int], Int) "- &a [&a 1]\n- *a\n")+  assertEqual+    "anchor inside a mapping with the same anchor"+    (Right (M.fromList [("x", 1)], 1))+    (decodeText @(M.Map T.Text Int, Int) "- &a {x: &a 1}\n- *a\n")+  assertEqual+    "error inside an alias"+    [ (1, 11, "expected an integer, but got a string")+    , (2, 4, "expected an integer, but got a string")+    , (3, 4, "expected an integer, but got a string")+    ]+    (errorsOf (decodeText @(M.Map T.Text [Int]) "a: &x [1, x]\nb: *x\nc: *x\n"))+  assertEqual+    "path of an error inside an alias"+    (Left [(2, 3, [Index 1])])+    $ first+      ( map (\err -> (err.location.line, err.location.column, pathElements err.path))+          . NE.toList+      )+      (decodeText @([T.Text], [Int]) "- &x [a, b]\n- *x\n")++test_optionalKeys :: Assertion+test_optionalKeys = do+  let check :: String -> (Maybe (Maybe Int), Maybe (Maybe Int)) -> T.Text -> Assertion+      check preface expected input =+        assertEqual+          preface+          (Right (Right expected))+          $ runParser+            ( withMapping $ \o ->+                (,)+                  <$> parseFieldMaybe o "a"+                  <*> parseFieldIfPresent o "a"+            )+            <$> decodeText input+  check+    "missing"+    (Nothing, Nothing)+    "b: 1\n"+  check+    "null"+    (Nothing, Just Nothing)+    "a: null\n"+  check+    "value"+    (Just (Just 1), Just (Just 1))+    "a: 1\n"+  let explicit+        :: String+        -> Either (NE.NonEmpty (Offset, String)) (Int, Maybe Int, Maybe (Maybe Int))+        -> T.Text+        -> Assertion+      explicit preface expected input =+        assertEqual+          preface+          (Right expected)+          $ runParser+            ( withMapping $ \o ->+                (,,)+                  <$> parseFieldWith small o "a"+                  <*> parseFieldMaybeWith small o "b"+                  <*> parseFieldIfPresentWith (parseYaml @(Maybe Int)) o "b"+            )+            <$> decodeText input+      small :: Node -> Parser Int+      small = withInt $ \i -> if i < 10 then pure (fromInteger i) else fail "too large"+  explicit+    "explicit, missing"+    (Right (1, Nothing, Nothing))+    "a: 1\n"+  explicit+    "explicit, null"+    (Right (1, Nothing, Just Nothing))+    "a: 1\nb: null\n"+  explicit+    "explicit, value"+    (Right (1, Just 2, Just (Just 2)))+    "a: 1\nb: 2\n"+  explicit+    "explicit, missing key"+    (Left (pure (Offset 0, "missing key \"a\"")))+    "b: 1\n"+  explicit+    "explicit, bad value"+    (Left (pure (Offset 3, "too large")))+    "a: 20\n"+  let keyError+        :: (Object -> T.Text -> Parser (Maybe Int))+        -> Either (NE.NonEmpty (Offset, String)) (Maybe Int)+      keyError op =+        either+          (error . show)+          (runParser (withMapping (`op` "404")))+          (decodeText "200: 1\n404: 2\n")+      integerKey :: Either (NE.NonEmpty (Offset, String)) (Maybe Int)+      integerKey = Left (pure (Offset 7, "the key \"404\" is an integer, not a string"))+  assertEqual+    "optional integer key"+    integerKey+    (keyError parseFieldMaybe)+  assertEqual+    "optional integer key, null as a value"+    integerKey+    (keyError parseFieldIfPresent)+  assertEqual+    "explicit optional integer key"+    integerKey+    (keyError (parseFieldMaybeWith parseYaml))+  assertEqual+    "explicit optional integer key, null as a value"+    integerKey+    (keyError (parseFieldIfPresentWith parseYaml))++-- | A located value keeps the offset of its node, and the errors at its offset+-- have lines, columns and paths.+test_located :: Assertion+test_located = do+  assertEqual+    "items"+    (Right [Located "a" (Offset 1), Located "b" (Offset 4)])+    (decodeText @[Located T.Text] "[a, b]")+  let input = "skip:\n  - x\n  - y\n"+  case decodeWithDocument @(M.Map T.Text [Located T.Text]) input of+    Right (m, doc) -> do+      let errs =+            [ (item.offset, "unknown package " ++ show item.value)+            | item <- M.findWithDefault [] "skip" m+            , item.value == "y"+            ]+      assertEqual+        "error at a located value"+        [(3, 5, "skip[1]", "unknown package \"y\"")]+        [ (e.location.line, e.location.column, renderPath e.path, e.message)+        | e <- documentErrors input doc errs+        ]+      assertEqual+        "error without an offset"+        ["conf.yml: not from the input"]+        $ map+          (prettyError "conf.yml")+          (documentErrors input doc [(noOffset, "not from the input")])+    Left errs -> assertFailure (show errs)+  assertEqual+    "second document"+    (errorOf (decodeText @Int "1\n--- 2\n"))+    (errorOf (decodeWithDocument @Int "1\n--- 2\n"))+  assertEqual+    "empty stream"+    ( Right+        ( Nothing+        , S.document $+            S.Node+              { S.offset = Offset 0+              , S.endOffset = Offset 0+              , S.props = S.noProps+              , S.comments = S.noComments+              , S.content = S.ScalarContent S.Plain ""+              }+        )+    )+    (decodeWithDocument @(Maybe Int) "")+  assertEqual+    "comments of the key"+    (Right (Just (Offset 3, Just "c")))+    $ fmap (\l -> (l.offset, l.value.comments.inline)) . M.lookup "a"+      <$> decodeText @(M.Map T.Text (Located (Commented T.Text))) "a: x # c\n"+  assertEqual+    "encoded"+    "a: 1\n"+    (encodeText @(M.Map T.Text (Located Int)) (M.fromList [("a", Located 1 (Offset 7))]))++test_syntaxTree :: Assertion+test_syntaxTree = do+  let input = "# The build.\nname: x\njobs: 4 # At most.\n"+  case S.parseDocumentsText input of+    Right [doc] -> do+      assertEqual+        "parsed"+        (Right Config {name = "x", paths = [], jobs = 4})+        (decodeDocument input doc)+      let changed = doc {S.root = S.mappingNode [(S.plainNode "name", S.plainNode "y")]}+      assertEqual+        "changed"+        (Right Config {name = "y", paths = [], jobs = 1})+        (decodeDocument input changed)+    r -> assertFailure (show r)+  case S.parseDocumentsText "name: x\njobs: many\n" of+    Right [doc] -> do+      assertEqual+        "type error"+        (Just (2, 7, "expected an integer, but got a string"))+        (errorOf (decodeDocument @Config "name: x\njobs: many\n" doc))+      let firstLines :: Either (NE.NonEmpty Error) Config -> [String]+          firstLines =+            either (map (takeWhile (/= '\n') . prettyError "f.yaml") . NE.toList) (const [])+      case doc.root.content of+        S.MappingContent _ [_, (_, jobs)] -> do+          let mixed =+                S.document+                  (S.mappingNode [(S.plainNode "name", S.plainNode "y"), (S.plainNode "jobs", jobs)])+          assertEqual+            "parsed node in a built document, with its input"+            ["f.yaml:2:7: jobs: expected an integer, but got a string"]+            (firstLines (decodeDocument "name: x\njobs: many\n" mixed))+          assertEqual+            "parsed node in a built document, without its input"+            ["f.yaml: jobs: expected an integer, but got a string"]+            (firstLines (decodeDocument "" mixed))+        c -> assertFailure (show c)+    r -> assertFailure (show r)+  let key = S.plainNode "a"+      built = S.document (S.mappingNode [(key, key), (key, key)])+  assertEqual+    "built"+    (Just ((0, 0, "duplicate key \"a\""), (0, 0, "the first key \"a\"")))+    (errorWithNote (decodeDocument @Value "" built))+  assertEqual+    "built, rendered"+    (Left ["built.yaml: duplicate key \"a\"", "built.yaml: the first key \"a\""])+    $ either+      (Left . map (prettyError "built.yaml") . NE.toList)+      (const (Right ()))+      (decodeDocument @Value "" built)+  assertEqual+    "decoder error in a built node"+    (Just (0, 0, "expected an integer, but got a string"))+    (errorOf (decodeDocument @Int "" (S.document (S.plainNode "x"))))
+ tests/Yamlet/Test/Encode.hs view
@@ -0,0 +1,16 @@+module Yamlet.Test.Encode (encodeTests) where++import Test.Tasty++import Yamlet.Test.Encode.Comments+import Yamlet.Test.Encode.Properties+import Yamlet.Test.Encode.Values++encodeTests :: TestTree+encodeTests =+  testGroup+    "encode"+    [ valueTests+    , commentTests+    , propertyTests+    ]
+ tests/Yamlet/Test/Encode/Comments.hs view
@@ -0,0 +1,317 @@+-- | The encodings of syntax trees, kept nodes and comments.+module Yamlet.Test.Encode.Comments+  ( commentTests+  ) where++import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Set qualified as Set+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Helpers++commentTests :: TestTree+commentTests =+  testGroup+    "comments"+    [ testCase "syntax tree" test_syntax+    , testCase "kept nodes" test_keptNodes+    , testCase "comments of keys" test_commentedKeys+    ]++test_syntax :: Assertion+test_syntax =+  assertEqual+    "output"+    expected+    (S.renderSyntax S.defaultRenderOptions [S.document (edit value)])+  where+    value :: S.Node+    value = mapping ["name" .= ("x" :: T.Text), "paths" .= ["a" :: T.Text, "b"]]++    -- Add a comment above the first key and use the flow style for the list.+    edit :: S.Node -> S.Node+    edit n = case n.content of+      S.MappingContent style [(k1, v1), (k2, v2)] ->+        n+          { S.content =+              S.MappingContent+                style+                [+                  ( k1 {S.comments = S.noComments {S.before = [S.Comment "The name."]}}+                  , v1+                  )+                , (k2, v2 {S.content = flow v2.content})+                ]+          }+      _ -> n++    flow :: S.Content -> S.Content+    flow = \case+      S.SequenceContent _ xs -> S.SequenceContent S.Flow xs+      c -> c++    expected :: T.Text+    expected = T.unlines ["# The name.", "name: x", "paths: [a, b]"]++-- | A record that keeps a part of its document as it was written.+data Workflow = Workflow {name :: T.Text, jobs :: Int, matrix :: Node}++instance FromYaml Workflow where+  parseYaml = withMapping $ \o ->+    Workflow+      <$> parseField o "name"+      <*> parseField o "jobs"+      <*> parseField o "matrix"++instance ToYaml Workflow where+  toYaml w = mapping ["name" .= w.name, "jobs" .= w.jobs, "matrix" .= w.matrix]++test_keptNodes :: Assertion+test_keptNodes = do+  case decodeText @Workflow input of+    Left errs -> assertFailure (unlines (map (prettyError "input") (NE.toList errs)))+    Right w -> do+      assertEqual+        "decoded field"+        "demo"+        w.name+      assertEqual+        "output"+        expected+        (encodeText Workflow {name = w.name, jobs = 8, matrix = w.matrix})+  assertEqual+    "kept nodes in a list"+    (Right "- ['9.10', \"9.12\"] # versions\n- {a: 1}\n")+    (encodeText <$> decodeText @[Node] "- ['9.10', \"9.12\"] # versions\n- {a: 1}\n")+  assertEqual+    "comments inside an alias"+    (Right "a: &x\n  k: v # c1\nb: # c2\n  k: v\n")+    (encodeText <$> decodeText @Node "a: &x\n  k: v # c1\nb: *x # c2\n")+  -- The comment belongs to the mapping, and a map has no place for it.+  assertEqual+    "comment after the tag of a mapping"+    (Right "a: 1\n")+    (encodeText <$> decodeText @(M.Map T.Text (Commented Node)) "!!map # c1\na: 1\n")+  assertEqual+    "lines above the first key of a mapping"+    (Right (M.fromList [("b", [Comment "c2"])]))+    $ M.map (.comments.before)+      <$> decodeText @(M.Map T.Text (Commented Int)) "# c1\n\n# c2\nb: 1\n"+  assertEqual+    "comment after the tag of a list"+    (Right "- 1\n")+    (encodeText <$> decodeText @[Commented Node] "!!seq # c1\n- 1\n")+  let valueLines = "# c1\nk:\n  # c2\n\n  # c3\n  - 1\n"+  assertEqual+    "lines above the first item of a value"+    (Right "# c1\nk:\n# c2\n\n# c3\n- 1\n")+    $ encodeText+      <$> decodeText @(M.Map T.Text (Commented (Commented [Commented Int]))) valueLines+  -- The lines belong to the list, and the comments of the entry have no place+  -- for them.+  assertEqual+    "lines above the first item of a value without a commented list"+    (Right "# c1\nk:\n# c3\n- 1\n")+    (encodeText <$> decodeText @(M.Map T.Text (Commented [Commented Int])) valueLines)+  let scalarRoot = "|\n  text\n# end\n"+  assertEqual+    "lines at the end of a scalar root"+    (Right scalarRoot)+    (encodeText <$> decodeText @Node scalarRoot)+  assertEqual+    "scalar root in a list"+    (Right "- |\n  text\n# end\n- 1\n")+    (encodeText . (: [toYaml @Int 1]) <$> decodeText @Node scalarRoot)+  where+    input :: T.Text+    input =+      T.unlines+        [ "name: demo"+        , "jobs: 4"+        , "matrix:"+        , "  # The operating systems."+        , "  os: [ubuntu, macos] # two for now"+        , "  ghc: ['9.10', \"9.12\"]"+        , "  base: &b"+        , "    x: 1"+        , "  copy: *b"+        ]++    -- The alias becomes a copy of the node that it refers to.+    expected :: T.Text+    expected =+      T.unlines+        [ "name: demo"+        , "jobs: 8"+        , "matrix:"+        , "  # The operating systems."+        , "  os: [ubuntu, macos] # two for now"+        , "  ghc: ['9.10', \"9.12\"]"+        , "  base: &b"+        , "    x: 1"+        , "  copy:"+        , "    x: 1"+        ]++-- | A record that keeps the comments of a key.+data Job = Job {name :: T.Text, permissions :: Commented Node}++instance FromYaml Job where+  parseYaml = withMapping $ \o ->+    Job+      <$> parseField o "name"+      <*> parseField o "permissions"++instance ToYaml Job where+  toYaml j = mapping ["name" .= j.name, "permissions" .= j.permissions]++test_commentedKeys :: Assertion+test_commentedKeys = do+  let job =+        T.unlines+          [ "name: build"+          , "# The test reporter writes check runs."+          , "permissions: # read-only"+          , "  contents: read"+          ]+  assertEqual+    "record"+    (Right job)+    (encodeText <$> decodeText @Job job)+  assertEqual+    "map"+    (Right "# one\na: 1\nb: 2 # two\n")+    $ encodeText+      <$> decodeText @(M.Map T.Text (Commented Int)) "# one\na: 1\nb: 2 # two\n"+  -- The parser gives the lines before the marker and at the end to the+  -- document, and the decoder gives them to the root. The renderer separates+  -- the lines of a block root from its first entry, so that they read back+  -- as the lines of the root.+  let top = "# top\n\na: 1\n# end\n"+  assertEqual+    "comments of the document"+    (Right top)+    $ encodeText+      <$> decodeText @(Commented (M.Map T.Text Int)) "# top\n---\na: 1\n# end\n"+  assertEqual+    "comments of the document read back"+    (Right top)+    (encodeText <$> decodeText @(Commented (M.Map T.Text Int)) top)+  let either_ = "# The name.\nLeft: foo # current\n"+  assertEqual+    "key of an either"+    (Right either_)+    (encodeText <$> decodeText @(Either (Commented T.Text) Int) either_)+  let set = "# first\n- a # one\n- b\n"+  assertEqual+    "set"+    (Right set)+    (encodeText <$> decodeText @(Set.Set (Commented T.Text)) set)+  -- The comment after 1 belongs to the value, which an integer cannot keep.+  assertEqual+    "keys of a map"+    (Right "# above\na: 1\n")+    (encodeText <$> decodeText @(M.Map (Commented T.Text) Int) "# above\na: 1 # c\n")+  -- Both take the comments of the key, and the encoder writes them once.+  assertEqual+    "keys and values of a map"+    (Right "# above\na: 1 # c\n")+    $ encodeText+      <$> decodeText @(M.Map (Commented T.Text) (Commented Int)) "# above\na: 1 # c\n"+  assertEqual+    "comments of an explicit key and its value"+    (Right "# above\n# k\na: 1 # v\n")+    $ encodeText+      <$> decodeText @(M.Map (Commented T.Text) (Commented Int)) "# above\n? a # k\n: 1 # v\n"+  assertEqual+    "built keys keep the comments that their values lack"+    "# on key\na: 1 # k\n# on value\nb: 2 # k\n"+    . encodeText+    $ M.fromList+      [+        ( Commented @T.Text "a" noComments {before = [Comment "on key"], inline = Just "k"}+        , Commented @Int 1 noComments+        )+      ,+        ( Commented "b" noComments {inline = Just "k"}+        , Commented 2 noComments {before = [Comment "on value"]}+        )+      ]+  let nodes = "os: [a, b] # two\nsteps:\n- x\n  # end\n"+  assertEqual+    "nodes keep their comments once"+    (Right nodes)+    (encodeText <$> decodeText @(M.Map T.Text (Commented Node)) nodes)+  assertEqual+    "list items"+    (Right [noComments {before = [Comment "c"]}, noComments {inline = Just "d"}])+    (map (.comments) <$> decodeText @[Commented Int] "# c\n- 1\n- 2 # d\n")+  -- The comment after the list belongs to the entry, and the comment above+  -- the first item belongs to the item.+  let branches =+        "branches: # which branches\n# the main branch\n- main # the old default\n- dev\n  # more later\n"+  assertEqual+    "commented items"+    (Right branches)+    (encodeText <$> decodeText @(M.Map T.Text (Commented [Commented T.Text])) branches)+  let commentedRoot = "# c1\n1 # c2\n# c3\n"+  assertEqual+    "commented scalar root"+    (Right commentedRoot)+    (encodeText <$> decodeText @(Commented Int) commentedRoot)+  let linesAfter =+        M.fromList @T.Text @(Commented Int)+          [ ("a", Commented 1 noComments {after = [Comment "c"]})+          , ("b", Commented 2 noComments)+          ]+  assertEqual+    "lines after a commented scalar value"+    "a: 1\n  # c\nb: 2\n"+    (encodeText linesAfter)+  assertEqual+    "lines after a commented scalar value read back"+    (Right (M.map (.comments) linesAfter))+    $ M.map (.comments)+      <$> decodeText @(M.Map T.Text (Commented Int)) (encodeText linesAfter)+  let quotedLinesAfter = "a: \"x\\r\\ny\"\n  # c\nb: d\n"+  assertEqual+    "lines after a text of several lines in double quotes"+    (Right quotedLinesAfter)+    (encodeText <$> decodeText @(M.Map T.Text (Commented T.Text)) quotedLinesAfter)+  let linesAbove =+        [ Commented @[Int]+            [1, 2]+            noComments {before = [Comment "above"], inline = Just "inline"}+        ]+  assertEqual+    "lines above a commented list item"+    "# above\n- # inline\n  - 1\n  - 2\n"+    (encodeText linesAbove)+  assertEqual+    "lines above a commented list item read back"+    (Right [noComments {before = [Comment "above"], inline = Just "inline"}])+    (map (.comments) <$> decodeText @[Commented [Int]] (encodeText linesAbove))+  -- A collection on the line of its indicator takes the lines above the+  -- indicator, so it starts below the indicator to leave them to its first+  -- entry.+  let above = noComments {before = [Comment "c"]}+      nestedItem = [[Commented @Int 1 above]]+      firstKey =+        [ M.fromList @T.Text+            [("a", Commented @Int 1 above), ("b", Commented 2 noComments)]+        ]+  assertEqual+    "lines above a nested first item"+    "# c\n-\n  - 1\n"+    (encodeText nestedItem)+  roundTrip "lines above a nested first item read back" nestedItem+  assertEqual+    "lines above a first key"+    "# c\n-\n  a: 1\n  b: 2\n"+    (encodeText firstKey)+  roundTrip "lines above a first key read back" firstKey
+ tests/Yamlet/Test/Encode/Properties.hs view
@@ -0,0 +1,259 @@+-- | The properties of the encoder on random values and syntax trees.+module Yamlet.Test.Encode.Properties+  ( propertyTests+  ) where++import Data.List qualified as L+import Data.Scientific qualified as Sci+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.QuickCheck++import Yamlet+import Yamlet.Syntax qualified as S++propertyTests :: TestTree+propertyTests =+  testGroup+    "properties"+    [ -- The renderers differ only in rare cases, e.g. for a key that needs an+      -- explicit entry. 10000 cases take about 0.2 s.+      localOption (QuickCheckTests 10000) $ testProperty "fast renderer" prop_fastRenderer+    , testProperty "fast renderer of several documents" prop_fastRendererAll+    , localOption (QuickCheckTests 10000) $+        testProperty "fast renderer of syntax trees" prop_fastRendererNodes+    , testProperty "round trip" prop_roundTrip+    , testProperty "syntax round trip" prop_syntaxRoundTrip+    ]++-- | The faster renderer of the encoder gives the same output as the renderer+-- of syntax trees.+prop_fastRenderer :: Doc -> Property+prop_fastRenderer (Doc n) =+  encodeText n === S.renderSyntax S.defaultRenderOptions [S.document (toYaml n)]++-- | The same for several documents.+prop_fastRendererAll :: [Doc] -> Property+prop_fastRendererAll docs =+  encodeAllText ns+    === S.renderSyntax S.defaultRenderOptions (map (S.document . toYaml) ns)+  where+    ns :: [Value]+    ns = [n | Doc n <- docs]++-- | The same for syntax trees that the faster renderer takes, with what the+-- trees of values do not have: tags on keys and on collections, scalar keys+-- in each style and keys of more than 1024 characters.+prop_fastRendererNodes :: SimpleNode -> Property+prop_fastRendererNodes (SimpleNode n) =+  encodeText n === S.renderSyntax S.defaultRenderOptions [S.document n]++-- | A tree without comments, anchors, aliases and flow collections, with+-- scalars on one line in the styles of the encoder.+newtype SimpleNode = SimpleNode S.Node+  deriving stock (Show)++instance Arbitrary SimpleNode where+  arbitrary = SimpleNode <$> sized genNode+    where+      genNode :: Int -> Gen S.Node+      genNode size+        | size <= 1 = genScalar+        | otherwise =+            frequency+              [ (3, genScalar)+              , (1, collection S.sequenceNode (genNode (size `div` 3)))+              ,+                ( 1+                , collection+                    S.mappingNode+                    ((,) <$> genNode (size `div` 3) <*> genNode (size `div` 3))+                )+              , (1, elements [S.sequenceNode [], S.mappingNode []] >>= withTag)+              ]++      collection :: ([a] -> S.Node) -> Gen a -> Gen S.Node+      collection node item = do+        k <- choose (1, 3)+        xs <- vectorOf k item+        withTag (node xs)++      genScalar :: Gen S.Node+      genScalar = do+        style <- elements [S.Plain, S.SingleQuoted, S.DoubleQuoted, S.Literal]+        t <- genText+        -- The faster renderer does not take an empty plain scalar.+        withTag (S.scalarNode style (if style == S.Plain && T.null t then "x" else t))++      withTag :: S.Node -> Gen S.Node+      withTag n = do+        tag <-+          frequency+            [ (4, pure S.NoTag)+            , (1, S.Tag <$> elements ["!t", "xy", "tag:yaml.org,2002:str", "", "a#b"])+            ]+        pure n {S.props = S.Props Nothing tag}++      genText :: Gen T.Text+      genText =+        oneof+          [ elements+              [ ""+              , " "+              , " a"+              , "\ta"+              , "a\n"+              , "\n"+              , " lead\nx"+              , "-"+              , "a: b"+              , "#"+              , "yes"+              , "x'y"+              , "a\x2028b"+              , "a\x01"+              , "---"+              , "a\n\n"+              ]+          , T.pack <$> listOf (elements "ab :#\n\t'\"-")+          , pure (T.replicate 1030 "k")+          ]++-- | Encoding a value and decoding the result gives the same value.+prop_roundTrip :: Doc -> Property+prop_roundTrip (Doc n) = readsBack (encodeText n) n++-- | Rendering the syntax tree of a value and decoding the result gives the+-- same value.+prop_syntaxRoundTrip :: Doc -> Property+prop_syntaxRoundTrip (Doc n) = readsBack output n+  where+    output :: T.Text+    output = S.renderSyntax S.defaultRenderOptions [S.document (toYaml n)]++readsBack :: T.Text -> Value -> Property+readsBack output n = case decodeAllText @Value output of+  Right [n'] -> counterexample (T.unpack output) $ n' === n+  r -> counterexample (T.unpack output ++ "\n" ++ show r) False++newtype Doc = Doc Value+  deriving stock (Show)++instance Arbitrary Doc where+  arbitrary = Doc <$> sized genValue++genValue :: Int -> Gen Value+genValue size+  | size <= 1 = genScalar+  | otherwise =+      frequency+        [ (3, genScalar)+        , (1, Sequence <$> genList)+        , (1, Mapping <$> genEntries)+        , (1, tagged <$> genScalar)+        , (1, Tagged <$> genTag <*> (Sequence <$> genList))+        ]+  where+    genList :: Gen [Value]+    genList = do+      k <- choose (0, 4)+      vectorOf k (genValue (size `div` 3))++    genEntries :: Gen [(Value, Value)]+    genEntries = do+      k <- choose (0, 4)+      keys <- L.nub <$> vectorOf k genKey+      mapM (\key -> (key,) <$> genValue (size `div` 3)) keys++    genKey :: Gen Value+    genKey = frequency [(4, genScalar), (1, elements [Sequence [], Mapping []])]++    -- A tag that is not a valid URI needs a %TAG directive.+    genTag :: Gen T.Text+    genTag = elements ["!custom", "xy"]++    tagged :: Value -> Value+    tagged v = case v of+      String _ -> Tagged "!custom" v+      _ -> v++    genScalar :: Gen Value+    genScalar =+      oneof+        [ pure Null+        , Bool <$> arbitrary+        , Int <$> arbitrary+        , Float . Finite <$> (Sci.scientific <$> arbitrary <*> chooseInt (-30, 30))+        , Float <$> elements [NegativeZero, Infinity, NegativeInfinity, NaN]+        , String <$> genText+        ]++    genText :: Gen T.Text+    genText =+      oneof+        [ elements tricky+        , T.pack <$> listOf genChar+        , T.intercalate "\n" <$> listOf (T.pack <$> listOf genChar)+        ]+      where+        tricky :: [T.Text]+        tricky =+          [ ""+          , " "+          , "-"+          , "- a"+          , "? a"+          , ": a"+          , "a: b"+          , "a:b"+          , "#"+          , "a #b"+          , "true"+          , "null"+          , "1"+          , "0x1F"+          , "0o7"+          , ".5"+          , "~"+          , "---"+          , "..."+          , "@x"+          , "`x"+          , "foo\n"+          , "\nfoo"+          , "  lead"+          , "trail  "+          , "a\n\nb\n\n"+          , "\t"+          , "é"+          , "\x85"+          , "\x2028"+          , "\xFEFF"+          , "\n"+          , "\n\n"+          , " \n"+          , "a\n "+          , "|"+          , ">"+          , "%x"+          , "&a"+          , "*a"+          , "!a"+          , "{}"+          , "[]"+          , "a, b"+          , "key:"+          , "'quoted'"+          , "\"dq\""+          , "\r\n"+          , "\\"+          , "a\tb"+          ]++        genChar :: Gen Char+        genChar =+          frequency+            [ (10, elements "abc xyz-:#,[]{}'\"!&*?|>%@`\\")+            , (2, elements "\t\r\x85\xA0\x2028\xFEFF\x01\x7F")+            , (1, arbitrary)+            ]
+ tests/Yamlet/Test/Encode/Values.hs view
@@ -0,0 +1,632 @@+module Yamlet.Test.Encode.Values+  ( valueTests+  ) where++import Data.Either+import Data.Fixed+import Data.Functor.Const+import Data.Functor.Identity+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Monoid qualified as Mon+import Data.Ord+import Data.Ratio+import Data.Scientific qualified as Sci+import Data.Semigroup qualified as Sem+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Time+import Data.Time.Calendar.Month+import Data.Time.Calendar.Quarter+import Data.Tree qualified as Tree+import Data.UUID.Types qualified as UUID+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding (Fixed)++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Helpers++valueTests :: TestTree+valueTests =+  testGroup+    "values"+    [ testCase "block style" test_blockStyle+    , testCase "quoting" test_quoting+    , testCase "floats" test_floats+    , testProperty "float format" prop_floatFormat+    , slow $ testCase "long floats" test_longFloats+    , slow $ testCase "long strings like numbers" test_longNumberLikeStrings+    , testCase "literal block scalars" test_literal+    , testCase "tags" test_tags+    , testCase "containers" test_containers+    , testCase "base" test_base+    , testCase "time" test_time+    ]++test_containers :: Assertion+test_containers = do+  assertEqual+    "set"+    "- 1\n- 2\n- 3\n"+    (encodeText (Set.fromList @Int [3, 1, 2]))+  assertEqual+    "int set"+    "- 1\n- 2\n- 3\n"+    (encodeText (IS.fromList [3, 1, 2]))+  assertEqual+    "left"+    "Left: 1\n"+    (encodeText (Left @Int @T.Text 1))+  assertEqual+    "right"+    "Right: a\n"+    (encodeText (Right @Int @T.Text "a"))+  roundTrip "int map" (IM.fromList @T.Text [(1, "a"), (-2, "b")])+  assertEqual+    "map with an empty list key"+    "? []\n: a\n? - 1\n: b\n"+    (encodeText (M.fromList @[Int] @T.Text [([], "a"), ([1], "b")]))+  roundTrip "sequence" (Seq.fromList @Int [1, 2, 3])+  -- Only a String is text.+  assertEqual+    "string"+    "ab\n"+    (encodeText @String "ab")+  assertEqual+    "set of characters"+    "- a\n- b\n"+    (encodeText (Set.fromList "ba"))+  roundTrip "set of characters" (Set.fromList "ab")+  roundTrip "non-empty list of characters" ('a' NE.:| "b")+  roundTrip "sequence of characters" (Seq.fromList "ab")+  roundTrip @[Either Int T.Text] "either" [Left 1, Right "a"]+  let tree = Tree.Node 'a' [Tree.Node 'b' [], Tree.Node 'c' [Tree.Node 'd' []]]+  assertEqual+    "tree"+    "- a\n- - - b\n    - []\n  - - c\n    - - - d\n        - []\n"+    (encodeText tree)+  roundTrip "tree" tree+  let uuid = UUID.fromWords 0x123e4567 0xe89b12d3 0xa4564266 0x14174000+  assertEqual+    "UUID"+    "123e4567-e89b-12d3-a456-426614174000\n"+    (encodeText uuid)+  roundTrip "UUIDs" [uuid, UUID.nil]+  roundTrip @(Int, Char, Bool, T.Text, Double, [Int], Maybe Char, (), Char, Int)+    "tuple of 10"+    (1, 'a', True, "b", 2.5, [1], Just 'c', (), 'd', -1)++test_base :: Assertion+test_base = do+  assertEqual+    "ordering"+    "- LT\n- EQ\n- GT\n"+    (encodeText [LT, EQ, GT])+  assertEqual+    "unit"+    "[]\n"+    (encodeText ())+  roundTrip "unit" ()+  assertEqual+    "ratio"+    "numerator: 1\ndenominator: 3\n"+    (encodeText @Rational (1 % 3))+  assertEqual+    "fixed"+    "1.25\n"+    (encodeText @Centi 1.25)+  assertEqual+    "fixed with a trailing zero"+    "1.5\n"+    (encodeText @Milli 1.5)+  assertEqual+    "whole fixed"+    "3.0\n"+    (encodeText @Uni 3)+  assertEqual+    "newtype"+    "- 1\n- 2\n"+    (encodeText (Identity @[Int] [1, 2]))+  assertEqual+    "string in a newtype"+    "ab\n"+    (encodeText (Sem.Min @String "ab"))+  roundTrip "ordering" [LT, EQ, GT]+  roundTrip @Rational "negative ratio" (negate 7 % 4)+  roundTrip @Milli "fixed" (-123.456)+  roundTrip @Nano "nano" 0.000000001+  roundTrip @(Fixed Quarters) "resolution of a power of 2" (MkFixed 3)+  assertEqual+    "resolution of 2s and 5s"+    "0.025\n"+    (encodeText @(Fixed Fortieths) (MkFixed 1))+  roundTrip @(Fixed Fortieths) "resolution of 2s and 5s" (MkFixed 7)+  assertEqual+    "resolution without a decimal form"+    "0.3\n"+    (encodeText @(Fixed Thirds) (MkFixed 1))+  roundTrip+    "newtypes"+    ( Down 'a'+    , Sem.Max @Int 1+    , Mon.First (Just True)+    , Sem.Sum @Double 2.5+    , Sem.All False+    , Const @Int @Bool 3+    )++-- | A resolution of 1/4, which has an exact decimal form.+data Quarters++instance HasResolution Quarters where+  resolution _ = 4++test_time :: Assertion+test_time = do+  let noon = LocalTime (fromGregorian 2026 9 25) (TimeOfDay 12 30 5.25)+  assertEqual+    "day"+    "2026-09-25\n"+    (encodeText (fromGregorian 2026 9 25))+  assertEqual+    "time, a base-60 number in YAML 1.1"+    "'12:30:00'\n"+    (encodeText (TimeOfDay 12 30 0))+  assertEqual+    "time without trailing zeros"+    "'12:30:15.000001'\n"+    (encodeText (TimeOfDay 12 30 15.000001))+  assertEqual+    "time with picoseconds"+    "'12:30:15.000000000001'\n"+    (encodeText (TimeOfDay 12 30 15.000000000001))+  assertEqual+    "local time"+    "2026-09-25T12:30:05.25\n"+    (encodeText noon)+  assertEqual+    "UTC time"+    "2026-09-25T12:30:00Z\n"+    (encodeText (UTCTime (fromGregorian 2026 9 25) (12 * 3600 + 30 * 60)))+  assertEqual+    "zoned time"+    "2026-09-25T12:30:05.25-02:30\n"+    (encodeText (ZonedTime noon (minutesToTimeZone (-150))))+  assertEqual+    "day of the year 0, which PyYAML cannot build"+    "'0000-01-01'\n"+    (encodeText (fromGregorian 0 1 1))+  assertEqual+    "day of the year 10000"+    "10000-01-01\n"+    (encodeText (fromGregorian 10000 1 1))+  assertEqual+    "UTC leap second"+    "'2016-12-31T23:59:60.5Z'\n"+    (encodeText (UTCTime (fromGregorian 2016 12 31) 86400.5))+  assertEqual+    "local leap second"+    "'2016-12-31T23:59:60'\n"+    (encodeText (LocalTime (fromGregorian 2016 12 31) (TimeOfDay 23 59 60)))+  assertEqual+    "zoned time of the year 0"+    "'0000-06-01T12:00:00+01:00'\n"+    . encodeText+    $ ZonedTime+      (LocalTime (fromGregorian 0 6 1) (TimeOfDay 12 0 0))+      (hoursToTimeZone 1)+  assertEqual+    "hour 24"+    "'2024-01-01T24:00:00'\n"+    (encodeText (LocalTime (fromGregorian 2024 1 1) (TimeOfDay 24 0 0)))+  assertEqual+    "time zone of 25 hours"+    "'2024-01-01T12:00:00+25:00'\n"+    . encodeText+    $ ZonedTime+      (LocalTime (fromGregorian 2024 1 1) (TimeOfDay 12 0 0))+      (hoursToTimeZone 25)+  assertBool+    "time zone of 25 hours does not read back"+    (isLeft (decodeText @ZonedTime (encodeText (ZonedTime noon (hoursToTimeZone 25)))))+  roundTrip "leap second" (UTCTime (fromGregorian 2016 12 31) 86400.5)+  assertEqual+    "duration"+    "1.5\n"+    (encodeText @NominalDiffTime 1.5)+  roundTrip "local time" noon+  roundTrip "UTC time" (UTCTime (fromGregorian (-44) 3 15) 0.000000000001)+  roundTrip "diff time" (picosecondsToDiffTime 123456789)+  assertEqual+    "month"+    "2026-09\n"+    (encodeText (YearMonth 2026 9))+  assertEqual+    "month of a negative year"+    "-0044-03\n"+    (encodeText (YearMonth (-44) 3))+  assertEqual+    "quarter"+    "2026-q3\n"+    (encodeText (YearQuarter 2026 Q3))+  assertEqual+    "quarter of a year"+    "q3\n"+    (encodeText Q3)+  assertEqual+    "day of the week"+    "monday\n"+    (encodeText Monday)+  assertEqual+    "calendar days"+    "months: 1\ndays: 2\n"+    (encodeText (CalendarDiffDays 1 2))+  assertEqual+    "calendar time"+    "months: 1\ntime: 1.5\n"+    (encodeText (CalendarDiffTime 1 1.5))+  roundTrip "months" [YearMonth 2026 1, YearMonth 12345 12, YearMonth (-1) 6]+  roundTrip "quarters" [YearQuarter 2026 Q1, YearQuarter (-5) Q4]+  roundTrip "quarters of a year" [Q1, Q2, Q3, Q4]+  roundTrip "days of the week" [Monday .. Sunday]+  roundTrip "calendar days" (CalendarDiffDays (-3) 40)+  roundTrip "calendar time" (CalendarDiffTime 2 (-0.000000000001))+  assertEqual+    "zoned time with a large offset"+    (Right (noon, 900))+    $ (\z -> (zonedTimeToLocalTime z, timeZoneMinutes (zonedTimeZone z)))+      <$> decodeText (encodeText (ZonedTime noon (minutesToTimeZone 900)))++test_blockStyle :: Assertion+test_blockStyle =+  assertEqual+    "output"+    expected+    (encodeText value)+  where+    value :: S.Node+    value =+      mapping+        [ "source_paths" .= ["." :: T.Text]+        , "exclude_paths" .= ["dist" :: T.Text, "dist-newstyle"]+        , "language" .= ("Haskell2010" :: T.Text)+        , "nested" .= mapping ["a" .= (1 :: Int), "b" .= [[True, False]]]+        , "records" .= [mapping ["x" .= (1.5 :: Double), "y" .= Null]]+        , "empty_list" .= ([] :: [Int])+        , "empty_map" .= mapping []+        ]++    expected :: T.Text+    expected =+      T.unlines+        [ "source_paths:"+        , "- ."+        , "exclude_paths:"+        , "- dist"+        , "- dist-newstyle"+        , "language: Haskell2010"+        , "nested:"+        , "  a: 1"+        , "  b:"+        , "  - - true"+        , "    - false"+        , "records:"+        , "- x: 1.5"+        , "  'y': null"+        , "empty_list: []"+        , "empty_map: {}"+        ]++test_quoting :: Assertion+test_quoting = do+  let check :: T.Text -> T.Text -> Assertion+      check expected s =+        assertEqual+          (show s)+          (expected <> "\n")+          (encodeText s)+  check "dist-newstyle" "dist-newstyle"+  check "-foo" "-foo"+  check "'-'" "-"+  check "'- a'" "- a"+  check "''" ""+  check "'true'" "true"+  check "'null'" "null"+  check "'12'" "12"+  check "'0x1F'" "0x1F"+  check "'1.5'" "1.5"+  check "'a: b'" "a: b"+  check "a:b" "a:b"+  check "'a #b'" "a #b"+  check "a#b" "a#b"+  check "'#a'" "#a"+  check "' a'" " a"+  check "'a '" "a "+  check "'---'" "---"+  check "\"a\\tb\"" "a\tb"+  check "\"\\x01\"" "\x01"+  check "\"\\uFEFF\"" "\xFEFF"+  check "zażółć" "zażółć"+  check "'yes'" "yes"+  check "'Off'" "Off"+  check "'y'" "y"+  check "yesterday" "yesterday"+  -- The texts that YAML 1.1 reads as other types.+  check "'22:22'" "22:22"+  check "'1:30.5'" "1:30.5"+  check "'1:5'" "1:5"+  check "'1:59'" "1:59"+  check "1:60" "1:60"+  check "'1_000'" "1_000"+  check "'0b101'" "0b101"+  check "'0b-1'" "0b-1"+  check "'0_b+1_0'" "0_b+1_0"+  check "-0b-1" "-0b-1"+  check "'1.5_0'" "1.5_0"+  check "'2024-01-01'" "2024-01-01"+  check "'2024-1-1 10:00:00 +02:00'" "2024-1-1 10:00:00 +02:00"+  check "'<<'" "<<"+  check "'='" "="+  check "'09:30'" "09:30"+  check "'1,000'" "1,000"+  check "'0,5'" "0,5"+  check "'trUe'" "trUe"+  check "'.e+9'" ".e+9"+  check "'0X1F'" "0X1F"+  check "'+_85'" "+_85"+  check "'8_11E3'" "8_11E3"+  check "'2024-1-1'" "2024-1-1"+  check "':foo'" ":foo"+  check "Truely" "Truely"+  check "1.2.3" "1.2.3"+  check "2024-01" "2024-01"+  check "\"a\\u2028b\"" "a\x2028\&b"+  check "\"a\\u2029b\"" "a\x2029\&b"+  assertEqual+    "YAML 1.1 boolean as a key"+    "'NO': Norway\n"+    (encodeText (mapping ["NO" .= ("Norway" :: T.Text)]))++-- | A float reads back as a float, not as an integer.+test_floats :: Assertion+test_floats = do+  assertEqual+    "integral double"+    "12.0\n"+    (encodeText @Double 12)+  assertEqual+    "double"+    "0.1\n"+    (encodeText @Double 0.1)+  assertEqual+    "small double"+    "0.01\n"+    (encodeText @Double 0.01)+  assertEqual+    "smallest decimal notation"+    "0.000001\n"+    (encodeText @Double 1e-6)+  assertEqual+    "below decimal notation"+    "1.0e-7\n"+    (encodeText @Double 1e-7)+  assertEqual+    "largest decimal notation"+    "100000000000000000000.0\n"+    (encodeText @Double 1e20)+  assertEqual+    "above decimal notation"+    "1.0e+21\n"+    (encodeText @Double 1e21)+  assertEqual+    "large scientific"+    "1.0e+30\n"+    (encodeText (Sci.scientific 1 30))+  assertEqual+    "exact scientific"+    "12345678901234567890.123\n"+    (encodeText (Sci.scientific 12345678901234567890123 (-3)))+  assertEqual+    "exponent beyond the limit"+    "1.0e+10001\n"+    (encodeText (Sci.scientific 1 10001))+  assertEqual+    "exponent beyond Int"+    "1.0e+9223372036854775808\n"+    (encodeText (Sci.scientific 10 maxBound))+  assertEqual+    "negative exponent beyond Int"+    "-1.23e+9223372036854775810\n"+    (encodeText (Sci.scientific (-1230) maxBound))+  assertEqual+    "zero with a large exponent"+    "0.0\n"+    (encodeText (Sci.scientific 0 maxBound))+  assertEqual+    "infinity"+    "-.inf\n"+    (encodeText @Double (-(1 / 0)))+  assertEqual+    "not a number"+    ".nan\n"+    (encodeText @Double (0 / 0))+  assertEqual+    "float"+    "0.1\n"+    (encodeText @Float 0.1)+  assertEqual+    "float infinity"+    "-.inf\n"+    (encodeText @Float (-(1 / 0)))+  assertEqual+    "float not a number"+    ".nan\n"+    (encodeText @Float (0 / 0))+  assertEqual+    "negative zero"+    "-0.0\n"+    (encodeText @Double (-0))+  assertEqual+    "float negative zero"+    "-0.0\n"+    (encodeText @Float (-0))++-- | A float has decimal notation from 10^-6 up to 10^21, as Number::toString+-- of ECMAScript, and exponential notation otherwise, with the sign of the+-- exponent.+prop_floatFormat :: Integer -> Property+prop_floatFormat c =+  forAll ((,) <$> chooseInt (0, 3) <*> chooseInt (-30, 30)) $ \(zeros, e) ->+    let s = Sci.scientific (c * 10 ^ zeros) e+        expected+          | s == 0 || (abs s >= Sci.scientific 1 (-6) && abs s < Sci.scientific 1 21) =+              Sci.formatScientific Sci.Fixed Nothing s+          | otherwise =+              case break (== 'e') (Sci.formatScientific Sci.Exponent Nothing s) of+                (m, 'e' : ex@(d : _)) | d /= '-' -> m ++ "e+" ++ ex+                _ -> Sci.formatScientific Sci.Exponent Nothing s+    in encodeText s === T.pack expected <> "\n"++-- | The time to check if YAML 1.1 parsers read a string as another value is+-- linear in its length.+test_longNumberLikeStrings :: Assertion+test_longNumberLikeStrings = do+  let underscores = T.replicate 20000 "1_" <> "x"+      base60 = "1" <> T.replicate 60000 ":55" <> "x"+  assertEqual+    "underscores"+    (underscores <> "\n")+    (encodeText underscores)+  assertEqual+    "base 60"+    (base60 <> "\n")+    (encodeText base60)++-- | The time to write a float is not quadratic in the number of its digits.+test_longFloats :: Assertion+test_longFloats = do+  let nines = 10 ^ (1000000 :: Int) - 1+  assertEqual+    "digits"+    ("9." <> T.replicate 999999 "9" <> "\n")+    (encodeText (Sci.scientific nines (-999999)))+  assertEqual+    "trailing zeros"+    "1.5e+1000000\n"+    (encodeText (Sci.scientific (15 * 10 ^ (1000000 :: Int)) (-1)))++test_literal :: Assertion+test_literal = do+  assertEqual+    "clip"+    "key: |\n  a\n  b\n"+    (encodeText (mapping ["key" .= ("a\nb\n" :: T.Text)]))+  assertEqual+    "strip"+    "key: |-\n  a\n  b\n"+    (encodeText (mapping ["key" .= ("a\nb" :: T.Text)]))+  assertEqual+    "keep"+    "key: |+\n  a\n\n"+    (encodeText (mapping ["key" .= ("a\n\n" :: T.Text)]))+  assertEqual+    "only line breaks"+    "key: \"\\n\\n\"\n"+    (encodeText (mapping ["key" .= ("\n\n" :: T.Text)]))+  assertEqual+    "indentation indicator"+    "- |2-\n    a\n  b\n"+    (encodeText @[T.Text] ["  a\nb"])+  assertEqual+    "indentation indicator for a tab"+    "- |2-\n  \ta\n  b\n"+    (encodeText @[T.Text] ["\ta\nb"])+  assertEqual+    "indentation indicator after empty lines"+    "- |2\n\n  \ta\n"+    (encodeText @[T.Text] ["\n\ta\n"])+  assertEqual+    "no indentation indicator at the top level"+    "\" a\\nb\"\n"+    (encodeText @T.Text " a\nb")+  assertEqual+    "no indentation indicator for a tab at the top level"+    "\"\\ta\\nb\"\n"+    (encodeText @T.Text "\ta\nb")+  let keep = mapping ["key" .= ("a\n\n" :: T.Text), "next" .= ("b" :: T.Text)]+  assertEqual+    "keep in a syntax tree"+    (encodeText keep)+    (S.renderSyntax S.defaultRenderOptions [S.document keep])++test_tags :: Assertion+test_tags = do+  let local = Tagged "!point" (Mapping [(String "x", Int 1)])+  assertEqual+    "local tag"+    "!point\nx: 1\n"+    (encodeText local)+  let str = Tagged "!name" (String "foo")+  assertEqual+    "tagged scalar"+    "- !name foo\n"+    (encodeText [str])+  let readBack :: T.Text -> Either (NE.NonEmpty Error) T.Text+      readBack t = valueTag <$> decodeText @Value (encodeText (Tagged t (String "x")))+      exact :: T.Text -> Assertion+      exact t =+        assertEqual+          (T.unpack t)+          (Right t)+          (readBack t)+  exact "!a b!c%"+  exact "!!x"+  exact "tag:yaml.org,2002:a,b é"+  exact "tag:example.com,2000:a%41,[b]"+  exact "tag:example.com,2000:a b>%"+  exact "foo"+  exact "!point#2d"+  exact "http://example.com/a#b"+  exact "tag:example.com,2000:a%20b"+  -- libyaml, PyYAML and go-yaml reject a # in a tag, and they decode the+  -- escapes of a verbatim tag.+  assertEqual+    "hash in a local tag"+    "!point%232d x\n"+    (encodeText (Tagged "!point#2d" (String "x")))+  assertEqual+    "hash in a global tag"+    "%TAG !t68! %68\n---\n!t68!ttp://example.com/a%23b x\n"+    (encodeText (Tagged "http://example.com/a#b" (String "x")))+  assertEqual+    "percent in a global tag"+    "%TAG !t74! %74\n---\n!t74!ag:example.com%2C2000:a%2520b x\n"+    (encodeText (Tagged "tag:example.com,2000:a%20b" (String "x")))+  assertEqual+    "verbatim tag"+    "!<http://example.com/a> x\n"+    (encodeText (Tagged "http://example.com/a" (String "x")))+  -- YAML 1.1 parsers read the non-specific tag ! as no tag, e.g. "! 12" as+  -- an integer, and YAML 1.2 as a string.+  assertEqual+    "empty tag"+    "12\n"+    (encodeText (Tagged "" (Int 12)))+  assertEqual+    "tag of one character"+    "'yes'\n"+    (encodeText (Tagged "!" (String "yes")))+  assertEqual+    "empty tag around a tag"+    "!b x\n"+    (encodeText (Tagged "" (Tagged "!b" (String "x"))))+  assertEqual+    "directives after a document"+    (Right [strTag, "foo"])+    $ map valueTag+      <$> decodeAllText @Value (encodeAllText [String "a", Tagged "foo" (String "b")])
+ tests/Yamlet/Test/Generic.hs view
@@ -0,0 +1,1288 @@+module Yamlet.Test.Generic (genericTests) where++import Control.Concurrent+import Control.Exception+import Data.Aeson qualified as A+import Data.Bifunctor+import Data.Char+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import GHC.Conc+import System.IO.Unsafe+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Yamlet+import Yamlet.Syntax qualified as S+import Yamlet.Test.Helpers++genericTests :: TestTree+genericTests =+  testGroup+    "generic"+    [ testCase "record" test_record+    , testCase "types with a parameter" test_parameters+    , testCase "collected errors" test_collectedErrors+    , testCase "enumeration" test_enumeration+    , testCase "sum" test_sum+    , shapes+    , testCase "options" test_options+    , testCase "missing contents" test_missingContents+    , testCase "flat fields" test_flatten+    , testCase "single field" test_singleField+    , testCase "default" test_default+    , testCase "required field" test_requiredField+    , testCase "interrupted check of a default" test_interruptedDefault+    , testCase "modifiers" test_modifiers+    , testCase "commented fields" test_commentedFields+    , testCase "commented values" test_commentedValues+    , testProperty "snakeCase is camelTo2 of aeson" . forAll name $ \s ->+        snakeCase s === A.camelTo2 '_' s+    , testProperty "kebabCase is camelTo2 of aeson" . forAll name $ \s ->+        kebabCase s === A.camelTo2 '-' s+    ]+  where+    -- Mostly letters in both cases, where the rules matter.+    name :: Gen String+    name = listOf (elements "aAbBzZ1_-")++data Server = Server {host :: T.Text, port :: Int, tags :: Maybe [T.Text]}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Server++-- | A type with a parameter. Its instances get the instances of the fields+-- as arguments, so GHC cannot inline them where it derives the instances.+data Pair a = Pair {left :: a, right :: a}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml (Pair a)++data Sparse a = Sparse {name :: T.Text, extra :: a}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml (Sparse a)++instance GenericYamlOptions (Sparse a) where+  yamlOptions = defaultYamlOptions {omitNullFields = True}++data Slot a = Filled a | Vacant+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml (Slot a)++data Turn = TurnLeft | TurnRight+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Turn++-- | The tags read as integers without quotes.+data Level = One | Two+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml) via GenericYaml Level++instance GenericYamlOptions Level where+  yamlOptions = defaultYamlOptions {constructorTagModifier = \case "One" -> "1"; _ -> "2"}++data Shape+  = Circle {radius :: Double}+  | Rectangle {width :: Double, height :: Double}+  | Dot+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Shape++data Token = Label T.Text | Number Int | End+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Token++newtype Name = Name T.Text+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Name++-- | The constructors of the single-field encoding can mix their fields.+data Figure = Round {radius :: Double} | Named T.Text | Point+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Figure++instance GenericYamlOptions Figure where+  type SumEncoding Figure = SingleField++data Gauge = Gauge {level :: Int} | Off+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Gauge++instance GenericYamlOptions Gauge where+  type SumEncoding Gauge = SingleField++-- | A tag that is a boolean without quotes.+data Lamp = Dimmed Int | Dark+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml) via GenericYaml Lamp++instance GenericYamlOptions Lamp where+  type SumEncoding Lamp = SingleField+  yamlOptions = defaultYamlOptions {constructorTagModifier = \case "Dark" -> "false"; t -> t}++data Memo = Memo (Commented T.Text) | NoMemo+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Memo++instance GenericYamlOptions Memo where+  type SumEncoding Memo = SingleField++data Strict = Strict {size :: Int, note :: Maybe T.Text}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Strict++instance GenericYamlOptions Strict where+  yamlOptions = defaultYamlOptions {omitNullFields = True}++newtype Loose = Loose {size :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Loose++instance GenericYamlOptions Loose where+  yamlOptions = defaultYamlOptions {rejectUnknownFields = False}++-- | The name of the field reads as a boolean.+newtype Switch = Switch {true :: Maybe Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Switch++newtype DefaultSwitch = DefaultSwitch {true :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml DefaultSwitch++instance GenericYamlOptions DefaultSwitch where+  yamlDefault = Just (DefaultSwitch 0)++data Command = Forward {stepCount :: Int} | Stop+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Command++instance GenericYamlOptions Command where+  yamlOptions =+    defaultYamlOptions+      { tagKey = "command"+      , constructorTagModifier = map toLower+      , fieldLabelModifier = concatMap (\c -> if isUpper c then ['_', toLower c] else [c])+      }++data Reply = Answer (Maybe Int) | Silence+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Reply++-- The types of the flat encoding follow the example of tagged-json.+data Step+  = Ahead Distance+  | Rotate Direction+  | Accelerate Speed+  | Halt+  | -- Fields that do not merge.+    Wait Int+  | Again Step+  | Boxed Box+  | Packed Crate+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Step++instance GenericYamlOptions Step where+  type SumEncoding Step = TaggedFlat+  yamlOptions = defaultYamlOptions {tagKey = "step"}++data Crate = Crate {contents :: Int, size :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Crate++-- | The flat encoding with unknown keys ignored.+data Order = Hold Int | Hasten Speed+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Order++instance GenericYamlOptions Order where+  type SumEncoding Order = TaggedFlat+  yamlOptions = defaultYamlOptions {rejectUnknownFields = False}++-- | Another contents key.+data Volume = Level Int | Mute+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Volume++instance GenericYamlOptions Volume where+  yamlOptions = defaultYamlOptions {contentsKey = "value"}++-- | The flat encoding with another contents key, which is the key of a field.+data Parcel = Sent Speed | Held Int | Packaged Box+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Parcel++instance GenericYamlOptions Parcel where+  type SumEncoding Parcel = TaggedFlat+  yamlOptions = defaultYamlOptions {contentsKey = "speed"}++-- | The flat encoding of a mapping that an alias elsewhere can refer to.+data Shared = Shared Node | Unshared+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Shared++instance GenericYamlOptions Shared where+  type SumEncoding Shared = TaggedFlat++data Route = Route {first :: Shared, again :: Node}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Route++-- | The flat encoding of a field with a key close to the contents key.+data Event = Opened Issue | Closed+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Event++instance GenericYamlOptions Event where+  type SumEncoding Event = TaggedFlat++data Issue = Issue {title :: T.Text, comments :: [T.Text]}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Issue++newtype Distance = Distance {distance :: Maybe Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Distance++newtype Speed = Speed {speed :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Speed++newtype Box = Box {contents :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Box++data Direction = Clockwise | Anticlockwise+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Direction++data Settings = Settings+  { name :: T.Text+  , retries :: Int+  , proxy :: Maybe T.Text+  , limits :: Limits+  }+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Settings++instance GenericYamlOptions Settings where+  yamlDefault =+    Just+      Settings+        { name = "app"+        , retries = 3+        , proxy = Just "proxy"+        , limits = Limits 10 20+        }++data Limits = Limits {soft :: Int, hard :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Limits++instance GenericYamlOptions Limits where+  yamlDefault = Just (Limits 1 2)++data Mode = Fast {level :: Int} | Slow {level :: Int, delay :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Mode++instance GenericYamlOptions Mode where+  yamlDefault = Just (Slow 1 2)++data Job = Run Int | Skip+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Job++instance GenericYamlOptions Job where+  yamlDefault = Just (Run 3)++data Profile = Profile {user :: T.Text, proxy :: Maybe T.Text, note :: Maybe T.Text}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Profile++instance GenericYamlOptions Profile where+  yamlOptions = defaultYamlOptions {omitNullFields = True}+  yamlDefault = Just Profile {user = "app", proxy = Just "proxy", note = Nothing}++data Remark = Remark {user :: T.Text, note :: Commented (Maybe T.Text)}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Remark++instance GenericYamlOptions Remark where+  yamlOptions = defaultYamlOptions {omitNullFields = True}+  yamlDefault =+    Just (Remark "app" (Commented Nothing noComments {before = [Comment "default"]}))++data Account = Account {user :: T.Text, shell :: T.Text, home :: Maybe T.Text}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Account++instance GenericYamlOptions Account where+  yamlOptions = defaultYamlOptions {omitNullFields = True}+  yamlDefault =+    Just Account {user = requiredField, shell = "/bin/sh", home = requiredField}++data Task = Once Int | Never+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Task++instance GenericYamlOptions Task where+  yamlDefault = Just (Once requiredField)++data Login = Login {user :: !T.Text, shell :: T.Text}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Login++instance GenericYamlOptions Login where+  yamlDefault = Just (Login requiredField "/bin/sh")++newtype Port = Port {port :: Maybe Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml) via GenericYaml Port++instance GenericYamlOptions Port where+  yamlDefault = Just (Port requiredField)++-- | A default with a field that waits for a gate, so that a test can+-- interrupt the decoder while it checks the field.+data Gated = Gated {gated :: Int, other :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml) via GenericYaml Gated++instance GenericYamlOptions Gated where+  yamlDefault = Just (Gated gatedDefault requiredField)++gatedDefault :: Int+gatedDefault = unsafePerformIO (putMVar gateEntered () >> takeMVar gate >> pure 1)+-- Without the pragma, each use could evaluate the action again.+{-# NOINLINE gatedDefault #-}++gateEntered, gate :: MVar ()+gateEntered = unsafePerformIO newEmptyMVar+-- Without the pragmas, each use could get its own variable.+{-# NOINLINE gateEntered #-}+gate = unsafePerformIO newEmptyMVar+{-# NOINLINE gate #-}++-- | Records that keep the comments of their keys.+data Pipeline = Pipeline {name :: Commented T.Text, lint :: Commented Lint}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Pipeline++data Lint = Lint {version :: Commented T.Text, level :: T.Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Lint++-- | A record with a field whose type is its own field.+data Card = Card {title :: Title, pages :: Int}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Card++newtype Title = Title (Commented T.Text)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Title++-- | A comment above a key with no empty line below it belongs to the key, also+-- for the first key of a mapping.+test_commentedFields :: Assertion+test_commentedFields = do+  assertEqual+    "round trip"+    (Right input)+    (encodeText <$> decodeText @Pipeline input)+  let card = T.unlines ["# The title.", "title: Hello # short", "pages: 2"]+  assertEqual+    "field of a type that is its field"+    (Right card)+    (encodeText <$> decodeText @Card card)+  where+    input :: T.Text+    input =+      T.unlines+        [ "# The name of the pipeline."+        , "name: ci"+        , ""+        , "# The linter."+        , "lint: # optional"+        , "  # The version of the linter."+        , "  version: '3.8'"+        , "  level: warning"+        ]++data Setup = Setup {hooks :: Commented Hooks, name :: Commented T.Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Setup++newtype Hooks = Hooks {afterSetup :: Commented [Script]}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Hooks++instance GenericYamlOptions Hooks where+  yamlOptions = defaultYamlOptions {fieldLabelModifier = kebabCase}++newtype Script = Script {run :: T.Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Script++data Optional = Optional {first :: T.Text, extra :: Maybe (Commented Node)}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Optional++data Note = Note (Commented T.Text) | Blank+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Note++-- | The comments at the end of a collection and after a value.+test_commentedValues :: Assertion+test_commentedValues = do+  -- The comment at the top belongs to the root mapping, and a record has no+  -- place for it.+  assertEqual+    "round trip"+    (Right (T.unlines (drop 2 (T.lines input))))+    (encodeText <$> decodeText @Setup input)+  let optional =+        T.unlines ["first: a", "# The extra part.", "extra: # optional", "  x: 1"]+  assertEqual+    "optional field"+    (Right optional)+    (encodeText <$> decodeText @Optional optional)+  let note = T.unlines ["tag: Note", "# The text.", "contents: hello # c"]+  assertEqual+    "contents key"+    (Right note)+    (encodeText <$> decodeText @Note note)+  where+    -- The comment "trailing" is at the end of the mapping of hooks.+    input :: T.Text+    input =+      T.unlines+        [ "# top"+        , ""+        , "hooks: # k"+        , "  # above"+        , "  after-setup:"+        , "  - run: a"+        , "  # trailing"+        , "name: x # c"+        ]++-- The types that only the table of shapes uses.++data Unit = Unit+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Unit++data UnitTagged = UnitTagged+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml UnitTagged++instance GenericYamlOptions UnitTagged where+  yamlOptions = defaultYamlOptions {tagSingleConstructors = True}++newtype NameTagged = NameTagged T.Text+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml NameTagged++instance GenericYamlOptions NameTagged where+  yamlOptions = defaultYamlOptions {tagSingleConstructors = True}++newtype Single = Single {value :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Single++instance GenericYamlOptions Single where+  yamlOptions = defaultYamlOptions {tagSingleConstructors = True}++data Literal = Whole Int | Words T.Text+  deriving stock (Eq, Show, Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Literal++data Motion = Go Distance | Hurry Speed+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Motion++instance GenericYamlOptions Motion where+  type SumEncoding Motion = TaggedFlat++newtype Bare = Bare {size :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Bare++instance GenericYamlOptions Bare where+  type SumEncoding Bare = SingleField++newtype Wrapped = Wrapped {size :: Int}+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Wrapped++instance GenericYamlOptions Wrapped where+  type SumEncoding Wrapped = SingleField+  yamlOptions = defaultYamlOptions {tagSingleConstructors = True}++data Light = Red | Green+  deriving stock (Eq, Show, Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Light++instance GenericYamlOptions Light where+  type SumEncoding Light = SingleField++-- | Each supported shape of constructors, with the options that change its+-- encoding.+shapes :: TestTree+shapes =+  testGroup+    "shapes"+    [ shape+        "one constructor without fields"+        Unit+        "Unit\n"+    , shape+        "one constructor without fields, tagSingleConstructors"+        UnitTagged+        "UnitTagged\n"+    , shape+        "one field without a name"+        (Name "x")+        "x\n"+    , shape+        "one field without a name with a tag"+        (NameTagged "x")+        "tag: NameTagged\ncontents: x\n"+    , shape+        "one named field"+        (Speed 1)+        "speed: 1\n"+    , shape+        "named fields"+        Server {host = "a", port = 1, tags = Nothing}+        "host: a\nport: 1\ntags: null\n"+    , shape+        "named fields with a tag"+        (Single 1)+        "tag: Single\nvalue: 1\n"+    , shape+        "enumeration"+        TurnLeft+        "TurnLeft\n"+    , shape+        "fields without names"+        (Whole 1)+        "tag: Whole\ncontents: 1\n"+    , shape+        "fields without names, with fields"+        (Label "x")+        "tag: Label\ncontents: x\n"+    , shape+        "fields without names, without fields"+        End+        "tag: End\n"+    , shape+        "flat fields"+        (Go (Distance (Just 1)))+        "tag: Go\ndistance: 1\n"+    , shape+        "flat fields, with fields"+        (Ahead (Distance (Just 10)))+        "step: Ahead\ndistance: 10\n"+    , shape+        "flat fields, without fields"+        Halt+        "step: Halt\n"+    , shape+        "named fields in a sum, one field"+        (Fast 1)+        "tag: Fast\nlevel: 1\n"+    , shape+        "named fields in a sum, several fields"+        (Slow 1 2)+        "tag: Slow\nlevel: 1\ndelay: 2\n"+    , shape+        "named fields in a sum, with fields"+        (Rectangle 2 3)+        "tag: Rectangle\nwidth: 2.0\nheight: 3.0\n"+    , shape+        "named fields in a sum, without fields"+        Dot+        "tag: Dot\n"+    , shape+        "single field, named fields"+        (Round 1)+        "Round:\n  radius: 1.0\n"+    , shape+        "single field, a field without a name"+        (Named "x")+        "Named: x\n"+    , shape+        "single field, without fields"+        Point+        "Point\n"+    , shape+        "single field, one constructor"+        (Bare 1)+        "size: 1\n"+    , shape+        "single field, one constructor with a tag"+        (Wrapped 1)+        "Wrapped:\n  size: 1\n"+    , shape+        "single field, enumeration"+        Red+        "Red\n"+    ]+  where+    shape :: (Eq a, Show a, FromYaml a, ToYaml a) => String -> a -> T.Text -> TestTree+    shape preface x yaml = testCase preface $ do+      assertEqual+        "encoded"+        yaml+        (encodeText x)+      assertEqual+        "decoded"+        (Right x)+        (decodeText yaml)++test_record :: Assertion+test_record = do+  assertEqual+    "optional field"+    (Right Server {host = "a", port = 1, tags = Nothing})+    (decodeText "host: a\nport: 1\n")+  assertEqual+    "all fields"+    (Right Server {host = "a", port = 1, tags = Just ["x"]})+    (decodeText "host: a\nport: 1\ntags: [x]\n")+  assertEqual+    "missing field"+    (Just (1, 1, "missing key \"port\""))+    (errorOf (decodeText @Server "host: a\n"))+  assertEqual+    "optional field with a key that is not a string"+    (Just (1, 1, "the key \"true\" is a boolean, not a string"))+    (errorOf (decodeText @Switch "true: 1\n"))+  assertEqual+    "field with a default and a key that is not a string"+    (Just (1, 1, "the key \"true\" is a boolean, not a string"))+    (errorOf (decodeText @DefaultSwitch "true: 1\n"))+  assertEqual+    "key that is not a string with another text"+    (Just (1, 1, "expected a string as the key, but got a boolean"))+    (errorOf (decodeText @Switch "True: 1\n"))+  assertEqual+    "quoted key"+    (Right (Switch (Just 1)))+    (decodeText "'true': 1\n")+  roundTrip "round trip" Server {host = "a", port = 1, tags = Just ["x", "y"]}++test_parameters :: Assertion+test_parameters = do+  assertEqual+    "encoded"+    "left: 1\nright: 2\n"+    (encodeText (Pair @Int 1 2))+  roundTrip "round trip" (Pair @Int 1 2)+  roundTrip "round trip of lists" (Pair @[Int] [1, 2] [])+  roundTrip "round trip of nested types" (Pair (Pair @T.Text "a" "b") (Pair "c" "d"))+  assertEqual+    "missing key of an optional field"+    (Right (Pair Nothing (Just 1)))+    (decodeText @(Pair (Maybe Int)) "right: 1\n")+  assertEqual+    "missing key of a required field"+    (Just (1, 1, "missing key \"left\""))+    (errorOf (decodeText @(Pair Int) "right: 1\n"))+  assertEqual+    "path of an error"+    (Left ["right"])+    $ first+      (map (renderPath . (.path)) . NE.toList)+      (decodeText @(Pair Int) "left: 1\nright: x\n")+  assertEqual+    "null field left out"+    "name: a\n"+    (encodeText (Sparse @(Maybe Int) "a" Nothing))+  assertEqual+    "field that is not null"+    "name: a\nextra: 1\n"+    (encodeText (Sparse @(Maybe Int) "a" (Just 1)))+  roundTrip "round trip with a null field left out" (Sparse @(Maybe Int) "a" Nothing)+  assertEqual+    "null field with a comment"+    "name: a\n# b\nextra: null\n"+    . encodeText+    $ Sparse "a" (Commented (Nothing @Int) noComments {before = [Comment "b"]})+  assertEqual+    "null field without comments left out"+    "name: a\n"+    (encodeText (Sparse "a" (Commented (Nothing @Int) noComments)))+  let anchored = (S.plainNode "") {S.props = S.noProps {S.anchor = Just "x"}}+      shared =+        encodeText [Sparse "a" anchored, Sparse "b" (S.contentNode (S.AliasContent "x"))]+  assertEqual+    "null field with an anchor"+    "- name: a\n  extra: &x\n- name: b\n  extra: *x\n"+    shared+  assertEqual+    "alias to a null field read back"+    (Right [Sparse "a" Null, Sparse "b" Null])+    (decodeText @[Sparse Value] shared)+  assertEqual+    "encoded sum"+    "- tag: Filled\n  contents: 1\n- tag: Vacant\n"+    (encodeText [Filled @Int 1, Vacant])+  roundTrip "round trip of a sum" [Filled @Int 1, Vacant]++-- | A derived decoder reports the errors of all its fields.+test_collectedErrors :: Assertion+test_collectedErrors = do+  let fields = decodeText @Server "host: [a]\nport: x\ntags: [1, b, 2]\n"+  assertEqual+    "fields"+    [ (1, 7, "expected a string, but got a list")+    , (2, 7, "expected an integer, but got a string")+    , (3, 8, "expected a string, but got an integer, quote the value, e.g. '1'")+    , (3, 14, "expected a string, but got an integer, quote the value, e.g. '2'")+    ]+    (errorsOf fields)+  assertEqual+    "paths"+    (Left ["host", "port", "tags[0]", "tags[2]"])+    (first (map (renderPath . (.path)) . NE.toList) fields)+  assertEqual+    "missing and invalid fields"+    [(1, 1, "missing key \"host\""), (1, 7, "expected an integer, but got a string")]+    (errorsOf (decodeText @Server "port: x\n"))+  assertEqual+    "unknown key and invalid field"+    [ (1, 7, "expected an integer, but got a string")+    , (2, 1, "unknown key \"colour\", expected one of: size, note")+    ]+    (errorsOf (decodeText @Strict "size: x\ncolour: red\n"))+  assertEqual+    "unknown keys"+    [ (1, 1, "unknown key \"colour\", expected one of: size, note")+    , (3, 1, "unknown key \"nate\", did you mean \"note\"?")+    ]+    (errorsOf (decodeText @Strict "colour: red\nsize: 1\nnate: x\n"))+  assertEqual+    "fields of a constructor"+    [ (1, 25, "expected a number, but got a string")+    , (1, 36, "expected a number, but got a string")+    ]+    (errorsOf (decodeText @Shape "{tag: Rectangle, width: x, height: y}"))+  assertEqual+    "items of a list"+    [(1, 19, "expected an integer, but got a string"), (2, 3, "missing key \"port\"")]+    (errorsOf (decodeText @[Server] "- {host: a, port: x}\n- host: b\n"))++test_enumeration :: Assertion+test_enumeration = do+  assertEqual+    "decoded"+    (Right [TurnLeft, TurnRight])+    (decodeText "[TurnLeft, TurnRight]")+  assertEqual+    "unknown value"+    (Just (1, 1, "unknown value \"Up\", expected one of: TurnLeft, TurnRight"))+    (errorOf (decodeText @Turn "Up"))+  assertEqual+    "null"+    (Just (1, 1, "expected one of: TurnLeft, TurnRight, but got null"))+    (errorOf (decodeText @Turn "null"))+  assertEqual+    "value that needs quotes"+    (Just (1, 1, "expected a string, but got an integer, quote the value, e.g. '1'"))+    (errorOf (decodeText @Level "1"))+  assertEqual+    "quoted value"+    (Right One)+    (decodeText "'1'")+  assertEqual+    "tag of a sum"+    (Just (1, 6, "expected one of: Circle, Rectangle, Dot, but got null"))+    (errorOf (decodeText @Shape "tag: null\n"))+  assertEqual+    "misspelled value"+    (Just (1, 1, "unknown value \"TurnLetf\", did you mean \"TurnLeft\"?"))+    (errorOf (decodeText @Turn "TurnLetf"))++test_sum :: Assertion+test_sum = do+  mapM_ (\s -> roundTrip (show s) s) [Circle 1, Rectangle 2 3, Dot]+  mapM_ (\s -> roundTrip (show s) s) [Label "x", Number 1, End]+  assertEqual+    "unknown tag"+    (Just (1, 6, "unknown tag \"Square\", expected one of: Circle, Rectangle, Dot"))+    (errorOf (decodeText @Shape "tag: Square\n"))+  assertEqual+    "misspelled tag"+    (Just (1, 6, "unknown tag \"Rectangel\", did you mean \"Rectangle\"?"))+    (errorOf (decodeText @Shape "tag: Rectangel\n"))+  assertEqual+    "missing tag"+    (Just (1, 1, "missing key \"tag\""))+    (errorOf (decodeText @Shape "radius: 1\n"))++test_options :: Assertion+test_options = do+  assertEqual+    "null field left out"+    "size: 1\n"+    (encodeText (Strict 1 Nothing))+  assertEqual+    "unknown field"+    (Just (2, 1, "unknown key \"colour\", expected one of: size, note"))+    (errorOf (decodeText @Strict "size: 1\ncolour: red\n"))+  assertEqual+    "unknown field ignored"+    (Right (Loose 1))+    (decodeText "size: 1\ncolour: red\n")+  assertEqual+    "key that is not a string"+    (Just (2, 1, "expected a string as the key, but got an integer"))+    (errorOf (decodeText @Strict "size: 1\n2: x\n"))+  assertEqual+    "tag key and modifiers"+    "command: forward\nstep_count: 3\n"+    (encodeText (Forward 3))+  roundTrip "tag key and modifiers" (Forward 3)+  assertEqual+    "contents key"+    "tag: Level\nvalue: 3\n"+    (encodeText (Level 3))+  roundTrip "contents key" [Level 3, Mute]+  assertEqual+    "missing contents key"+    (Just (1, 1, "missing key \"value\""))+    (errorOf (decodeText @Volume "tag: Level\n"))+  assertEqual+    "default contents key"+    [ (1, 1, "missing key \"value\"")+    , (2, 1, "unknown key \"contents\", expected one of: tag, value")+    ]+    (errorsOf (decodeText @Volume "tag: Level\ncontents: 3\n"))+  assertEqual+    "flat contents key"+    "tag: Sent\nspeed:\n  speed: 1\n"+    (encodeText (Sent (Speed 1)))+  assertEqual+    "flat contents key without a mapping"+    "tag: Held\nspeed: 5\n"+    (encodeText (Held 5))+  assertEqual+    "flat default contents key"+    "tag: Packaged\ncontents: 1\n"+    (encodeText (Packaged (Box 1)))+  roundTrip "flat contents key" [Sent (Speed 1), Held 5, Packaged (Box 1)]++test_missingContents :: Assertion+test_missingContents = do+  assertEqual+    "field that accepts null"+    (Right (Answer Nothing))+    (decodeText "tag: Answer\n")+  assertEqual+    "field that does not accept null"+    (Just (1, 1, "missing key \"contents\""))+    (errorOf (decodeText @Token "tag: Label\n"))++-- | The errors of the single-field encoding, and the comments of its key.+test_singleField :: Assertion+test_singleField = do+  assertEqual+    "second key"+    (Just (1, 22, "expected a mapping with one key, but got a second key"))+    (errorOf (decodeText @Figure "{Round: {radius: 1}, Point: x}"))+  assertEqual+    "unknown constructor"+    (Just (1, 1, "unknown constructor \"Rund\", did you mean \"Round\"?"))+    (errorOf (decodeText @Figure "Rund: {radius: 1}"))+  assertEqual+    "constructor with fields as a string"+    ( Just+        (1, 1, "expected a mapping with the key \"Round\", because the constructor has fields")+    )+    (errorOf (decodeText @Figure "Round"))+  assertEqual+    "constructor without fields as a mapping"+    (Just (1, 1, "expected the string \"Point\", because the constructor has no fields"))+    (errorOf (decodeText @Figure "Point: x"))+  assertEqual+    "empty mapping"+    (Just (1, 1, "expected a mapping with one key, but got an empty mapping"))+    (errorOf (decodeText @Figure "{}"))+  assertEqual+    "neither a string nor a mapping"+    (Just (1, 1, "expected a string or a mapping with one key, but got an integer"))+    (errorOf (decodeText @Figure "1"))+  assertEqual+    "constructor that needs quotes"+    (Just (1, 1, "expected a string, but got a boolean, quote the value, e.g. 'false'"))+    (errorOf (decodeText @Lamp "false"))+  assertEqual+    "quoted constructor"+    (Right Dark)+    (decodeText "'false'")+  assertEqual+    "unknown field in the value"+    (Just (2, 3, "unknown key \"lvl\", did you mean \"level\"?"))+    (errorOf (decodeText @Gauge "Gauge:\n  lvl: 2\n  level: 1\n"))+  let input = "# The memo.\nMemo: hello # inline\n"+  assertEqual+    "comments of the key"+    (Right input)+    (encodeText <$> decodeText @Memo input)++test_flatten :: Assertion+test_flatten = do+  assertEqual+    "enumeration"+    "step: Rotate\ncontents: Clockwise\n"+    (encodeText (Rotate Clockwise))+  assertEqual+    "no mapping"+    "step: Wait\ncontents: 5\n"+    (encodeText (Wait 5))+  assertEqual+    "tag key"+    "step: Again\ncontents:\n  step: Halt\n"+    (encodeText (Again Halt))+  assertEqual+    "contents key"+    "step: Boxed\ncontents:\n  contents: 1\n"+    (encodeText (Boxed (Box 1)))+  assertEqual+    "contents key with other keys"+    "step: Packed\ncontents:\n  contents: 1\n  size: 2\n"+    (encodeText (Packed (Crate 1 2)))+  mapM_+    (\s -> roundTrip (show s) s)+    [ Ahead (Distance (Just 10))+    , Ahead (Distance Nothing)+    , Rotate Anticlockwise+    , Accelerate (Speed 2)+    , Halt+    , Wait 5+    , Again (Again (Rotate Clockwise))+    , Boxed (Box 1)+    , Packed (Crate 1 2)+    ]+  assertEqual+    "missing field"+    (Right (Ahead (Distance Nothing)))+    (decodeText "step: Ahead\n")+  let onlyTagNote :: String -> Int -> (Int, Int, String)+      onlyTagNote constructor column =+        ( 1+        , column+        , "the mapping has no key \"contents\" and no other keys for the field of " ++ constructor+        )+  assertEqual+    "error in a field"+    [(1, 1, "missing key \"speed\""), onlyTagNote "Accelerate" 7]+    (errorsOf (decodeText @Step "step: Accelerate\n"))+  assertEqual+    "only the tag for a field that is not a mapping"+    [(1, 1, "expected an integer, but got a mapping"), onlyTagNote "Wait" 7]+    (errorsOf (decodeText @Step "step: Wait\n"))+  assertEqual+    "misspelled field"+    [ (1, 1, "missing key \"speed\"")+    , (2, 1, "unknown key \"sped\", did you mean \"speed\"?")+    ]+    (errorsOf (decodeText @Step "step: Accelerate\nsped: 2\n"))+  assertEqual+    "misspelled contents key"+    [(1, 1, "expected an integer, but got a mapping")]+    (errorsOf (decodeText @Step "step: Wait\ncontnets: 5\n"))+  assertEqual+    "error in a field with a key close to the contents key"+    [(2, 8, "expected a string, but got a list")]+    (errorsOf (decodeText @Event "tag: Opened\ntitle: [1]\ncomments: [first]\n"))+  roundTrip "field with a key close to the contents key" (Opened (Issue "a" ["b"]))+  let entry = S.mappingNode [(S.plainNode "k", S.plainNode "v")]+      anchored = entry {S.props = S.noProps {S.anchor = Just "x"}}+      route = encodeText (Route (Shared anchored) (S.contentNode (S.AliasContent "x")))+  assertEqual+    "mapping without an anchor"+    "tag: Shared\nk: v\n"+    (encodeText (Shared entry))+  assertEqual+    "mapping with an anchor"+    "first:\n  tag: Shared\n  contents: &x\n    k: v\nagain: *x\n"+    route+  assertEqual+    "alias to a mapping with an anchor read back"+    ( Right $+        Mapping+          [+            ( String "first"+            , Mapping+                [ (String "tag", String "Shared")+                , (String "contents", Mapping [(String "k", String "v")])+                ]+            )+          , (String "again", Mapping [(String "k", String "v")])+          ]+    )+    (decodeText @Value route)+  let fieldProps :: Shared -> Maybe S.Props+      fieldProps = \case+        Shared n -> Just n.props+        Unshared -> Nothing+  assertEqual+    "tag and anchor of the mapping, not of the field"+    (Right (Just S.noProps))+    (fieldProps <$> decodeText "!foo &x {tag: Shared, k: v}\n")+  let tagged = entry {S.props = S.noProps {S.tag = S.Tag "!foo"}}+  assertEqual+    "mapping with a tag"+    "tag: Shared\ncontents: !foo\n  k: v\n"+    (encodeText (Shared tagged))+  assertEqual+    "mapping with a tag read back"+    (Right (Just S.noProps {S.tag = S.Tag "!foo"}))+    (fieldProps <$> decodeText (encodeText (Shared tagged)))+  assertEqual+    "other key next to the contents key"+    [(3, 1, "unknown key \"extra\", expected one of: step, contents")]+    (errorsOf (decodeText @Step "step: Wait\ncontents: 5\nextra: 1\n"))+  assertEqual+    "misspelled field with unknown keys ignored by the outer type only"+    [ (1, 1, "missing key \"speed\"")+    , (2, 1, "unknown key \"sped\", did you mean \"speed\"?")+    ]+    (errorsOf (decodeText @Order "tag: Hasten\nsped: 2\n"))+  assertEqual+    "misspelled contents key with unknown keys ignored"+    [(1, 1, "expected an integer, but got a mapping")]+    (errorsOf (decodeText @Order "tag: Hold\ncontnets: 5\n"))+  assertEqual+    "other key next to the contents key with unknown keys ignored"+    (Right (Hold 5))+    (decodeText "tag: Hold\ncontents: 5\nextra: 1\n")+  -- The flat field of the recursive type reads the mapping again.+  assertEqual+    "duplicate tag keys reported once"+    [ (1, 1, "missing key \"step\"")+    , onlyTagNote "Again" 7+    , (2, 4, "duplicate key \"step\"")+    , (1, 1, "the first key \"step\"")+    , (3, 4, "duplicate key \"step\"")+    , (1, 1, "the first key \"step\"")+    ]+    (errorsOf (decodeText @Step "step: Again\n!a step: Again\n!b step: Halt\n"))++test_default :: Assertion+test_default = do+  assertEqual+    "all keys missing"+    ( Right+        Settings+          { name = "app"+          , retries = 3+          , proxy = Just "proxy"+          , limits = Limits 10 20+          }+    )+    (decodeText "{}")+  assertEqual+    "some keys missing"+    ( Right+        Settings+          { name = "app"+          , retries = 5+          , proxy = Just "proxy"+          , limits = Limits 10 20+          }+    )+    (decodeText "retries: 5")+  assertEqual+    "explicit null"+    ( Right+        Settings+          { name = "app"+          , retries = 3+          , proxy = Nothing+          , limits = Limits 10 20+          }+    )+    (decodeText "proxy: null")+  assertEqual+    "default of the inner type"+    ( Right+        Settings+          { name = "app"+          , retries = 3+          , proxy = Just "proxy"+          , limits = Limits 7 2+          }+    )+    (decodeText "limits: {soft: 7}")+  assertEqual+    "constructor of the default"+    (Right (Slow 4 2))+    (decodeText "tag: Slow\nlevel: 4\n")+  assertEqual+    "other constructor"+    (Just (1, 1, "missing key \"level\""))+    (errorOf (decodeText @Mode "tag: Fast\n"))+  assertEqual+    "missing contents"+    (Right (Run 3))+    (decodeText "tag: Run\n")+  roundTrip+    "round trip"+    Settings {name = "x", retries = 1, proxy = Nothing, limits = Limits 3 4}+  assertEqual+    "null fields left out only if the default is null"+    "user: x\nproxy: null\n"+    (encodeText Profile {user = "x", proxy = Nothing, note = Nothing})+  roundTrip+    "round trip of null fields"+    Profile {user = "x", proxy = Nothing, note = Nothing}+  assertEqual+    "null fields left out only if the default has no comments"+    "user: x\nnote: null\n"+    (encodeText (Remark "x" (Commented Nothing noComments)))+  roundTrip+    "round trip of a null field without comments"+    (Remark "x" (Commented Nothing noComments))++test_requiredField :: Assertion+test_requiredField = do+  assertEqual+    "present"+    (Right Account {user = "x", shell = "/bin/sh", home = Just "/home/x"})+    (decodeText "user: x\nhome: /home/x\n")+  assertEqual+    "missing"+    (Just (1, 1, "missing key \"user\""))+    (errorOf (decodeText @Account "shell: /bin/zsh\nhome: null\n"))+  assertEqual+    "explicit null"+    (Right Account {user = "x", shell = "/bin/sh", home = Nothing})+    (decodeText "user: x\nhome: null\n")+  assertEqual+    "missing field that accepts null"+    (Just (1, 1, "missing key \"home\""))+    (errorOf (decodeText @Account "user: x"))+  assertEqual+    "null field kept"+    "user: x\nshell: /bin/sh\nhome: null\n"+    (encodeText Account {user = "x", shell = "/bin/sh", home = Nothing})+  roundTrip+    "round trip of a null field"+    Account {user = "x", shell = "/bin/sh", home = Nothing}+  roundTrip+    "round trip"+    Account {user = "x", shell = "/bin/zsh", home = Just "/home/x"}+  assertEqual+    "present contents"+    (Right (Once 2))+    (decodeText "tag: Once\ncontents: 2\n")+  assertEqual+    "missing contents"+    (Just (1, 1, "missing key \"contents\""))+    (errorOf (decodeText @Task "tag: Once\n"))+  decoded <-+    try @ErrorCall (evaluate (length (show (decodeText @Login "user: x\nshell: y\n"))))+  assertEqual+    "decoder with a strict field"+    (Left (strictError "Login"))+    (first message decoded)+  encoded <- try @ErrorCall (evaluate (T.length (encodeText (Login "x" "y"))))+  assertEqual+    "encoder with a strict field"+    (Left (strictError "Login"))+    (first message encoded)+  newtypeDecoded <-+    try @ErrorCall (evaluate (length (show (decodeText @Port "port: 1\n"))))+  assertEqual+    "decoder of a newtype"+    (Left (strictError "Port"))+    (first message newtypeDecoded)+  where+    strictError :: String -> String+    strictError name =+      "requiredField in a strict field or a newtype of the default of " ++ name++    -- The equality of 'ErrorCall' also compares the location of the call.+    message :: ErrorCall -> String+    message (ErrorCall m) = m++-- | A thread killed while the decoder checks a field of the default for+-- 'requiredField' does not break the decoder for other threads.+test_interruptedDefault :: Assertion+test_interruptedDefault = do+  done <- newEmptyMVar+  worker <-+    forkIO+      (try @SomeException (evaluate (decodeText @Gated "other: 2\n")) >>= putMVar done)+  takeMVar gateEntered+  killer <- forkIO (killThread worker)+  waitBlockedOrDone killer+  putMVar gate ()+  _ <- takeMVar done+  assertEqual+    "decode after the interrupted one"+    (Right (Gated 1 2))+    (decodeText "other: 2\n")+  where+    -- The exception is on its way once the thread that throws it waits or+    -- has thrown it.+    waitBlockedOrDone :: ThreadId -> IO ()+    waitBlockedOrDone t =+      threadStatus t >>= \case+        ThreadBlocked _ -> pure ()+        ThreadFinished -> pure ()+        _ -> yield >> waitBlockedOrDone t++test_modifiers :: Assertion+test_modifiers = do+  assertEqual+    "lower camel case"+    "source_paths"+    (snakeCase "sourcePaths")+  assertEqual+    "upper camel case"+    "source_paths"+    (snakeCase "SourcePaths")+  assertEqual+    "acronym"+    "http_server"+    (snakeCase "HTTPServer")+  assertEqual+    "acronym in the middle"+    "camel_api_case"+    (snakeCase "camelAPICase")+  assertEqual+    "kebab case"+    "source-paths"+    (kebabCase "sourcePaths")
+ tests/Yamlet/Test/Helpers.hs view
@@ -0,0 +1,63 @@+-- | The helpers that several test modules use.+module Yamlet.Test.Helpers+  ( errorPlace+  , errorOf+  , errorsOf+  , roundTrip+  , slow+  , Fortieths+  , Thirds+  ) where++import Data.Fixed+import Data.List.NonEmpty qualified as NE+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet++-- | The time limit of a test on a large input, so that a regression to+-- quadratic time fails the test instead of stalling the suite. No+-- measurement gave the limit. A test must stay well below it also on CI,+-- which runs the tests several times slower than a fast local machine, so a+-- slow test gets a smaller input, not a higher limit.+slow :: TestTree -> TestTree+slow = localOption (mkTimeout 10000000)++-- | The line, the column and the message of an error.+errorPlace :: Error -> (Int, Int, String)+errorPlace err = (err.location.line, err.location.column, err.message)++-- | The line, the column and the message of the only error.+errorOf :: Either (NE.NonEmpty Error) a -> Maybe (Int, Int, String)+errorOf = \case+  Left (err NE.:| []) -> Just (errorPlace err)+  Left errs ->+    error $ "expected one error, but got " ++ show (map (.message) (NE.toList errs))+  Right _ -> Nothing++-- | The line, the column and the message of each error.+errorsOf :: Either (NE.NonEmpty Error) a -> [(Int, Int, String)]+errorsOf = \case+  Left errs -> map errorPlace (NE.toList errs)+  Right _ -> []++-- | Encoding a value and decoding the result gives the same value.+roundTrip :: (Eq a, Show a, ToYaml a, FromYaml a) => String -> a -> Assertion+roundTrip preface x =+  assertEqual+    preface+    (Right x)+    (decodeText (encodeText x))++-- | A resolution of 1/40, which needs three places after the point.+data Fortieths++instance HasResolution Fortieths where+  resolution _ = 40++-- | A resolution of 1/3, which has no exact decimal form.+data Thirds++instance HasResolution Thirds where+  resolution _ = 3
+ tests/Yamlet/Test/Helpers/Thunks.hs view
@@ -0,0 +1,28 @@+-- | A check that a value is fully evaluated.+module Yamlet.Test.Helpers.Thunks+  ( thunks+  ) where++import GHC.Exts.Heap++-- | The thunks that a value refers to, each with the constructors on the way+-- to it.+thunks :: a -> IO [String]+thunks = go [] . asBox+  where+    go :: [String] -> Box -> IO [String]+    go path b =+      getBoxedClosureData b >>= \case+        ConstrClosure {name, ptrArgs} -> concat <$> mapM (go (name : path)) ptrArgs+        -- An evaluated thunk refers to its value until the next garbage+        -- collection.+        IndClosure {indirectee} -> go path indirectee+        BlackholeClosure {indirectee} -> go path indirectee+        ThunkClosure {} -> found "thunk"+        SelectorClosure {} -> found "selector thunk"+        APClosure {} -> found "application thunk"+        APStackClosure {} -> found "stack thunk"+        _ -> pure []+      where+        found :: String -> IO [String]+        found kind = pure [unwords (reverse (kind : path))]
+ tests/Yamlet/Test/Inspection.hs view
@@ -0,0 +1,734 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}++-- | The derived instances contain no generic representation.+--+-- The module exports every binding, because GHC 9.14 removes an unused+-- binding before the plugin checks it.+module Yamlet.Test.Inspection where++import Data.Text qualified as T+import Test.Inspection+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet+import Yamlet.Test.Inspection.Obligations++-- Each type has a test for each method, which checks both obligations. The+-- encoders of Step keep the representation with every GHC, and those of+-- Shape with GHC before 9.12, which 'assertFailureIf' expects. The encoders+-- of lists and fields keep it because they call the encoder of the type. The+-- optimizer moves the node of the constructor without fields, Halt or Dot, to+-- the top level. Then the code of the last constructors is in a function with+-- two callers, which takes their representation.+inspectionTests :: TestTree+inspectionTests =+  testGroup+    "inspection"+    [ testGroup+        "Server"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeServer)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeServer)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeServer)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeServer)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeServerList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeServerList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeServerList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeServerList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeServerField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeServerField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeServerField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeServerField)+        ]+    , testGroup+        "Wide"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeWide)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeWide)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeWide)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeWide)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeWideList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeWideList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeWideList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeWideList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeWideField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeWideField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeWideField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeWideField)+        ]+    , testGroup+        "Name"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeName)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeName)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeName)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeName)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeNameList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeNameList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeNameList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeNameList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeNameField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeNameField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeNameField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeNameField)+        ]+    , testGroup+        "Box"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeBox)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeBox)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeBox)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeBox)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeBoxList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeBoxList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeBoxList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeBoxList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeBoxField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeBoxField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeBoxField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeBoxField)+        ]+    , testGroup+        "Velocity"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeVelocity)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeVelocity)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeVelocity)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeVelocity)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeVelocityList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeVelocityList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeVelocityList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeVelocityList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeVelocityField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeVelocityField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeVelocityField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeVelocityField)+        ]+    , testGroup+        "Distance"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeDistance)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeDistance)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeDistance)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeDistance)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeDistanceList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeDistanceList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeDistanceList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeDistanceList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeDistanceField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeDistanceField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeDistanceField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeDistanceField)+        ]+    , testGroup+        "Speed"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeSpeed)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeSpeed)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeSpeed)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeSpeed)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeSpeedList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeSpeedList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeSpeedList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeSpeedList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeSpeedField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeSpeedField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeSpeedField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeSpeedField)+        ]+    , testGroup+        "Config"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeConfig)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeConfig)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeConfig)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeConfig)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeConfigList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeConfigList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeConfigList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeConfigList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeConfigField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeConfigField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeConfigField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeConfigField)+        ]+    , testGroup+        "Preset"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodePreset)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodePreset)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodePreset)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodePreset)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodePresetList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodePresetList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodePresetList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodePresetList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodePresetField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodePresetField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodePresetField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodePresetField)+        ]+    , testGroup+        "Turn"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeTurn)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeTurn)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeTurn)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeTurn)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeTurnList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeTurnList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeTurnList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeTurnList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeTurnField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeTurnField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeTurnField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeTurnField)+        ]+    , testGroup+        "Shape"+        [ testCase "encode" $ do+            assertFailureIf+              (ghcVersion < (9, 12))+              $(inspectTest $ hasNoGenericRep 'encodeShape)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeShape)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeShape)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeShape)+        , testCase "encode a list" $ do+            assertFailureIf+              (ghcVersion < (9, 12))+              $(inspectTest $ hasNoGenericRep 'encodeShapeList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeShapeList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeShapeList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeShapeList)+        , testCase "encode a field" $ do+            assertFailureIf+              (ghcVersion < (9, 12))+              $(inspectTest $ hasNoGenericRep 'encodeShapeField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeShapeField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeShapeField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeShapeField)+        ]+    , testGroup+        "Step"+        [ testCase "encode" $ do+            assertFailureIf True $(inspectTest $ hasNoGenericRep 'encodeStep)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeStep)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeStep)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeStep)+        , testCase "encode a list" $ do+            assertFailureIf True $(inspectTest $ hasNoGenericRep 'encodeStepList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeStepList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeStepList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeStepList)+        , testCase "encode a field" $ do+            assertFailureIf True $(inspectTest $ hasNoGenericRep 'encodeStepField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeStepField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeStepField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeStepField)+        ]+    , testGroup+        "Figure"+        [ testCase "encode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeFigure)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeFigure)+        , testCase "decode" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeFigure)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeFigure)+        , testCase "encode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeFigureList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeFigureList)+        , testCase "decode a list" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeFigureList)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeFigureList)+        , testCase "encode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'encodeFigureField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'encodeFigureField)+        , testCase "decode a field" $ do+            assertSuccess $(inspectTest $ hasNoGenericRep 'decodeFigureField)+            assertSuccess $(inspectTest $ hasNoGenericDictionaries 'decodeFigureField)+        ]+    ]++----------------------------------------+-- Products++data Server = Server {host :: T.Text, port :: Int, tags :: Maybe [T.Text]}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Server++data Wide = Wide+  { i00 :: Int+  , i01 :: Int+  , i02 :: Int+  , i03 :: Int+  , i04 :: Int+  , i05 :: Int+  , i06 :: Int+  , i07 :: Int+  , i08 :: Int+  , i09 :: Int+  , i10 :: Int+  , i11 :: Int+  , i12 :: Int+  , i13 :: Int+  , i14 :: Int+  , i15 :: Int+  , i16 :: Int+  , i17 :: Int+  , i18 :: Int+  , i19 :: Int+  , i20 :: Int+  , i21 :: Int+  , i22 :: Int+  , i23 :: Int+  , i24 :: Int+  , i25 :: Int+  , i26 :: Int+  , i27 :: Int+  , i28 :: Int+  , i29 :: Int+  , i30 :: Int+  , i31 :: Int+  , i32 :: Int+  , i33 :: Int+  , t00 :: T.Text+  , t01 :: T.Text+  , t02 :: T.Text+  , t03 :: T.Text+  , t04 :: T.Text+  , t05 :: T.Text+  , t06 :: T.Text+  , t07 :: T.Text+  , t08 :: T.Text+  , t09 :: T.Text+  , t10 :: T.Text+  , t11 :: T.Text+  , t12 :: T.Text+  , t13 :: T.Text+  , t14 :: T.Text+  , t15 :: T.Text+  , t16 :: T.Text+  , t17 :: T.Text+  , t18 :: T.Text+  , t19 :: T.Text+  , t20 :: T.Text+  , t21 :: T.Text+  , t22 :: T.Text+  , t23 :: T.Text+  , t24 :: T.Text+  , t25 :: T.Text+  , t26 :: T.Text+  , t27 :: T.Text+  , t28 :: T.Text+  , t29 :: T.Text+  , t30 :: T.Text+  , t31 :: T.Text+  , t32 :: T.Text+  , m00 :: Maybe Int+  , m01 :: Maybe Int+  , m02 :: Maybe Int+  , m03 :: Maybe Int+  , m04 :: Maybe Int+  , m05 :: Maybe Int+  , m06 :: Maybe Int+  , m07 :: Maybe Int+  , m08 :: Maybe Int+  , m09 :: Maybe Int+  , m10 :: Maybe Int+  , m11 :: Maybe Int+  , m12 :: Maybe Int+  , m13 :: Maybe Int+  , m14 :: Maybe Int+  , m15 :: Maybe Int+  , m16 :: Maybe Int+  , m17 :: Maybe Int+  , m18 :: Maybe Int+  , m19 :: Maybe Int+  , m20 :: Maybe Int+  , m21 :: Maybe Int+  , m22 :: Maybe Int+  , m23 :: Maybe Int+  , m24 :: Maybe Int+  , m25 :: Maybe Int+  , m26 :: Maybe Int+  , m27 :: Maybe Int+  , m28 :: Maybe Int+  , m29 :: Maybe Int+  , m30 :: Maybe Int+  , m31 :: Maybe Int+  , m32 :: Maybe Int+  }+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Wide++newtype Name = Name T.Text+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Name++newtype Box a = Box {item :: a}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml (Box a)++newtype Velocity = Velocity Speed+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Velocity++instance GenericYamlOptions Velocity where+  type SumEncoding Velocity = TaggedFlat+  yamlOptions = defaultYamlOptions {tagSingleConstructors = True}++newtype Distance = Distance {distance :: Maybe Int}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Distance++newtype Speed = Speed {speed :: Int}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Speed++data Config = Config {paths :: [T.Text], jobs :: Int, verbose :: Maybe Bool}+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Config++-- The option is on, so that the check of the encoder covers the default too.+-- The encoder uses the default only with 'omitNullFields', to decide if it+-- can leave out a null field.+instance GenericYamlOptions Config where+  yamlOptions = defaultYamlOptions {omitNullFields = True}+  yamlDefault = Just Config {paths = ["."], jobs = 1, verbose = Nothing}++-- Without 'omitNullFields', the encoder does not use the default.+data Preset = Preset {paths :: [T.Text], jobs :: Int, verbose :: Maybe Bool}+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Preset++instance GenericYamlOptions Preset where+  yamlDefault = Just Preset {paths = ["."], jobs = 1, verbose = Nothing}++----------------------------------------+-- Sums++data Turn = TurnLeft | TurnRight | TurnBack+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Turn++data Shape = Circle {radius :: Double} | Dot | Square {side :: Double, angle :: Double}+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Shape++data Step = Ahead Distance | Accelerate Speed | Halt+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Step++instance GenericYamlOptions Step where+  type SumEncoding Step = TaggedFlat+  yamlOptions = defaultYamlOptions {tagKey = "step"}++data Figure = Round {radius :: Double} | Named T.Text | Point+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Figure++instance GenericYamlOptions Figure where+  type SumEncoding Figure = SingleField++----------------------------------------+-- Functions under test++encodeServer :: Server -> Node+encodeServer = toYaml++decodeServer :: Node -> Parser Server+decodeServer = parseYaml++encodeServerList :: [Server] -> Node+encodeServerList = toYamlList++decodeServerList :: Node -> Parser [Server]+decodeServerList = parseYamlList++encodeServerField :: Node -> Server -> (Node, Node)+encodeServerField = toYamlField++decodeServerField :: Node -> Node -> Parser Server+decodeServerField = parseYamlField++encodeWide :: Wide -> Node+encodeWide = toYaml++decodeWide :: Node -> Parser Wide+decodeWide = parseYaml++encodeWideList :: [Wide] -> Node+encodeWideList = toYamlList++decodeWideList :: Node -> Parser [Wide]+decodeWideList = parseYamlList++encodeWideField :: Node -> Wide -> (Node, Node)+encodeWideField = toYamlField++decodeWideField :: Node -> Node -> Parser Wide+decodeWideField = parseYamlField++encodeName :: Name -> Node+encodeName = toYaml++decodeName :: Node -> Parser Name+decodeName = parseYaml++encodeNameList :: [Name] -> Node+encodeNameList = toYamlList++decodeNameList :: Node -> Parser [Name]+decodeNameList = parseYamlList++encodeNameField :: Node -> Name -> (Node, Node)+encodeNameField = toYamlField++decodeNameField :: Node -> Node -> Parser Name+decodeNameField = parseYamlField++encodeBox :: Box Int -> Node+encodeBox = toYaml++decodeBox :: Node -> Parser (Box Int)+decodeBox = parseYaml++encodeBoxList :: [Box Int] -> Node+encodeBoxList = toYamlList++decodeBoxList :: Node -> Parser [Box Int]+decodeBoxList = parseYamlList++encodeBoxField :: Node -> Box Int -> (Node, Node)+encodeBoxField = toYamlField++decodeBoxField :: Node -> Node -> Parser (Box Int)+decodeBoxField = parseYamlField++encodeVelocity :: Velocity -> Node+encodeVelocity = toYaml++decodeVelocity :: Node -> Parser Velocity+decodeVelocity = parseYaml++encodeVelocityList :: [Velocity] -> Node+encodeVelocityList = toYamlList++decodeVelocityList :: Node -> Parser [Velocity]+decodeVelocityList = parseYamlList++encodeVelocityField :: Node -> Velocity -> (Node, Node)+encodeVelocityField = toYamlField++decodeVelocityField :: Node -> Node -> Parser Velocity+decodeVelocityField = parseYamlField++encodeDistance :: Distance -> Node+encodeDistance = toYaml++decodeDistance :: Node -> Parser Distance+decodeDistance = parseYaml++encodeDistanceList :: [Distance] -> Node+encodeDistanceList = toYamlList++decodeDistanceList :: Node -> Parser [Distance]+decodeDistanceList = parseYamlList++encodeDistanceField :: Node -> Distance -> (Node, Node)+encodeDistanceField = toYamlField++decodeDistanceField :: Node -> Node -> Parser Distance+decodeDistanceField = parseYamlField++encodeSpeed :: Speed -> Node+encodeSpeed = toYaml++decodeSpeed :: Node -> Parser Speed+decodeSpeed = parseYaml++encodeSpeedList :: [Speed] -> Node+encodeSpeedList = toYamlList++decodeSpeedList :: Node -> Parser [Speed]+decodeSpeedList = parseYamlList++encodeSpeedField :: Node -> Speed -> (Node, Node)+encodeSpeedField = toYamlField++decodeSpeedField :: Node -> Node -> Parser Speed+decodeSpeedField = parseYamlField++encodeConfig :: Config -> Node+encodeConfig = toYaml++decodeConfig :: Node -> Parser Config+decodeConfig = parseYaml++encodeConfigList :: [Config] -> Node+encodeConfigList = toYamlList++decodeConfigList :: Node -> Parser [Config]+decodeConfigList = parseYamlList++encodeConfigField :: Node -> Config -> (Node, Node)+encodeConfigField = toYamlField++decodeConfigField :: Node -> Node -> Parser Config+decodeConfigField = parseYamlField++encodePreset :: Preset -> Node+encodePreset = toYaml++decodePreset :: Node -> Parser Preset+decodePreset = parseYaml++encodePresetList :: [Preset] -> Node+encodePresetList = toYamlList++decodePresetList :: Node -> Parser [Preset]+decodePresetList = parseYamlList++encodePresetField :: Node -> Preset -> (Node, Node)+encodePresetField = toYamlField++decodePresetField :: Node -> Node -> Parser Preset+decodePresetField = parseYamlField++encodeTurn :: Turn -> Node+encodeTurn = toYaml++decodeTurn :: Node -> Parser Turn+decodeTurn = parseYaml++encodeTurnList :: [Turn] -> Node+encodeTurnList = toYamlList++decodeTurnList :: Node -> Parser [Turn]+decodeTurnList = parseYamlList++encodeTurnField :: Node -> Turn -> (Node, Node)+encodeTurnField = toYamlField++decodeTurnField :: Node -> Node -> Parser Turn+decodeTurnField = parseYamlField++encodeShape :: Shape -> Node+encodeShape = toYaml++decodeShape :: Node -> Parser Shape+decodeShape = parseYaml++encodeShapeList :: [Shape] -> Node+encodeShapeList = toYamlList++decodeShapeList :: Node -> Parser [Shape]+decodeShapeList = parseYamlList++encodeShapeField :: Node -> Shape -> (Node, Node)+encodeShapeField = toYamlField++decodeShapeField :: Node -> Node -> Parser Shape+decodeShapeField = parseYamlField++encodeStep :: Step -> Node+encodeStep = toYaml++decodeStep :: Node -> Parser Step+decodeStep = parseYaml++encodeStepList :: [Step] -> Node+encodeStepList = toYamlList++decodeStepList :: Node -> Parser [Step]+decodeStepList = parseYamlList++encodeStepField :: Node -> Step -> (Node, Node)+encodeStepField = toYamlField++decodeStepField :: Node -> Node -> Parser Step+decodeStepField = parseYamlField++encodeFigure :: Figure -> Node+encodeFigure = toYaml++decodeFigure :: Node -> Parser Figure+decodeFigure = parseYaml++encodeFigureList :: [Figure] -> Node+encodeFigureList = toYamlList++decodeFigureList :: Node -> Parser [Figure]+decodeFigureList = parseYamlList++encodeFigureField :: Node -> Figure -> (Node, Node)+encodeFigureField = toYamlField++decodeFigureField :: Node -> Node -> Parser Figure+decodeFigureField = parseYamlField
+ tests/Yamlet/Test/Inspection/Obligations.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-- | Obligations for the inspection tests. They are in their own module,+-- because a splice cannot use a function of the module that holds it.+--+-- Keep every function of this module, also one that no test uses at the+-- moment, e.g. 'assertFailureIf' and 'ghcVersion' when no test expects a+-- failure. A later change to the library or a new version of GHC can need+-- them again.+module Yamlet.Test.Inspection.Obligations+  ( hasNoGenericRep+  , hasNoGenericDictionaries+  , assertSuccess+  , assertFailureIf+  , ghcVersion+  ) where++import GHC.Generics qualified as G+import Language.Haskell.TH+import Test.Inspection+import Test.Tasty.HUnit++import Yamlet++-- | The code uses no function and no constructor of the generic+-- representation. 'hasNoGenerics' checks the types instead, but the types+-- appear in coercions and in the types of join points after the optimizer+-- removed the representation. The constructors of the newtypes 'G.K1' and+-- 'G.M1' are casts in Core, so the list cannot name them.+hasNoGenericRep :: Name -> Obligation+hasNoGenericRep name =+  mkObligation name $+    NoUseOf+      [ 'G.from+      , 'G.to+      , '(G.:*:)+      , 'G.L1+      , 'G.R1+      , 'G.U1+      ]++-- | The code passes no dictionaries of the generic classes, e.g. to a method+-- of the instance for t'Yamlet.GenericYaml' that GHC did not inline at the+-- type. That method keeps the generic representation in another module.+-- 'hasNoGenericRep' sees such a call only through the 'G.Generic' instance+-- of a type in the module of the test.+hasNoGenericDictionaries :: Name -> Obligation+hasNoGenericDictionaries name =+  mkObligation name $+    NoTypes+      [ ''G.Generic+      , ''GenericYamlOptions+      , ''GDatatype+      , ''GConstructors+      , ''GEncoding+      , ''GToConstructor+      , ''GFromConstructor+      , ''GFields+      , ''GToFields+      , ''GFromFields+      ]++-- | Fail with the Core of the function if the obligation does not hold.+assertSuccess :: Result -> Assertion+assertSuccess = \case+  Success _ -> pure ()+  Failure err -> assertFailure err++-- | If the flag is set, fail if the obligation holds, for a known failure,+-- e.g. on a version of GHC that optimizes the code less. Then the test also+-- shows when a version of GHC fixes the failure. Otherwise, 'assertSuccess'.+assertFailureIf :: Bool -> Result -> Assertion+assertFailureIf = \case+  True -> \case+    Success msg -> assertFailure ("expected a failure, but " ++ msg)+    Failure _ -> pure ()+  False -> assertSuccess++-- | The major version of GHC, e.g. @(9, 12)@.+ghcVersion :: (Int, Int)+ghcVersion = __GLASGOW_HASKELL__ `quotRem` 100
+ tests/Yamlet/Test/Render.hs view
@@ -0,0 +1,20 @@+module Yamlet.Test.Render (renderTests) where++import Test.Tasty++import Yamlet.Test.Render.Attachment+import Yamlet.Test.Render.Comments+import Yamlet.Test.Render.Documents+import Yamlet.Test.Render.Properties+import Yamlet.Test.Render.Styles++renderTests :: TestTree+renderTests =+  testGroup+    "render"+    [ styleTests+    , documentTests+    , attachmentTests+    , commentTests+    , propertyTests+    ]
+ tests/Yamlet/Test/Render/Attachment.hs view
@@ -0,0 +1,271 @@+-- | The rules that attach comment lines to the nodes.+module Yamlet.Test.Render.Attachment+  ( attachmentTests+  ) where++import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet.Syntax+import Yamlet.Test.Render.Helpers++attachmentTests :: TestTree+attachmentTests = testCase "attachment" test_attachment++-- | Each rule of the documentation.+test_attachment :: Assertion+test_attachment = do+  let check :: String -> [(String, String, T.Text)] -> T.Text -> Assertion+      check preface expected input = case parseDocumentsText input of+        Right [doc] ->+          assertEqual+            preface+            expected+            (commentsOf doc)+        r -> assertFailure (preface ++ ": " ++ show r)+  check+    "above a key"+    [("/b:key", "before", "c")]+    "a: 1\n# c\nb: 2\n"+  check+    "above the first key"+    [("/a:key", "before", "c")]+    "# c\na: 1\n"+  check+    "above the first key of a value"+    [("/a/b:key", "before", "c")]+    "a:\n  # c\n  b: 1\n"+  check+    "above an empty line above the first key"+    [("", "before", "c"), ("/a:key", "before", "d")]+    "# c\n\n# d\na: 1\n"+  check+    "above the first key after an indicator"+    [("/0", "inline", "c"), ("/0/a:key", "before", "d")]+    "- # c\n  # d\n  a: 1\n"+  check+    "above an item with a mapping"+    [("/0", "before", "c"), ("/1", "before", "d")]+    "# c\n- a: 1\n# d\n- b: 2\n"+  check+    "at the end of a value"+    [("/a", "inline", "c")]+    "a: 1 # c\n"+  check+    "at the end of a key"+    [("/a:key", "inline", "c")]+    "a: # c\n  b: 1\n"+  check+    "on a block scalar header"+    [("/a", "inline", "c")]+    "a: | # c\n  text\n"+  check+    "after a block scalar in a key"+    [("/?:key/0", "inline", "c"), ("/?", "inline", "d")]+    "? - | # c\n    text\n: # d\n  - x\n"+  check+    "after a kept block scalar in a key"+    [("/?", "inline", "c")]+    "? - |+\n    text\n\n: # c\n  k: v\n"+  check+    "above a sequence item"+    [("/a/1", "before", "c")]+    "a:\n- 1\n# c\n- 2\n"+  check+    "after a flow collection"+    [("/a", "inline", "c")]+    "a: [1, 2] # c\n"+  check+    "on an item line"+    [("/0", "inline", "c")]+    "- # c\n  a: 1\n"+  check+    "on an item line and after the item"+    [("/0", "before", "c"), ("/0", "inline", "d")]+    "- # c\n  a # d\n"+  check+    "on a bracket line and after the item"+    [("/a/0", "before", "c"), ("/a/0", "inline", "d")]+    "a: [ # c\n  1, # d\n  2]\n"+  check+    "on an item line and on a block scalar header"+    [("/0", "before", "c"), ("/0", "inline", "d")]+    "- # c\n  | # d\n  text\n"+  check+    "at the end of an indented list"+    [("/a", "after", "c")]+    "a:\n  - 1\n  # c\nb: 2\n"+  check+    "at the key column after a list"+    [("/b:key", "before", "c")]+    "a:\n- 1\n# c\nb: 2\n"+  check+    "at the end of a nested mapping"+    [("/a", "after", "c")]+    "a:\n  b: 1\n  # c\nd: 2\n"+  check+    "at the end of the root"+    [("", "after", "c")]+    "a: 1\n# c\n"+  check+    "after an empty line at the end of the root"+    [("", "after", "c"), ("", "after", "d")]+    "a: 1\n# c\n\n# d\n"+  check+    "at the end of a scalar root"+    [("", "after", "c")]+    "a\n# c\n"+  check+    "below a flow root"+    [("document", "after", "c")]+    "[a]\n# c\n"+  check+    "before the end marker"+    [("document", "after", "d"), ("", "after", "c")]+    "a\n# c\n...\n# d\n"+  check+    "below a flow root and the end marker"+    [("document", "after", "c"), ("document", "after", "d")]+    "[a]\n# c\n...\n# d\n"+  check+    "before the marker"+    [("document", "before", "c")]+    "# c\n---\na: 1\n"+  check+    "on the marker line"+    [("document", "inline", "c")]+    "--- # c\na: 1\n"+  check+    "after a root on the marker line"+    [("", "inline", "c")]+    "--- a # c\n"+  check+    "after a tag on the marker line"+    [("document", "inline", "c")]+    "--- !!map # c\na: 1\n"+  check+    "after the end marker"+    [("document", "after", "c")]+    "a\n...\n# c\n"+  check+    "after the end marker of a mapping"+    [("document", "after", "c")]+    "a: 1\n...\n# c\n"+  check+    "on the end marker line"+    [("document", "after", "c")]+    "a\n... # c\n"+  check+    "after two end markers"+    [("document", "after", "c"), ("document", "after", "d")]+    "a\n...\n# c\n...\n# d\n"+  check+    "on a second end marker line"+    [("document", "after", "c")]+    "a\n...\n... # c\n"+  check+    "after an empty flow sequence with lines inside"+    [("/0", "inline", "d"), ("/0", "after", "c")]+    "- [\n  # c\n  ] # d\n- 2\n"+  check+    "after a flow mapping with lines inside"+    [("/k", "inline", "d"), ("/k", "after", "c")]+    "k: {a: 1,\n  # c\n  } # d\n"+  check+    "inside a flow sequence"+    [("/0", "inline", "c"), ("/1", "before", "d")]+    "[a, # c\n # d\n b]\n"+  check+    "below an explicit key without a value"+    [("/b:key", "before", "c")]+    "? a\n# c\n? b\n"+  check+    "at the end of a list item with an explicit key"+    [("/0", "after", "c")]+    "- ? a\n  # c\n- b\n"+  check+    "at the end of a mapping with an explicit key"+    [("/x", "after", "c")]+    "x:\n  ? a\n  # c\ny: 1\n"+  check+    "empty lines"+    []+    "a: 1\n\n\nb: 2\n"+  assertEqual+    "empty lines"+    (Right [EmptyLine, EmptyLine])+    $ ( \case+          [d] | MappingContent _ [_, (k, _)] <- d.root.content -> k.comments.before+          _ -> []+      )+      <$> parseDocumentsText "a: 1\n\n\nb: 2\n"+  assertEqual+    "empty line below the end of a collection"+    (Right [([Comment "c"], [EmptyLine])])+    $ map+      ( \d -> case d.root.content of+          MappingContent _ [(_, v), (k, _)] -> (v.comments.after, k.comments.before)+          _ -> ([], [])+      )+      <$> parseDocumentsText "a:\n  b: 1\n  # c\n\nd: 2\n"+  assertEqual+    "empty line below an explicit key without a value"+    (Right "a:\n\n# c\nb:\n")+    (renderSyntax defaultRenderOptions <$> parseDocumentsText "? a\n\n# c\n? b\n")+  assertEqual+    "empty line at the end of the root"+    (Right [([Comment "c"], [EmptyLine, Comment "d"], [])])+    $ map+      ( \d -> case d.root.content of+          MappingContent _ [(_, v)] ->+            (v.comments.after, d.root.comments.after, d.docComments.after)+          _ -> ([], [], [])+      )+      <$> parseDocumentsText "a:\n  b: 1\n  # c\n\n# d\n"+  let between :: String -> [([Line], [Line])] -> T.Text -> Assertion+      between preface expected input =+        assertEqual+          preface+          (Right expected)+          $ map+            ( \d ->+                ( d.root.comments.after ++ d.docComments.after+                , d.docComments.before ++ d.root.comments.before+                )+            )+            <$> parseDocumentsText input+  between+    "above the marker of the next document"+    [([Comment "c"], []), ([], [])]+    "a\n# c\n---\nb\n"+  between+    "empty line above the marker of the next document"+    [([Comment "c"], []), ([], [EmptyLine, Comment "d"])]+    "a\n# c\n\n# d\n---\nb\n"+  between+    "empty line after the end marker"+    [([Comment "c"], []), ([], [EmptyLine, Comment "d"])]+    "a\n...\n# c\n\n# d\n---\nb\n"+  between+    "empty line after the end marker above a bare document"+    [([Comment "c"], []), ([], [EmptyLine, Comment "d"])]+    "a\n...\n# c\n\n# d\nb\n"+  between+    "empty line below a flow root"+    [([Comment "c"], []), ([], [EmptyLine, Comment "d"])]+    "[a]\n# c\n\n# d\n---\nb\n"+  between+    "empty line below a flow root above the last end marker"+    [([Comment "c", EmptyLine], [])]+    "[a]\n# c\n\n...\n\n"+  assertEqual+    "empty lines above the first key"+    (Right [([Comment "a", EmptyLine, Comment "b", EmptyLine, EmptyLine], [Comment "c"])])+    $ map (\d -> (d.root.comments.before, firstKey d.root))+      <$> parseDocumentsText "# a\n\n# b\n\n\n# c\nk: v\n"+  where+    firstKey :: Node -> [Line]+    firstKey n = case n.content of+      MappingContent _ ((k, _) : _) -> k.comments.before+      _ -> []
+ tests/Yamlet/Test/Render/Comments.hs view
@@ -0,0 +1,503 @@+-- | The comments that rendering writes and moves.+module Yamlet.Test.Render.Comments+  ( commentTests+  ) where++import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet.Syntax+import Yamlet.Test.Helpers.Thunks+import Yamlet.Test.Render.Helpers++commentTests :: TestTree+commentTests =+  testGroup+    "comments"+    [ testCase "configuration" test_configuration+    , testCase "round trip" test_commentRoundTrip+    , testCase "several hashes" test_hashes+    , testCase "moved comments" test_movedComments+    , testCase "lines after a list" test_linesAfterList+    , testCase "lines below an indicator" test_linesBelowIndicator+    , testCase "byte order mark" test_byteOrderMark+    , testCase "no thunks" test_noThunks+    ]++-- | A byte order mark at the start of a line does not change the comments of+-- the document after it.+test_byteOrderMark :: Assertion+test_byteOrderMark =+  sequence_+    [ assertEqual+        (preface ++ " " ++ show input)+        (comments (above <> input))+        (comments (above <> "\xFEFF" <> input))+    | input <- inputs+    , (preface, above) <- [("first document", ""), ("after an end marker", "a\n...\n")]+    ]+  where+    inputs :: [T.Text]+    inputs =+      [ "a: | # c\n  b\nd:\n- e\n"+      , "a: x\n  # c\nb:\n  c: d\n  # e\nf: g\n"+      , "- a: 1\n  # c\n- b\n"+      , "--- a # c\n"+      ]++    comments :: T.Text -> Either String [[(String, String, T.Text)]]+    comments t = either (Left . show) (Right . map commentsOf) (parseDocumentsText t)++-- | The parser returns documents with comments without thunks, as it does for+-- documents without comments.+test_noThunks :: Assertion+test_noThunks =+  mapM_+    check+    [ ("configuration", configuration)+    , ("flow collections", "a: [1, # b\n  2] # c\nd: {e: f, # g\n  h: i}\n")+    , ("explicit keys", "? a\n# b\n? c\n: d\n\n# e\n")+    , ("documents", "# a\n--- # b\nc\n...\n# d\n---\ne: 1\n")+    , ("empty quoted keys", "'': a\n? \"\"\n: b\nc: {'': d}\n")+    , ("pairs in flow sequences", "[[]: a, '': b]\n")+    , ("empty nodes", "a:\nb: !t\n? c\nd: {e: , &f : g}\n")+    ]+  where+    check :: (String, T.Text) -> Assertion+    check (preface, input) = case parseDocumentsText input of+      Right docs -> thunks docs >>= assertEqual preface []+      Left e -> assertFailure (preface ++ ": " ++ show e)++-- | The configuration of the haskell-gha test with comments.+test_configuration :: Assertion+test_configuration = case parseDocumentsText configuration of+  Right [doc] ->+    assertEqual+      "comments"+      expected+      (commentsOf doc)+  r -> assertFailure (show r)+  where+    expected :: [(String, String, T.Text)]+    expected =+      [ ("/matrix:key", "before", "The oldest and the newest supported Postgres.")+      , ("/services:key", "before", "The services of each build job.")+      , ("/services/postgres:key", "before", "The database for the tests.")+      , ("/services/postgres/env/POSTGRES_PASSWORD", "inline", "Only for CI.")+      , ("/permissions:key", "before", "The test reporter writes check runs.")+      , ("/permissions/checks:key", "before", "For the annotations of the test results.")+      , ("/hooks:key", "before", "The steps for Postgres.")+      , ("/hooks/before-build/1", "before", "Wait until the database accepts connections.")+      , ("/hooks/before-build", "after", "The database is ready for the build.")+      , ("/hooks/after-build", "after", "The tests come next.")+      ]++configuration :: T.Text+configuration =+  T.unlines+    [ "name: Postgres CI"+    , "branches: [master, 'release/**']"+    , "# The oldest and the newest supported Postgres."+    , "matrix:"+    , "  postgres: ['15', '18']"+    , "  exclude:"+    , "    - ghc: '9.10'"+    , "      postgres: '15'"+    , "apt: [libpq-dev, postgresql-client]"+    , "# The services of each build job."+    , "services:"+    , "  # The database for the tests."+    , "  postgres:"+    , "    image: postgres:${{ matrix.postgres }}"+    , "    env:"+    , "      POSTGRES_PASSWORD: postgres # Only for CI."+    , "    ports: ['5432:5432']"+    , "# The test reporter writes check runs."+    , "permissions:"+    , "  contents: read"+    , "  # For the annotations of the test results."+    , "  checks: write"+    , "# The steps for Postgres."+    , "hooks:"+    , "  before-build:"+    , "    - name: Show the Postgres version"+    , "      run: psql --version"+    , "    # Wait until the database accepts connections."+    , "    - name: Wait for Postgres"+    , "      run: |"+    , "        until pg_isready -h localhost; do"+    , "          sleep 1"+    , "        done"+    , "    # The database is ready for the build."+    , "  after-build:"+    , "    - name: Show the executables"+    , "      run: cabal list-bin all"+    , "    # The tests come next."+    , "ghc-options: -Werror -Wno-unused-imports"+    , "jobs: 2"+    ]++-- | Rendering keeps every comment, and a second round trip gives the same+-- text. The end comments of an indentless sequence belong to its last item+-- after the round trip.+test_commentRoundTrip :: Assertion+test_commentRoundTrip = case parseDocumentsText configuration of+  Right docs -> do+    let out = renderSyntax defaultRenderOptions docs+        texts :: Document -> [T.Text]+        texts d = [t | (_, _, t) <- commentsOf d]+    case parseDocumentsText out of+      Right docs' -> do+        assertEqual+          ("comments\n" ++ T.unpack out)+          (map texts docs)+          (map texts docs')+        assertEqual+          "text"+          out+          (renderSyntax defaultRenderOptions docs')+      Left err -> assertFailure (T.unpack out ++ "\n" ++ show err)+  Left err -> assertFailure (show err)++-- | A comment on a line of its own keeps its # characters. A comment at the+-- end of a line keeps them in its text.+test_hashes :: Assertion+test_hashes = do+  let input = "## a\n### b ###\n####\n# #c\nk: 1 ##d\n  ## e\n"+  assertEqual+    "lines"+    (Right [[CommentLine 2 "a", CommentLine 3 "b ###", CommentLine 4 "", Comment "#c"]])+    $ map+      ( \d -> case d.root.content of+          MappingContent _ ((k, _) : _) -> k.comments.before+          _ -> []+      )+      <$> parseDocumentsText input+  assertEqual+    "inline and below a value"+    (Right [(Just "#d", [CommentLine 2 "e"])])+    $ map+      ( ( \case+            MappingContent _ [(_, v)] -> (v.comments.inline, v.comments.after)+            _ -> (Nothing, [])+        )+          . (.root.content)+      )+      <$> parseDocumentsText input+  assertEqual+    "rendered"+    (Right "## a\n### b ###\n####\n# #c\nk: 1 # #d\n  ## e\n")+    (renderSyntax defaultRenderOptions <$> parseDocumentsText input)+  assertEqual+    "count below 1"+    "# a\n---\nk: 1\n"+    $ renderSyntax+      defaultRenderOptions+      [ (document (mappingNode [(plainNode "k", plainNode "1")]))+          { docComments = noComments {before = [CommentLine (-1) "a"]}+          }+      ]++-- | The lines after a list under a key stay at the end of the list. Without+-- indentation, a block collection as the last item would take them in.+test_linesAfterList :: Assertion+test_linesAfterList = do+  rendersBack "mapping as the last item" "a:\n  - b: 1\n  # c\n"+  rendersBack "list as the last item" "a:\n  - - b\n  # c\n"+  rendersBack "block scalar as the last item" "a:\n  - |\n    b\n  # c\n"+  rendersBack "scalar as the last item" "a:\n- b\n  # c\n"+  rendersBack "no lines after the list" "a:\n- b: 1\n"++-- | The lines above and below the indicator of a block collection with+-- properties stay with their nodes. Above the indicator of a first entry,+-- the collection around it would take the lines up to the last empty line.+test_linesBelowIndicator :: Assertion+test_linesBelowIndicator = do+  let check :: String -> T.Text -> Assertion+      check preface input = case parseDocumentsText input of+        Right docs -> do+          let out = renderSyntax defaultRenderOptions docs+          case parseDocumentsText out of+            Right docs' -> do+              assertEqual+                (preface ++ "\n" ++ T.unpack out)+                (map commentsOf docs)+                (map commentsOf docs')+              assertEqual+                preface+                out+                (renderSyntax defaultRenderOptions docs')+            Left err -> assertFailure (preface ++ ": " ++ show err)+        Left err -> assertFailure (preface ++ ": " ++ show err)+  check "first item with a tag" "k:\n- !!map\n  # a\n\n  # b\n  c: 1\n- d\n"+  check "first item with a comment" "k:\n- &x # a\n  # b\n\n  c: 1\n- d\n"+  check "explicit key" "- ? &x\n    # a\n\n    b: 1\n  : c\n"+  check "nested first items" "- &x\n  - &y\n    # a\n\n    b: 1\n"+  check "second item" "k:\n- a\n- !!map\n  # b\n  c: 1\n"+  check "second item with a comment" "- a\n- &x # a\n  # b\n  c: 1\n"+  let owners :: String -> [(String, String, T.Text)] -> T.Text -> Assertion+      owners preface expected input =+        assertEqual+          preface+          (Right [expected])+          (map commentsOf <$> parseDocumentsText input)+      ownersRenderBack :: String -> [(String, String, T.Text)] -> T.Text -> Assertion+      ownersRenderBack preface expected input = do+        owners+          preface+          expected+          input+        check preface input+  ownersRenderBack+    "below the indicator of a second item"+    [("/jobs/1/name:key", "before", "c")]+    "jobs:\n- name: a\n- &b\n  # c\n  name: b\n"+  -- The lines of the first entries read back the same above the indicator,+  -- where they stay.+  ownersRenderBack+    "above a first item with an anchor"+    [("/jobs/0/name:key", "before", "c")]+    "jobs:\n# c\n- &b\n  name: b\n"+  rendersBack+    "above a first item with an anchor, the text"+    "jobs:\n# c\n- &b\n  name: b\n"+  rendersBack "above nested first items with tags" "# c\n- !a\n  - !b\n    - 2\n"+  rendersBack+    "above a second item with nested first items"+    "- x\n# c\n- !a\n  - !b\n    - 2\n"+  rendersBack "above an explicit key with an anchor" "# c\n? &a\n  - a\n: b\n"+  rendersBack "below a first item with a comment on its line" "- &a # i\n  # c\n  k: v\n"+  -- A comment on the line of the indicator keeps the lines above it from+  -- the first entries.+  rendersBack+    "above a first item with a comment and nested first items"+    "# c\n- # d\n  - !!map\n    k: v\n"+  rendersBack+    "above a second item with a comment and nested first items"+    "- x\n# c\n\n# e\n- # d\n  - &b\n    - y\n"+  rendersBack "above a first item with a comment" "# c\n- # d\n  # f\n  - a\n"+  rendersBack "above a first item with a comment under a key" "k:\n# c\n- # d\n  - a\n"+  rendersBack "above an explicit key with a comment" "# c\n? # d\n  - a\n: v\n"+  rendersBack+    "below an indicator above a first item with a comment"+    "- # a\n  # h\n  - # b\n    - x\n"+  rendersBack+    "below properties above a first item with a comment"+    "- !!seq\n  # h\n  - # b\n    - x\n"+  rendersBack+    "below an indicator above an explicit key with a comment"+    "- # a\n  # h\n  ? # b\n    - x\n  : v\n"+  rendersBack+    "below root properties above a first item with a comment"+    "!!seq\n# h\n- # b\n  - x\n"+  -- A collection on the line of its indicator would take the lines of its+  -- first entry, so it starts below the indicator.+  ownersRenderBack+    "above a nested first item"+    [("/0/0", "before", "c")]+    "# c\n-\n  - 1\n"+  rendersBack "above a nested first item, the text" "# c\n-\n  - 1\n"+  ownersRenderBack+    "above a first key"+    [("/1/a:key", "before", "c")]+    "- x\n# c\n-\n  a: 1\n  b: 2\n"+  rendersBack "above a first key, the text" "- x\n# c\n-\n  a: 1\n  b: 2\n"+  rendersAs+    "above an explicit key"+    "- ?\n    # c\n    - a\n  : v\n"+    "-\n  ?\n    # c\n    - a\n  : v\n"+  ownersRenderBack+    "below the indicator of a scalar"+    [("/1", "before", "c")]+    "- a\n- !!str\n  # c\n  x\n"+  ownersRenderBack+    "below the indicator of an explicit key"+    [("/x:key", "before", "c")]+    "k: a\n? &k\n  # c\n  x\n: v\n"+  ownersRenderBack+    "below the indicator of an explicit value"+    [("/?/b:key", "before", "c")]+    "? a: 1\n: &x\n  # c\n  b: 2\n"+  ownersRenderBack+    "below an indicator with a comment"+    [("/1", "inline", "i"), ("/1/c:key", "before", "b")]+    "- a\n- # i\n  # b\n  c: 1\n"+  -- The renderer writes these items on the line of the indicator, with the+  -- lines above it, so the lines read back as the lines of the item.+  owners+    "below a bare indicator"+    [("/1/name:key", "before", "c")]+    "-\n  name: a\n-\n  # c\n  name: b\n"+  owners+    "below the indicator of a nested list"+    [("/1/0", "before", "c")]+    "- - a\n-\n  # c\n  - x\n"+  let withAbove :: Node -> Node+      withAbove n = n {comments = noComments {before = [Comment "a"]}}+      list :: Node+      list = sequenceNode [plainNode "1"]+  assertEqual+    "lines of a first item below its indicator"+    (Right [[("/0", "before", "a"), ("/0", "inline", "i")]])+    $ map commentsOf+      <$> parseDocumentsText+        ( render $+            sequenceNode+              [ list+                  { comments = noComments {before = [Comment "a"], inline = Just "i"}+                  }+              ]+        )+  let anchored :: Node -> Node+      anchored n = n {props = noProps {anchor = Just "x"}}+  assertEqual+    "lines of a first item with nested first items"+    (Right [[("/0", "before", "a")]])+    $ map commentsOf+      <$> parseDocumentsText+        (render (sequenceNode [withAbove (anchored (sequenceNode [anchored list]))]))+  assertEqual+    "lines of a block value below its key"+    "k:\n# a\n\n- 1\n"+    (render (mappingNode [(plainNode "k", withAbove list)]))+  assertEqual+    "lines of a block value below its key read back"+    (Right [[("/k", "before", "a")]])+    $ map commentsOf+      <$> parseDocumentsText (render (mappingNode [(plainNode "k", withAbove list)]))++-- | A comment without a place at its node moves to one that has it.+test_movedComments :: Assertion+test_movedComments = do+  let withInline :: T.Text -> Node -> Node+      withInline t n = n {comments = n.comments {inline = Just t}}+      withBefore :: T.Text -> Node -> Node+      withBefore t n = n {comments = n.comments {before = [Comment t]}}+      withAfter :: T.Text -> Node -> Node+      withAfter t n = n {comments = n.comments {after = [Comment t]}}+  assertEqual+    "lines above a value on the line of the key"+    "# v\na: 1\n"+    (render (mappingNode [(plainNode "a", withBefore "v" (plainNode "1"))]))+  assertEqual+    "lines after a scalar key"+    "# b\nk: 1\n  # a\n"+    . render+    $ mappingNode [(withAfter "a" (withBefore "b" (plainNode "k")), plainNode "1")]+  assertEqual+    "lines after a scalar key with a block scalar value"+    "# a\nk: |\n  text\n"+    . render+    $ mappingNode+      [+        ( withAfter "a" (plainNode "k")+        , contentNode (ScalarContent Literal "text\n")+        )+      ]+  assertEqual+    "lines after a block scalar value"+    "k: |\n  text\n# a\nx: 1\n"+    . render+    $ mappingNode+      [+        ( plainNode "k"+        , withAfter "a" (contentNode (ScalarContent Literal "text\n"))+        )+      , (plainNode "x", plainNode "1")+      ]+  assertEqual+    "lines after a list item"+    "- 1\n  # a\n- 2\n"+    . render+    . contentNode+    $ SequenceContent Block [withAfter "a" (plainNode "1"), plainNode "2"]+  assertEqual+    "empty lines at the end of an empty flow collection"+    "a: [\n  # c\n  ]\n\nb: 1\n"+    . render+    $ mappingNode+      [+        ( plainNode "a"+        , (contentNode (SequenceContent Flow []))+            { comments = noComments {after = [Comment "c", EmptyLine]}+            }+        )+      , (plainNode "b", plainNode "1")+      ]+  assertEqual+    "two comments on one line"+    "# k\na: 1 # v\n"+    . render+    $ mappingNode [(withInline "k" (plainNode "a"), withInline "v" (plainNode "1"))]+  assertEqual+    "two comments on one line, one with a line break"+    "# k l\na: 1 # v\n"+    . render+    $ mappingNode+      [(withInline "k\nl" (plainNode "a"), withInline "v" (plainNode "1"))]+  assertEqual+    "comment in a flow sequence"+    "a:\n- 1 # c\n- 2\n"+    . render+    $ mappingNode+      [+        ( plainNode "a"+        , contentNode+            (SequenceContent Flow [withInline "c" (plainNode "1"), plainNode "2"])+        )+      ]+  assertEqual+    "YAML 1.1 line breaks in comments"+    "# a\n# b\n# c\n# d\nk: v # e f g h\n"+    . render+    $ mappingNode+      [+        ( withBefore "a\x85\&b\x2028\&c\x2029\&d" (plainNode "k")+        , withInline "e\x85\&f\x2028\&g\x2029\&h" (plainNode "v")+        )+      ]+  assertEqual+    "comment on a block root"+    "--- # c\na: 1\n"+    (render (withInline "c" (mappingNode [(plainNode "a", plainNode "1")])))+  rendersBack "comment on the properties of a block root" "# r\n!!map # c\n# f\na: 1\n"+  rendersBack+    "comment on the properties of a block root below a marker with a comment"+    "--- # d\n&a # c\n- x\n"+  rendersAs+    "lines below the properties of a block root with a comment"+    "# e\n\n!!map # c\n# f\na: 1\n"+    "!!map # c\n# e\n\n# f\na: 1\n"+  let rootWithLines = withBefore "r" (mappingNode [(plainNode "a", plainNode "1")])+  assertEqual+    "lines of a block root without an empty line"+    "# r\n\na: 1\n"+    (render rootWithLines)+  assertEqual+    "lines of a block root read back"+    (Right [[Comment "r", EmptyLine]])+    (map (\d -> d.root.comments.before) <$> parseDocumentsText (render rootWithLines))+  assertEqual+    "comment on a block root below the comment of the marker"+    "--- # d\n# c\n\na: 1\n"+    $ renderSyntax+      defaultRenderOptions+      [ (document (withInline "c" (mappingNode [(plainNode "a", plainNode "1")])))+          { docComments = noComments {inline = Just "d"}+          }+      ]+  let list :: Node -> Node+      list item =+        mappingNode+          [ (plainNode "a", withAfter "c" (sequenceNode [item]))+          , (plainNode "b", plainNode "2")+          ]+  assertEqual+    "end of a list with a mapping"+    "a:\n  - x: 1\n  # c\nb: 2\n"+    (render (list (mappingNode [(plainNode "x", plainNode "1")])))+  assertEqual+    "end of a list with a block scalar"+    "a:\n  - |\n    x\n  # c\nb: 2\n"+    (render (list (scalarNode Literal "x\n")))
+ tests/Yamlet/Test/Render/Documents.hs view
@@ -0,0 +1,272 @@+-- | The markers, directives and comments between the documents of a stream.+module Yamlet.Test.Render.Documents+  ( documentTests+  ) where++import Control.Monad+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet.Syntax+import Yamlet.Test.Render.Helpers++documentTests :: TestTree+documentTests = testCase "documents" test_documents++test_documents :: Assertion+test_documents = do+  rendersBack "markers" $+    T.unlines+      [ "first"+      , "---"+      , "second"+      , "..."+      , "%YAML 1.2"+      , "---"+      , "a: b"+      , "---"+      ]+  -- YAML 1.1 parsers need a start marker after an end marker.+  rendersAs+    "document after an end marker"+    "a\n...\n---\nb\n"+    "a\n...\nb\n"+  rendersAs+    "comment after the end marker"+    "a: b\n...\n# c\n---\nd: e\n"+    "a: b\n...\n# c\nd: e\n"+  rendersBack "comment before the directives" "a\n...\n# b\n%YAML 1.2\n---\nc\n"+  rendersBack+    "comments at the end of a root collection and a document"+    "a: 1\n# b\n\n# c\n...\n"+  rendersBack+    "comments around an end marker between documents"+    "a\n# b\n...\n# c\n---\nd\n"+  rendersAs+    "empty line before the bracket of a flow root"+    "key: value\n# zq\n...\n"+    "{\n key: value\n # zq\n\n}\n...\n"+  rendersAs+    "empty line before the bracket of a flow value"+    "a:\n  key: value\n  # zq\n\nb: 1\n"+    "a: {\n key: value\n # zq\n\n }\nb: 1\n"+  rendersAs+    "empty line before the bracket and a comment after it"+    "a: {key: value} # c\n\nb: 1\n"+    "a: {\n key: value\n\n } # c\nb: 1\n"+  assertEqual+    "comment after a byte order mark between documents"+    (Right [[("document", "after", "c")], [("document", "before", "d")]])+    $ map commentsOf+      <$> parseDocumentsText "a: 1\n...\n\xFEFF# c\n\n\xFEFF# d\n---\nb: 2\n"+  let commented :: Document -> Document+      commented d = d {docComments = noComments {before = [Comment "c"]}}+  assertEqual+    "comment above a document without an end marker above it"+    "a\n\n# c\n---\nb\n"+    $ renderSyntax+      defaultRenderOptions+      [document (plainNode "a"), commented (document (plainNode "b"))]+  assertEqual+    "comment above a document with directives"+    "a\n...\n\n# c\n%YAML 1.2\n---\nb\n"+    $ renderSyntax+      defaultRenderOptions+      [ document (plainNode "a")+      , commented (document (plainNode "b")) {version = Just (YamlVersion 1 2)}+      ]+  let flowWithLines =+        (document (contentNode (SequenceContent Flow [plainNode "a"])))+          { docComments = noComments {after = [Comment "c"]}+          }+      beforeDirectives =+        renderSyntax+          defaultRenderOptions+          [flowWithLines, (document (plainNode "b")) {version = Just (YamlVersion 1 2)}]+  assertEqual+    "lines of a flow root above directives"+    "[a]\n...\n# c\n%YAML 1.2\n---\nb\n"+    beforeDirectives+  rendersBack "lines of a flow root above directives, rendered again" beforeDirectives+  -- A block scalar without content would take the comment in.+  forM_ [Literal, Folded] $ \style ->+    assertEqual+      ("comment above a document below an empty " ++ show style ++ " root")+      "\"\"\n\n# c\n---\nb\n"+      $ renderSyntax+        defaultRenderOptions+        [document (scalarNode style ""), commented (document (plainNode "b"))]+  let keyComment :: Document+      keyComment =+        document $+          mappingNode+            [+              ( (plainNode "k") {comments = noComments {before = [Comment "c"]}}+              , plainNode "v"+              )+            ]+      afterEnd :: T.Text+      afterEnd =+        renderSyntax+          defaultRenderOptions+          [(document (plainNode "a")) {explicitEnd = True}, keyComment]+      firstKeyLines :: Document -> [Line]+      firstKeyLines d = case d.root.content of+        MappingContent _ ((k, _) : _) -> k.comments.before+        _ -> []+  assertEqual+    "comment above the first key after an end marker"+    "a\n...\n---\n# c\nk: v\n"+    afterEnd+  assertEqual+    "comment above the first key after an end marker, read back"+    (Right [[], [Comment "c"]])+    (map firstKeyLines <$> parseDocumentsText afterEnd)+  let rootWithGap :: Bool -> Document+      rootWithGap end =+        ( document+            (contentNode (SequenceContent Block [plainNode "a"]))+              { comments = noComments {after = [Comment "c", EmptyLine]}+              }+        )+          { explicitEnd = end+          }+  assertEqual+    "empty line at the end of a block root before an end marker"+    "- a\n# c\n\n...\n"+    (renderSyntax defaultRenderOptions [rootWithGap True])+  assertEqual+    "empty line at the end of a block root before a document"+    "- a\n# c\n\n---\nb\n"+    (renderSyntax defaultRenderOptions [rootWithGap False, document (plainNode "b")])+  -- The end marker keeps the lines of a document from the next document.+  rendersBack+    "empty line below a flow root above an end marker"+    "[a]\n\n# c\n...\n---\nx\n"+  rendersBack+    "empty line at the end of a flow root above an end marker"+    "[a]\n# c\n\n...\n---\nx\n"+  rendersAs+    "empty line at the end of a flow root in the block style"+    "key: value\n\n# c\n...\n---\nx\n"+    "{\n key: value\n\n# c\n}\n---\nx\n"+  let boundary+        :: String -> T.Text -> [[(String, String, T.Text)]] -> [Document] -> Assertion+      boundary preface expected comments docs = do+        let rendered = renderSyntax defaultRenderOptions docs+        assertEqual+          preface+          expected+          rendered+        assertEqual+          (preface ++ ", read back")+          (Right comments)+          (map commentsOf <$> parseDocumentsText rendered)+      withLines :: Comments -> Node -> Node+      withLines c n = n {comments = c}+  boundary+    "empty line at the end of a block root before a document"+    "k: v\n\n# c\n...\n---\nb\n"+    [[("", "after", "c")], []]+    [ document $+        withLines+          noComments {after = [EmptyLine, Comment "c"]}+          (mappingNode [(plainNode "k", plainNode "v")])+    , document (plainNode "b")+    ]+  boundary+    "empty line at the end of the last value of a block root before a document"+    "k: v\n\n# c\n...\n---\nb\n"+    [[("", "after", "c")], []]+    [ document+        . withLines noComments {after = [Comment "c"]}+        $ mappingNode+          [+            ( plainNode "k"+            , withLines noComments {after = [EmptyLine]} (plainNode "v")+            )+          ]+    , document (plainNode "b")+    ]+  boundary+    "empty line below a flow root before a document"+    "[a]\n\n# c\n...\n---\nb\n"+    [[("document", "after", "c")], []]+    [ (document (contentNode (SequenceContent Flow [plainNode "a"])))+        { docComments = noComments {after = [EmptyLine, Comment "c"]}+        }+    , document (plainNode "b")+    ]+  boundary+    "empty line after the last key of a block root before a document"+    "k: v\n\n  # c\n...\n---\nb\n"+    [[("/k", "after", "c")], []]+    [ document $+        mappingNode+          [+            ( withLines noComments {after = [EmptyLine, Comment "c"]} (plainNode "k")+            , plainNode "v"+            )+          ]+    , document (plainNode "b")+    ]+  boundary+    "empty line above the comment of an empty root before a document"+    "a\n---\n\n# c\n...\n---\nb\n"+    [[], [("", "after", "c")], []]+    [ document (plainNode "a")+    , document (withLines noComments {before = [EmptyLine, Comment "c"]} (plainNode ""))+    , document (plainNode "b")+    ]+  boundary+    "keep literal root above a comment of the next document"+    "|+\n  a\n\n...\n\n# c\n---\nb\n"+    [[], [("document", "before", "c")]]+    [document (scalarNode Literal "a\n\n"), commented (document (plainNode "b"))]+  boundary+    "keep literal at the end of a root above a comment of the next document"+    "k: |+\n  a\n\n...\n\n# c\n---\nb\n"+    [[], [("document", "before", "c")]]+    [ document (mappingNode [(plainNode "k", scalarNode Literal "a\n\n")])+    , commented (document (plainNode "b"))+    ]+  let versioned :: YamlVersion -> T.Text+      versioned v =+        renderSyntax defaultRenderOptions [(document (plainNode "a")) {version = Just v}]+  assertEqual+    "supported version"+    "%YAML 1.3\n---\na\n"+    (versioned (YamlVersion 1 3))+  assertEqual+    "unsupported version"+    "a\n"+    (versioned (YamlVersion 2 0))+  assertEqual+    "negative minor version"+    "a\n"+    (versioned (YamlVersion 1 (-1)))+  assertEqual+    "minor version beyond the limit"+    "a\n"+    (versioned (YamlVersion 1 1000001))+  -- Without the marker, the next parse would give the comment to the root.+  let first :: String -> T.Text -> Node -> Assertion+      first preface expected root = do+        let out = renderSyntax defaultRenderOptions [commented (document root)]+        assertEqual+          preface+          expected+          out+        assertEqual+          (preface ++ ", read back")+          (Right [[Comment "c"]])+          (map (\d -> d.docComments.before) <$> parseDocumentsText out)+  first+    "comment above the first document"+    "# c\n---\na: 1\n"+    (mappingNode [(plainNode "a", plainNode "1")])+  first+    "comment above the first document with a scalar root"+    "# c\n---\na\n"+    (plainNode "a")
+ tests/Yamlet/Test/Render/Helpers.hs view
@@ -0,0 +1,66 @@+-- | The helpers that several render test modules use.+module Yamlet.Test.Render.Helpers+  ( render+  , rendersBack+  , rendersAs+  , commentsOf+  ) where++import Data.Text qualified as T+import Test.Tasty.HUnit++import Yamlet.Syntax++-- | The text of a document with the node as its root.+render :: Node -> T.Text+render n = renderSyntax defaultRenderOptions [document n]++-- | Parsing and rendering gives back the input.+rendersBack :: String -> T.Text -> Assertion+rendersBack preface input =+  assertEqual+    preface+    (Right input)+    (renderSyntax defaultRenderOptions <$> parseDocumentsText input)++-- | Parsing and rendering gives the expected text, which gives itself back.+rendersAs :: String -> T.Text -> T.Text -> Assertion+rendersAs preface expected input = do+  assertEqual+    preface+    (Right expected)+    (renderSyntax defaultRenderOptions <$> parseDocumentsText input)+  rendersBack (preface ++ ", rendered again") expected++-- | The comments of a document with the path of their nodes.+commentsOf :: Document -> [(String, String, T.Text)]+commentsOf doc = lines_ "document" doc.docComments ++ node "" doc.root+  where+    node :: String -> Node -> [(String, String, T.Text)]+    node path n =+      lines_ path n.comments {after = []}+        ++ inner+        ++ lines_ path noComments {after = n.comments.after}+      where+        inner :: [(String, String, T.Text)]+        inner = case n.content of+          SequenceContent _ xs ->+            concat (zipWith (\i x -> node (path ++ "/" ++ show i) x) [0 :: Int ..] xs)+          MappingContent _ kvs -> concatMap (entry path) kvs+          _ -> []++    entry :: String -> (Node, Node) -> [(String, String, T.Text)]+    entry path (k, v) =+      let path' = path ++ "/" ++ keyText k+      in node (path' ++ ":key") k ++ node path' v++    keyText :: Node -> String+    keyText k = case k.content of+      ScalarContent _ t -> T.unpack t+      _ -> "?"++    lines_ :: String -> Comments -> [(String, String, T.Text)]+    lines_ path c =+      [(path, "before", t) | Comment t <- c.before]+        ++ [(path, "inline", t) | Just t <- [c.inline]]+        ++ [(path, "after", t) | Comment t <- c.after]
+ tests/Yamlet/Test/Render/Properties.hs view
@@ -0,0 +1,285 @@+module Yamlet.Test.Render.Properties+  ( propertyTests+  ) where++import Data.List qualified as L+import Data.Maybe+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.QuickCheck++import Yamlet.Syntax+import Yamlet.Test.Helpers.Thunks+import Yamlet.Test.Render.Helpers++propertyTests :: TestTree+propertyTests =+  testGroup+    "properties"+    [ testProperty "no thunks in generated documents" prop_noThunks+    , testProperty "round trip" prop_roundTrip+    ]++prop_noThunks :: Tree -> Property+prop_noThunks (Tree doc) =+  let out = renderSyntax defaultRenderOptions [doc]+  in counterexample (T.unpack out) $ case parseDocumentsText out of+       Right docs -> ioProperty ((=== []) <$> thunks docs)+       Left e -> counterexample (show e) False++-- | Rendering a tree and parsing the result gives the same tree, except for+-- the styles, the offsets and the places of the comments. Every comment+-- stays, and rendering the result again gives the same text.+prop_roundTrip :: Tree -> Property+prop_roundTrip (Tree doc) =+  let out = renderSyntax defaultRenderOptions [doc]+  in counterexample (T.unpack out) $ case parseDocumentsText out of+       Right [doc'] ->+         checkCoverage . cover 10 (hasLines doc'.root) "scalars on several lines" $+           conjoin+             [ counterexample "tree" $+                 strip doc'.root === strip (flowItems False doc.root)+             , counterexample "comments" $+                 L.sort (allComments doc') === L.sort (allComments doc)+             , let out' = renderSyntax defaultRenderOptions [doc']+               in counterexample ("text: " ++ firstDifference out out') (out' == out)+             ]+       r -> counterexample (show r) False+  where+    strip :: Node -> Node+    strip n =+      ( contentNode $ case n.content of+          ScalarContent _ t -> ScalarContent Plain t+          SequenceContent _ xs -> SequenceContent Block (map strip xs)+          MappingContent _ kvs ->+            MappingContent Block [(strip k, strip v) | (k, v) <- kvs]+          AliasContent a -> AliasContent a+      )+        { props = n.props+        }++    -- The first line where two texts differ, with the line before it.+    firstDifference :: T.Text -> T.Text -> String+    firstDifference a b = go 1 "" (T.lines a) (T.lines b)+      where+        go :: Int -> T.Text -> [T.Text] -> [T.Text] -> String+        go n prev xs ys = case (xs, ys) of+          (x : xs', y : ys') | x == y -> go (n + 1) x xs' ys'+          _ ->+            "line "+              ++ show n+              ++ " after "+              ++ show prev+              ++ ": "+              ++ show (take 1 xs)+              ++ " /= "+              ++ show (take 1 ys)++    allComments :: Document -> [T.Text]+    allComments d = [t | (_, _, t) <- commentsOf d]++    hasLines :: Node -> Bool+    hasLines n = case n.content of+      ScalarLinesContent _ _ starts -> not (null starts)+      SequenceContent _ xs -> any hasLines xs+      MappingContent _ kvs -> any (\(k, v) -> hasLines k || hasLines v) kvs+      AliasContent _ -> False++    -- The renderer gives an empty item of a flow sequence a tag.+    flowItems :: Bool -> Node -> Node+    flowItems inFlow n = case n.content of+      SequenceContent s xs ->+        let inFlow' = inFlow || (s == Flow && not (hasComments n))+        in n {content = SequenceContent s (map (item inFlow' . flowItems inFlow') xs)}+      MappingContent s kvs ->+        let inFlow' = inFlow || (s == Flow && not (hasComments n))+        in n+             { content =+                 MappingContent+                   s+                   [(flowItems inFlow' k, flowItems inFlow' v) | (k, v) <- kvs]+             }+      _ -> n++    item :: Bool -> Node -> Node+    item inFlow n = case (n.props, n.content) of+      (Props Nothing NoTag, ScalarContent Plain "")+        | inFlow ->+            n {props = Props Nothing (Tag "tag:yaml.org,2002:null")}+      _ -> n++    -- A flow collection with comments inside becomes a block collection.+    hasComments :: Node -> Bool+    hasComments n =+      not (null [() | Comment _ <- n.comments.after]) || case n.content of+        SequenceContent _ xs -> any inner xs+        MappingContent _ kvs -> any (\(k, v) -> inner k || inner v) kvs+        _ -> False+      where+        inner :: Node -> Bool+        inner x =+          not (null [() | Comment _ <- x.comments.before])+            || isJust x.comments.inline+            || hasComments x++newtype Tree = Tree Document+  deriving stock (Show)++instance Arbitrary Tree where+  arbitrary = do+    root <- sized genNode+    c <- genComments+    pure . Tree $ (document root) {docComments = c}++genNode :: Int -> Gen Node+genNode size = do+  n <-+    if size <= 1+      then genScalar+      else+        frequency+          [ (3, genScalar)+          , (1, contentNode . AliasContent <$> genAnchor)+          , (1, contentNode <$> (SequenceContent <$> genStyle <*> genList))+          , (1, contentNode <$> (MappingContent <$> genStyle <*> genEntries))+          ]+  p <- case n.content of+    AliasContent _ -> pure noProps+    _ -> genProps+  c <- genComments+  -- The text has no place for the lines after a block scalar.+  pure n {props = p, comments = if isBlock n then c {after = []} else c}+  where+    genList :: Gen [Node]+    genList = do+      k <- choose (0, 4)+      vectorOf k (genNode (size `div` 3))++    -- The lines below a scalar or an alias key read back as the lines above+    -- the value.+    genEntries :: Gen [(Node, Node)]+    genEntries = do+      k <- choose (0, 4)+      vectorOf+        k+        ((,) . noLinesAfterScalar <$> genNode (size `div` 4) <*> genNode (size `div` 3))++    noLinesAfterScalar :: Node -> Node+    noLinesAfterScalar k = case k.content of+      SequenceContent {} -> k+      MappingContent {} -> k+      _ -> k {comments = k.comments {after = []}}++    isBlock :: Node -> Bool+    isBlock n = case n.content of+      ScalarLinesContent style _ _ -> style == Literal || style == Folded+      _ -> False++    genStyle :: Gen CollectionStyle+    genStyle = elements [Block, Flow]++    -- A scalar, often with positions of new lines. Some positions are not+    -- valid, e.g. outside the text or twice the same.+    genScalar :: Gen Node+    genScalar = do+      style <- elements [minBound .. maxBound]+      t <- genText+      starts <-+        frequency [(1, pure []), (2, L.sort <$> listOf (choose (0, T.length t + 1)))]+      pure (contentNode (ScalarLinesContent style t starts))++    genProps :: Gen Props+    genProps =+      Props+        <$> oneof [pure Nothing, Just <$> genAnchor]+        <*> elements+          [ NoTag+          , NoTag+          , NonSpecificTag+          , Tag "tag:yaml.org,2002:str"+          , Tag "!local"+          , Tag "tag:example.com,2000:x"+          ]++    genAnchor :: Gen T.Text+    genAnchor = elements ["a", "b", "anchor"]++    genText :: Gen T.Text+    genText =+      oneof+        [ elements tricky+        , T.pack <$> listOf genChar+        , T.intercalate "\n" <$> listOf (T.pack <$> listOf genChar)+        ]+      where+        tricky :: [T.Text]+        tricky =+          [ ""+          , " "+          , "-"+          , "- a"+          , "? a"+          , ": a"+          , "a: b"+          , "a:b"+          , "#"+          , "a #b"+          , "true"+          , "12"+          , "---"+          , "..."+          , "foo\n"+          , "\nfoo"+          , "  lead"+          , "trail  "+          , "a\n\nb\n\n"+          , "\n"+          , "\n\n"+          , " \n"+          , "a\n "+          , "|"+          , ">"+          , "[a]"+          , "{a: b}"+          , "a, b"+          , "key:"+          , "\r\n"+          , "a\n  b\nc"+          , "  a\nb"+          , "a\n\n  b\n\nc\n"+          ]++        genChar :: Gen Char+        genChar =+          frequency+            [ (10, elements "abc xyz-:#,[]{}'\"!&*?|>%@`\\")+            , (2, elements "\t\r\x85\xA0\x2028\xFEFF\x01")+            , (1, arbitrary)+            ]++-- | Comments for a node.+genComments :: Gen Comments+genComments =+  frequency+    [ (3, pure noComments)+    ,+      ( 1+      , Comments+          <$> genLines+          <*> oneof [pure Nothing, Just <$> genCommentText]+          <*> genLines+      )+    ]+  where+    genLines :: Gen [Line]+    genLines = do+      k <- choose (0, 2)+      vectorOf k $+        frequency+          [ (3, CommentLine <$> elements [1, 1, 2, 3] <*> genCommentText)+          , (1, pure EmptyLine)+          ]++    genCommentText :: Gen T.Text+    genCommentText =+      elements ["a comment", "", "x", "# hash", "key: value", "- item", "'quoted'"]
+ tests/Yamlet/Test/Render/Styles.hs view
@@ -0,0 +1,634 @@+-- | The styles of the rendered nodes and their fallbacks.+module Yamlet.Test.Render.Styles+  ( styleTests+  ) where++import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet hiding (Commented (..))+import Yamlet.Syntax+import Yamlet.Test.Helpers+import Yamlet.Test.Render.Helpers++styleTests :: TestTree+styleTests =+  testGroup+    "styles"+    [ testCase "workflow" test_workflow+    , testCase "styles" test_styles+    , testCase "fallbacks" test_fallbacks+    , testCase "force block" test_forceBlock+    , testCase "lines of scalars" test_scalarLines+    , slow $ testCase "many invalid anchor names" test_manyAnchors+    , slow $ testCase "deep comment" test_deepComment+    , slow $ testCase "nested keys" test_nestedKeys+    , slow $ testCase "comments above nesting" test_commentsAboveNesting+    , slow $ testCase "many escaped line breaks" test_escapedBreaks+    ]++-- | A generated file with a header, and empty lines between the jobs and+-- between the steps. The header is on the root, so the file has no start+-- marker.+test_workflow :: Assertion+test_workflow = do+  let out = renderSyntax defaultRenderOptions [doc]+  assertEqual+    "output"+    expected+    out+  assertEqual+    "header read back"+    (Right [[Comment "Generated by haskell-gha.", Comment "Do not edit.", EmptyLine]])+    (map (\d -> d.root.comments.before) <$> parseDocumentsText out)+  where+    doc :: Document+    doc =+      Document+        { version = Nothing+        , explicitStart = False+        , explicitEnd = False+        , docComments = noComments+        , root =+            withHeader $+              mappingNode+                [ (plainNode "name", plainNode "CI")+                ,+                  ( withEmptyLine (plainNode "jobs")+                  , mappingNode+                      [+                        ( withEmptyLine (plainNode "build")+                        , mappingNode+                            [ (plainNode "runs-on", plainNode "ubuntu-latest")+                            , (plainNode "steps", steps)+                            ]+                        )+                      ,+                        ( withEmptyLine (plainNode "lint")+                        , mappingNode [(plainNode "ghc", scalarNode SingleQuoted "9.10")]+                        )+                      ]+                  )+                ]+        }++    steps :: Node+    steps =+      sequenceNode+        [ mappingNode [(plainNode "uses", plainNode "actions/checkout@v4")]+        , withEmptyLine $+            mappingNode+              [ (plainNode "name", plainNode "Build")+              , (plainNode "run", scalarNode Literal "cabal build\ncabal test\n")+              ]+        ]++    withEmptyLine :: Node -> Node+    withEmptyLine n = n {comments = n.comments {before = [EmptyLine]}}++    withHeader :: Node -> Node+    withHeader n =+      n+        { comments =+            n.comments {before = [Comment "Generated by haskell-gha.\nDo not edit."]}+        }++    expected :: T.Text+    expected =+      T.unlines+        [ "# Generated by haskell-gha."+        , "# Do not edit."+        , ""+        , "name: CI"+        , ""+        , "jobs:"+        , ""+        , "  build:"+        , "    runs-on: ubuntu-latest"+        , "    steps:"+        , "    - uses: actions/checkout@v4"+        , ""+        , "    - name: Build"+        , "      run: |"+        , "        cabal build"+        , "        cabal test"+        , ""+        , "  lint:"+        , "    ghc: '9.10'"+        ]++test_styles :: Assertion+test_styles = rendersBack "output" input+  where+    input :: T.Text+    input =+      T.unlines+        [ "plain: text"+        , "single: 'it''s'"+        , "double: \"a\\tb\""+        , "literal: |"+        , "  line 1"+        , "   line 2"+        , "folded: >-"+        , "  first"+        , ""+        , "  second"+        , "list:"+        , "- a"+        , "- - b"+        , "  - c: d"+        , "flow: [a, 'b', {c: d}]"+        , "anchor: &x value"+        , "alias: *x"+        , "*x : key alias"+        , "tagged: !!str 12"+        , "local: !point {x: 1}"+        , "empty:"+        , "[complex, key]: value"+        ]++test_fallbacks :: Assertion+test_fallbacks = do+  assertEqual+    "plain with a colon"+    "'a: b'\n"+    (render (plainNode "a: b"))+  assertEqual+    "plain number stays plain"+    "12\n"+    (render (plainNode "12"))+  rendersAs+    "empty collection keys"+    "? []\n: a\n? {}\n: b\n!t []: c\n&x {}: d\n[[]]: e\n"+    "[]: a\n{}: b\n!t []: c\n&x {}: d\n[[]]: e\n"+  assertEqual+    "single-quoted line break"+    "\"a\\nb\"\n"+    (render (scalarNode SingleQuoted "a\nb"))+  assertEqual+    "literal with an indicator at the top level"+    "\" a\\nb\"\n"+    (render (scalarNode Literal " a\nb"))+  assertEqual+    "folded with an indicator at the top level"+    "\" a\\nb\"\n"+    (render (scalarNode Folded " a\nb"))+  let withLineBelow :: Node -> Node+      withLineBelow n = n {comments = noComments {after = [Comment "c"]}}+  assertEqual+    "empty literal with a line below at the top level"+    "\"\"\n# c\n"+    (render (withLineBelow (scalarNode Literal "")))+  assertEqual+    "empty folded with a line below at the top level"+    "\"\"\n# c\n"+    (render (withLineBelow (scalarNode Folded "")))+  assertEqual+    "literal of only line breaks with a line below at the top level"+    (Right [(ScalarContent DoubleQuoted "\n", [("", "after", "c")])])+    $ map (\d -> (d.root.content, commentsOf d))+      <$> parseDocumentsText (render (withLineBelow (scalarNode Literal "\n")))+  assertEqual+    "literal with a line below in a list"+    "- |-\n# c\n"+    (render (sequenceNode [withLineBelow (scalarNode Literal "")]))+  assertEqual+    "literal with an indicator in a list"+    "- |2-\n   a\n  b\n"+    (render (sequenceNode [scalarNode Literal " a\nb"]))+  assertEqual+    "folded with a tab in a list"+    "- >2-\n  \ta\n  b\n"+    (render (sequenceNode [scalarNode Folded "\ta\nb"]))+  -- A block scalar cannot hold the character, so the lines below it stay+  -- deeper than the key, as below any quoted scalar.+  let quotedBlocks =+        mappingNode+          [ (plainNode "a", withLineBelow (scalarNode Literal "x\DEL"))+          ,+            ( plainNode "b"+            , sequenceNode [withLineBelow (scalarNode Folded "x\DEL"), plainNode "y"]+            )+          , (sequenceNode [plainNode "k"], withLineBelow (scalarNode Literal "x\DEL"))+          ]+  assertEqual+    "lines below a block scalar in double quotes"+    "a: \"x\\x7F\"\n  # c\nb:\n- \"x\\x7F\"\n  # c\n- y\n? - k\n: \"x\\x7F\"\n  # c\n"+    (render quotedBlocks)+  assertEqual+    "lines below a block scalar in double quotes read back"+    (Right [[("/a", "after", "c"), ("/b/0", "after", "c"), ("/?", "after", "c")]])+    (map commentsOf <$> parseDocumentsText (render quotedBlocks))+  assertEqual+    "keep indicator"+    "- |+\n  a\n\n- b\n"+    . render+    $ sequenceNode+      [ scalarNode Literal "a\n\n"+      , (plainNode "b") {comments = noComments {before = [EmptyLine]}}+      ]+  assertEqual+    "block scalar in a flow collection"+    "[\"a\\n\"]\n"+    (render (contentNode (SequenceContent Flow [scalarNode Literal "a\n"])))+  -- YAML 1.1 parsers read a comma or a bracket right after a tag as part of+  -- the tag.+  assertEqual+    "empty item of a flow sequence"+    "[!!null , a, !!null ]\n"+    . render+    $ contentNode (SequenceContent Flow [plainNode "", plainNode "a", plainNode ""])+  assertEqual+    "empty tagged values in flow collections"+    (Right "[80, !!str , 443]\n---\n{a: !!str , b: !!str }\n")+    $ renderSyntax defaultRenderOptions+      <$> parseDocumentsText "[80, !!str , 443]\n---\n{a: !!str , b: !!str }\n"+  -- YAML 1.1 parsers misread or reject these plain scalars, empty keys and+  -- empty values in flow collections.+  assertEqual+    "indicators in plain scalars of a flow collection"+    "['?a', 'a?b', ':a', 'a:?', a:b, -a]\n"+    . render+    . contentNode+    $ SequenceContent Flow (map plainNode ["?a", "a?b", ":a", "a:?", "a:b", "-a"])+  rendersAs+    "empty keys and values in flow mappings"+    "{k: , a: 1}\n---\n{? : x}\n---\n{? }\n"+    "{k:, a: 1}\n---\n{: x}\n---\n{: }\n"+  -- libyaml and PyYAML reject an implicit key of more than 1024 characters+  -- in a flow mapping too.+  let flowEntry :: Node -> Node -> Node+      flowEntry k v = contentNode (MappingContent Flow [(k, v)])+      longest = T.replicate 1024 "a"+      long = T.replicate 1025 "a"+      anchoredKey =+        (plainNode (T.replicate 1020 "a")) {props = noProps {anchor = Just "anchor"}}+  assertEqual+    "flow key of the longest length"+    ("{" <> longest <> ": 1}\n")+    (render (flowEntry (plainNode longest) (plainNode "1")))+  assertEqual+    "long flow key"+    ("{? " <> long <> " : 1}\n")+    (render (flowEntry (plainNode long) (plainNode "1")))+  assertEqual+    "long flow key without a value"+    ("{? " <> long <> "}\n")+    (render (flowEntry (plainNode long) (plainNode "")))+  assertEqual+    "flow key that an anchor makes long"+    ("{? &anchor " <> T.replicate 1020 "a" <> " : 1}\n")+    (render (flowEntry anchoredKey (plainNode "1")))+  let emptyTagged :: Int -> Node+      emptyTagged n = (plainNode "") {props = noProps {tag = Tag ("!" <> T.replicate (n - 1) "t")}}+  assertEqual+    "flow key with a tag and a space of the longest length"+    ("{!" <> T.replicate 1022 "t" <> " : 1}\n")+    (render (flowEntry (emptyTagged 1023) (plainNode "1")))+  assertEqual+    "flow key that the space after a tag makes long"+    ("{? !" <> T.replicate 1023 "t" <> " : 1}\n")+    (render (flowEntry (emptyTagged 1024) (plainNode "1")))+  let longTag = "!" <> T.replicate 1100 "t"+      longTagged = (plainNode "") {props = noProps {tag = Tag longTag}}+  assertEqual+    "flow key that a tag makes long, without a value"+    ("{? " <> longTag <> " , b: c}\n")+    . render+    . contentNode+    $ MappingContent Flow [(longTagged, plainNode ""), (plainNode "b", plainNode "c")]+  assertEqual+    "long flow keys read back"+    ( Right+        [ Mapping [(String long, Int 1)]+        , Mapping [(String long, Null)]+        , Mapping [(String (T.replicate 1020 "a"), Int 1)]+        ]+    )+    . decodeAllText @Value+    . renderSyntax defaultRenderOptions+    $ map+      document+      [ flowEntry (plainNode long) (plainNode "1")+      , flowEntry (plainNode long) (plainNode "")+      , flowEntry anchoredKey (plainNode "1")+      ]+  assertEqual+    "empty key"+    "?\n: a\n"+    (render (mappingNode [(plainNode "", plainNode "a")]))+  let emptyWithComment =+        (contentNode (SequenceContent Block []))+          { comments = noComments {after = [Comment "c"]}+          }+      commented = mappingNode [(plainNode "k", emptyWithComment)]+  assertEqual+    "comment in an empty collection"+    "k: [\n  # c\n  ]\n"+    (render commented)+  assertEqual+    "comment in an empty collection reads back"+    (Right [[("/k", "after", "c")]])+    (map commentsOf <$> parseDocumentsText (render commented))+  let keyWithLineBelow :: Node -> Node+      keyWithLineBelow v =+        mappingNode+          [ ((plainNode "k") {comments = noComments {after = [Comment "c"]}}, v)+          , (plainNode "l", plainNode "y")+          ]+      flowSequence :: Node+      flowSequence = contentNode (SequenceContent Flow [plainNode "a"])+  assertEqual+    "lines after a key with a flow value"+    "# c\nk: [a]\nl: y\n"+    (render (keyWithLineBelow flowSequence))+  assertEqual+    "lines after a key with a flow value read back"+    (Right [[("/k:key", "before", "c")]])+    (map commentsOf <$> parseDocumentsText (render (keyWithLineBelow flowSequence)))+  assertEqual+    "lines after a key with an empty flow value"+    "# c\nk: {}\nl: y\n"+    (render (keyWithLineBelow (contentNode (MappingContent Flow []))))+  assertEqual+    "comment in an empty key"+    "? [\n  # c\n  ]\n: v\n"+    (render (mappingNode [(emptyWithComment, plainNode "v")]))+  assertEqual+    "comment in an empty key reads back"+    (Right [[("/?:key", "after", "c")]])+    $ map commentsOf+      <$> parseDocumentsText (render (mappingNode [(emptyWithComment, plainNode "v")]))+  assertEqual+    "white space at the end of a comment"+    "# y\na # x\n"+    $ render+      (plainNode "a")+        { comments = noComments {before = [Comment "y\t"], inline = Just "x "}+        }+  let anchored :: T.Text -> Node -> Node+      anchored a n = n {props = noProps {anchor = Just a}}+  assertEqual+    "invalid anchor names"+    "[&a_b x, *a_b, &a_b_2 y, *a_b_2, &anchor z, *anchor]\n"+    . render+    . contentNode+    $ SequenceContent+      Flow+      [ anchored "a b" (plainNode "x")+      , contentNode (AliasContent "a b")+      , anchored "a]b" (plainNode "y")+      , contentNode (AliasContent "a]b")+      , anchored "" (plainNode "z")+      , contentNode (AliasContent "")+      ]+  let tagged :: T.Text -> Node+      tagged t = (plainNode "x") {props = noProps {tag = Tag t}}+      tagOf :: T.Text -> Either String [Tag]+      tagOf t = case parseDocumentsText (render (tagged t)) of+        Right docs -> Right [d.root.props.tag | d <- docs]+        Left err -> Left (show err)+  assertEqual+    "empty tag"+    "! x\n"+    (render (tagged ""))+  assertEqual+    "global tag"+    "!<tag:example.com,2000:x> x\n"+    (render (tagged "tag:example.com,2000:x"))+  assertEqual+    "tag with a directive"+    "%TAG !t74! %74\n---\n!t74!ag:x%3Ey x\n"+    (render (tagged "tag:x>y"))+  mapM_+    ( \t ->+        assertEqual+          ("tag " ++ show t)+          (Right [Tag t])+          (tagOf t)+    )+    [ "tag:x>y"+    , "x%2"+    , "foo"+    , "#a b"+    , "!a b"+    , "tag:x%41"+    , "tag:yaml.org,2002:a%"+    , "\x100\&z"+    ]+  assertEqual+    "directives after a document"+    (Right [(NoTag, ScalarContent Plain "a"), (Tag "foo", ScalarContent Plain "x")])+    $ map (\d -> (d.root.props.tag, d.root.content))+      <$> parseDocumentsText+        ( renderSyntax+            defaultRenderOptions+            [document (plainNode "a"), document (tagged "foo")]+        )+  assertEqual+    "taken anchor name"+    "- &a_b x\n- &a_b_2 y\n- *a_b_2\n"+    . render+    $ sequenceNode+      [ anchored "a_b" (plainNode "x")+      , anchored "a b" (plainNode "y")+      , contentNode (AliasContent "a b")+      ]+  assertEqual+    "anchor names with line separators"+    "- &a_b x\n- &c_d y\n- *a_b\n- *c_d\n"+    . render+    $ sequenceNode+      [ anchored "a\x2028\&b" (plainNode "x")+      , anchored "c\x2029\&d" (plainNode "y")+      , contentNode (AliasContent "a\x2028\&b")+      , contentNode (AliasContent "c\x2029\&d")+      ]+  assertEqual+    "anchor names that YAML 1.1 parsers end early"+    "k: &a_b x\nl: &c_ y\nm: *a_b\n"+    . render+    $ mappingNode+      [ (plainNode "k", anchored "a:b" (plainNode "x"))+      , (plainNode "l", anchored "c?" (plainNode "y"))+      , (plainNode "m", contentNode (AliasContent "a:b"))+      ]++-- | The new names of many invalid anchor names with one base take linear+-- time, not quadratic.+test_manyAnchors :: Assertion+test_manyAnchors = do+  let names = map T.pack (mapM (const " ,[]{}") [1 .. 6 :: Int])+      tree =+        sequenceNode [(plainNode "x") {props = noProps {anchor = Just a}} | a <- names]+  assertEqual+    "first and last names"+    ["- &______ x", "- &_______" <> T.pack (show (length names)) <> " x"]+    $ case T.lines (render tree) of+      first : rest -> first : take 1 (reverse rest)+      [] -> []++-- | The time to render nested flow collections with a comment inside is+-- linear in the depth.+test_deepComment :: Assertion+test_deepComment =+  assertEqual+    "output"+    (Right expected)+    (renderSyntax defaultRenderOptions <$> parseDocumentsText input)+  where+    depth :: Int+    depth = 100000++    input :: T.Text+    input = T.replicate depth "[" <> " # c\n" <> T.replicate depth "]\n"++    expected :: T.Text+    expected =+      T.replicate (depth - 1) "- " <> "[\n" <> indent <> "# c\n" <> indent <> "]\n"++    indent :: T.Text+    indent = T.replicate (2 * (depth - 1)) " "++-- | The time to render keys inside keys of flow mappings is linear in the+-- depth.+test_nestedKeys :: Assertion+test_nestedKeys = do+  rendersBack+    "implicit keys"+    (T.replicate 30 "{" <> "a: b" <> T.replicate 30 "}: b" <> "\n")+  -- The keys inside become implicit as long as they fit.+  let explicitKeys = T.replicate 20000 "{? " <> "a" <> T.replicate 20000 "}" <> "\n"+  case renderSyntax defaultRenderOptions <$> parseDocumentsText explicitKeys of+    Right output -> rendersBack "explicit keys" output+    Left err -> assertFailure (show err)++-- | The time to attach the comment lines above nested lists, each on its own+-- line, is linear in the number of lines, not in the number of lines times+-- the depth.+test_commentsAboveNesting :: Assertion+test_commentsAboveNesting =+  assertEqual+    "lines above the innermost item"+    (Right [replicate count (Comment "c")])+    (map (innermostLines . (.root)) <$> parseDocumentsText input)+  where+    count, depth :: Int+    count = 100000+    depth = 2000++    input :: T.Text+    input =+      T.replicate count "# c\n"+        <> T.concat [T.replicate i " " <> "-\n" | i <- [0 .. depth - 1]]+        <> T.replicate depth " "+        <> "a\n"++    innermostLines :: Node -> [Line]+    innermostLines n = case n.content of+      SequenceContent _ (x : _) -> innermostLines x+      _ -> n.comments.before++-- | The time to render a double-quoted scalar whose escaped line breaks all+-- join their lines is linear in the number of lines.+test_escapedBreaks :: Assertion+test_escapedBreaks =+  assertEqual+    "output"+    (Right ("k: \"a" <> T.replicate count " b" <> "\\\n  c\"\n"))+    (renderSyntax defaultRenderOptions <$> parseDocumentsText input)+  where+    count :: Int+    count = 300000++    input :: T.Text+    input = "k: \"a\\\n" <> T.replicate count "  \\ b\\\n" <> "  c\"\n"++test_forceBlock :: Assertion+test_forceBlock = do+  assertEqual+    "output"+    (Right expected)+    (renderSyntax defaultRenderOptions {forceBlock = True} <$> parseDocumentsText input)+  assertEqual+    "collection in a key"+    (Right "? - a\n  - b\n: 1\n")+    $ renderSyntax defaultRenderOptions {forceBlock = True}+      <$> parseDocumentsText "[a, b]: 1\n"+  where+    input :: T.Text+    input = "list: [a, [b, c], {d: e}]\nkey: [[f]]\n"++    expected :: T.Text+    expected =+      T.unlines+        [ "list:"+        , "- a"+        , "- - b"+        , "  - c"+        , "- d: e"+        , "key:"+        , "- - f"+        ]++-- | A scalar that the source writes on several lines keeps its lines, also+-- where the text has a space in place of a line break.+test_scalarLines :: Assertion+test_scalarLines = do+  rendersBack+    "folded"+    "options: >-\n  --health-cmd pg_isready\n  --health-interval 5s\n  --health-retries 10\n"+  rendersBack "folded with paragraphs" "a: >\n  one\n  two\n\n  three\n  four\n"+  rendersBack "folded with more indented lines" "a: >\n  one\n    two\n  three\n  four\n"+  rendersBack "folded with a space at the end of a line" "a: >-\n  one \n  two\n"+  rendersBack "empty block scalars" "a: |-\nb: >-\nc:\n- |-\n"+  rendersAs+    "empty block scalars with clip"+    "a: |-\nb: >-\n"+    "a: |\nb: >\n"+  rendersBack "block scalars of only line breaks" "a: |+\n\nb:\n  c: |+\n\n\n  d: 1\n"+  rendersBack "block scalar of only line breaks at the top level" "|+\n\n"+  rendersBack "plain" "a: one\n  two\n  three\n"+  rendersBack "plain with an empty line" "a: one\n\n  two\n"+  rendersBack "plain in a sequence" "- one\n  two\n"+  rendersBack "plain root" "one\n  two\n"+  rendersBack "plain in a flow sequence" "a: [one\n  two, three]\n"+  rendersBack "single-quoted" "a: 'one\n  two'\n"+  rendersBack "double-quoted" "a: \"one\n  two\"\n"+  rendersBack "double-quoted with an escaped line break" "a: \"one\\\n  two\"\n"+  rendersBack "double-quoted with an empty line" "a: \"one\n\n  two\"\n"+  rendersBack "comment after the last line" "a: one\n  two # c\n"+  rendersAs+    "key"+    "one two: a\n"+    "? one\n  two\n: a\n"+  rendersAs+    "indentation"+    "a: one\n  two\n"+    "a:   one\n      two\n"+  let folded :: String -> [T.Text] -> Assertion+      folded preface ls = do+        let out = render (mappingNode [(plainNode "a", foldedNode ls)])+        assertEqual+          preface+          ("a: >-\n" <> T.concat [if T.null l then "\n" else "  " <> l <> "\n" | l <- ls])+          out+        assertEqual+          (preface ++ ", read back")+          (Right [[(foldedNode ls).content]])+          (map values <$> parseDocumentsText out)+      values :: Document -> [Content]+      values d = [v.content | MappingContent _ kvs <- [d.root.content], (_, v) <- kvs]+  folded "folded node" ["one two", "three", "four"]+  folded "folded node with a space at a line start" ["one", " two", "three"]+  folded "folded node with a space at a line end" ["one ", "two"]+  folded "folded node with one line" ["one"]+  folded "folded node with empty lines" ["one", "", "two", "", "", "three"]+  folded+    "folded node with an indented example"+    ["Example:", "  GET /orders", "", "The end."]+  assertEqual+    "positions"+    (Right [ScalarLinesContent Plain "one two\nthree" [4, 8]])+    (map (\d -> d.root.content) <$> parseDocumentsText "one\n two\n\n three\n")
+ tests/Yamlet/Test/TypeError.hs view
@@ -0,0 +1,121 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}++-- | The type errors of the generic instances. The module defers type errors,+-- so an instance with a type error compiles, and using it throws the error.+module Yamlet.Test.TypeError (typeErrorTests) where++import Control.Exception+import Data.List qualified as L+import Data.Text qualified as T+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet++typeErrorTests :: TestTree+typeErrorTests =+  testGroup+    "type errors"+    [ testCase "several fields without names" $ do+        rejects+          "The constructor Pair has several fields without names."+          (encodeText (Pair 1 "a"))+        rejects+          "The constructor Pair has several fields without names."+          (decodeText @Pair "[1, a]")+        rejects "Give the fields names." (encodeText (Pair 1 "a"))+    , testCase "several fields without names in a sum" $+        rejects+          "The constructor Line has several fields without names."+          (encodeText (Line 1 2))+    , testCase "named fields and a field without a name" $ do+        rejects+          "The constructor Circle has named fields and the constructor Label has one field without a name."+          (encodeText (Label "x"))+        rejects "use the sum encoding SingleField" (encodeText (Label "x"))+    , testCase "flat named fields" $ do+        rejects+          "TaggedFlat needs constructors with one field without a name, but the constructor Jump has named fields."+          (encodeText (Jump 1))+        rejects flatFieldsFix (encodeText (Jump 1))+    , testCase "flat several fields without names" $ do+        rejects+          "The constructor Leap has several fields without names."+          (encodeText (Leap 1 2))+        rejects flatFieldsFix (encodeText (Leap 1 2))+    , testCase "flat named fields and a field without a name" $ do+        rejects+          "TaggedFlat needs constructors with one field without a name, but the constructor Run has named fields."+          (encodeText (Wait 1))+        rejects flatFieldsFix (encodeText (Wait 1))+    , testCase "several fields without names in a single field" $+        rejects+          "The constructor Coords has several fields without names."+          (encodeText (Coords 1 2))+    , testCase "no constructors" $+        rejects+          "A type without constructors cannot derive FromYaml or ToYaml"+          (decodeText @Empty "null")+    ]++data Pair = Pair Int T.Text+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Pair++data Segment = Line Double Double | Dot+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Segment++data Mixed = Circle {radius :: Double} | Label T.Text+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Mixed++data FlatNamed = Jump {height :: Int} | Halt+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml FlatNamed++instance GenericYamlOptions FlatNamed where+  type SumEncoding FlatNamed = TaggedFlat++data FlatPair = Leap Int Int | Rest+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml FlatPair++instance GenericYamlOptions FlatPair where+  type SumEncoding FlatPair = TaggedFlat++data FlatMixed = Run {speed :: Int} | Wait Int | Idle+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml FlatMixed++instance GenericYamlOptions FlatMixed where+  type SumEncoding FlatMixed = TaggedFlat++flatFieldsFix :: String+flatFieldsFix =+  "Put the fields in a record type, and make it the one field of the constructor."++data Place = Coords Double Double | Nowhere+  deriving stock (Generic)+  deriving (FromYaml, ToYaml) via GenericYaml Place++instance GenericYamlOptions Place where+  type SumEncoding Place = SingleField++data Empty+  deriving stock (Generic)+  deriving anyclass (GenericYamlOptions)+  deriving (FromYaml, ToYaml) via GenericYaml Empty++-- | Using the value throws a deferred type error with the message.+rejects :: String -> a -> Assertion+rejects expected x =+  try (evaluate x) >>= \case+    Left (TypeError msg) ->+      assertBool+        ("the message contains " ++ show expected ++ ":\n" ++ msg)+        (expected `L.isInfixOf` msg)+    Right _ -> assertFailure "expected a type error"
+ tests/Yamlet/Test/YamlTestSuite.hs view
@@ -0,0 +1,311 @@+-- | The official YAML test suite, https://github.com/yaml/yaml-test-suite.+module Yamlet.Test.YamlTestSuite (testSuiteTests) where++import Control.Applicative+import Control.Monad+import Data.Aeson qualified as J+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Parser qualified as J+import Data.Attoparsec.ByteString.Char8 qualified as A+import Data.ByteString qualified as BS+import Data.List qualified as L+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Vector qualified as V+import System.Directory+import System.Environment+import System.FilePath+import Test.Tasty+import Test.Tasty.HUnit++import Yamlet qualified as Y+import Yamlet.Error+import Yamlet.Syntax+import Yamlet.Test.YamlTestSuite.Events++-- | The tests of the suite. The directory with the data branch of the+-- repository is in @YAML_TEST_SUITE@, or in+-- @tests/fixtures/yaml-test-suite@.+testSuiteTests :: IO TestTree+testSuiteTests = do+  dir <- fromMaybe "tests/fixtures/yaml-test-suite" <$> lookupEnv "YAML_TEST_SUITE"+  exists <- doesDirectoryExist dir+  if not exists+    then+      pure . testCase "yaml-test-suite" $+        assertFailure+          "The test suite is missing, run scripts/fetch-test-suite.sh or set YAML_TEST_SUITE"+    else do+      paths <- findCases dir+      pure . testGroup "yaml-test-suite" $+        testCase "error messages" (checkErrorMessages dir paths)+          : [testCase (makeRelative dir path) (runTest path) | path <- paths]++-- | The directories of the test cases, in order.+findCases :: FilePath -> IO [FilePath]+findCases dir = do+  -- The name and tags directories link to the tests by other names.+  entries <- L.sort . filter (`notElem` ["name", "tags"]) <$> listDirectory dir+  fmap concat . forM entries $ \entry -> do+    let path = dir </> entry+    isDir <- doesDirectoryExist path+    hasInput <- doesFileExist (path </> "in.yaml")+    if+      | isDir && hasInput -> pure [path]+      | isDir -> findCases path+      | otherwise -> pure []++-- | The error messages for the invalid inputs match the file+-- @tests/fixtures/error-messages.txt@. The messages come from heuristics+-- that look at the input around an error, so a change in one can change+-- others. If @YAMLET_ACCEPT_ERRORS@ is set, the test writes the file+-- instead.+checkErrorMessages :: FilePath -> [FilePath] -> Assertion+checkErrorMessages root paths = do+  actual <- fmap (unlines . concat) . forM paths $ \path -> do+    (name, input, isError) <- readCase path+    if not isError+      then pure []+      else do+        let message = case parseDocumentsText input of+              Left err ->+                show err.location.line+                  ++ ":"+                  ++ show err.location.column+                  ++ ": "+                  ++ err.message+              Right _ -> "no error"+        pure ["# " ++ makeRelative root path ++ ": " ++ T.unpack name, message]+  accept <- lookupEnv "YAMLET_ACCEPT_ERRORS"+  case accept of+    Just _ -> writeFile file actual+    Nothing -> do+      expected <- readFile file+      let changes =+            [ header ++ "\n- " ++ old ++ "\n+ " ++ new+            | ((header, old), (_, new)) <- zip (entries expected) (entries actual)+            , old /= new+            ]+          preface =+            "the error messages differ from "+              ++ file+              ++ ", set YAMLET_ACCEPT_ERRORS to update it"+      when (length (entries expected) /= length (entries actual)) $+        assertFailure (preface ++ ": the number of invalid inputs changed")+      unless (null changes) $ assertFailure (preface ++ ":\n" ++ unlines changes)+  where+    file :: FilePath+    file = "tests/fixtures/error-messages.txt"++    -- The pairs of a case header and its message.+    entries :: String -> [(String, String)]+    entries s = pairs (lines s)+      where+        pairs :: [String] -> [(String, String)]+        pairs = \case+          header : message : rest -> (header, message) : pairs rest+          _ -> []++-- | The name of a case, its input and whether the input is invalid.+readCase :: FilePath -> IO (T.Text, T.Text, Bool)+readCase path = do+  name <- T.strip . T.decodeUtf8 <$> BS.readFile (path </> "===")+  input <- T.decodeUtf8 <$> BS.readFile (path </> "in.yaml")+  isError <- doesFileExist (path </> "error")+  pure (name, input, isError)++runTest :: FilePath -> Assertion+runTest path = do+  (name, input, isError) <- readCase path+  let preface = T.unpack name ++ "\n" ++ T.unpack input+  case parseDocumentsText input of+    Left err+      | isError -> pure ()+      | otherwise ->+          assertFailure $ preface ++ "\nunexpected error: " ++ prettyError "in.yaml" err+    Right docs+      | isError ->+          assertFailure $+            preface+              ++ "\nexpected an error, got:\n"+              ++ unlines (map renderEvent (toEvents docs))+      | otherwise -> do+          expected <-+            lines . T.unpack . T.decodeUtf8 <$> BS.readFile (path </> "test.event")+          assertEqual+            preface+            expected+            (map renderEvent (toEvents docs))+          let styles =+                [ ("rendered", defaultRenderOptions)+                , ("rendered in block style", defaultRenderOptions {forceBlock = True})+                ]+          forM_ styles $ \(label, options) -> do+            let out = renderSyntax options docs+            case parseDocumentsText out of+              Left err ->+                assertFailure $+                  preface+                    ++ "\n"+                    ++ label+                    ++ ":\n"+                    ++ T.unpack out+                    ++ "\nerror: "+                    ++ prettyError "out.yaml" err+              Right docs' -> do+                assertEqual+                  (preface ++ "\n" ++ label ++ ":\n" ++ T.unpack out)+                  (rendered (toEvents docs))+                  (rendered (toEvents docs'))+                assertEqual+                  (preface ++ "\n" ++ label ++ " again")+                  out+                  (renderSyntax options docs')+          hasJson <- doesFileExist (path </> "in.json")+          case Y.decodeAllText @Y.Value input of+            Left err+              -- The decoder rejects duplicate keys, which the syntax allows.+              | not hasJson && "duplicate key" `L.isPrefixOf` (NE.head err).message ->+                  pure ()+              | otherwise ->+                  assertFailure $+                    preface+                      ++ "\nunexpected error: "+                      ++ prettyError "in.yaml" (NE.head err)+            Right nodes -> do+              when hasJson $ do+                json <- BS.readFile (path </> "in.json")+                expectedValues <- case A.parseOnly jsonValues json of+                  Right vs -> pure vs+                  Left err -> assertFailure $ "invalid in.json: " ++ err+                assertEqual+                  (preface ++ "\nvalues")+                  expectedValues+                  (map toJson nodes)+              let encoded = Y.encodeAllText nodes+              case Y.decodeAllText @Y.Value encoded of+                Left err ->+                  assertFailure $+                    preface+                      ++ "\nencoded:\n"+                      ++ T.unpack encoded+                      ++ "\nerror: "+                      ++ prettyError "out.yaml" (NE.head err)+                Right nodes' ->+                  assertEqual+                    (preface ++ "\nencoded:\n" ++ T.unpack encoded)+                    nodes+                    nodes'+  where+    jsonValues :: A.Parser [J.Value]+    jsonValues = many (A.skipSpace *> J.json') <* A.skipSpace <* A.endOfInput++    -- The JSON form of a value. The keys of the mappings in the tests with+    -- JSON are strings.+    toJson :: Y.Value -> J.Value+    toJson = \case+      Y.Null -> J.Null+      Y.Bool b -> J.Bool b+      Y.Int i -> J.Number (fromInteger i)+      Y.Float (Y.Finite s) -> J.Number s+      Y.Float _ -> J.Null+      Y.String t -> J.String t+      Y.Sequence xs -> J.Array . V.fromList $ map toJson xs+      Y.Mapping kvs -> J.Object $ KM.fromList [(key k, toJson v) | (k, v) <- kvs]+      Y.Tagged _ v -> toJson v+      where+        key :: Y.Value -> K.Key+        key = \case+          Y.String t -> K.fromText t+          Y.Null -> K.fromText ""+          Y.Tagged _ v -> key v+          v -> K.fromString (show v)++    -- An event in the format of the test suite.+    renderEvent :: Event -> String+    renderEvent = \case+      StreamStart -> "+STR"+      StreamEnd -> "-STR"+      DocumentStart explicit -> "+DOC" ++ if explicit then " ---" else ""+      DocumentEnd explicit -> "-DOC" ++ if explicit then " ..." else ""+      SequenceStart props style -> "+SEQ" ++ flow style "[]" ++ renderProps props+      SequenceEnd -> "-SEQ"+      MappingStart props style -> "+MAP" ++ flow style "{}" ++ renderProps props+      MappingEnd -> "-MAP"+      ScalarEvent props style t ->+        "=VAL" ++ renderProps props ++ " " ++ styleChar style : escape (T.unpack t)+      AliasEvent name -> "=ALI *" ++ T.unpack name+      where+        flow :: CollectionStyle -> String -> String+        flow style s = case style of+          Flow -> ' ' : s+          Block -> ""++        renderProps :: Props -> String+        renderProps props =+          maybe "" (\a -> " &" ++ T.unpack a) props.anchor ++ case props.tag of+            NoTag -> ""+            NonSpecificTag -> " <!>"+            Tag t -> " <" ++ T.unpack t ++ ">"++        styleChar :: ScalarStyle -> Char+        styleChar = \case+          Plain -> ':'+          SingleQuoted -> '\''+          DoubleQuoted -> '"'+          Literal -> '|'+          Folded -> '>'++        escape :: String -> String+        escape = concatMap $ \case+          '\\' -> "\\\\"+          '\n' -> "\\n"+          '\t' -> "\\t"+          '\b' -> "\\b"+          '\r' -> "\\r"+          c -> [c]++-- | The events that the renderer keeps. It writes a start marker for every+-- document after the first one. It can rename an anchor, so a name becomes+-- the number of the names before its first use in the document.+rendered :: [Event] -> [Event]+rendered = go M.empty+  where+    go :: M.Map T.Text Int -> [Event] -> [Event]+    go names = \case+      DocumentEnd explicit : DocumentStart _ : rest ->+        DocumentEnd explicit : DocumentStart True : go M.empty rest+      e : rest ->+        let (names', e') = numbered names (withoutStyle e)+        in e' : go names' rest+      [] -> []++    numbered :: M.Map T.Text Int -> Event -> (M.Map T.Text Int, Event)+    numbered names = \case+      SequenceStart props style -> (`SequenceStart` style) <$> numberedProps props+      MappingStart props style -> (`MappingStart` style) <$> numberedProps props+      ScalarEvent props style t -> (\p -> ScalarEvent p style t) <$> numberedProps props+      AliasEvent a -> AliasEvent <$> number a+      e -> (names, e)+      where+        numberedProps :: Props -> (M.Map T.Text Int, Props)+        numberedProps props = case props.anchor of+          Just a -> (\n -> props {anchor = Just n}) <$> number a+          Nothing -> (names, props)++        number :: T.Text -> (M.Map T.Text Int, T.Text)+        number a = case M.lookup a names of+          Just i -> (names, T.pack (show i))+          Nothing -> (M.insert a (M.size names) names, T.pack (show (M.size names)))++    -- The renderer can change the styles.+    withoutStyle :: Event -> Event+    withoutStyle = \case+      SequenceStart props _ -> SequenceStart props Block+      MappingStart props _ -> MappingStart props Block+      ScalarEvent props _ t -> ScalarEvent props Plain t+      e -> e
+ tests/Yamlet/Test/YamlTestSuite/Events.hs view
@@ -0,0 +1,46 @@+-- | A YAML stream as a sequence of events, the representation that the YAML+-- specification uses to describe the result of parsing.+module Yamlet.Test.YamlTestSuite.Events+  ( Event (..)+  , toEvents+  ) where++import Data.Text qualified as T++import Yamlet.Syntax++data Event+  = StreamStart+  | StreamEnd+  | -- | The document starts with a @---@ marker.+    DocumentStart !Bool+  | -- | The document ends with a @...@ marker.+    DocumentEnd !Bool+  | SequenceStart !Props !CollectionStyle+  | SequenceEnd+  | MappingStart !Props !CollectionStyle+  | MappingEnd+  | ScalarEvent !Props !ScalarStyle !T.Text+  | AliasEvent !T.Text+  deriving stock (Eq, Show)++-- | The events of a stream.+toEvents :: [Document] -> [Event]+toEvents docs = StreamStart : foldr documentEvents [StreamEnd] docs+  where+    documentEvents :: Document -> [Event] -> [Event]+    documentEvents doc rest =+      DocumentStart doc.explicitStart+        : node doc.root (DocumentEnd doc.explicitEnd : rest)++    node :: Node -> [Event] -> [Event]+    node n rest = case n.content of+      ScalarContent style t -> ScalarEvent n.props style t : rest+      SequenceContent style xs ->+        SequenceStart n.props style : foldr node (SequenceEnd : rest) xs+      MappingContent style kvs ->+        MappingStart n.props style : foldr pair (MappingEnd : rest) kvs+      AliasContent name -> AliasEvent name : rest++    pair :: (Node, Node) -> [Event] -> [Event]+    pair (k, v) rest = node k (node v rest)
+ tests/fixtures/error-messages.txt view
@@ -0,0 +1,188 @@+# 236B: Invalid value after mapping+3:8: expected ':' after the key+# 2CMS: Invalid mapping in plain multiline+3:10: unexpected ':', this line continues the scalar from the line above, check the indentation and the line above+# 2G84/00: Literal modifers+1:6: the indentation indicator of a block scalar must be from 1 to 9+# 2G84/01: Literal modifers+1:7: the indentation indicator of a block scalar must be from 1 to 9+# 3HFZ: Invalid content after document end marker+3:5: unexpected content after the document end marker (...)+# 4EJS: Invalid tabs as indendation in a mapping+3:1: tabs cannot be used for indentation+# 4H7K: Flow sequence with invalid extra closing bracket+2:13: unexpected ']' after the end of a flow collection+# 4HVU: Wrong indendation in Sequence+4:3: unexpected indentation+# 4JVG: Scalar value with two anchors+4:11: unexpected end of line+# 55WF: Invalid escape in double quoted string+2:2: invalid escape sequence, write \\ for a backslash or use single quotes+# 5LLU: Block scalar with wrong indented line after spaces only+4:4: a leading empty line of a block scalar has more spaces than the first non-empty line+# 5TRB: Invalid document-start marker in doublequoted tring+3:1: unexpected '---' in a double-quoted scalar, indent the line+# 5U3A: Sequence on same Line as Mapping Key+1:6: unexpected '-', a list cannot start on the line of its key+# 62EZ: Invalid block mapping key on same line as previous key+2:12: unexpected 'i' after the end of a flow collection+# 6JTT: Flow sequence without closing bracket+2:1: unterminated flow sequence+# 6S55: Invalid scalar at the end of sequence+4:2: unexpected value among list items+# 7LBH: Multiline double quoted implicit keys+2:3: a key must be on a single line+# 7MNF: Missing colon+3:5: expected ':' after the key+# 8XDJ: Comment in plain multiline value+3:3: a comment ends a plain scalar, so this line cannot continue it+# 9C9N: Wrong indented flow sequence+3:1: the line is indented too little to continue the flow sequence+# 9CWY: Invalid scalar at the end of mapping+4:8: expected ':' after the key+# 9HCY: Need document footer before directives+2:1: unexpected '%', a directive needs '...' on a line above it to end the document+# 9JBA: Invalid comment after end of flow sequence+2:13: unexpected '#', a comment needs a space before it+# 9KBC: Mapping starting at --- line+1:9: unexpected ':', a mapping cannot start on the line of '---'+# 9MAG: Flow sequence with invalid comma at the beginning+2:3: unexpected ',', a flow collection cannot have an empty entry+# 9MMA: Directive by itself with no document+2:1: expected a document start marker (---) after the directives+# 9MQT/01: Scalar doc with '...' in content+2:1: unexpected '...' in a double-quoted scalar, indent the line+# B63P: Directive without document+2:1: expected a document start marker (---) after the directives+# BD7L: Invalid mapping after sequence+3:1: unexpected key among list items+# BF9H: Trailing comment in multiline plain scalar+4:8: a comment ends a plain scalar, so this line cannot continue it+# BS4K: Comment between plain scalar lines+2:1: a comment ends a plain scalar, so this line cannot continue it+# C2SP: Flow Mapping Key on two lines+2:2: unexpected ':', a key must be on a single line+# CML9: Missing comma in flow+3:3: expected ',' or ']'+# CQ3W: Double quoted string without closing quote+2:6: unterminated double-quoted scalar+# CTN5: Flow sequence with invalid extra comma+2:12: unexpected ',', a flow collection cannot have an empty entry+# CVW2: Invalid comment after comma+2:11: unexpected '#', a comment needs a space before it+# CXX2: Mapping with anchor on document start line+1:14: unexpected ':', a mapping cannot start on the line of '---'+# D49Q: Multiline single quoted implicit keys+2:3: a key must be on a single line+# DK4H: Implicit key followed by newline+3:3: expected ',' or ']'+# DK95/01: Tabs that look like indentation+2:1: tabs cannot be used for indentation+# DK95/06: Tabs that look like indentation+3:3: tabs cannot be used for indentation+# DMG6: Wrong indendation in Map+3:2: unexpected indentation+# EB22: Missing document-end marker before directive+3:1: unexpected '%', a directive needs '...' on a line above it to end the document+# EW3V: Wrong indendation in mapping+2:4: unexpected ':', this line continues the scalar from the line above, check the indentation and the line above+# G5U8: Plain dashes in flow sequence+2:4: unexpected '-', a list item cannot be inside a flow collection, quote '-' if it is a string+# G7JE: Multiline implicit keys+2:2: expected ':' after the key+# G9HC: Invalid anchor in zero indented sequence+3:1: an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'+# GDY7: Comment that looks like a mapping key+2:8: expected ':' after the key+# GT5M: Node anchor in sequence+2:1: an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'+# H7J7: Node anchor not indented+2:1: an anchor or a tag cannot be on a line of its own here, write it after the key or the '-'+# H7TQ: Extra words on %YAML directive+1:11: unexpected content after the %YAML version+# HRE5: Double quoted scalar with escaped single quote+2:17: invalid escape sequence, write \\ for a backslash or use single quotes+# HU3P: Invalid Mapping in plain scalar+3:5: unexpected ':', this line continues the scalar from the line above, check the indentation and the line above+# JKF3: Multiline unidented double quoted block key+2:1: invalid indentation of a line in a double-quoted scalar+# JY7Z: Trailing content that looks like a mapping+2:17: unexpected 'n' after the end of a quoted scalar+# KS4U: Invalid item after end of flow sequence+5:1: unexpected 'i'+# LHL4: Invalid tag+2:9: unexpected '{'+# MUS6/00: Directive variants+1:7: expected a version such as 1.2 after %YAML+# MUS6/01: Directive variants+3:1: unexpected '%', a directive needs '...' on a line above it to end the document+# N4JP: Bad indentation in mapping+3:2: unexpected indentation+# N782: Invalid document markers in flow style+2:1: unexpected '---' in a flow sequence, indent the line+# P2EQ: Invalid sequene item on same line as previous item+2:11: unexpected '-' after the end of a flow collection+# Q4CL: Trailing content after quoted value+2:17: unexpected 't' after the end of a quoted scalar+# QB6E: Wrong indented multiline quoted scalar+3:1: invalid indentation of a line in a double-quoted scalar+# QLJ7: Tag shorthand used in documents but only defined in the first+4:5: undefined tag handle !prefix!+# RHX7: YAML directive without document end marker+3:1: unexpected '%', a directive needs '...' on a line above it to end the document+# RXY3: Invalid document-end marker in single quoted string+3:1: unexpected '...' in a single-quoted scalar, indent the line+# S4GJ: Invalid text after block scalar indicator+2:11: the content of a block scalar starts on the next line+# S98Z: Block scalar with more spaces than first content line+4:4: a leading empty line of a block scalar has more spaces than the first non-empty line+# SF5V: Duplicate YAML directive+2:1: duplicate %YAML directive+# SR86: Anchor plus Alias+2:10: unexpected '*', an alias cannot have an anchor or a tag+# SU5Z: Comment without whitespace after doublequoted scalar+1:13: unexpected '#', a comment needs a space before it+# SU74: Anchor and alias as mapping key+2:4: unexpected '*', an alias cannot have an anchor or a tag+# SY6V: Anchor before sequence entry on same line+1:9: unexpected '-', a list cannot start on the line of its anchor or tag+# T833: Flow mapping missing a separating comma+4:5: expected ',' or '}'+# TD5N: Invalid scalar after sequence+3:1: unexpected value among list items+# U44R: Bad indentation in mapping (2)+3:4: unexpected indentation+# U99R: Invalid comma in tag+1:8: unexpected ','+# VJP3/00: Flow collections over many lines+2:1: the line is indented too little to continue the flow mapping+# W9L4: Literal block scalar with more spaces in first line+3:6: a leading empty line of a block scalar has more spaces than the first non-empty line+# X4QW: Comment without whitespace after block scalar indicator+1:8: invalid block scalar header+# Y79Y/000: Tabs in various contexts+2:1: tabs cannot be used for indentation+# Y79Y/003: Tabs in various contexts+2:1: tabs cannot be used for indentation+# Y79Y/004: Tabs in various contexts+1:2: tabs cannot be used for indentation+# Y79Y/005: Tabs in various contexts+1:3: tabs cannot be used for indentation+# Y79Y/006: Tabs in various contexts+1:2: tabs cannot be used for indentation+# Y79Y/007: Tabs in various contexts+2:2: tabs cannot be used for indentation+# Y79Y/008: Tabs in various contexts+1:2: tabs cannot be used for indentation+# Y79Y/009: Tabs in various contexts+2:2: tabs cannot be used for indentation+# YJV2: Dash in flow sequence+1:2: unexpected '-', a list item cannot be inside a flow collection, quote '-' if it is a string+# ZCZ6: Invalid mapping in plain single line value+1:5: unexpected ':', quote the value if it contains ": "+# ZL4Z: Invalid nested mapping+2:7: unexpected ':', quote the value if it contains ": "+# ZVH3: Wrong indented sequence item+2:2: unexpected indentation+# ZXT5: Implicit key followed by newline and adjacent value+2:3: expected ',' or ']'
+ tests/fixtures/yaml-test-suite/229Q/=== view
@@ -0,0 +1,1 @@+Spec Example 2.4. Sequence of Mappings
+ tests/fixtures/yaml-test-suite/229Q/in.json view
@@ -0,0 +1,12 @@+[+  {+    "name": "Mark McGwire",+    "hr": 65,+    "avg": 0.278+  },+  {+    "name": "Sammy Sosa",+    "hr": 63,+    "avg": 0.288+  }+]
+ tests/fixtures/yaml-test-suite/229Q/in.yaml view
@@ -0,0 +1,8 @@+-+  name: Mark McGwire+  hr:   65+  avg:  0.278+-+  name: Sammy Sosa+  hr:   63+  avg:  0.288
+ tests/fixtures/yaml-test-suite/229Q/out.yaml view
@@ -0,0 +1,6 @@+- name: Mark McGwire+  hr: 65+  avg: 0.278+- name: Sammy Sosa+  hr: 63+  avg: 0.288
+ tests/fixtures/yaml-test-suite/229Q/test.event view
@@ -0,0 +1,22 @@++STR++DOC++SEQ++MAP+=VAL :name+=VAL :Mark McGwire+=VAL :hr+=VAL :65+=VAL :avg+=VAL :0.278+-MAP++MAP+=VAL :name+=VAL :Sammy Sosa+=VAL :hr+=VAL :63+=VAL :avg+=VAL :0.288+-MAP+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/236B/=== view
@@ -0,0 +1,1 @@+Invalid value after mapping
+ tests/fixtures/yaml-test-suite/236B/error view
+ tests/fixtures/yaml-test-suite/236B/in.yaml view
@@ -0,0 +1,3 @@+foo:+  bar+invalid
+ tests/fixtures/yaml-test-suite/236B/test.event view
@@ -0,0 +1,5 @@++STR++DOC++MAP+=VAL :foo+=VAL :bar
+ tests/fixtures/yaml-test-suite/26DV/=== view
@@ -0,0 +1,1 @@+Whitespace around colon in mappings
+ tests/fixtures/yaml-test-suite/26DV/in.json view
@@ -0,0 +1,18 @@+{+  "top1": {+    "key1": "scalar1"+  },+  "top2": {+    "key2": "scalar2"+  },+  "top3": {+    "scalar1": "scalar3"+  },+  "top4": {+    "scalar2": "scalar4"+  },+  "top5": "scalar5",+  "top6": {+    "key6": "scalar6"+  }+}
+ tests/fixtures/yaml-test-suite/26DV/in.yaml view
@@ -0,0 +1,12 @@+"top1" : +  "key1" : &alias1 scalar1+'top2' : +  'key2' : &alias2 scalar2+top3: &node3 +  *alias1 : scalar3+top4: +  *alias2 : scalar4+top5   :    +  scalar5+top6: +  &anchor6 'key6' : scalar6
+ tests/fixtures/yaml-test-suite/26DV/out.yaml view
@@ -0,0 +1,11 @@+"top1":+  "key1": &alias1 scalar1+'top2':+  'key2': &alias2 scalar2+top3: &node3+  *alias1 : scalar3+top4:+  *alias2 : scalar4+top5: scalar5+top6:+  &anchor6 'key6': scalar6
+ tests/fixtures/yaml-test-suite/26DV/test.event view
@@ -0,0 +1,33 @@++STR++DOC++MAP+=VAL "top1++MAP+=VAL "key1+=VAL &alias1 :scalar1+-MAP+=VAL 'top2++MAP+=VAL 'key2+=VAL &alias2 :scalar2+-MAP+=VAL :top3++MAP &node3+=ALI *alias1+=VAL :scalar3+-MAP+=VAL :top4++MAP+=ALI *alias2+=VAL :scalar4+-MAP+=VAL :top5+=VAL :scalar5+=VAL :top6++MAP+=VAL &anchor6 'key6+=VAL :scalar6+-MAP+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/27NA/=== view
@@ -0,0 +1,1 @@+Spec Example 5.9. Directive Indicator
+ tests/fixtures/yaml-test-suite/27NA/in.json view
@@ -0,0 +1,1 @@+"text"
+ tests/fixtures/yaml-test-suite/27NA/in.yaml view
@@ -0,0 +1,2 @@+%YAML 1.2+--- text
+ tests/fixtures/yaml-test-suite/27NA/out.yaml view
@@ -0,0 +1,1 @@+--- text
+ tests/fixtures/yaml-test-suite/27NA/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL :text+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2AUY/=== view
@@ -0,0 +1,1 @@+Tags in Block Sequence
+ tests/fixtures/yaml-test-suite/2AUY/in.json view
@@ -0,0 +1,6 @@+[+  "a",+  "b",+  42,+  "d"+]
+ tests/fixtures/yaml-test-suite/2AUY/in.yaml view
@@ -0,0 +1,4 @@+ - !!str a+ - b+ - !!int 42+ - d
+ tests/fixtures/yaml-test-suite/2AUY/out.yaml view
@@ -0,0 +1,4 @@+- !!str a+- b+- !!int 42+- d
+ tests/fixtures/yaml-test-suite/2AUY/test.event view
@@ -0,0 +1,10 @@++STR++DOC++SEQ+=VAL <tag:yaml.org,2002:str> :a+=VAL :b+=VAL <tag:yaml.org,2002:int> :42+=VAL :d+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2CMS/=== view
@@ -0,0 +1,1 @@+Invalid mapping in plain multiline
+ tests/fixtures/yaml-test-suite/2CMS/error view
+ tests/fixtures/yaml-test-suite/2CMS/in.yaml view
@@ -0,0 +1,3 @@+this+ is+  invalid: x
+ tests/fixtures/yaml-test-suite/2CMS/test.event view
@@ -0,0 +1,2 @@++STR++DOC
+ tests/fixtures/yaml-test-suite/2EBW/=== view
@@ -0,0 +1,1 @@+Allowed characters in keys
+ tests/fixtures/yaml-test-suite/2EBW/in.json view
@@ -0,0 +1,7 @@+{+  "a!\"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~": "safe",+  "?foo": "safe question mark",+  ":foo": "safe colon",+  "-foo": "safe dash",+  "this is#not": "a comment"+}
+ tests/fixtures/yaml-test-suite/2EBW/in.yaml view
@@ -0,0 +1,5 @@+a!"#$%&'()*+,-./09:;<=>?@AZ[\]^_`az{|}~: safe+?foo: safe question mark+:foo: safe colon+-foo: safe dash+this is#not: a comment
+ tests/fixtures/yaml-test-suite/2EBW/out.yaml view
@@ -0,0 +1,5 @@+a!"#$%&'()*+,-./09:;<=>?@AZ[\]^_`az{|}~: safe+?foo: safe question mark+:foo: safe colon+-foo: safe dash+this is#not: a comment
+ tests/fixtures/yaml-test-suite/2EBW/test.event view
@@ -0,0 +1,16 @@++STR++DOC++MAP+=VAL :a!"#$%&'()*+,-./09:;<=>?@AZ[\\]^_`az{|}~+=VAL :safe+=VAL :?foo+=VAL :safe question mark+=VAL ::foo+=VAL :safe colon+=VAL :-foo+=VAL :safe dash+=VAL :this is#not+=VAL :a comment+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2G84/00/=== view
@@ -0,0 +1,1 @@+Literal modifers
+ tests/fixtures/yaml-test-suite/2G84/00/error view
+ tests/fixtures/yaml-test-suite/2G84/00/in.yaml view
@@ -0,0 +1,1 @@+--- |0
+ tests/fixtures/yaml-test-suite/2G84/00/test.event view
@@ -0,0 +1,2 @@++STR++DOC ---
+ tests/fixtures/yaml-test-suite/2G84/01/=== view
@@ -0,0 +1,1 @@+Literal modifers
+ tests/fixtures/yaml-test-suite/2G84/01/error view
+ tests/fixtures/yaml-test-suite/2G84/01/in.yaml view
@@ -0,0 +1,1 @@+--- |10
+ tests/fixtures/yaml-test-suite/2G84/01/test.event view
@@ -0,0 +1,2 @@++STR++DOC ---
+ tests/fixtures/yaml-test-suite/2G84/02/=== view
@@ -0,0 +1,1 @@+Literal modifers
+ tests/fixtures/yaml-test-suite/2G84/02/emit.yaml view
@@ -0,0 +1,1 @@+--- ""
+ tests/fixtures/yaml-test-suite/2G84/02/in.json view
@@ -0,0 +1,1 @@+""
+ tests/fixtures/yaml-test-suite/2G84/02/in.yaml view
@@ -0,0 +1,1 @@+--- |1-
+ tests/fixtures/yaml-test-suite/2G84/02/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL |+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2G84/03/=== view
@@ -0,0 +1,1 @@+Literal modifers
+ tests/fixtures/yaml-test-suite/2G84/03/emit.yaml view
@@ -0,0 +1,1 @@+--- ""
+ tests/fixtures/yaml-test-suite/2G84/03/in.json view
@@ -0,0 +1,1 @@+""
+ tests/fixtures/yaml-test-suite/2G84/03/in.yaml view
@@ -0,0 +1,1 @@+--- |1+
+ tests/fixtures/yaml-test-suite/2G84/03/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL |+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2JQS/=== view
@@ -0,0 +1,1 @@+Block Mapping with Missing Keys
+ tests/fixtures/yaml-test-suite/2JQS/in.yaml view
@@ -0,0 +1,2 @@+: a+: b
+ tests/fixtures/yaml-test-suite/2JQS/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP+=VAL :+=VAL :a+=VAL :+=VAL :b+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2LFX/=== view
@@ -0,0 +1,1 @@+Spec Example 6.13. Reserved Directives [1.3]
+ tests/fixtures/yaml-test-suite/2LFX/emit.yaml view
@@ -0,0 +1,1 @@+--- "foo"
+ tests/fixtures/yaml-test-suite/2LFX/in.json view
@@ -0,0 +1,1 @@+"foo"
+ tests/fixtures/yaml-test-suite/2LFX/in.yaml view
@@ -0,0 +1,4 @@+%FOO  bar baz # Should be ignored+              # with a warning.+---+"foo"
+ tests/fixtures/yaml-test-suite/2LFX/out.yaml view
@@ -0,0 +1,2 @@+---+"foo"
+ tests/fixtures/yaml-test-suite/2LFX/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL "foo+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2SXE/=== view
@@ -0,0 +1,1 @@+Anchors With Colon in Name
+ tests/fixtures/yaml-test-suite/2SXE/in.json view
@@ -0,0 +1,4 @@+{+  "key": "value",+  "foo": "key"+}
+ tests/fixtures/yaml-test-suite/2SXE/in.yaml view
@@ -0,0 +1,3 @@+&a: key: &a value+foo:+  *a:
+ tests/fixtures/yaml-test-suite/2SXE/out.yaml view
@@ -0,0 +1,2 @@+&a: key: &a value+foo: *a:
+ tests/fixtures/yaml-test-suite/2SXE/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP+=VAL &a: :key+=VAL &a :value+=VAL :foo+=ALI *a:+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/2XXW/=== view
@@ -0,0 +1,1 @@+Spec Example 2.25. Unordered Sets
+ tests/fixtures/yaml-test-suite/2XXW/in.json view
@@ -0,0 +1,5 @@+{+  "Mark McGwire": null,+  "Sammy Sosa": null,+  "Ken Griff": null+}
+ tests/fixtures/yaml-test-suite/2XXW/in.yaml view
@@ -0,0 +1,7 @@+# Sets are represented as a+# Mapping where each key is+# associated with a null value+--- !!set+? Mark McGwire+? Sammy Sosa+? Ken Griff
+ tests/fixtures/yaml-test-suite/2XXW/out.yaml view
@@ -0,0 +1,4 @@+--- !!set+Mark McGwire:+Sammy Sosa:+Ken Griff:
+ tests/fixtures/yaml-test-suite/2XXW/test.event view
@@ -0,0 +1,12 @@++STR++DOC ---++MAP <tag:yaml.org,2002:set>+=VAL :Mark McGwire+=VAL :+=VAL :Sammy Sosa+=VAL :+=VAL :Ken Griff+=VAL :+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/33X3/=== view
@@ -0,0 +1,1 @@+Three explicit integers in a block sequence
+ tests/fixtures/yaml-test-suite/33X3/in.json view
@@ -0,0 +1,5 @@+[+  1,+  -2,+  33+]
+ tests/fixtures/yaml-test-suite/33X3/in.yaml view
@@ -0,0 +1,4 @@+---+- !!int 1+- !!int -2+- !!int 33
+ tests/fixtures/yaml-test-suite/33X3/out.yaml view
@@ -0,0 +1,4 @@+---+- !!int 1+- !!int -2+- !!int 33
+ tests/fixtures/yaml-test-suite/33X3/test.event view
@@ -0,0 +1,9 @@++STR++DOC ---++SEQ+=VAL <tag:yaml.org,2002:int> :1+=VAL <tag:yaml.org,2002:int> :-2+=VAL <tag:yaml.org,2002:int> :33+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/35KP/=== view
@@ -0,0 +1,1 @@+Tags for Root Objects
+ tests/fixtures/yaml-test-suite/35KP/in.json view
@@ -0,0 +1,7 @@+{+  "a": "b"+}+[+  "c"+]+"d e"
+ tests/fixtures/yaml-test-suite/35KP/in.yaml view
@@ -0,0 +1,8 @@+--- !!map+? a+: b+--- !!seq+- !!str c+--- !!str+d+e
+ tests/fixtures/yaml-test-suite/35KP/out.yaml view
@@ -0,0 +1,5 @@+--- !!map+a: b+--- !!seq+- !!str c+--- !!str d e
+ tests/fixtures/yaml-test-suite/35KP/test.event view
@@ -0,0 +1,16 @@++STR++DOC ---++MAP <tag:yaml.org,2002:map>+=VAL :a+=VAL :b+-MAP+-DOC++DOC ---++SEQ <tag:yaml.org,2002:seq>+=VAL <tag:yaml.org,2002:str> :c+-SEQ+-DOC++DOC ---+=VAL <tag:yaml.org,2002:str> :d e+-DOC+-STR
+ tests/fixtures/yaml-test-suite/36F6/=== view
@@ -0,0 +1,1 @@+Multiline plain scalar with empty line
+ tests/fixtures/yaml-test-suite/36F6/in.json view
@@ -0,0 +1,3 @@+{+  "plain": "a b\nc"+}
+ tests/fixtures/yaml-test-suite/36F6/in.yaml view
@@ -0,0 +1,5 @@+---+plain: a+ b++ c
+ tests/fixtures/yaml-test-suite/36F6/out.yaml view
@@ -0,0 +1,4 @@+---+plain: 'a b++  c'
+ tests/fixtures/yaml-test-suite/36F6/test.event view
@@ -0,0 +1,8 @@++STR++DOC ---++MAP+=VAL :plain+=VAL :a b\nc+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3ALJ/=== view
@@ -0,0 +1,1 @@+Block Sequence in Block Sequence
+ tests/fixtures/yaml-test-suite/3ALJ/in.json view
@@ -0,0 +1,7 @@+[+  [+    "s1_i1",+    "s1_i2"+  ],+  "s2"+]
+ tests/fixtures/yaml-test-suite/3ALJ/in.yaml view
@@ -0,0 +1,3 @@+- - s1_i1+  - s1_i2+- s2
+ tests/fixtures/yaml-test-suite/3ALJ/test.event view
@@ -0,0 +1,11 @@++STR++DOC++SEQ++SEQ+=VAL :s1_i1+=VAL :s1_i2+-SEQ+=VAL :s2+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3GZX/=== view
@@ -0,0 +1,1 @@+Spec Example 7.1. Alias Nodes
+ tests/fixtures/yaml-test-suite/3GZX/in.json view
@@ -0,0 +1,6 @@+{+  "First occurrence": "Foo",+  "Second occurrence": "Foo",+  "Override anchor": "Bar",+  "Reuse anchor": "Bar"+}
+ tests/fixtures/yaml-test-suite/3GZX/in.yaml view
@@ -0,0 +1,4 @@+First occurrence: &anchor Foo+Second occurrence: *anchor+Override anchor: &anchor Bar+Reuse anchor: *anchor
+ tests/fixtures/yaml-test-suite/3GZX/test.event view
@@ -0,0 +1,14 @@++STR++DOC++MAP+=VAL :First occurrence+=VAL &anchor :Foo+=VAL :Second occurrence+=ALI *anchor+=VAL :Override anchor+=VAL &anchor :Bar+=VAL :Reuse anchor+=ALI *anchor+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3HFZ/=== view
@@ -0,0 +1,1 @@+Invalid content after document end marker
+ tests/fixtures/yaml-test-suite/3HFZ/error view
+ tests/fixtures/yaml-test-suite/3HFZ/in.yaml view
@@ -0,0 +1,3 @@+---+key: value+... invalid
+ tests/fixtures/yaml-test-suite/3HFZ/test.event view
@@ -0,0 +1,7 @@++STR++DOC ---++MAP+=VAL :key+=VAL :value+-MAP+-DOC ...
+ tests/fixtures/yaml-test-suite/3MYT/=== view
@@ -0,0 +1,1 @@+Plain Scalar looking like key, comment, anchor and tag
+ tests/fixtures/yaml-test-suite/3MYT/in.json view
@@ -0,0 +1,1 @@+"k:#foo &a !t s"
+ tests/fixtures/yaml-test-suite/3MYT/in.yaml view
@@ -0,0 +1,3 @@+---+k:#foo+ &a !t s
+ tests/fixtures/yaml-test-suite/3MYT/out.yaml view
@@ -0,0 +1,1 @@+--- k:#foo &a !t s
+ tests/fixtures/yaml-test-suite/3MYT/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL :k:#foo &a !t s+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3R3P/=== view
@@ -0,0 +1,1 @@+Single block sequence with anchor
+ tests/fixtures/yaml-test-suite/3R3P/in.json view
@@ -0,0 +1,3 @@+[+  "a"+]
+ tests/fixtures/yaml-test-suite/3R3P/in.yaml view
@@ -0,0 +1,2 @@+&sequence+- a
+ tests/fixtures/yaml-test-suite/3R3P/out.yaml view
@@ -0,0 +1,2 @@+&sequence+- a
+ tests/fixtures/yaml-test-suite/3R3P/test.event view
@@ -0,0 +1,7 @@++STR++DOC++SEQ &sequence+=VAL :a+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/00/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/00/emit.yaml view
@@ -0,0 +1,1 @@+"1 leading \ttab"
+ tests/fixtures/yaml-test-suite/3RLN/00/in.json view
@@ -0,0 +1,1 @@+"1 leading \ttab"
+ tests/fixtures/yaml-test-suite/3RLN/00/in.yaml view
@@ -0,0 +1,2 @@+"1 leading+    \ttab"
+ tests/fixtures/yaml-test-suite/3RLN/00/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "1 leading \ttab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/01/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/01/emit.yaml view
@@ -0,0 +1,1 @@+"2 leading \ttab"
+ tests/fixtures/yaml-test-suite/3RLN/01/in.json view
@@ -0,0 +1,1 @@+"2 leading \ttab"
+ tests/fixtures/yaml-test-suite/3RLN/01/in.yaml view
@@ -0,0 +1,2 @@+"2 leading+    \	tab"
+ tests/fixtures/yaml-test-suite/3RLN/01/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "2 leading \ttab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/02/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/02/emit.yaml view
@@ -0,0 +1,1 @@+"3 leading tab"
+ tests/fixtures/yaml-test-suite/3RLN/02/in.json view
@@ -0,0 +1,1 @@+"3 leading tab"
+ tests/fixtures/yaml-test-suite/3RLN/02/in.yaml view
@@ -0,0 +1,2 @@+"3 leading+    	tab"
+ tests/fixtures/yaml-test-suite/3RLN/02/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "3 leading tab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/03/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/03/emit.yaml view
@@ -0,0 +1,1 @@+"4 leading \t  tab"
+ tests/fixtures/yaml-test-suite/3RLN/03/in.json view
@@ -0,0 +1,1 @@+"4 leading \t  tab"
+ tests/fixtures/yaml-test-suite/3RLN/03/in.yaml view
@@ -0,0 +1,2 @@+"4 leading+    \t  tab"
+ tests/fixtures/yaml-test-suite/3RLN/03/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "4 leading \t  tab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/04/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/04/emit.yaml view
@@ -0,0 +1,1 @@+"5 leading \t  tab"
+ tests/fixtures/yaml-test-suite/3RLN/04/in.json view
@@ -0,0 +1,1 @@+"5 leading \t  tab"
+ tests/fixtures/yaml-test-suite/3RLN/04/in.yaml view
@@ -0,0 +1,2 @@+"5 leading+    \	  tab"
+ tests/fixtures/yaml-test-suite/3RLN/04/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "5 leading \t  tab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3RLN/05/=== view
@@ -0,0 +1,1 @@+Leading tabs in double quoted
+ tests/fixtures/yaml-test-suite/3RLN/05/emit.yaml view
@@ -0,0 +1,1 @@+"6 leading tab"
+ tests/fixtures/yaml-test-suite/3RLN/05/in.json view
@@ -0,0 +1,1 @@+"6 leading tab"
+ tests/fixtures/yaml-test-suite/3RLN/05/in.yaml view
@@ -0,0 +1,2 @@+"6 leading+    	  tab"
+ tests/fixtures/yaml-test-suite/3RLN/05/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "6 leading tab+-DOC+-STR
+ tests/fixtures/yaml-test-suite/3UYS/=== view
@@ -0,0 +1,1 @@+Escaped slash in double quotes
+ tests/fixtures/yaml-test-suite/3UYS/in.json view
@@ -0,0 +1,3 @@+{+  "escaped slash": "a/b"+}
+ tests/fixtures/yaml-test-suite/3UYS/in.yaml view
@@ -0,0 +1,1 @@+escaped slash: "a\/b"
+ tests/fixtures/yaml-test-suite/3UYS/out.yaml view
@@ -0,0 +1,1 @@+escaped slash: "a/b"
+ tests/fixtures/yaml-test-suite/3UYS/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP+=VAL :escaped slash+=VAL "a/b+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4ABK/=== view
@@ -0,0 +1,1 @@+Flow Mapping Separate Values
+ tests/fixtures/yaml-test-suite/4ABK/in.yaml view
@@ -0,0 +1,5 @@+{+unquoted : "separate",+http://foo.com,+omitted value:,+}
+ tests/fixtures/yaml-test-suite/4ABK/out.yaml view
@@ -0,0 +1,3 @@+unquoted: "separate"+http://foo.com: null+omitted value: null
+ tests/fixtures/yaml-test-suite/4ABK/test.event view
@@ -0,0 +1,12 @@++STR++DOC++MAP {}+=VAL :unquoted+=VAL "separate+=VAL :http://foo.com+=VAL :+=VAL :omitted value+=VAL :+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4CQQ/=== view
@@ -0,0 +1,1 @@+Spec Example 2.18. Multi-line Flow Scalars
+ tests/fixtures/yaml-test-suite/4CQQ/in.json view
@@ -0,0 +1,4 @@+{+  "plain": "This unquoted scalar spans many lines.",+  "quoted": "So does this quoted scalar.\n"+}
+ tests/fixtures/yaml-test-suite/4CQQ/in.yaml view
@@ -0,0 +1,6 @@+plain:+  This unquoted scalar+  spans many lines.++quoted: "So does this+  quoted scalar.\n"
+ tests/fixtures/yaml-test-suite/4CQQ/out.yaml view
@@ -0,0 +1,2 @@+plain: This unquoted scalar spans many lines.+quoted: "So does this quoted scalar.\n"
+ tests/fixtures/yaml-test-suite/4CQQ/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP+=VAL :plain+=VAL :This unquoted scalar spans many lines.+=VAL :quoted+=VAL "So does this quoted scalar.\n+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4EJS/=== view
@@ -0,0 +1,1 @@+Invalid tabs as indendation in a mapping
+ tests/fixtures/yaml-test-suite/4EJS/error view
+ tests/fixtures/yaml-test-suite/4EJS/in.yaml view
@@ -0,0 +1,4 @@+---+a:+	b:+		c: value
+ tests/fixtures/yaml-test-suite/4EJS/test.event view
@@ -0,0 +1,4 @@++STR++DOC ---++MAP+=VAL :a
+ tests/fixtures/yaml-test-suite/4FJ6/=== view
@@ -0,0 +1,1 @@+Nested implicit complex keys
+ tests/fixtures/yaml-test-suite/4FJ6/in.yaml view
@@ -0,0 +1,4 @@+---+[+  [ a, [ [[b,c]]: d, e]]: 23+]
+ tests/fixtures/yaml-test-suite/4FJ6/out.yaml view
@@ -0,0 +1,7 @@+---+- ? - a+    - - ? - - b+            - c+        : d+      - e+  : 23
+ tests/fixtures/yaml-test-suite/4FJ6/test.event view
@@ -0,0 +1,24 @@++STR++DOC ---++SEQ []++MAP {}++SEQ []+=VAL :a++SEQ []++MAP {}++SEQ []++SEQ []+=VAL :b+=VAL :c+-SEQ+-SEQ+=VAL :d+-MAP+=VAL :e+-SEQ+-SEQ+=VAL :23+-MAP+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4GC6/=== view
@@ -0,0 +1,1 @@+Spec Example 7.7. Single Quoted Characters
+ tests/fixtures/yaml-test-suite/4GC6/in.json view
@@ -0,0 +1,1 @@+"here's to \"quotes\""
+ tests/fixtures/yaml-test-suite/4GC6/in.yaml view
@@ -0,0 +1,1 @@+'here''s to "quotes"'
+ tests/fixtures/yaml-test-suite/4GC6/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL 'here's to "quotes"+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4H7K/=== view
@@ -0,0 +1,1 @@+Flow sequence with invalid extra closing bracket
+ tests/fixtures/yaml-test-suite/4H7K/error view
+ tests/fixtures/yaml-test-suite/4H7K/in.yaml view
@@ -0,0 +1,2 @@+---+[ a, b, c ] ]
+ tests/fixtures/yaml-test-suite/4H7K/test.event view
@@ -0,0 +1,8 @@++STR++DOC ---++SEQ+=VAL :a+=VAL :b+=VAL :c+-SEQ+-DOC
+ tests/fixtures/yaml-test-suite/4HVU/=== view
@@ -0,0 +1,1 @@+Wrong indendation in Sequence
+ tests/fixtures/yaml-test-suite/4HVU/error view
+ tests/fixtures/yaml-test-suite/4HVU/in.yaml view
@@ -0,0 +1,4 @@+key:+   - ok+   - also ok+  - wrong
+ tests/fixtures/yaml-test-suite/4HVU/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP+=VAL :key++SEQ+=VAL :ok+=VAL :also ok+-SEQ
+ tests/fixtures/yaml-test-suite/4JVG/=== view
@@ -0,0 +1,1 @@+Scalar value with two anchors
+ tests/fixtures/yaml-test-suite/4JVG/error view
+ tests/fixtures/yaml-test-suite/4JVG/in.yaml view
@@ -0,0 +1,4 @@+top1: &node1+  &k1 key1: val1+top2: &node2+  &v2 val2
+ tests/fixtures/yaml-test-suite/4JVG/test.event view
@@ -0,0 +1,9 @@++STR++DOC++MAP+=VAL :top1++MAP &node1+=VAL &k1 :key1+=VAL :val1+-MAP+=VAL :top2
+ tests/fixtures/yaml-test-suite/4MUZ/00/=== view
@@ -0,0 +1,1 @@+Flow mapping colon on line after key
+ tests/fixtures/yaml-test-suite/4MUZ/00/emit.yaml view
@@ -0,0 +1,1 @@+"foo": "bar"
+ tests/fixtures/yaml-test-suite/4MUZ/00/in.json view
@@ -0,0 +1,3 @@+{+  "foo": "bar"+}
+ tests/fixtures/yaml-test-suite/4MUZ/00/in.yaml view
@@ -0,0 +1,2 @@+{"foo"+: "bar"}
+ tests/fixtures/yaml-test-suite/4MUZ/00/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP {}+=VAL "foo+=VAL "bar+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4MUZ/01/=== view
@@ -0,0 +1,1 @@+Flow mapping colon on line after key
+ tests/fixtures/yaml-test-suite/4MUZ/01/emit.yaml view
@@ -0,0 +1,1 @@+"foo": bar
+ tests/fixtures/yaml-test-suite/4MUZ/01/in.json view
@@ -0,0 +1,3 @@+{+  "foo": "bar"+}
+ tests/fixtures/yaml-test-suite/4MUZ/01/in.yaml view
@@ -0,0 +1,2 @@+{"foo"+: bar}
+ tests/fixtures/yaml-test-suite/4MUZ/01/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP {}+=VAL "foo+=VAL :bar+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4MUZ/02/=== view
@@ -0,0 +1,1 @@+Flow mapping colon on line after key
+ tests/fixtures/yaml-test-suite/4MUZ/02/emit.yaml view
@@ -0,0 +1,1 @@+foo: bar
+ tests/fixtures/yaml-test-suite/4MUZ/02/in.json view
@@ -0,0 +1,3 @@+{+  "foo": "bar"+}
+ tests/fixtures/yaml-test-suite/4MUZ/02/in.yaml view
@@ -0,0 +1,2 @@+{foo+: bar}
+ tests/fixtures/yaml-test-suite/4MUZ/02/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP {}+=VAL :foo+=VAL :bar+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4Q9F/=== view
@@ -0,0 +1,1 @@+Folded Block Scalar [1.3]
+ tests/fixtures/yaml-test-suite/4Q9F/in.json view
@@ -0,0 +1,1 @@+"ab cd\nef\n\ngh\n"
+ tests/fixtures/yaml-test-suite/4Q9F/in.yaml view
@@ -0,0 +1,8 @@+--- >+ ab+ cd+ + ef+++ gh
+ tests/fixtures/yaml-test-suite/4Q9F/out.yaml view
@@ -0,0 +1,7 @@+--- >+  ab cd++  ef+++  gh
+ tests/fixtures/yaml-test-suite/4Q9F/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL >ab cd\nef\n\ngh\n+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4QFQ/=== view
@@ -0,0 +1,1 @@+Spec Example 8.2. Block Indentation Indicator [1.3]
+ tests/fixtures/yaml-test-suite/4QFQ/emit.yaml view
@@ -0,0 +1,10 @@+- |+  detected+- >2+++  # detected+- |2+   explicit+- >+  detected
+ tests/fixtures/yaml-test-suite/4QFQ/in.json view
@@ -0,0 +1,6 @@+[+  "detected\n",+  "\n\n# detected\n",+  " explicit\n",+  "detected\n"+]
+ tests/fixtures/yaml-test-suite/4QFQ/in.yaml view
@@ -0,0 +1,10 @@+- |+ detected+- >+ +  +  # detected+- |1+  explicit+- >+ detected
+ tests/fixtures/yaml-test-suite/4QFQ/test.event view
@@ -0,0 +1,10 @@++STR++DOC++SEQ+=VAL |detected\n+=VAL >\n\n# detected\n+=VAL | explicit\n+=VAL >detected\n+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4RWC/=== view
@@ -0,0 +1,1 @@+Trailing spaces after flow collection
+ tests/fixtures/yaml-test-suite/4RWC/in.json view
@@ -0,0 +1,5 @@+[+  1,+  2,+  3+]
+ tests/fixtures/yaml-test-suite/4RWC/in.yaml view
@@ -0,0 +1,2 @@+  [1, 2, 3]  +  
+ tests/fixtures/yaml-test-suite/4RWC/out.yaml view
@@ -0,0 +1,3 @@+- 1+- 2+- 3
+ tests/fixtures/yaml-test-suite/4RWC/test.event view
@@ -0,0 +1,9 @@++STR++DOC++SEQ []+=VAL :1+=VAL :2+=VAL :3+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4UYU/=== view
@@ -0,0 +1,1 @@+Colon in Double Quoted String
+ tests/fixtures/yaml-test-suite/4UYU/in.json view
@@ -0,0 +1,1 @@+"foo: bar\": baz"
+ tests/fixtures/yaml-test-suite/4UYU/in.yaml view
@@ -0,0 +1,1 @@+"foo: bar\": baz"
+ tests/fixtures/yaml-test-suite/4UYU/test.event view
@@ -0,0 +1,5 @@++STR++DOC+=VAL "foo: bar": baz+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4V8U/=== view
@@ -0,0 +1,1 @@+Plain scalar with backslashes
+ tests/fixtures/yaml-test-suite/4V8U/in.json view
@@ -0,0 +1,1 @@+"plain\\value\\with\\backslashes"
+ tests/fixtures/yaml-test-suite/4V8U/in.yaml view
@@ -0,0 +1,2 @@+---+plain\value\with\backslashes
+ tests/fixtures/yaml-test-suite/4V8U/out.yaml view
@@ -0,0 +1,1 @@+--- plain\value\with\backslashes
+ tests/fixtures/yaml-test-suite/4V8U/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL :plain\\value\\with\\backslashes+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4WA9/=== view
@@ -0,0 +1,1 @@+Literal scalars
+ tests/fixtures/yaml-test-suite/4WA9/emit.yaml view
@@ -0,0 +1,4 @@+- aaa: |+    xxx+  bbb: |+    xxx
+ tests/fixtures/yaml-test-suite/4WA9/in.json view
@@ -0,0 +1,6 @@+[+  {+    "aaa" : "xxx\n",+    "bbb" : "xxx\n"+  }+]
+ tests/fixtures/yaml-test-suite/4WA9/in.yaml view
@@ -0,0 +1,4 @@+- aaa: |2+    xxx+  bbb: |+    xxx
+ tests/fixtures/yaml-test-suite/4WA9/out.yaml view
@@ -0,0 +1,5 @@+---+- aaa: |+    xxx+  bbb: |+    xxx
+ tests/fixtures/yaml-test-suite/4WA9/test.event view
@@ -0,0 +1,12 @@++STR++DOC++SEQ++MAP+=VAL :aaa+=VAL |xxx\n+=VAL :bbb+=VAL |xxx\n+-MAP+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/4ZYM/=== view
@@ -0,0 +1,1 @@+Spec Example 6.4. Line Prefixes
+ tests/fixtures/yaml-test-suite/4ZYM/emit.yaml view
@@ -0,0 +1,5 @@+plain: text lines+quoted: "text lines"+block: |+  text+   	lines
+ tests/fixtures/yaml-test-suite/4ZYM/in.json view
@@ -0,0 +1,5 @@+{+  "plain": "text lines",+  "quoted": "text lines",+  "block": "text\n \tlines\n"+}
+ tests/fixtures/yaml-test-suite/4ZYM/in.yaml view
@@ -0,0 +1,7 @@+plain: text+  lines+quoted: "text+  	lines"+block: |+  text+   	lines
+ tests/fixtures/yaml-test-suite/4ZYM/out.yaml view
@@ -0,0 +1,3 @@+plain: text lines+quoted: "text lines"+block: "text\n \tlines\n"
+ tests/fixtures/yaml-test-suite/4ZYM/test.event view
@@ -0,0 +1,12 @@++STR++DOC++MAP+=VAL :plain+=VAL :text lines+=VAL :quoted+=VAL "text lines+=VAL :block+=VAL |text\n \tlines\n+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/52DL/=== view
@@ -0,0 +1,1 @@+Explicit Non-Specific Tag [1.3]
+ tests/fixtures/yaml-test-suite/52DL/in.json view
@@ -0,0 +1,1 @@+"a"
+ tests/fixtures/yaml-test-suite/52DL/in.yaml view
@@ -0,0 +1,2 @@+---+! a
+ tests/fixtures/yaml-test-suite/52DL/out.yaml view
@@ -0,0 +1,1 @@+--- ! a
+ tests/fixtures/yaml-test-suite/52DL/test.event view
@@ -0,0 +1,5 @@++STR++DOC ---+=VAL <!> :a+-DOC+-STR
+ tests/fixtures/yaml-test-suite/54T7/=== view
@@ -0,0 +1,1 @@+Flow Mapping
+ tests/fixtures/yaml-test-suite/54T7/in.json view
@@ -0,0 +1,4 @@+{+  "foo": "you",+  "bar": "far"+}
+ tests/fixtures/yaml-test-suite/54T7/in.yaml view
@@ -0,0 +1,1 @@+{foo: you, bar: far}
+ tests/fixtures/yaml-test-suite/54T7/out.yaml view
@@ -0,0 +1,2 @@+foo: you+bar: far
+ tests/fixtures/yaml-test-suite/54T7/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP {}+=VAL :foo+=VAL :you+=VAL :bar+=VAL :far+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/55WF/=== view
@@ -0,0 +1,1 @@+Invalid escape in double quoted string
+ tests/fixtures/yaml-test-suite/55WF/error view
+ tests/fixtures/yaml-test-suite/55WF/in.yaml view
@@ -0,0 +1,2 @@+---+"\."
+ tests/fixtures/yaml-test-suite/55WF/test.event view
@@ -0,0 +1,2 @@++STR++DOC ---
+ tests/fixtures/yaml-test-suite/565N/=== view
@@ -0,0 +1,1 @@+Construct Binary
+ tests/fixtures/yaml-test-suite/565N/in.json view
@@ -0,0 +1,5 @@+{+  "canonical": "R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLCAgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=",+  "generic": "R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5\nOTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+\n+f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC\nAgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=\n",+  "description": "The binary value above is a tiny arrow encoded as a gif image."+}
+ tests/fixtures/yaml-test-suite/565N/in.yaml view
@@ -0,0 +1,12 @@+canonical: !!binary "\+ R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5\+ OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+\+ +f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC\+ AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs="+generic: !!binary |+ R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5+ OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/++ +f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC+ AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=+description:+ The binary value above is a tiny arrow encoded as a gif image.
+ tests/fixtures/yaml-test-suite/565N/test.event view
@@ -0,0 +1,12 @@++STR++DOC++MAP+=VAL :canonical+=VAL <tag:yaml.org,2002:binary> "R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLCAgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=+=VAL :generic+=VAL <tag:yaml.org,2002:binary> |R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5\nOTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+\n+f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC\nAgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=\n+=VAL :description+=VAL :The binary value above is a tiny arrow encoded as a gif image.+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/57H4/=== view
@@ -0,0 +1,1 @@+Spec Example 8.22. Block Collection Nodes
+ tests/fixtures/yaml-test-suite/57H4/in.json view
@@ -0,0 +1,11 @@+{+  "sequence": [+    "entry",+    [+      "nested"+    ]+  ],+  "mapping": {+    "foo": "bar"+  }+}
+ tests/fixtures/yaml-test-suite/57H4/in.yaml view
@@ -0,0 +1,6 @@+sequence: !!seq+- entry+- !!seq+ - nested+mapping: !!map+ foo: bar
+ tests/fixtures/yaml-test-suite/57H4/out.yaml view
@@ -0,0 +1,6 @@+sequence: !!seq+- entry+- !!seq+  - nested+mapping: !!map+  foo: bar
+ tests/fixtures/yaml-test-suite/57H4/test.event view
@@ -0,0 +1,18 @@++STR++DOC++MAP+=VAL :sequence++SEQ <tag:yaml.org,2002:seq>+=VAL :entry++SEQ <tag:yaml.org,2002:seq>+=VAL :nested+-SEQ+-SEQ+=VAL :mapping++MAP <tag:yaml.org,2002:map>+=VAL :foo+=VAL :bar+-MAP+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/58MP/=== view
@@ -0,0 +1,1 @@+Flow mapping edge cases
+ tests/fixtures/yaml-test-suite/58MP/in.json view
@@ -0,0 +1,3 @@+{+  "x": ":x"+}
+ tests/fixtures/yaml-test-suite/58MP/in.yaml view
@@ -0,0 +1,1 @@+{x: :x}
+ tests/fixtures/yaml-test-suite/58MP/out.yaml view
@@ -0,0 +1,1 @@+x: :x
+ tests/fixtures/yaml-test-suite/58MP/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP {}+=VAL :x+=VAL ::x+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5BVJ/=== view
@@ -0,0 +1,1 @@+Spec Example 5.7. Block Scalar Indicators
+ tests/fixtures/yaml-test-suite/5BVJ/in.json view
@@ -0,0 +1,4 @@+{+  "literal": "some\ntext\n",+  "folded": "some text\n"+}
+ tests/fixtures/yaml-test-suite/5BVJ/in.yaml view
@@ -0,0 +1,6 @@+literal: |+  some+  text+folded: >+  some+  text
+ tests/fixtures/yaml-test-suite/5BVJ/out.yaml view
@@ -0,0 +1,5 @@+literal: |+  some+  text+folded: >+  some text
+ tests/fixtures/yaml-test-suite/5BVJ/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP+=VAL :literal+=VAL |some\ntext\n+=VAL :folded+=VAL >some text\n+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5C5M/=== view
@@ -0,0 +1,1 @@+Spec Example 7.15. Flow Mappings
+ tests/fixtures/yaml-test-suite/5C5M/in.json view
@@ -0,0 +1,10 @@+[+  {+    "one": "two",+    "three": "four"+  },+  {+    "five": "six",+    "seven": "eight"+  }+]
+ tests/fixtures/yaml-test-suite/5C5M/in.yaml view
@@ -0,0 +1,2 @@+- { one : two , three: four , }+- {five: six,seven : eight}
+ tests/fixtures/yaml-test-suite/5C5M/out.yaml view
@@ -0,0 +1,4 @@+- one: two+  three: four+- five: six+  seven: eight
+ tests/fixtures/yaml-test-suite/5C5M/test.event view
@@ -0,0 +1,18 @@++STR++DOC++SEQ++MAP {}+=VAL :one+=VAL :two+=VAL :three+=VAL :four+-MAP++MAP {}+=VAL :five+=VAL :six+=VAL :seven+=VAL :eight+-MAP+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5GBF/=== view
@@ -0,0 +1,1 @@+Spec Example 6.5. Empty Lines
+ tests/fixtures/yaml-test-suite/5GBF/in.json view
@@ -0,0 +1,4 @@+{+  "Folding": "Empty line\nas a line feed",+  "Chomping": "Clipped empty lines\n"+}
+ tests/fixtures/yaml-test-suite/5GBF/in.yaml view
@@ -0,0 +1,8 @@+Folding:+  "Empty line+   	+  as a line feed"+Chomping: |+  Clipped empty lines+ +
+ tests/fixtures/yaml-test-suite/5GBF/out.yaml view
@@ -0,0 +1,3 @@+Folding: "Empty line\nas a line feed"+Chomping: |+  Clipped empty lines
+ tests/fixtures/yaml-test-suite/5GBF/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP+=VAL :Folding+=VAL "Empty line\nas a line feed+=VAL :Chomping+=VAL |Clipped empty lines\n+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5KJE/=== view
@@ -0,0 +1,1 @@+Spec Example 7.13. Flow Sequence
+ tests/fixtures/yaml-test-suite/5KJE/in.json view
@@ -0,0 +1,10 @@+[+  [+    "one",+    "two"+  ],+  [+    "three",+    "four"+  ]+]
+ tests/fixtures/yaml-test-suite/5KJE/in.yaml view
@@ -0,0 +1,2 @@+- [ one, two, ]+- [three ,four]
+ tests/fixtures/yaml-test-suite/5KJE/out.yaml view
@@ -0,0 +1,4 @@+- - one+  - two+- - three+  - four
+ tests/fixtures/yaml-test-suite/5KJE/test.event view
@@ -0,0 +1,14 @@++STR++DOC++SEQ++SEQ []+=VAL :one+=VAL :two+-SEQ++SEQ []+=VAL :three+=VAL :four+-SEQ+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5LLU/=== view
@@ -0,0 +1,1 @@+Block scalar with wrong indented line after spaces only
+ tests/fixtures/yaml-test-suite/5LLU/error view
+ tests/fixtures/yaml-test-suite/5LLU/in.yaml view
@@ -0,0 +1,5 @@+block scalar: >+ +  +   + invalid
+ tests/fixtures/yaml-test-suite/5LLU/test.event view
@@ -0,0 +1,4 @@++STR++DOC++MAP+=VAL :block scalar
+ tests/fixtures/yaml-test-suite/5MUD/=== view
@@ -0,0 +1,1 @@+Colon and adjacent value on next line
+ tests/fixtures/yaml-test-suite/5MUD/in.json view
@@ -0,0 +1,3 @@+{+  "foo": "bar"+}
+ tests/fixtures/yaml-test-suite/5MUD/in.yaml view
@@ -0,0 +1,3 @@+---+{ "foo"+  :bar }
+ tests/fixtures/yaml-test-suite/5MUD/out.yaml view
@@ -0,0 +1,2 @@+---+"foo": bar
+ tests/fixtures/yaml-test-suite/5MUD/test.event view
@@ -0,0 +1,8 @@++STR++DOC ---++MAP {}+=VAL "foo+=VAL :bar+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5NYZ/=== view
@@ -0,0 +1,1 @@+Spec Example 6.9. Separated Comment
+ tests/fixtures/yaml-test-suite/5NYZ/in.json view
@@ -0,0 +1,3 @@+{+  "key": "value"+}
+ tests/fixtures/yaml-test-suite/5NYZ/in.yaml view
@@ -0,0 +1,2 @@+key:    # Comment+  value
+ tests/fixtures/yaml-test-suite/5NYZ/out.yaml view
@@ -0,0 +1,1 @@+key: value
+ tests/fixtures/yaml-test-suite/5NYZ/test.event view
@@ -0,0 +1,8 @@++STR++DOC++MAP+=VAL :key+=VAL :value+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5T43/=== view
@@ -0,0 +1,1 @@+Colon at the beginning of adjacent flow scalar
+ tests/fixtures/yaml-test-suite/5T43/emit.yaml view
@@ -0,0 +1,2 @@+- "key": value+- "key": :value
+ tests/fixtures/yaml-test-suite/5T43/in.json view
@@ -0,0 +1,8 @@+[+  {+    "key": "value"+  },+  {+    "key": ":value"+  }+]
+ tests/fixtures/yaml-test-suite/5T43/in.yaml view
@@ -0,0 +1,2 @@+- { "key":value }+- { "key"::value }
+ tests/fixtures/yaml-test-suite/5T43/out.yaml view
@@ -0,0 +1,2 @@+- key: value+- key: :value
+ tests/fixtures/yaml-test-suite/5T43/test.event view
@@ -0,0 +1,14 @@++STR++DOC++SEQ++MAP {}+=VAL "key+=VAL :value+-MAP++MAP {}+=VAL "key+=VAL ::value+-MAP+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5TRB/=== view
@@ -0,0 +1,1 @@+Invalid document-start marker in doublequoted tring
+ tests/fixtures/yaml-test-suite/5TRB/error view
+ tests/fixtures/yaml-test-suite/5TRB/in.yaml view
@@ -0,0 +1,4 @@+---+"+---+"
+ tests/fixtures/yaml-test-suite/5TRB/test.event view
@@ -0,0 +1,2 @@++STR++DOC ---
+ tests/fixtures/yaml-test-suite/5TYM/=== view
@@ -0,0 +1,1 @@+Spec Example 6.21. Local Tag Prefix
+ tests/fixtures/yaml-test-suite/5TYM/in.json view
@@ -0,0 +1,2 @@+"fluorescent"+"green"
+ tests/fixtures/yaml-test-suite/5TYM/in.yaml view
@@ -0,0 +1,7 @@+%TAG !m! !my-+--- # Bulb here+!m!light fluorescent+...+%TAG !m! !my-+--- # Color here+!m!light green
+ tests/fixtures/yaml-test-suite/5TYM/test.event view
@@ -0,0 +1,8 @@++STR++DOC ---+=VAL <!my-light> :fluorescent+-DOC ...++DOC ---+=VAL <!my-light> :green+-DOC+-STR
+ tests/fixtures/yaml-test-suite/5U3A/=== view
@@ -0,0 +1,1 @@+Sequence on same Line as Mapping Key
+ tests/fixtures/yaml-test-suite/5U3A/error view
+ tests/fixtures/yaml-test-suite/5U3A/in.yaml view
@@ -0,0 +1,2 @@+key: - a+     - b
+ tests/fixtures/yaml-test-suite/5U3A/test.event view
@@ -0,0 +1,4 @@++STR++DOC++MAP+=VAL :key
+ tests/fixtures/yaml-test-suite/5WE3/=== view
@@ -0,0 +1,1 @@+Spec Example 8.17. Explicit Block Mapping Entries
+ tests/fixtures/yaml-test-suite/5WE3/in.json view
@@ -0,0 +1,7 @@+{+  "explicit key": null,+  "block key\n": [+    "one",+    "two"+  ]+}
+ tests/fixtures/yaml-test-suite/5WE3/in.yaml view
@@ -0,0 +1,5 @@+? explicit key # Empty value+? |+  block key+: - one # Explicit compact+  - two # block value
+ tests/fixtures/yaml-test-suite/5WE3/out.yaml view
@@ -0,0 +1,5 @@+explicit key:+? |+  block key+: - one+  - two
+ tests/fixtures/yaml-test-suite/5WE3/test.event view
@@ -0,0 +1,13 @@++STR++DOC++MAP+=VAL :explicit key+=VAL :+=VAL |block key\n++SEQ+=VAL :one+=VAL :two+-SEQ+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/62EZ/=== view
@@ -0,0 +1,1 @@+Invalid block mapping key on same line as previous key
+ tests/fixtures/yaml-test-suite/62EZ/error view
+ tests/fixtures/yaml-test-suite/62EZ/in.yaml view
@@ -0,0 +1,2 @@+---+x: { y: z }in: valid
+ tests/fixtures/yaml-test-suite/62EZ/test.event view
@@ -0,0 +1,8 @@++STR++DOC ---++MAP+=VAL :x++MAP {}+=VAL :y+=VAL :z+-MAP
+ tests/fixtures/yaml-test-suite/652Z/=== view
@@ -0,0 +1,1 @@+Question mark at start of flow key
+ tests/fixtures/yaml-test-suite/652Z/emit.yaml view
@@ -0,0 +1,2 @@+?foo: bar+bar: 42
+ tests/fixtures/yaml-test-suite/652Z/in.json view
@@ -0,0 +1,4 @@+{+  "?foo" : "bar",+  "bar" : 42+}
+ tests/fixtures/yaml-test-suite/652Z/in.yaml view
@@ -0,0 +1,3 @@+{ ?foo: bar,+bar: 42+}
+ tests/fixtures/yaml-test-suite/652Z/out.yaml view
@@ -0,0 +1,3 @@+---+?foo: bar+bar: 42
+ tests/fixtures/yaml-test-suite/652Z/test.event view
@@ -0,0 +1,10 @@++STR++DOC++MAP {}+=VAL :?foo+=VAL :bar+=VAL :bar+=VAL :42+-MAP+-DOC+-STR
+ tests/fixtures/yaml-test-suite/65WH/=== view
@@ -0,0 +1,1 @@+Single Entry Block Sequence
+ tests/fixtures/yaml-test-suite/65WH/in.json view
@@ -0,0 +1,3 @@+[+  "foo"+]
+ tests/fixtures/yaml-test-suite/65WH/in.yaml view
@@ -0,0 +1,1 @@+- foo
+ tests/fixtures/yaml-test-suite/65WH/test.event view
@@ -0,0 +1,7 @@++STR++DOC++SEQ+=VAL :foo+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/6BCT/=== view
@@ -0,0 +1,1 @@+Spec Example 6.3. Separation Spaces
+ tests/fixtures/yaml-test-suite/6BCT/in.json view
@@ -0,0 +1,9 @@+[+  {+    "foo": "bar"+  },+  [+    "baz",+    "baz"+  ]+]
+ tests/fixtures/yaml-test-suite/6BCT/in.yaml view
@@ -0,0 +1,3 @@+- foo:	 bar+- - baz+  -	baz
+ tests/fixtures/yaml-test-suite/6BCT/out.yaml view
@@ -0,0 +1,3 @@+- foo: bar+- - baz+  - baz
+ tests/fixtures/yaml-test-suite/6BCT/test.event view
@@ -0,0 +1,14 @@++STR++DOC++SEQ++MAP+=VAL :foo+=VAL :bar+-MAP++SEQ+=VAL :baz+=VAL :baz+-SEQ+-SEQ+-DOC+-STR
+ tests/fixtures/yaml-test-suite/6BFJ/=== view
@@ -0,0 +1,1 @@+Mapping, key and flow sequence item anchors
+ tests/fixtures/yaml-test-suite/6BFJ/in.yaml view
@@ -0,0 +1,3 @@+---+&mapping+&key [ &item a, b, c ]: value
+ tests/fixtures/yaml-test-suite/6BFJ/out.yaml view
@@ -0,0 +1,6 @@+--- &mapping+? &key+- &item a+- b+- c+: value
+ tests/fixtures/yaml-test-suite/6BFJ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CA3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CA3/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CA3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CA3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CA3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CK3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CK3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CK3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6CK3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6FWR/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6H3V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6H3V/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6H3V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6H3V/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6H3V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6HB6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6HB6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6HB6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6HB6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6HB6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JQW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JQW/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JQW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JQW/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JQW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JTT/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JTT/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JTT/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JTT/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JWB/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JWB/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JWB/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JWB/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6JWB/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6KGN/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6KGN/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6KGN/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6KGN/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6KGN/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6LVF/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6LVF/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6LVF/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6LVF/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6LVF/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6M2F/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6M2F/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6M2F/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6M2F/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6PBE/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6PBE/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6PBE/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6PBE/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6S55/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6S55/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/6S55/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6S55/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6SLA/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6SLA/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6SLA/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6SLA/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6SLA/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6VJK/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6VJK/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6VJK/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6VJK/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6VJK/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WLZ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6WPF/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6XDY/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6XDY/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6XDY/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6XDY/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6XDY/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/6ZKB/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/6ZKB/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6ZKB/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/6ZKB/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/6ZKB/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/735Y/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/735Y/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/735Y/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/735Y/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/735Y/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/74H7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/74H7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/74H7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/74H7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/74H7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/753E/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/753E/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/753E/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/753E/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/753E/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7A4E/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7A4E/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7A4E/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7A4E/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7A4E/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BMT/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BMT/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BMT/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BMT/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BMT/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BUB/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BUB/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BUB/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BUB/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7BUB/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7FWL/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7FWL/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7FWL/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7FWL/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7FWL/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7LBH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7LBH/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/7LBH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7LBH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7MNF/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7MNF/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/7MNF/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7MNF/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7T8X/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7T8X/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7T8X/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7T8X/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7T8X/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7TMG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7TMG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7TMG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7TMG/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7TMG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7W2P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7W2P/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7W2P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7W2P/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7W2P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7Z25/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7Z25/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7Z25/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7Z25/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7Z25/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/7ZZ5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/7ZZ5/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/7ZZ5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7ZZ5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/7ZZ5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/82AN/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/82AN/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/82AN/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/82AN/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/82AN/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/87E4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/87E4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/87E4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/87E4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/87E4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8CWC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8CWC/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8CWC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8CWC/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8CWC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8G76/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8G76/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8G76/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8G76/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8G76/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8KB6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8KB6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8KB6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8KB6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8KB6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8MK2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8MK2/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8MK2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8MK2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8QBE/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8QBE/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8QBE/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8QBE/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8QBE/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8UDB/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8UDB/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8UDB/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8UDB/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8UDB/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XDJ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XDJ/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XDJ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XDJ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XYN/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XYN/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XYN/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XYN/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/8XYN/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/93JH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/93JH/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/93JH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/93JH/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/93JH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/93WF/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/93WF/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/93WF/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/93WF/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/93WF/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/96L6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/96L6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/96L6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96L6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96L6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/96NN/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/98YD/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/98YD/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/98YD/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/98YD/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/98YD/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9BXH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9BXH/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9BXH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9BXH/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9BXH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9C9N/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9C9N/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9C9N/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9C9N/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9CWY/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9CWY/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9CWY/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9CWY/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9DXL/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9DXL/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9DXL/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9DXL/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9DXL/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9FMG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9FMG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9FMG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9FMG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9HCY/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9HCY/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9HCY/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9HCY/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9J7A/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9J7A/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9J7A/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9J7A/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9JBA/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9JBA/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9JBA/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9JBA/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KAX/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KAX/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KAX/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KAX/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KAX/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KBC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KBC/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KBC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9KBC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MAG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MAG/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MAG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MAG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMA/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMA/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMA/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMA/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMW/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MMW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/01/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9MQT/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SA2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SA2/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SA2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SA2/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SA2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SHH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SHH/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SHH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9SHH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9TFX/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9U5K/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9U5K/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9U5K/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9U5K/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9U5K/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9WXW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9WXW/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9WXW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9WXW/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9WXW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/9YRD/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/9YRD/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/9YRD/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9YRD/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/9YRD/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/A2M4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/A2M4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/A2M4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A2M4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A2M4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/A6F9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/A6F9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/A6F9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A6F9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A6F9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/A984/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/A984/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/A984/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A984/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/A984/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/AB8U/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/AB8U/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/AB8U/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/AB8U/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/AB8U/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/AVM7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/AVM7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/AVM7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/AVM7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZ63/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZ63/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZ63/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZ63/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZW3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZW3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZW3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/AZW3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/B3HG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/B63P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/B63P/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/B63P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/B63P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/BD7L/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/BD7L/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/BD7L/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BD7L/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/BEC7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/BEC7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/BEC7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BEC7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BEC7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/BF9H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/BF9H/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/BF9H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BF9H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/BS4K/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/BS4K/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/BS4K/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BS4K/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/BU8L/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/BU8L/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/BU8L/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BU8L/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/BU8L/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2DT/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2DT/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2DT/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2DT/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2DT/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2SP/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2SP/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2SP/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/C2SP/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/C4HZ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/C4HZ/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/C4HZ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/C4HZ/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/C4HZ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CC74/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CC74/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/CC74/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CC74/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CC74/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CFD4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CFD4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CFD4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CFD4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CML9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CML9/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/CML9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CML9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CN3R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CN3R/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/CN3R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CN3R/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CN3R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CPZ3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CPZ3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/CPZ3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CPZ3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CPZ3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CQ3W/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CQ3W/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/CQ3W/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CQ3W/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CT4Q/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CT4Q/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/CT4Q/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CT4Q/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CT4Q/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CTN5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CTN5/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/CTN5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CTN5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CUP7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CUP7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/CUP7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CUP7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CUP7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CVW2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CVW2/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/CVW2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CVW2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/CXX2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/CXX2/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/CXX2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/CXX2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/D49Q/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/D49Q/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/D49Q/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D49Q/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/D83L/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/D83L/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/D83L/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D83L/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D83L/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/D88J/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/D88J/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/D88J/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D88J/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D88J/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/D9TU/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/D9TU/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/D9TU/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/D9TU/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DBG4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DBG4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DBG4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DBG4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DBG4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DC7X/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DC7X/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DC7X/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DC7X/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DC7X/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/02/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/02/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/03/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/03/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/03/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/03/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/03/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/04/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/04/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/04/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/04/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/04/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/05/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/05/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/05/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/05/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DE56/05/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DFF7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DFF7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DFF7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DFF7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DHP8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DHP8/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DHP8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DHP8/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DHP8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK3J/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK3J/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK3J/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK3J/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK3J/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK4H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK4H/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK4H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK4H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/00/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/02/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/02/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/03/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/03/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/03/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/03/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/03/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/04/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/04/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/04/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/04/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/04/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/05/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/05/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/05/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/05/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/05/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/06/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/07/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/07/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/07/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/07/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/07/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/08/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/08/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/08/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/08/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DK95/08/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DMG6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DMG6/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/DMG6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DMG6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/DWX9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/E76Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/E76Z/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/E76Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/E76Z/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/E76Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/EB22/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/EB22/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/EB22/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EB22/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/EHF6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/EHF6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/EHF6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EHF6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EHF6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/EW3V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/EW3V/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/EW3V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EW3V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EX5H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/EXG3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/F2C7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/F2C7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/F2C7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F2C7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F2C7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/F3CP/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/F3CP/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/F3CP/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F3CP/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F3CP/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/F6MC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/F6MC/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F6MC/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/F6MC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F6MC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/F8F9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/F8F9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/F8F9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F8F9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/F8F9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FBC9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FBC9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/FBC9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FBC9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FBC9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FH7J/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FH7J/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FH7J/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FH7J/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FP8R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FP8R/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/FP8R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FP8R/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FP8R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FQ7F/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FQ7F/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/FQ7F/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FQ7F/lex.token view
file too large to diff
+ tests/fixtures/yaml-test-suite/FQ7F/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FRK4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FRK4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FRK4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FTA2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FTA2/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/FTA2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FTA2/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FTA2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/FUP4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/FUP4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/FUP4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FUP4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/FUP4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/G4RS/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/G4RS/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/G4RS/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G4RS/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G4RS/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/G5U8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/G5U8/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/G5U8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G5U8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/G7JE/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/G7JE/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/G7JE/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G7JE/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/G992/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/G992/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/G992/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G992/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G992/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/G9HC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/G9HC/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/G9HC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/G9HC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/GDY7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/GDY7/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/GDY7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/GDY7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/GH63/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/GH63/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/GH63/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/GH63/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/GH63/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/GT5M/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/GT5M/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/GT5M/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/GT5M/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H2RW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/H3Z8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/H3Z8/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/H3Z8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H3Z8/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H3Z8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7J7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7J7/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7J7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7J7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7TQ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7TQ/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7TQ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/H7TQ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HM87/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMK4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMK4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMK4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMK4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMK4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMQ5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMQ5/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMQ5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMQ5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HMQ5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HRE5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HRE5/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/HRE5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HRE5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HS5T/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HS5T/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HS5T/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HS5T/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HS5T/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HU3P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HU3P/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/HU3P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HU3P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/HWV9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/HWV9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/HWV9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HWV9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/HWV9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/J3BT/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/J3BT/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/J3BT/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J3BT/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J3BT/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/J5UC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/J5UC/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/J5UC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J5UC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7PZ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7PZ/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7PZ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7PZ/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7PZ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7VC/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7VC/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7VC/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7VC/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J7VC/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/J9HZ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/J9HZ/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/J9HZ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J9HZ/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/J9HZ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/02/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/02/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JEF9/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JHB9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JHB9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JHB9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JHB9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JHB9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JKF3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JKF3/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/JKF3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JKF3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JQ4R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JQ4R/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JQ4R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JQ4R/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JQ4R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JR7V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JR7V/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JR7V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JR7V/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JR7V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JS2J/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JS2J/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JS2J/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JS2J/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JTV5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JTV5/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/JTV5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JTV5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JTV5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/JY7Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/JY7Z/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/JY7Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/JY7Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/K3WX/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/K3WX/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/K3WX/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K3WX/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K3WX/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/K4SU/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/K4SU/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/K4SU/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K4SU/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/K527/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/K527/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/K527/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K527/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K527/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/K54U/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/K54U/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/K54U/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K54U/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K54U/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/K858/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/K858/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/K858/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K858/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/K858/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/02/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/02/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KH5V/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KK5P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KK5P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KK5P/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KK5P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KMK3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KMK3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/KMK3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KMK3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KS4U/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KS4U/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/KS4U/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KS4U/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/KSS4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/00/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/01/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L24T/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/L383/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/L383/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/L383/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L383/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L383/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/L94M/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/L94M/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/L94M/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L94M/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L94M/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/L9U5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/L9U5/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/L9U5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L9U5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/L9U5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/LE5A/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/LE5A/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/LE5A/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LE5A/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/LHL4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/LHL4/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/LHL4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LHL4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/LP6E/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/LP6E/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/LP6E/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LP6E/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LP6E/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/LQZ7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/LQZ7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/LQZ7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LQZ7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LQZ7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/LX3P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/LX3P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LX3P/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/LX3P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M29M/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M29M/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M29M/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M29M/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M29M/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M2N8/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5C3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5C3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5C3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5C3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5C3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5DY/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5DY/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5DY/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M5DY/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M6YH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M6YH/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M6YH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M6YH/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M6YH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7A3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7A3/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7A3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7A3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7A3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7NX/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7NX/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7NX/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7NX/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M7NX/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/M9B4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/M9B4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/M9B4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M9B4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/M9B4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MJS9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MJS9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MJS9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MJS9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MJS9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/00/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/01/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/02/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/02/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/03/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/03/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/03/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/03/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/03/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/04/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/04/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/04/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/04/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/04/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/05/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/05/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/05/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/05/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/05/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/06/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/06/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/06/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/06/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MUS6/06/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MXS3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MXS3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MXS3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MXS3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MXS3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MYW6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MYW6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MYW6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MYW6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MYW6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/MZX3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/MZX3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/MZX3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/MZX3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/N4JP/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/N4JP/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/N4JP/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/N4JP/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/N782/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/N782/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/N782/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/N782/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NAT4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NAT4/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NAT4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/NAT4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NAT4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NB6Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NB6Z/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/NB6Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NB6Z/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NB6Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NHX8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NHX8/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NHX8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NHX8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NJ66/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NJ66/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/NJ66/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NJ66/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NJ66/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NKF9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NKF9/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NKF9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NKF9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/NP9H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/NP9H/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/NP9H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NP9H/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/NP9H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2AD/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2AD/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2AD/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2AD/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2AD/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2EQ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2EQ/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2EQ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P2EQ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/P76L/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/P76L/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/P76L/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P76L/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P76L/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/P94K/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/P94K/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/P94K/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P94K/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/P94K/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/PBJ2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/PBJ2/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/PBJ2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PBJ2/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PBJ2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PRH3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/PUW8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/PUW8/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/PUW8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PUW8/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PUW8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/PW8X/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/PW8X/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PW8X/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/PW8X/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q4CL/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q4CL/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q4CL/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q4CL/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q5MG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q5MG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q5MG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q5MG/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q5MG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q88A/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q88A/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q88A/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q88A/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q88A/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q8AD/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q9WF/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q9WF/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q9WF/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Q9WF/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/QB6E/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/QB6E/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/QB6E/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QB6E/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/QF4Y/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/QF4Y/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/QF4Y/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QF4Y/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QF4Y/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/QLJ7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/QLJ7/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/QLJ7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QLJ7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/QT73/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/QT73/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/QT73/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QT73/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/QT73/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/R4YG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/R4YG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/R4YG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/R4YG/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/R4YG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/R52L/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/R52L/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/R52L/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/R52L/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/R52L/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RHX7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RHX7/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/RHX7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RHX7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RLU9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RLU9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/RLU9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RLU9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RLU9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RR7F/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RR7F/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/RR7F/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RR7F/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RR7F/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RTP8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RTP8/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/RTP8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RTP8/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RTP8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RXY3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RXY3/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/RXY3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RXY3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZP5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZP5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZP5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZP5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZT7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZT7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZT7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZT7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/RZT7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S3PD/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S3PD/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S3PD/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S3PD/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4GJ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4GJ/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4GJ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4GJ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4JQ/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4JQ/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4JQ/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4JQ/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4JQ/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4T7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4T7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4T7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S4T7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S7BG/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S7BG/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/S7BG/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S7BG/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S7BG/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S98Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S98Z/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/S98Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S98Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/S9E8/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/S9E8/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/S9E8/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S9E8/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/S9E8/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SBG9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SBG9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SBG9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SBG9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SF5V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SF5V/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/SF5V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SF5V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SKE5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SKE5/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/SKE5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SKE5/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SKE5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/00/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/00/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SM9W/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SR86/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SR86/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/SR86/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SR86/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SSW6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SSW6/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/SSW6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SSW6/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SSW6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU5Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU5Z/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU5Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU5Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU74/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU74/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU74/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SU74/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SY6V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SY6V/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/SY6V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SY6V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/SYW4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/SYW4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/SYW4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SYW4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/SYW4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T26H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T4YY/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T5N4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/T833/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/T833/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/T833/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/T833/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/TD5N/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/TD5N/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/TD5N/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TD5N/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/TE2A/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/TE2A/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/TE2A/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TE2A/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TE2A/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/TL85/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/TL85/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/TL85/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TL85/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TL85/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/TS54/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/TS54/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/TS54/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TS54/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/TS54/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3C3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3C3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3C3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3C3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3C3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3XV/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3XV/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3XV/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3XV/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U3XV/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/U44R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/U44R/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/U44R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U44R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/U99R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/U99R/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/U99R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U99R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/U9NS/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/U9NS/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/U9NS/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/U9NS/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDM2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDM2/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDM2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDM2/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDM2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDR7/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDR7/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDR7/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDR7/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UDR7/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UGM3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UGM3/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UGM3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UGM3/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UGM3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/02/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/02/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UKK6/02/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UT92/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UT92/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UT92/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UT92/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UT92/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/UV7Q/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/UV7Q/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/UV7Q/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UV7Q/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/UV7Q/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/V55R/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/V55R/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/V55R/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/V55R/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/V9D5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/V9D5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/V9D5/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/00/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/00/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/00/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/00/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/emit.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/VJP3/01/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/W42U/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/W42U/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/W42U/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W42U/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W42U/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/W4TN/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/W4TN/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/W4TN/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W4TN/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W4TN/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/W5VH/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/W5VH/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/W5VH/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W5VH/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/W9L4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/W9L4/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/W9L4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/W9L4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/WZ62/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/WZ62/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/WZ62/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/WZ62/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/WZ62/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/X38W/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/X38W/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/X38W/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/X38W/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/X4QW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/X4QW/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/X4QW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/X4QW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/X8DW/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/X8DW/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/X8DW/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/X8DW/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/X8DW/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/XLQ9/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/XLQ9/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/XLQ9/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XLQ9/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XLQ9/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/XV9V/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/XV9V/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/XV9V/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XV9V/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XV9V/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/XW4D/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/XW4D/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XW4D/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/XW4D/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y2GN/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y2GN/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y2GN/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y2GN/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y2GN/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/000/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/000/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/000/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/000/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/001/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/001/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/001/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/001/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/001/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/002/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/002/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/002/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/002/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/002/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/003/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/003/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/003/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/003/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/003/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/004/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/004/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/004/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/004/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/004/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/005/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/005/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/005/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/005/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/005/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/006/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/006/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/006/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/006/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/006/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/007/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/007/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/007/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/007/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/007/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/008/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/008/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/008/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/008/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/008/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/009/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/009/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/009/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/009/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/009/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/010/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/010/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/010/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/010/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Y79Y/010/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/YD5X/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/YD5X/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/YD5X/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/YD5X/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/YD5X/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/YJV2/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/YJV2/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/YJV2/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/YJV2/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z67P/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z67P/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z67P/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z67P/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z67P/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z9M4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z9M4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z9M4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z9M4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/Z9M4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZCZ6/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZCZ6/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZCZ6/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZCZ6/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZF4X/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZF4X/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZF4X/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZF4X/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZF4X/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZH7C/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZH7C/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZH7C/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZH7C/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZK9H/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZK9H/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZK9H/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZK9H/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZK9H/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZL4Z/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZL4Z/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZL4Z/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZL4Z/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZVH3/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZVH3/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZVH3/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZVH3/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZWK4/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZWK4/in.json view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZWK4/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZWK4/out.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZWK4/test.event view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZXT5/=== view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZXT5/error view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZXT5/in.yaml view
file too large to diff
+ tests/fixtures/yaml-test-suite/ZXT5/test.event view
file too large to diff
+ yamlet.cabal view
file too large to diff