yamlet-1.0.0.0: tests/Yamlet/Test/Render/Styles.hs
-- | 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")