@@ -0,0 +1,899 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE PackageImports #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TupleSections #-}
7+
8+module Data.YamlSpec (main, spec) where
9+
10+import qualified Text.Libyaml as Y
11+import qualified Data.ByteString as BS
12+import qualified Data.ByteString.Char8 as B8
13+import Data.Int (Int64)
14+import qualified Data.Scientific as S
15+
16+import Test.HUnit hiding (Test, path)
17+
18+import Data.Conduit (runConduitRes, (.|), ConduitM)
19+import qualified Data.Conduit.List as CL
20+
21+import Control.Monad
22+import Control.Exception (try, SomeException)
23+import Test.Hspec
24+import Test.Hspec.QuickCheck
25+import Data.Either.Compat
26+import System.Directory (createDirectory, createDirectoryIfMissing)
27+import Test.Mockery.Directory
28+
29+import qualified Data.Yaml as D
30+import qualified Data.Yaml.Builder as B
31+import qualified Data.Yaml.Internal as Internal
32+import qualified Data.Yaml.Pretty as Pretty
33+import Data.Yaml (object, array, (.=))
34+import Data.Maybe
35+import qualified Data.HashMap.Strict as HM
36+#if MIN_VERSION_aeson(2,0,0)
37+import qualified Data.Aeson.KeyMap as M
38+import qualified Data.Aeson.Key as K
39+import Data.Aeson.KeyMap (KeyMap)
40+#else
41+import qualified Data.HashMap.Strict as M
42+#endif
43+import qualified Data.Text as T
44+import Data.Aeson.TH
45+import Data.Scientific (Scientific)
46+import Data.String (fromString)
47+import Data.Text (Text)
48+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
49+import Data.Vector (Vector)
50+import qualified Data.Vector as V
51+import Data.HashMap.Strict (HashMap)
52+import qualified Data.HashMap.Strict as HM
53+import System.IO (hClose)
54+import System.IO.Temp (withSystemTempFile)
55+
56+#if MIN_VERSION_aeson(2,0,0)
57+fromText :: T.Text -> K.Key
58+fromText = K.fromText
59+
60+toText :: K.Key -> T.Text
61+toText = K.toText
62+#else
63+fromText :: T.Text -> T.Text
64+fromText = id
65+
66+toText :: Key -> T.Text
67+toText = id
68+
69+type KeyMap a = M.HashMap Text a
70+type Key = Text
71+#endif
72+
73+data TestJSON = TestJSON
74+ { string :: Text
75+ , number :: Int
76+ , anArray :: Vector Text
77+ , hash :: HashMap Text Text
78+ , extrastring :: Text
79+ } deriving (Show, Eq)
80+
81+deriveJSON defaultOptions ''TestJSON
82+
83+testJSON :: TestJSON
84+testJSON = TestJSON
85+ { string = "str"
86+ , number = 2
87+ , anArray = V.fromList ["a", "b"]
88+ , hash = HM.fromList [("key1", "value1"), ("key2", "value2")]
89+ , extrastring = "1234-foo"
90+ }
91+
92+shouldDecode :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> a -> IO ()
93+shouldDecode bs expected = do
94+ actual <- D.decodeThrow bs
95+ actual `shouldBe` expected
96+
97+shouldDecodeAll :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> [a] -> IO ()
98+shouldDecodeAll bs expected = do
99+ actual <- D.decodeAllThrow bs
100+ actual `shouldBe` expected
101+
102+shouldDecodeEvents :: B8.ByteString -> [Y.Event] -> IO ()
103+shouldDecodeEvents bs expected = do
104+ actual <- runConduitRes $ Y.decode bs .| CL.consume
105+ map anyStyle actual `shouldBe` map anyStyle expected
106+
107+anyStyle :: Y.Event -> Y.Event
108+anyStyle (Y.EventScalar bs tag _ anchor) = Y.EventScalar bs tag Y.Any anchor
109+anyStyle (Y.EventSequenceStart tag _ anchor) = Y.EventSequenceStart tag Y.AnySequence anchor
110+anyStyle (Y.EventMappingStart tag _ anchor) = Y.EventMappingStart tag Y.AnyMapping anchor
111+anyStyle event = event
112+
113+testEncodeWith :: Y.FormatOptions -> [Y.Event] -> IO BS.ByteString
114+testEncodeWith opts es = runConduitRes $ CL.sourceList (eventStream es) .| Y.encodeWith opts
115+
116+eventStream :: [Y.Event] -> [Y.Event]
117+eventStream events =
118+ [Y.EventStreamStart, Y.EventDocumentStart]
119+ ++ events
120+ ++ [Y.EventDocumentEnd, Y.EventStreamEnd]
121+
122+main :: IO ()
123+main = hspec spec
124+
125+spec :: Spec
126+spec = do
127+ describe "streaming" $ do
128+ it "count scalars with anchor" caseCountScalarsWithAnchor
129+ it "count sequences with anchor" caseCountSequencesWithAnchor
130+ it "count mappings with anchor" caseCountMappingsWithAnchor
131+ it "count sequences with custom tag" caseCountSequenceTags
132+ it "count mappings with custom tag" caseCountMappingTags
133+ it "count count sequences with ! tag" caseCountEmptySequenceTags
134+ it "count count mappings with ! tag" caseCountEmptyMappingTags
135+ it "count block style sequences" caseCountBlockStyleSequences
136+ it "count flow style sequences" caseCountFlowStyleSequences
137+ it "count block style mappings" caseCountBlockStyleMappings
138+ it "count flow style mappings" caseCountFlowStyleMappings
139+ it "count aliases" caseCountAliases
140+ it "count scalars" caseCountScalars
141+ it "largest string" caseLargestString
142+ it "encode/decode" caseEncodeDecode
143+ it "encode/decode events" caseEncodeDecodeEvents
144+ it "encode/decode file" caseEncodeDecodeFile
145+ it "interleaved encode/decode" caseInterleave
146+ it "decode invalid document (without segfault)" caseDecodeInvalidDocument
147+ describe "Data.Yaml" $ do
148+ it "encode/decode" caseEncodeDecodeData
149+ it "encode/decode file" caseEncodeDecodeFileData
150+ it "encode/decode files with non-ASCII names" caseEncodeDecodeNonAsciiFileData
151+ it "encode/decode strings" caseEncodeDecodeStrings
152+ it "decode invalid file" caseDecodeInvalid
153+ it "processes datatypes" caseDataTypes
154+ it "encode invalid numbers" caseEncodeInvalidNumbers
155+ describe "Data.Yaml.Pretty" $ do
156+ it "encode/decode" caseEncodeDecodeDataPretty
157+ it "encode/decode strings" caseEncodeDecodeStringsPretty
158+ it "processes datatypes" caseDataTypesPretty
159+ describe "Data.Yaml.Builder" $ do
160+ it "encode/decode" caseEncodeDecodeDataBuilder
161+ it "encode/decode complex mapping" caseEncodeDecodeComplexMappingBuilder
162+ describe "Data.Yaml aliases" $ do
163+ it "simple scalar alias" caseSimpleScalarAlias
164+ it "simple sequence alias" caseSimpleSequenceAlias
165+ it "simple mapping alias" caseSimpleMappingAlias
166+ it "mapping alias before anchor" caseMappingAliasBeforeAnchor
167+ it "mapping alias inside anchor" caseMappingAliasInsideAnchor
168+ it "scalar alias overriding" caseScalarAliasOverriding
169+ describe "Data.Yaml merge keys" $ do
170+ it "test uniqueness of keys" caseAllKeysShouldBeUnique
171+ it "test mapping merge" caseSimpleMappingMerge
172+ it "test sequence of mappings merging" caseMergeSequence
173+ describe "numbers" $ do
174+ it "parses as string when quoted" caseQuotedNumber
175+ it "parses as number when unquoted" caseUnquotedNumber
176+ it "parses as number !!str is present" caseAttribNumber
177+ it "integers have no decimals" caseIntegerDecimals
178+ describe "booleans" $ do
179+ it "parses when all lowercase" caseLowercaseBool
180+ it "parses when all uppercase" caseUppercaseBool
181+ it "parses when titlecase" caseTitlecaseBool
182+ describe "empty input" $ do
183+ it "parses as Null" caseEmptyInput
184+ it "parses as Null from file" caseEmptyInputFile
185+ describe "comment only input" $ do
186+ it "parses as Null" caseCommentOnlyInput
187+ it "parses as Null from file" caseCommentOnlyInputFile
188+ describe "alias stripping" $ do
189+ it "works" caseStripAlias
190+ describe "nulls" $ do
191+ checkNull "null"
192+ checkNull "Null"
193+ checkNull "NULL"
194+ checkNull "~"
195+ checkNull ""
196+
197+ describe "pretty output" $ do
198+ it "simple nulls" $ D.encode (object ["foo" .= D.Null]) `shouldBe` "foo: null\n"
199+ it "simple numbers" $ D.encode (object ["foo" .= (4 :: Int)]) `shouldBe` "foo: 4\n"
200+ it "True" $ D.encode (object ["foo" .= True]) `shouldBe` "foo: true\n"
201+ it "False" $ D.encode (object ["foo" .= False]) `shouldBe` "foo: false\n"
202+ it "simple string" $ D.encode (object ["foo" .= ("bar" :: T.Text)]) `shouldBe` "foo: bar\n"
203+ it "*" $ D.encode (object ["foo" .= ("*" :: T.Text)]) `shouldBe` "foo: '*'\n"
204+
205+ describe "special keys" $ do
206+ let tester key = it (T.unpack key) $
207+ let value = object [fromText key .= True]
208+ in D.encode value `shouldDecode` value
209+ mapM_ tester specialStrings
210+
211+ describe "special values" $ do
212+ let tester value = it (T.unpack value) $
213+ let value' = object ["foo" .= value]
214+ in D.encode value' `shouldDecode` value'
215+ mapM_ tester specialStrings
216+
217+ describe "decodeFileEither" $ do
218+ it "loads YAML through JSON into Haskell data" $ do
219+ tj <- either (error . show) id `fmap` D.decodeFileEither "test/json.yaml"
220+ tj `shouldBe` testJSON
221+
222+ context "when file does not exist" $ do
223+ it "returns Left" $ do
224+ (D.decodeFileEither "./does_not_exist.yaml" :: IO (Either D.ParseException D.Value)) >>= (`shouldSatisfy` isLeft)
225+
226+ describe "multiple document support" $ do
227+ it "decodes zero-length input" $
228+ "" `shouldDecodeAll` ([] :: [D.Value])
229+ it "decodes comment-only input" $
230+ "# foo\n# bar" `shouldDecodeAll` ([] :: [D.Value])
231+ it "decodes a single document stream" $
232+ "foo: true" `shouldDecodeAll` [object ["foo" .= True]]
233+ it "decodes multiple documents" $
234+ "--- 1\n--- 2" `shouldDecodeAll` [D.Number 1, D.Number 2]
235+
236+ describe "round-tripping of special scalars" $ do
237+ let special = words "y Y On ON false 12345 12345.0 12345a 12e3"
238+ forM_ special $ \w -> it w $
239+ let v = object ["word" .= w]
240+ in D.encode v `shouldDecode` v
241+ it "no tags" $ D.encode (object ["word" .= ("true" :: String)]) `shouldBe` "word: 'true'\n"
242+
243+ it "aliases in keys #49" caseIssue49
244+
245+ it "serialization of +123 #64" $ do
246+ D.encode ("+123" :: String) `shouldDecode` ("+123" :: String)
247+
248+ it "preserves Scientific precision" casePreservesScientificPrecision
249+
250+ it "truncates files" caseTruncatesFiles
251+
252+ it "encode quotes special keys #137" $ caseSpecialKeys D.encode
253+
254+ it "encodePretty quotes special keys #179" $ caseSpecialKeys (Pretty.encodePretty Pretty.defConfig)
255+
256+ describe "non-decimal numbers #135" $ do
257+ let go str val = it str $ encodeUtf8 (T.pack str) `shouldDecode` val
258+ go "12345" (12345 :: Int)
259+ go "+12345" (12345 :: Int)
260+ go "0o14" (12 :: Int)
261+ go "0o123" (83 :: Int)
262+ go "0xC" (12 :: Int)
263+ go "0xc" (12 :: Int)
264+ go "0xdeadBEEF" (3735928559 :: Int64)
265+ go "0xDEADBEEF" (3735928559 :: Int64)
266+ go "1.23015e+3" (1230.15 :: Scientific)
267+ go "12.3015e+02" (1230.15 :: Scientific)
268+ go "1230.15" (1230.15 :: Scientific)
269+
270+ describe "Text.Libyaml with default tag rendering" $ do
271+ let enc = testEncodeWith Y.defaultFormatOptions
272+ it "elides custom sequence tags" $
273+ enc taggedSequence `shouldReturn` "[]\n"
274+ it "elides custom mapping tags" $
275+ enc taggedMapping `shouldReturn` "{}\n"
276+ it "elides default sequence tags" $
277+ enc defaultTaggedSequence `shouldReturn` "[]\n"
278+ it "elides default mapping tags" $
279+ enc defaultTaggedMapping `shouldReturn` "{}\n"
280+ it "handles NoTag on sequences" $
281+ enc untaggedSequence `shouldReturn` "[]\n"
282+ it "handles NoTag on mappings" $
283+ enc untaggedMapping `shouldReturn` "{}\n"
284+ it "handles mixed tag usages but elides all mapping and sequence tags" $
285+ enc mixedTagSampleA `shouldReturn` "- {}\n"
286+ it "in combination of tags, anchors and styles, outputs only the scalar tags" $
287+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c [&d !!null '']\n"
288+ it "outputs tags when double quoted" $
289+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "!!str \"foo\"\n"
290+ it "outputs tags when single quoted" $
291+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "!!str 'foo'\n"
292+ it "outputs tags on literal text" $
293+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "!!str |-\n foo\n"
294+ it "outputs tags on folded text" $
295+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` "!!str >-\n foo\n"
296+ describe "Text.Libyaml with all tags on" $ do
297+ let enc = testEncodeWith $ Y.setTagRendering Y.renderAllTags Y.defaultFormatOptions
298+ it "will output custom sequence tags" $
299+ enc taggedSequence `shouldReturn` "!foo []\n"
300+ it "will output custom mapping tags" $
301+ enc taggedMapping `shouldReturn` "!foo {}\n"
302+ it "will output default sequence tags" $
303+ enc defaultTaggedSequence `shouldReturn` "!!seq []\n"
304+ it "will output default mapping tags" $
305+ enc defaultTaggedMapping `shouldReturn` "!!map {}\n"
306+ it "handles NoTag on sequences" $
307+ enc untaggedSequence `shouldReturn` "[]\n"
308+ it "handles NoTag on mappings" $
309+ enc untaggedMapping `shouldReturn` "{}\n"
310+ it "handles mixed tag usages outputting all mapping and sequence tags" $
311+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
312+ it "in combination of tags, anchors and styles, outputs all the tags" $
313+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d !!null '']\n"
314+ it "outputs plain tags" $
315+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "!!str foo\n"
316+ it "respects PlainNoTag tags" $
317+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
318+ describe "Text.Libyaml with uri tags on" $ do
319+ let enc = testEncodeWith $ Y.setTagRendering Y.renderUriTags Y.defaultFormatOptions
320+ it "will output custom sequence tags" $
321+ enc taggedSequence `shouldReturn` "!foo []\n"
322+ it "will output custom mapping tags" $
323+ enc taggedMapping `shouldReturn` "!foo {}\n"
324+ it "will output default sequence tags" $
325+ enc defaultTaggedSequence `shouldReturn` "[]\n"
326+ it "will output default mapping tags" $
327+ enc defaultTaggedMapping `shouldReturn` "{}\n"
328+ it "handles NoTag on sequences" $
329+ enc untaggedSequence `shouldReturn` "[]\n"
330+ it "handles NoTag on mappings" $
331+ enc untaggedMapping `shouldReturn` "{}\n"
332+ it "handles mixed tag usages outputting all mapping and sequence tags" $
333+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
334+ it "in combination of tags, anchors and styles, outputs all the tags" $
335+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d '']\n"
336+ describe "Text.Libyaml with tags off" $ do
337+ let enc = testEncodeWith $ Y.setTagRendering Y.renderNoTags Y.defaultFormatOptions
338+ it "outputs plain tags" $
339+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "foo\n"
340+ it "respects PlainNoTag tags" $
341+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
342+ it "elides tags when double quoted" $
343+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "\"foo\"\n"
344+ it "elides tags when single quoted" $
345+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "'foo'\n"
346+ it "elides tags on literal text" $
347+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "|-\n foo\n"
348+ it "elides tags on folded text" $
349+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` ">-\n foo\n"
350+ describe "Text.Libyaml with only UriTags set to render " $ do
351+ let enc =
352+ testEncodeWith $
353+ Y.setTagRendering Y.renderUriTags $ Y.defaultFormatOptions
354+ it "outputs only UriTags" $
355+ enc
356+ [ Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing
357+ , Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing
358+ , Y.EventScalar "99" Y.IntTag Y.Plain Nothing
359+ , Y.EventScalar "99.99" Y.FloatTag Y.Plain Nothing
360+ , Y.EventScalar "bar" Y.NoTag Y.Plain Nothing
361+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.DoubleQuoted Nothing
362+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.Plain Nothing
363+ , Y.EventSequenceEnd
364+ ] `shouldReturn`
365+ "[\"foo\", 99, 99.99, bar, !foo \"foo\", !foo foo]\n"
366+
367+ prop "Scientific values round-trip" $ \coeff expon -> do
368+ let val = D.Number $ S.scientific coeff expon
369+ let rendered = D.encode val
370+ case D.decodeEither' rendered of
371+ Left e -> error $ show (coeff, expon, e)
372+ Right val' -> val' `shouldBe` val
373+
374+specialStrings :: [T.Text]
375+specialStrings =
376+ [ "fo\"o"
377+ , "fo\'o"
378+ , "fo\\'o"
379+ , "fo: o"
380+ , "foo\nbar\nbaz\n"
381+ ]
382+
383+counter :: Monad m => (Y.Event -> Bool) -> ConduitM Y.Event o m Int
384+counter pred' =
385+ CL.fold (\cnt e -> (if pred' e then 1 else 0) + cnt) 0
386+
387+caseHelper :: String
388+ -> (Y.Event -> Bool)
389+ -> Int
390+ -> Assertion
391+caseHelper yamlString pred' expRes = do
392+ res <- runConduitRes $ Y.decode (B8.pack yamlString) .| counter pred'
393+ res @?= expRes
394+
395+caseCountScalarsWithAnchor :: Assertion
396+caseCountScalarsWithAnchor =
397+ caseHelper yamlString isScalarA 1
398+ where
399+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"
400+ isScalarA (Y.EventScalar _ _ _ (Just _)) = True
401+ isScalarA _ = False
402+
403+caseCountSequencesWithAnchor :: Assertion
404+caseCountSequencesWithAnchor =
405+ caseHelper yamlString isSequenceStartA 1
406+ where
407+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"
408+ isSequenceStartA (Y.EventSequenceStart Y.NoTag _ (Just _)) = True
409+ isSequenceStartA _ = False
410+
411+caseCountMappingsWithAnchor :: Assertion
412+caseCountMappingsWithAnchor =
413+ caseHelper yamlString isMappingA 1
414+ where
415+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"
416+ isMappingA (Y.EventMappingStart _ _ (Just _)) = True
417+ isMappingA _ = False
418+
419+caseCountAliases :: Assertion
420+caseCountAliases =
421+ caseHelper yamlString isAlias 1
422+ where
423+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"
424+ isAlias Y.EventAlias{} = True
425+ isAlias _ = False
426+
427+caseCountMappingTags :: Assertion
428+caseCountMappingTags =
429+ caseHelper yamlString isCustomTaggedMapping 1
430+ where
431+ yamlString = "foo: !bar\n k: v\n k2: v2"
432+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!bar") _ _) = True
433+ isCustomTaggedMapping _ = False
434+
435+caseCountEmptyMappingTags :: Assertion
436+caseCountEmptyMappingTags =
437+ caseHelper yamlString isCustomTaggedMapping 1
438+ where
439+ yamlString = "foo: !\n k: v\n k2: v2"
440+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!") _ _) = True
441+ isCustomTaggedMapping _ = False
442+
443+caseCountSequenceTags :: Assertion
444+caseCountSequenceTags =
445+ caseHelper yamlString isCustomTaggedSequence 1
446+ where
447+ yamlString = "foo: !bar [x, y, z]"
448+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!bar") _ _) = True
449+ isCustomTaggedSequence _ = False
450+
451+caseCountEmptySequenceTags :: Assertion
452+caseCountEmptySequenceTags =
453+ caseHelper yamlString isCustomTaggedSequence 1
454+ where
455+ yamlString = "foo: ! [x, y, z]"
456+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!") _ _) = True
457+ isCustomTaggedSequence _ = False
458+
459+caseCountFlowStyleSequences :: Assertion
460+caseCountFlowStyleSequences =
461+ caseHelper yamlString isFlowStyleSequence 1
462+ where
463+ yamlString = "foo: [x, y, z]"
464+ isFlowStyleSequence (Y.EventSequenceStart _ Y.FlowSequence _) = True
465+ isFlowStyleSequence _ = False
466+
467+caseCountBlockStyleSequences :: Assertion
468+caseCountBlockStyleSequences =
469+ caseHelper yamlString isBlockStyleSequence 1
470+ where
471+ yamlString = "foo:\n- x\n- y\n- z\n"
472+ isBlockStyleSequence (Y.EventSequenceStart _ Y.BlockSequence _) = True
473+ isBlockStyleSequence _ = False
474+
475+caseCountFlowStyleMappings :: Assertion
476+caseCountFlowStyleMappings =
477+ caseHelper yamlString isFlowStyleMapping 1
478+ where
479+ yamlString = "foo: { bar: 1, baz: 2 }"
480+ isFlowStyleMapping (Y.EventMappingStart _ Y.FlowMapping _) = True
481+ isFlowStyleMapping _ = False
482+
483+caseCountBlockStyleMappings :: Assertion
484+caseCountBlockStyleMappings =
485+ caseHelper yamlString isBlockStyleMapping 1
486+ where
487+ yamlString = "foo: bar\nbaz: quux"
488+ isBlockStyleMapping (Y.EventMappingStart _ Y.BlockMapping _) = True
489+ isBlockStyleMapping _ = False
490+
491+caseCountScalars :: Assertion
492+caseCountScalars = do
493+ res <- runConduitRes $ Y.decode yamlBS .| CL.fold adder accum
494+ res @?= (7, 1, 2)
495+ where
496+ yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"
497+ yamlBS = B8.pack yamlString
498+ adder (s, l, m) (Y.EventScalar{}) = (s + 1, l, m)
499+ adder (s, l, m) (Y.EventSequenceStart{}) = (s, l + 1, m)
500+ adder (s, l, m) (Y.EventMappingStart{}) = (s, l, m + 1)
501+ adder a _ = a
502+ accum = (0, 0, 0) :: (Int, Int, Int)
503+
504+caseLargestString :: Assertion
505+caseLargestString = do
506+ res <- runConduitRes $ Y.decodeFile filePath .| CL.fold adder accum
507+ res @?= (length expected, expected)
508+ where
509+ expected = "this one is just a little bit bigger than the others"
510+ filePath = "test/largest-string.yaml"
511+ adder (i, s) (Y.EventScalar bs _ _ _) =
512+ let s' = B8.unpack bs
513+ i' = length s'
514+ in if i' > i then (i', s') else (i, s)
515+ adder acc _ = acc
516+ accum = (0, "no strings found")
517+
518+newtype MyEvent = MyEvent Y.Event deriving Show
519+instance Eq MyEvent where
520+ (MyEvent (Y.EventScalar s t _ _)) == (MyEvent (Y.EventScalar s' t' _ _)) =
521+ s == s' && t == t'
522+ MyEvent e1 == MyEvent e2 = e1 == e2
523+
524+caseEncodeDecode :: Assertion
525+caseEncodeDecode = do
526+ eList <- runConduitRes $ Y.decode yamlBS .| CL.consume
527+ bs <- runConduitRes $ CL.sourceList eList .| Y.encode
528+ eList2 <- runConduitRes $ Y.decode bs .| CL.consume
529+ map MyEvent eList @=? map MyEvent eList2
530+ where
531+ yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"
532+ yamlBS = B8.pack yamlString
533+
534+caseEncodeDecodeEvents :: Assertion
535+caseEncodeDecodeEvents = do
536+ let events = Internal.objToEvents D.defaultStringStyle testJSON []
537+ result <- Internal.decodeHelper_ . CL.sourceList $ eventStream events
538+ let (_, value) = either (error . show) id result
539+ value @?= testJSON
540+
541+caseEncodeDecodeFile :: Assertion
542+caseEncodeDecodeFile = withFile "" $ \tmpPath -> do
543+ eList <- runConduitRes $ Y.decodeFile filePath .| CL.consume
544+ runConduitRes $ CL.sourceList eList .| Y.encodeFile tmpPath
545+ eList2 <- runConduitRes $ Y.decodeFile filePath .| CL.consume
546+ map MyEvent eList @=? map MyEvent eList2
547+ where
548+ filePath = "test/largest-string.yaml"
549+
550+caseInterleave :: Assertion
551+caseInterleave = withFile "" $ \tmpPath -> withFile "" $ \tmpPath2 -> do
552+ () <- runConduitRes $ Y.decodeFile filePath .| Y.encodeFile tmpPath
553+ () <- runConduitRes $ Y.decodeFile tmpPath .| Y.encodeFile tmpPath2
554+ f1 <- readFile tmpPath
555+ f2 <- readFile tmpPath2
556+ f1 @=? f2
557+ where
558+ filePath = "test/largest-string.yaml"
559+
560+caseDecodeInvalidDocument :: Assertion
561+caseDecodeInvalidDocument = do
562+ x <- try $ runConduitRes $ Y.decode yamlBS .| CL.sinkNull
563+ case x of
564+ Left (_ :: SomeException) -> return ()
565+ Right y -> do
566+ putStrLn $ "bad return value: " ++ show y
567+ assertFailure "expected parsing exception, but got no errors"
568+ where
569+ yamlString = " - foo\n - baz\nbuz"
570+ yamlBS = B8.pack yamlString
571+
572+mkScalar :: String -> D.Value
573+mkScalar = mkStrScalar
574+
575+mkStrScalar :: String -> D.Value
576+mkStrScalar = D.String . T.pack
577+
578+mappingKey :: D.Value-> String -> D.Value
579+mappingKey (D.Object m) k = (fromJust . M.lookup (fromText $ T.pack k) $ m)
580+mappingKey _ _ = error "expected Object"
581+
582+sample :: D.Value
583+sample = array
584+ [ D.String "foo"
585+ , object
586+ [ ("bar1", D.String "bar2")
587+ , ("bar3", D.String "")
588+ ]
589+ , D.String ""
590+ , D.Number 1
591+ , D.Number 0.1
592+ , D.Bool True
593+ , D.Null
594+ ]
595+
596+sampleBuilder :: B.YamlBuilder
597+sampleBuilder = B.array
598+ [ B.string "foo"
599+ , B.mapping
600+ [ ("bar1", B.string "bar2")
601+ , ("bar3", B.string "")
602+ ]
603+ , B.string ""
604+ , B.scientific 1
605+ , B.scientific 0.1
606+ , B.bool True
607+ , B.null
608+ ]
609+
610+caseEncodeDecodeData :: Assertion
611+caseEncodeDecodeData = D.encode sample `shouldDecode` sample
612+
613+caseEncodeDecodeDataPretty :: Assertion
614+caseEncodeDecodeDataPretty =
615+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample
616+
617+caseEncodeDecodeDataBuilder :: Assertion
618+caseEncodeDecodeDataBuilder = do
619+ let events = B.unYamlBuilder sampleBuilder []
620+ bs <- testEncodeWith Y.defaultFormatOptions events
621+ bs `shouldDecodeEvents` eventStream events
622+
623+caseEncodeDecodeComplexMappingBuilder :: Assertion
624+caseEncodeDecodeComplexMappingBuilder = do
625+ let events = B.unYamlBuilder builder []
626+ bs <- testEncodeWith Y.defaultFormatOptions events
627+ bs `shouldDecodeEvents` eventStream events
628+ where
629+ builder :: B.YamlBuilder
630+ builder = B.mappingComplex
631+ [ ( B.mapping
632+ [ ("foo", B.scientific 1)
633+ , ("bar", B.scientific 2)
634+ ]
635+ , B.bool True
636+ )
637+ ]
638+
639+caseEncodeDecodeFileData :: Assertion
640+caseEncodeDecodeFileData = withFile "" $ \fp -> do
641+ D.encodeFile fp sample
642+ out <- D.decodeFileThrow fp
643+ out @?= sample
644+
645+caseEncodeDecodeNonAsciiFileData :: Assertion
646+caseEncodeDecodeNonAsciiFileData = do
647+ let mySample = (object ["foo" .= True])
648+ inTempDirectory $ do
649+ createDirectory "accenté"
650+ D.encodeFile "accenté/bar.yaml" mySample
651+ out1 <- D.decodeFileThrow "accenté/bar.yaml"
652+ out1 @?= mySample
653+
654+ c <- readFile "test/resources/accent/foo.yaml"
655+ inTempDirectory $ do
656+ createDirectoryIfMissing True "test/resources/unicode/accenté/"
657+ writeFile "test/resources/unicode/accenté/foo.yaml" c
658+ out2 <- D.decodeFileThrow "test/resources/unicode/accenté/foo.yaml"
659+ out2 @?= mySample
660+
661+caseEncodeDecodeStrings :: Assertion
662+caseEncodeDecodeStrings = D.encode sample `shouldDecode` sample
663+
664+caseEncodeDecodeStringsPretty :: Assertion
665+caseEncodeDecodeStringsPretty =
666+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample
667+
668+caseDecodeInvalid :: Assertion
669+caseDecodeInvalid =
670+ D.decodeThrow "\tthis is 'not' valid :-)" `shouldBe`
671+ (Nothing :: Maybe D.Value)
672+
673+caseSimpleScalarAlias :: Assertion
674+caseSimpleScalarAlias =
675+ "- &anch foo\n- baz\n- *anch" `shouldDecode`
676+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo")]
677+
678+caseSimpleSequenceAlias :: Assertion
679+caseSimpleSequenceAlias =
680+ "seq: &anch\n - foo\n - baz\nseq2: *anch" `shouldDecode`
681+ object [("seq", array [(mkScalar "foo"), (mkScalar "baz")]), ("seq2", array [(mkScalar "foo"), (mkScalar "baz")])]
682+
683+caseSimpleMappingAlias :: Assertion
684+caseSimpleMappingAlias =
685+ "map: &anch\n key1: foo\n key2: baz\nmap2: *anch" `shouldDecode`
686+ object [(packStr "map", object [("key1", mkScalar "foo"), ("key2", (mkScalar "baz"))]), (packStr "map2", object [("key1", (mkScalar "foo")), ("key2", mkScalar "baz")])]
687+ where
688+ packStr = fromText . T.pack
689+
690+caseMappingAliasBeforeAnchor :: Assertion
691+caseMappingAliasBeforeAnchor =
692+ case D.decodeThrow "map: *anch\nmap2: &anch\n key1: foo\n key2: baz" of
693+ Nothing -> pure ()
694+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"
695+
696+caseMappingAliasInsideAnchor :: Assertion
697+caseMappingAliasInsideAnchor = do
698+ case D.decodeThrow "map: &anch\n key1: foo\n key2: *anch" of
699+ Nothing -> pure ()
700+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"
701+
702+caseScalarAliasOverriding :: Assertion
703+caseScalarAliasOverriding =
704+ "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch" `shouldDecode`
705+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo"), (mkScalar "boo"), (mkScalar "buz"), (mkScalar "boo")]
706+
707+caseAllKeysShouldBeUnique :: Assertion
708+caseAllKeysShouldBeUnique = do
709+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\nfoo1: buz"
710+ mappingKey res "foo1" `shouldBe` mkScalar "buz"
711+
712+caseSimpleMappingMerge :: Assertion
713+caseSimpleMappingMerge = do
714+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\n<<:\n foo1: buz\n foo3: fuz"
715+ mappingKey res "foo1" `shouldBe` mkScalar "foo"
716+ mappingKey res "foo3" `shouldBe` mkScalar "fuz"
717+
718+caseMergeSequence :: Assertion
719+caseMergeSequence = do
720+ res <- D.decodeThrow "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"
721+ mappingKey res "foo1" @?= (mkScalar "foo")
722+ mappingKey res "k1" @?= (D.String "1")
723+ mappingKey res "k2" @?= (D.String "2")
724+ mappingKey res "k3" @?= (D.String "4")
725+
726+caseDataTypes :: Assertion
727+caseDataTypes =
728+ D.encode val `shouldDecode` val
729+ where
730+ val = object
731+ [ ("string", D.String "foo")
732+ , ("int", D.Number 5)
733+ , ("float", D.Number 4.3)
734+ , ("true", D.Bool True)
735+ , ("false", D.Bool False)
736+ , ("null", D.Null)
737+ ]
738+
739+caseEncodeInvalidNumbers :: Assertion
740+caseEncodeInvalidNumbers =
741+ D.encode (D.String ".") `shouldBe` ".\n"
742+
743+caseDataTypesPretty :: Assertion
744+caseDataTypesPretty =
745+ Pretty.encodePretty Pretty.defConfig val `shouldDecode` val
746+ where
747+ val = object
748+ [ ("string", D.String "foo")
749+ , ("int", D.Number 5)
750+ , ("float", D.Number 4.3)
751+ , ("true", D.Bool True)
752+ , ("false", D.Bool False)
753+ , ("null", D.Null)
754+ ]
755+caseQuotedNumber, caseUnquotedNumber, caseAttribNumber, caseIntegerDecimals :: Assertion
756+caseQuotedNumber = "foo: \"1234\"" `shouldDecode` object [("foo", D.String "1234")]
757+caseUnquotedNumber = "foo: 1234" `shouldDecode` object [("foo", D.Number 1234)]
758+caseAttribNumber = "foo: !!str 1234" `shouldDecode` object [("foo", D.String "1234")]
759+caseIntegerDecimals = "1\n" `shouldDecode` (1 :: Int)
760+
761+obj :: D.Value
762+obj = object [("foo", D.Bool False), ("bar", D.Bool True), ("baz", D.Bool True)]
763+
764+caseLowercaseBool, caseUppercaseBool, caseTitlecaseBool :: Assertion
765+caseLowercaseBool = "foo: off\nbar: y\nbaz: true" `shouldDecode` obj
766+caseUppercaseBool = "foo: FALSE\nbar: Y\nbaz: ON" `shouldDecode` obj
767+caseTitlecaseBool = "foo: No\nbar: Yes\nbaz: True" `shouldDecode` obj
768+
769+caseEmptyInput :: Assertion
770+caseEmptyInput = B8.empty `shouldDecode` D.Null
771+
772+caseEmptyInputFile :: Assertion
773+caseEmptyInputFile = do
774+ out <- D.decodeFileEither "test/resources/empty.yaml"
775+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null
776+
777+caseCommentOnlyInput :: Assertion
778+caseCommentOnlyInput = "# comment\n" `shouldDecode` D.Null
779+
780+caseCommentOnlyInputFile :: Assertion
781+caseCommentOnlyInputFile = do
782+ out <- D.decodeFileEither "test/resources/empty2.yaml"
783+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null
784+
785+checkNull :: T.Text -> Spec
786+checkNull x =
787+ it ("null recognized: " ++ show x) $
788+ B8.pack ("foo: " ++ T.unpack x) `shouldDecode` object [("foo", D.Null)]
789+
790+caseStripAlias :: Assertion
791+caseStripAlias =
792+ src `shouldDecode` object
793+ [ "Default" .= object
794+ [ "foo" .= (1 :: Int)
795+ , "bar" .= (2 :: Int)
796+ ]
797+ , "Obj" .= object
798+ [ "foo" .= (1 :: Int)
799+ , "bar" .= (2 :: Int)
800+ , "key" .= (3 :: Int)
801+ ]
802+ ]
803+ where
804+ src = "Default: &def\n foo: 1\n bar: 2\nObj:\n <<: *def\n key: 3\n"
805+
806+caseIssue49 :: Assertion
807+caseIssue49 =
808+ src `shouldDecode` object
809+ [ "a" .= object [ "value" .= (1.0 :: Double) ]
810+ , "b" .= object [ "value" .= (1.2 :: Double) ]
811+ ]
812+ where
813+ src = "---\na:\n &id5 value: 1.0\nb:\n *id5: 1.2"
814+
815+-- | We cannot guarantee this before aeson started using 'Scientific'.
816+casePreservesScientificPrecision :: Assertion
817+casePreservesScientificPrecision = do
818+ "x: 1e-100000" `shouldDecode` object
819+ [ "x" .= D.Number (read "1e-100000") ]
820+ -- Note that this ought to work also without 'Scientific', given
821+ -- that @read (show "9.78159610558926e-5") == 9.78159610558926e-5@.
822+ -- However, it didn't work (and still doesn't work with aeson < 0.7)
823+ -- for two reasons:
824+ --
825+ -- - We use 'Data.Text.Read.double', which is not as accurate as it
826+ -- can be;
827+ -- - Even if we used 'Data.Text.Read.rational' we would not get good
828+ -- results, because of <https://github.com/bos/text/issues/34>.
829+ "x: 9.78159610558926e-5" `shouldDecode` object
830+ [ "x" .= D.Number (read "9.78159610558926e-5") ]
831+
832+caseTruncatesFiles :: Assertion
833+caseTruncatesFiles = withSystemTempFile "truncate.yaml" $ \fp h -> do
834+ replicateM_ 500 $ B8.hPut h "HELLO WORLD!!!!!\n"
835+ hClose h
836+ let val = object ["hello" .= ("world" :: String)]
837+ D.encodeFile fp val
838+ res <- D.decodeFileEither fp
839+ either (Left . show) Right res `shouldBe` Right val
840+
841+caseSpecialKeys :: (KeyMap () -> B8.ByteString) -> Assertion
842+caseSpecialKeys encoder = do
843+ let keys = T.words "true false NO YES 1.2 1e5 null"
844+ bs = encoder $ M.fromList $ map (, ()) $ fmap fromText keys
845+ text = decodeUtf8 bs
846+ forM_ keys $ \key -> do
847+ let quoted = T.concat ["'", key, "'"]
848+ unless (quoted `T.isInfixOf` text) $ error $ concat
849+ [ "Could not find quoted key: "
850+ , T.unpack quoted
851+ , "\n\n"
852+ , T.unpack text
853+ ] :: IO ()
854+
855+taggedSequence :: [Y.Event]
856+taggedSequence =
857+ [ Y.EventSequenceStart (Y.UriTag "!foo") Y.FlowSequence Nothing
858+ , Y.EventSequenceEnd
859+ ]
860+
861+taggedMapping :: [Y.Event]
862+taggedMapping =
863+ [ Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
864+ , Y.EventMappingEnd
865+ ]
866+
867+defaultTaggedSequence :: [Y.Event]
868+defaultTaggedSequence =
869+ [Y.EventSequenceStart Y.SeqTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
870+
871+defaultTaggedMapping :: [Y.Event]
872+defaultTaggedMapping =
873+ [Y.EventMappingStart Y.MapTag Y.FlowMapping Nothing, Y.EventMappingEnd]
874+
875+untaggedSequence :: [Y.Event]
876+untaggedSequence =
877+ [Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
878+
879+untaggedMapping :: [Y.Event]
880+untaggedMapping =
881+ [Y.EventMappingStart Y.NoTag Y.FlowMapping Nothing, Y.EventMappingEnd]
882+
883+mixedTagSampleA :: [Y.Event]
884+mixedTagSampleA =
885+ [ Y.EventSequenceStart Y.NoTag Y.BlockSequence Nothing
886+ , Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
887+ , Y.EventMappingEnd
888+ , Y.EventSequenceEnd
889+ ]
890+
891+mixedTagSampleB :: [Y.Event]
892+mixedTagSampleB =
893+ [ Y.EventMappingStart Y.NoTag Y.BlockMapping (Just "a")
894+ , Y.EventScalar "foo" (Y.UriTag "bar") Y.Plain (Just "b")
895+ , Y.EventSequenceStart (Y.UriTag "!baz") Y.FlowSequence (Just "c")
896+ , Y.EventScalar "" Y.NullTag Y.Plain (Just "d")
897+ , Y.EventSequenceEnd
898+ , Y.EventMappingEnd
899+ ]