git.iko.soy/typeable/yaml
on master help sign in
Merge pull request #165 from curvelogic/feature/tag-format-options

Mapping/Sequence tag output control via FormatOptions

commitac1c995ec2905bee68eddbb06b4b5367ea658b3d authorMichael Snoyman <michael@snoyman.com> dateTue 12 Feb 2019, 10:48 (8 years ago) parent35f0286b8b5756
3 files changed+239−14
compare with master
unifiedsplit
libyaml/src/Text/Libyaml.hs+83−14 yaml/ChangeLog.md+4 yaml/test/Data/YamlSpec.hs+152
libyaml/src/Text/Libyaml.hs+83−14
@@ -32,6 +32,11 @@ module Text.Libyaml
3232 , FormatOptions
3333 , defaultFormatOptions
3434 , setWidth
35+ , setTagRendering
36+ , renderScalarTags
37+ , renderAllTags
38+ , renderNoTags
39+ , renderUriTags
3540 -- * Error handling
3641 , YamlException (..)
3742 , YamlMark (..)
@@ -121,6 +126,11 @@ data Tag = StrTag
121126 | NoTag
122127 deriving (Show, Eq, Read, Data, Typeable)
123128
129+tagSuppressed :: Tag -> Bool
130+tagSuppressed (NoTag) = True
131+tagSuppressed (UriTag "") = True
132+tagSuppressed _ = False
133+
124134type AnchorName = String
125135type Anchor = Maybe AnchorName
126136
@@ -446,8 +456,8 @@ foreign import ccall unsafe "yaml_alias_event_initialize"
446456 -> Ptr CUChar
447457 -> IO CInt
448458
449−toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
450−toEventRaw e f = allocaBytes eventSize $ \er -> do
459+toEventRaw :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a
460+toEventRaw opts e f = allocaBytes eventSize $ \er -> do
451461 ret <- case e of
452462 EventStreamStart ->
453463 c_yaml_stream_start_event_initialize
@@ -465,13 +475,13 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
465475 len' = fromIntegral len :: CInt
466476 let thetag' = tagToString thetag
467477 withCString thetag' $ \tag' -> do
468− let (pi, style) =
469− case style0 of
470− PlainNoTag -> (1, Plain)
471− x -> (0, x)
478+ let pi0 = tagsImplicit e
479+ (pi, style) =
480+ case style0 of
481+ PlainNoTag -> (1, Plain)
482+ x -> (pi0, x)
472483 style' = toEnum $ fromEnum style
473484 tagP = castPtr tag'
474− qi = if null thetag' then 1 else 0
475485 case anchor of
476486 Nothing ->
477487 c_yaml_scalar_event_initialize
@@ -481,7 +491,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
481491 value' -- value
482492 len' -- length
483493 pi -- plain_implicit
484− qi -- quoted_implicit
494+ pi -- quoted_implicit
485495 style' -- style
486496 Just anchor' ->
487497 withCString anchor' $ \anchorP' -> do
@@ -493,7 +503,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
493503 value' -- value
494504 len' -- length
495505 0 -- plain_implicit
496− qi -- quoted_implicit
506+ pi -- quoted_implicit
497507 style' -- style
498508 EventSequenceStart tag style Nothing ->
499509 withCString (tagToString tag) $ \tag' -> do
@@ -502,7 +512,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
502512 er
503513 nullPtr
504514 tagP
505− 1
515+ (tagsImplicit e)
506516 (toEnum $ fromEnum style)
507517 EventSequenceStart tag style (Just anchor) ->
508518 withCString (tagToString tag) $ \tag' -> do
@@ -513,7 +523,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
513523 er
514524 anchorP
515525 tagP
516− 1
526+ (tagsImplicit e)
517527 (toEnum $ fromEnum style)
518528 EventSequenceEnd ->
519529 c_yaml_sequence_end_event_initialize er
@@ -524,7 +534,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
524534 er
525535 nullPtr
526536 tagP
527− 1
537+ (tagsImplicit e)
528538 (toEnum $ fromEnum style)
529539 EventMappingStart tag style (Just anchor) ->
530540 withCString (tagToString tag) $ \tag' -> do
@@ -535,7 +545,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
535545 er
536546 anchorP
537547 tagP
538− 1
548+ (tagsImplicit e)
539549 (toEnum $ fromEnum style)
540550 EventMappingEnd ->
541551 c_yaml_mapping_end_event_initialize er
@@ -547,6 +557,11 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
547557 anchorP
548558 unless (ret == 1) $ throwIO $ ToEventRawException ret
549559 f er
560+ where
561+ tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1
562+ tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1
563+ tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1
564+ tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt
550565
551566newtype ToEventRawException = ToEventRawException CInt
552567 deriving (Show, Typeable)
@@ -663,11 +678,58 @@ parserParseOne' parser = allocaBytes eventSize $ \er -> do
663678 return $ Left $ YamlParseException problem context problemMark
664679 else Right <$> getEvent er
665680
681+-- | Whether a tag should be rendered explicitly in the output or left
682+-- implicit.
683+--
684+-- @since 0.11.1.0
685+data TagRender = Explicit | Implicit
686+ deriving (Enum)
687+
688+toImplicitParam :: TagRender -> CInt
689+toImplicitParam Explicit = 0
690+toImplicitParam Implicit = 1
691+
692+-- | A value for 'formatOptionsRenderTags' that renders no
693+-- collection tags but all scalar tags (unless suppressed with styles
694+-- 'NoTag or 'PlainNoTag').
695+--
696+-- @since 0.11.1.0
697+renderScalarTags :: Event -> TagRender
698+renderScalarTags (EventScalar _ _ _ _) = Explicit
699+renderScalarTags (EventSequenceStart _ _ _) = Implicit
700+renderScalarTags (EventMappingStart _ _ _) = Implicit
701+renderScalarTags _ = Implicit
702+
703+-- | A value for 'formatOptionsRenderTags' that renders all
704+-- tags (except 'NoTag' tag and 'PlainNoTag' style).
705+--
706+-- @since 0.11.1.0
707+renderAllTags :: Event -> TagRender
708+renderAllTags _ = Explicit
709+
710+-- | A value for 'formatOptionsRenderTags' that renders no
711+-- tags.
712+--
713+-- @since 0.11.1.0
714+renderNoTags :: Event -> TagRender
715+renderNoTags _ = Implicit
716+
717+-- | A value for 'formatOptionsRenderCollectionTags' that renders tags
718+-- which are instances of 'UriTag'
719+--
720+-- @since 0.11.1.0
721+renderUriTags :: Event -> TagRender
722+renderUriTags (EventScalar _ UriTag{} _ _) = Explicit
723+renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit
724+renderUriTags (EventMappingStart UriTag{} _ _) = Explicit
725+renderUriTags _ = Implicit
726+
666727-- | Contains options relating to the formatting (indendation, width) of the YAML output.
667728--
668729-- @since 0.10.2.0
669730data FormatOptions = FormatOptions
670731 { formatOptionsWidth :: Maybe Int
732+ , formatOptionsRenderTags :: Event -> TagRender
671733 }
672734
673735-- |
@@ -675,6 +737,7 @@ data FormatOptions = FormatOptions
675737defaultFormatOptions :: FormatOptions
676738defaultFormatOptions = FormatOptions
677739 { formatOptionsWidth = Just 80 -- by default the width is set to 0 in the C code, which gets turned into 80 in yaml_emitter_emit_stream_start
740+ , formatOptionsRenderTags = renderScalarTags
678741 }
679742
680743-- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters.
@@ -683,6 +746,12 @@ defaultFormatOptions = FormatOptions
683746setWidth :: Maybe Int -> FormatOptions -> FormatOptions
684747setWidth w opts = opts { formatOptionsWidth = w }
685748
749+-- | Control when and whether tags are rendered to output.
750+--
751+-- @since 0.11.1.0
752+setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions
753+setTagRendering f opts = opts { formatOptionsRenderTags = f }
754+
686755encode :: MonadResource m => ConduitM Event o m ByteString
687756encode = encodeWith defaultFormatOptions
688757
@@ -756,7 +825,7 @@ runEmitter opts allocI closeI =
756825 loop = await >>= maybe (close ()) push
757826
758827 push e = do
759− _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
828+ _ <- liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter
760829 loop
761830 close u = liftIO $ closeI u a
762831
yaml/ChangeLog.md+4
@@ -1,5 +1,9 @@
11# ChangeLog for yaml
22
3+## 0.11.1.0
4+
5+* Add options to `FormatOptions` to govern when tags rendered explicitly and when they are left implicit. [#165](https://github.com/snoyberg/yaml/issues/165)
6+
37## 0.11.0.0
48
59* Split out the `libyaml` and `Text.Libyaml` code into its own package. [#145](https://github.com/snoyberg/yaml/issues/145)
yaml/test/Data/YamlSpec.hs+152
@@ -8,6 +8,7 @@
88module Data.YamlSpec (main, spec) where
99
1010import qualified Text.Libyaml as Y
11+import qualified Data.ByteString as BS
1112import qualified Data.ByteString.Char8 as B8
1213import Data.Int (Int64)
1314
@@ -55,6 +56,13 @@ shouldDecode bs expected = do
5556 actual <- D.decodeThrow bs
5657 actual `shouldBe` expected
5758
59+testEncodeWith :: Y.FormatOptions -> [Y.Event] -> IO BS.ByteString
60+testEncodeWith opts es = runConduitRes (CL.sourceList events .| Y.encodeWith opts)
61+ where
62+ events =
63+ [Y.EventStreamStart, Y.EventDocumentStart] ++ es ++
64+ [Y.EventDocumentEnd, Y.EventStreamEnd]
65+
5866main :: IO ()
5967main = hspec spec
6068
@@ -205,6 +213,103 @@ spec = do
205213 go "12.3015e+02" (1230.15 :: Scientific)
206214 go "1230.15" (1230.15 :: Scientific)
207215
216+ describe "Text.Libyaml with default tag rendering" $ do
217+ let enc = testEncodeWith Y.defaultFormatOptions
218+ it "elides custom sequence tags" $
219+ enc taggedSequence `shouldReturn` "[]\n"
220+ it "elides custom mapping tags" $
221+ enc taggedMapping `shouldReturn` "{}\n"
222+ it "elides default sequence tags" $
223+ enc defaultTaggedSequence `shouldReturn` "[]\n"
224+ it "elides default mapping tags" $
225+ enc defaultTaggedMapping `shouldReturn` "{}\n"
226+ it "handles NoTag on sequences" $
227+ enc untaggedSequence `shouldReturn` "[]\n"
228+ it "handles NoTag on mappings" $
229+ enc untaggedMapping `shouldReturn` "{}\n"
230+ it "handles mixed tag usages but elides all mapping and sequence tags" $
231+ enc mixedTagSampleA `shouldReturn` "- {}\n"
232+ it "in combination of tags, anchors and styles, outputs only the scalar tags" $
233+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c [&d !!null '']\n"
234+ it "outputs tags when double quoted" $
235+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "!!str \"foo\"\n"
236+ it "outputs tags when single quoted" $
237+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "!!str 'foo'\n"
238+ it "outputs tags on literal text" $
239+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "!!str |-\n foo\n"
240+ it "outputs tags on folded text" $
241+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` "!!str >-\n foo\n"
242+ describe "Text.Libyaml with all tags on" $ do
243+ let enc = testEncodeWith $ Y.setTagRendering Y.renderAllTags Y.defaultFormatOptions
244+ it "will output custom sequence tags" $
245+ enc taggedSequence `shouldReturn` "!foo []\n"
246+ it "will output custom mapping tags" $
247+ enc taggedMapping `shouldReturn` "!foo {}\n"
248+ it "will output default sequence tags" $
249+ enc defaultTaggedSequence `shouldReturn` "!!seq []\n"
250+ it "will output default mapping tags" $
251+ enc defaultTaggedMapping `shouldReturn` "!!map {}\n"
252+ it "handles NoTag on sequences" $
253+ enc untaggedSequence `shouldReturn` "[]\n"
254+ it "handles NoTag on mappings" $
255+ enc untaggedMapping `shouldReturn` "{}\n"
256+ it "handles mixed tag usages outputting all mapping and sequence tags" $
257+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
258+ it "in combination of tags, anchors and styles, outputs all the tags" $
259+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d !!null '']\n"
260+ it "outputs plain tags" $
261+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "!!str foo\n"
262+ it "respects PlainNoTag tags" $
263+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
264+ describe "Text.Libyaml with uri tags on" $ do
265+ let enc = testEncodeWith $ Y.setTagRendering Y.renderUriTags Y.defaultFormatOptions
266+ it "will output custom sequence tags" $
267+ enc taggedSequence `shouldReturn` "!foo []\n"
268+ it "will output custom mapping tags" $
269+ enc taggedMapping `shouldReturn` "!foo {}\n"
270+ it "will output default sequence tags" $
271+ enc defaultTaggedSequence `shouldReturn` "[]\n"
272+ it "will output default mapping tags" $
273+ enc defaultTaggedMapping `shouldReturn` "{}\n"
274+ it "handles NoTag on sequences" $
275+ enc untaggedSequence `shouldReturn` "[]\n"
276+ it "handles NoTag on mappings" $
277+ enc untaggedMapping `shouldReturn` "{}\n"
278+ it "handles mixed tag usages outputting all mapping and sequence tags" $
279+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
280+ it "in combination of tags, anchors and styles, outputs all the tags" $
281+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d '']\n"
282+ describe "Text.Libyaml with tags off" $ do
283+ let enc = testEncodeWith $ Y.setTagRendering Y.renderNoTags Y.defaultFormatOptions
284+ it "outputs plain tags" $
285+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "foo\n"
286+ it "respects PlainNoTag tags" $
287+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
288+ it "elides tags when double quoted" $
289+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "\"foo\"\n"
290+ it "elides tags when single quoted" $
291+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "'foo'\n"
292+ it "elides tags on literal text" $
293+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "|-\n foo\n"
294+ it "elides tags on folded text" $
295+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` ">-\n foo\n"
296+ describe "Text.Libyaml with only UriTags set to render " $ do
297+ let enc =
298+ testEncodeWith $
299+ Y.setTagRendering Y.renderUriTags $ Y.defaultFormatOptions
300+ it "outputs only UriTags" $
301+ enc
302+ [ Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing
303+ , Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing
304+ , Y.EventScalar "99" Y.IntTag Y.Plain Nothing
305+ , Y.EventScalar "99.99" Y.FloatTag Y.Plain Nothing
306+ , Y.EventScalar "bar" Y.NoTag Y.Plain Nothing
307+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.DoubleQuoted Nothing
308+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.Plain Nothing
309+ , Y.EventSequenceEnd
310+ ] `shouldReturn`
311+ "[\"foo\", 99, 99.99, bar, !foo \"foo\", !foo foo]\n"
312+
208313specialStrings :: [T.Text]
209314specialStrings =
210315 [ "fo\"o"
@@ -622,3 +727,50 @@ caseTruncatesFiles = withSystemTempFile "truncate.yaml" $ \fp h -> do
622727 D.encodeFile fp val
623728 res <- D.decodeFileEither fp
624729 either (Left . show) Right res `shouldBe` Right val
730+
731+
732+taggedSequence :: [Y.Event]
733+taggedSequence =
734+ [ Y.EventSequenceStart (Y.UriTag "!foo") Y.FlowSequence Nothing
735+ , Y.EventSequenceEnd
736+ ]
737+
738+taggedMapping :: [Y.Event]
739+taggedMapping =
740+ [ Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
741+ , Y.EventMappingEnd
742+ ]
743+
744+defaultTaggedSequence :: [Y.Event]
745+defaultTaggedSequence =
746+ [Y.EventSequenceStart Y.SeqTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
747+
748+defaultTaggedMapping :: [Y.Event]
749+defaultTaggedMapping =
750+ [Y.EventMappingStart Y.MapTag Y.FlowMapping Nothing, Y.EventMappingEnd]
751+
752+untaggedSequence :: [Y.Event]
753+untaggedSequence =
754+ [Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
755+
756+untaggedMapping :: [Y.Event]
757+untaggedMapping =
758+ [Y.EventMappingStart Y.NoTag Y.FlowMapping Nothing, Y.EventMappingEnd]
759+
760+mixedTagSampleA :: [Y.Event]
761+mixedTagSampleA =
762+ [ Y.EventSequenceStart Y.NoTag Y.BlockSequence Nothing
763+ , Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
764+ , Y.EventMappingEnd
765+ , Y.EventSequenceEnd
766+ ]
767+
768+mixedTagSampleB :: [Y.Event]
769+mixedTagSampleB =
770+ [ Y.EventMappingStart Y.NoTag Y.BlockMapping (Just "a")
771+ , Y.EventScalar "foo" (Y.UriTag "bar") Y.Plain (Just "b")
772+ , Y.EventSequenceStart (Y.UriTag "!baz") Y.FlowSequence (Just "c")
773+ , Y.EventScalar "" Y.NullTag Y.Plain (Just "d")
774+ , Y.EventSequenceEnd
775+ , Y.EventMappingEnd
776+ ]