Merge pull request #165 from curvelogic/feature/tag-format-options

Mapping/Sequence tag output control via FormatOptions

libyaml/src/Text/Libyaml.hs

@@ -32,6 +32,11 @@ module Text.Libyaml
     , FormatOptions
     , defaultFormatOptions
     , setWidth
+    , setTagRendering
+    , renderScalarTags
+    , renderAllTags
+    , renderNoTags
+    , renderUriTags
       -- * Error handling
     , YamlException (..)
     , YamlMark (..)
@@ -121,6 +126,11 @@ data Tag = StrTag
          | NoTag
     deriving (Show, Eq, Read, Data, Typeable)
 
+tagSuppressed :: Tag -> Bool
+tagSuppressed (NoTag) = True
+tagSuppressed (UriTag "") = True
+tagSuppressed _ = False
+
 type AnchorName = String
 type Anchor = Maybe AnchorName
 
@@ -446,8 +456,8 @@ foreign import ccall unsafe "yaml_alias_event_initialize"
         -> Ptr CUChar
         -> IO CInt
 
-toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
-toEventRaw e f = allocaBytes eventSize $ \er -> do
+toEventRaw :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a
+toEventRaw opts e f = allocaBytes eventSize $ \er -> do
     ret <- case e of
         EventStreamStart ->
             c_yaml_stream_start_event_initialize
@@ -465,13 +475,13 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                     len' = fromIntegral len :: CInt
                 let thetag' = tagToString thetag
                 withCString thetag' $ \tag' -> do
-                    let (pi, style) =
-                            case style0 of
-                                PlainNoTag -> (1, Plain)
-                                x -> (0, x)
+                    let pi0 = tagsImplicit e
+                        (pi, style) =
+                          case style0 of
+                            PlainNoTag -> (1, Plain)
+                            x -> (pi0, x)
                         style' = toEnum $ fromEnum style
                         tagP = castPtr tag'
-                        qi = if null thetag' then 1 else 0
                     case anchor of
                         Nothing ->
                             c_yaml_scalar_event_initialize
@@ -481,7 +491,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                                 value'  -- value
                                 len'    -- length
                                 pi      -- plain_implicit
-                                qi      -- quoted_implicit
+                                pi      -- quoted_implicit
                                 style'  -- style
                         Just anchor' ->
                             withCString anchor' $ \anchorP' -> do
@@ -493,7 +503,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                                     value'  -- value
                                     len'    -- length
                                     0       -- plain_implicit
-                                    qi      -- quoted_implicit
+                                    pi      -- quoted_implicit
                                     style'  -- style
         EventSequenceStart tag style Nothing ->
             withCString (tagToString tag) $ \tag' -> do
@@ -502,7 +512,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                   er
                   nullPtr
                   tagP
-                  1
+                  (tagsImplicit e)
                   (toEnum $ fromEnum style)
         EventSequenceStart tag style (Just anchor) ->
             withCString (tagToString tag) $ \tag' -> do
@@ -513,7 +523,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                         er
                         anchorP
                         tagP
-                        1
+                        (tagsImplicit e)
                         (toEnum $ fromEnum style)
         EventSequenceEnd ->
             c_yaml_sequence_end_event_initialize er
@@ -524,7 +534,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                     er
                     nullPtr
                     tagP
-                    1
+                    (tagsImplicit e)
                     (toEnum $ fromEnum style)
         EventMappingStart tag style (Just anchor) ->
             withCString (tagToString tag) $ \tag' -> do
@@ -535,7 +545,7 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                         er
                         anchorP
                         tagP
-                        1
+                        (tagsImplicit e)
                         (toEnum $ fromEnum style)
         EventMappingEnd ->
             c_yaml_mapping_end_event_initialize er
@@ -547,6 +557,11 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do
                     anchorP
     unless (ret == 1) $ throwIO $ ToEventRawException ret
     f er
+  where
+    tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1
+    tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1
+    tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1
+    tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt
 
 newtype ToEventRawException = ToEventRawException CInt
     deriving (Show, Typeable)
@@ -663,18 +678,66 @@ parserParseOne' parser = allocaBytes eventSize $ \er -> do
           return $ Left $ YamlParseException problem context problemMark
         else Right <$> getEvent er
 
+-- | Whether a tag should be rendered explicitly in the output or left
+-- implicit.
+--
+-- @since 0.11.1.0
+data TagRender = Explicit | Implicit
+  deriving (Enum)
+
+toImplicitParam :: TagRender -> CInt
+toImplicitParam Explicit = 0
+toImplicitParam Implicit = 1
+
+-- | A value for 'formatOptionsRenderTags' that renders no
+-- collection tags but all scalar tags (unless suppressed with styles
+-- 'NoTag or 'PlainNoTag').
+--
+-- @since 0.11.1.0
+renderScalarTags :: Event -> TagRender
+renderScalarTags (EventScalar _ _ _ _) = Explicit
+renderScalarTags (EventSequenceStart _ _ _) = Implicit
+renderScalarTags (EventMappingStart _ _ _) = Implicit
+renderScalarTags _ = Implicit
+
+-- | A value for 'formatOptionsRenderTags' that renders all
+-- tags (except 'NoTag' tag and 'PlainNoTag' style).
+--
+-- @since 0.11.1.0
+renderAllTags :: Event -> TagRender
+renderAllTags _ = Explicit
+
+-- | A value for 'formatOptionsRenderTags' that renders no
+-- tags.
+--
+-- @since 0.11.1.0
+renderNoTags :: Event -> TagRender
+renderNoTags _ = Implicit
+
+-- | A value for 'formatOptionsRenderCollectionTags' that renders tags
+-- which are instances of 'UriTag'
+--
+-- @since 0.11.1.0
+renderUriTags :: Event -> TagRender
+renderUriTags (EventScalar _ UriTag{} _ _) = Explicit
+renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit
+renderUriTags (EventMappingStart UriTag{} _ _) = Explicit
+renderUriTags _ = Implicit
+
 -- | Contains options relating to the formatting (indendation, width) of the YAML output.
 --
 -- @since 0.10.2.0
 data FormatOptions = FormatOptions
     { formatOptionsWidth :: Maybe Int
+    , formatOptionsRenderTags :: Event -> TagRender
     }
 
 -- |
 -- @since 0.10.2.0
 defaultFormatOptions :: FormatOptions
 defaultFormatOptions = FormatOptions
     { 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
+    , formatOptionsRenderTags = renderScalarTags
     }
 
 -- | 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
 setWidth :: Maybe Int -> FormatOptions -> FormatOptions
 setWidth w opts = opts { formatOptionsWidth = w }
 
+-- | Control when and whether tags are rendered to output.
+--
+-- @since 0.11.1.0
+setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions
+setTagRendering f opts = opts { formatOptionsRenderTags = f }
+
 encode :: MonadResource m => ConduitM Event o m ByteString
 encode = encodeWith defaultFormatOptions
 
@@ -756,7 +825,7 @@ runEmitter opts allocI closeI =
         loop = await >>= maybe (close ()) push
 
         push e = do
-            _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
+            _ <- liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter
             loop
         close u = liftIO $ closeI u a
 

yaml/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yaml
 
+## 0.11.1.0
+
+* Add options to `FormatOptions` to govern when tags rendered explicitly and when they are left implicit. [#165](https://github.com/snoyberg/yaml/issues/165)
+
 ## 0.11.0.0
 
 * 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

@@ -8,6 +8,7 @@
 module Data.YamlSpec (main, spec) where
 
 import qualified Text.Libyaml as Y
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B8
 import Data.Int (Int64)
 
@@ -55,6 +56,13 @@ shouldDecode bs expected = do
   actual <- D.decodeThrow bs
   actual `shouldBe` expected
 
+testEncodeWith :: Y.FormatOptions -> [Y.Event] -> IO BS.ByteString
+testEncodeWith opts es = runConduitRes (CL.sourceList events .| Y.encodeWith opts)
+  where
+    events =
+      [Y.EventStreamStart, Y.EventDocumentStart] ++ es ++
+      [Y.EventDocumentEnd, Y.EventStreamEnd]
+
 main :: IO ()
 main = hspec spec
 
@@ -205,6 +213,103 @@ spec = do
       go "12.3015e+02" (1230.15 :: Scientific)
       go "1230.15" (1230.15 :: Scientific)
 
+    describe "Text.Libyaml with default tag rendering" $ do
+      let enc = testEncodeWith Y.defaultFormatOptions
+      it "elides custom sequence tags" $
+        enc taggedSequence `shouldReturn` "[]\n"
+      it "elides custom mapping tags" $
+        enc taggedMapping `shouldReturn` "{}\n"
+      it "elides default sequence tags" $
+        enc defaultTaggedSequence `shouldReturn` "[]\n"
+      it "elides default mapping tags" $
+        enc defaultTaggedMapping `shouldReturn` "{}\n"
+      it "handles NoTag on sequences" $
+        enc untaggedSequence `shouldReturn` "[]\n"
+      it "handles NoTag on mappings" $
+        enc untaggedMapping `shouldReturn` "{}\n"
+      it "handles mixed tag usages but elides all mapping and sequence tags" $
+        enc mixedTagSampleA `shouldReturn` "- {}\n"
+      it "in combination of tags, anchors and styles, outputs only the scalar tags" $
+        enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c [&d !!null '']\n"
+      it "outputs tags when double quoted" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "!!str \"foo\"\n"
+      it "outputs tags when single quoted" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "!!str 'foo'\n"
+      it "outputs tags on literal text" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "!!str |-\n  foo\n"
+      it "outputs tags on folded text" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` "!!str >-\n  foo\n"
+    describe "Text.Libyaml with all tags on" $ do
+      let enc = testEncodeWith $ Y.setTagRendering Y.renderAllTags Y.defaultFormatOptions
+      it "will output custom sequence tags" $
+        enc taggedSequence `shouldReturn` "!foo []\n"
+      it "will output custom mapping tags" $
+        enc taggedMapping `shouldReturn` "!foo {}\n"
+      it "will output default sequence tags" $
+        enc defaultTaggedSequence `shouldReturn` "!!seq []\n"
+      it "will output default mapping tags" $
+        enc defaultTaggedMapping `shouldReturn` "!!map {}\n"
+      it "handles NoTag on sequences" $
+        enc untaggedSequence `shouldReturn` "[]\n"
+      it "handles NoTag on mappings" $
+        enc untaggedMapping `shouldReturn` "{}\n"
+      it "handles mixed tag usages outputting all mapping and sequence tags" $
+        enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
+      it "in combination of tags, anchors and styles, outputs all the tags" $
+        enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d !!null '']\n"
+      it "outputs plain tags" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "!!str foo\n"
+      it "respects PlainNoTag tags" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
+    describe "Text.Libyaml with uri tags on" $ do
+      let enc = testEncodeWith $ Y.setTagRendering Y.renderUriTags Y.defaultFormatOptions
+      it "will output custom sequence tags" $
+        enc taggedSequence `shouldReturn` "!foo []\n"
+      it "will output custom mapping tags" $
+        enc taggedMapping `shouldReturn` "!foo {}\n"
+      it "will output default sequence tags" $
+        enc defaultTaggedSequence `shouldReturn` "[]\n"
+      it "will output default mapping tags" $
+        enc defaultTaggedMapping `shouldReturn` "{}\n"
+      it "handles NoTag on sequences" $
+        enc untaggedSequence `shouldReturn` "[]\n"
+      it "handles NoTag on mappings" $
+        enc untaggedMapping `shouldReturn` "{}\n"
+      it "handles mixed tag usages outputting all mapping and sequence tags" $
+        enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
+      it "in combination of tags, anchors and styles, outputs all the tags" $
+        enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d '']\n"
+    describe "Text.Libyaml with tags off" $ do
+      let enc = testEncodeWith $ Y.setTagRendering Y.renderNoTags Y.defaultFormatOptions
+      it "outputs plain tags" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "foo\n"
+      it "respects PlainNoTag tags" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
+      it "elides tags when double quoted" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "\"foo\"\n"
+      it "elides tags when single quoted" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "'foo'\n"
+      it "elides tags on literal text" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "|-\n  foo\n"
+      it "elides tags on folded text" $
+        enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` ">-\n  foo\n"
+    describe "Text.Libyaml with only UriTags set to render " $ do
+      let enc =
+            testEncodeWith $
+            Y.setTagRendering Y.renderUriTags $ Y.defaultFormatOptions
+      it "outputs only UriTags" $
+        enc
+          [ Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing
+          , Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing
+          , Y.EventScalar "99" Y.IntTag Y.Plain Nothing
+          , Y.EventScalar "99.99" Y.FloatTag Y.Plain Nothing
+          , Y.EventScalar "bar" Y.NoTag Y.Plain Nothing
+          , Y.EventScalar "foo" (Y.UriTag "!foo") Y.DoubleQuoted Nothing
+          , Y.EventScalar "foo" (Y.UriTag "!foo") Y.Plain Nothing
+          , Y.EventSequenceEnd
+          ] `shouldReturn`
+        "[\"foo\", 99, 99.99, bar, !foo \"foo\", !foo foo]\n"
+
 specialStrings :: [T.Text]
 specialStrings =
     [ "fo\"o"
@@ -622,3 +727,50 @@ caseTruncatesFiles = withSystemTempFile "truncate.yaml" $ \fp h -> do
     D.encodeFile fp val
     res <- D.decodeFileEither fp
     either (Left . show) Right res `shouldBe` Right val
+
+
+taggedSequence :: [Y.Event]
+taggedSequence =
+  [ Y.EventSequenceStart (Y.UriTag "!foo") Y.FlowSequence Nothing
+  , Y.EventSequenceEnd
+  ]
+
+taggedMapping :: [Y.Event]
+taggedMapping =
+  [ Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
+  , Y.EventMappingEnd
+  ]
+
+defaultTaggedSequence :: [Y.Event]
+defaultTaggedSequence =
+  [Y.EventSequenceStart Y.SeqTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
+
+defaultTaggedMapping :: [Y.Event]
+defaultTaggedMapping =
+  [Y.EventMappingStart Y.MapTag Y.FlowMapping Nothing, Y.EventMappingEnd]
+
+untaggedSequence :: [Y.Event]
+untaggedSequence =
+  [Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
+
+untaggedMapping :: [Y.Event]
+untaggedMapping =
+  [Y.EventMappingStart Y.NoTag Y.FlowMapping Nothing, Y.EventMappingEnd]
+
+mixedTagSampleA :: [Y.Event]
+mixedTagSampleA =
+  [ Y.EventSequenceStart Y.NoTag Y.BlockSequence Nothing
+  , Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
+  , Y.EventMappingEnd
+  , Y.EventSequenceEnd
+  ]
+
+mixedTagSampleB :: [Y.Event]
+mixedTagSampleB =
+  [ Y.EventMappingStart Y.NoTag Y.BlockMapping (Just "a")
+  , Y.EventScalar "foo" (Y.UriTag "bar") Y.Plain (Just "b")
+  , Y.EventSequenceStart (Y.UriTag "!baz") Y.FlowSequence (Just "c")
+  , Y.EventScalar "" Y.NullTag Y.Plain (Just "d")
+  , Y.EventSequenceEnd
+  , Y.EventMappingEnd
+  ]