yamlet-1.0.0.0: tests/Yamlet/Test/Encode/Values.hs
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")])