diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yaml +## 0.9.0 + +* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141) + ## 0.8.32 * Escape keys as necessary [#137](https://github.com/snoyberg/yaml/issues/137) diff --git a/c/helper.c b/c/helper.c --- a/c/helper.c +++ b/c/helper.c @@ -108,11 +108,6 @@ return s; } -unsigned long get_scalar_tag_len(yaml_event_t *e) -{ - return strlen((char *) get_scalar_tag(e)); -} - int get_scalar_style(yaml_event_t *e) { return e->data.scalar.style; @@ -128,9 +123,33 @@ return e->data.sequence_start.anchor; } +int get_sequence_start_style(yaml_event_t *e) +{ + return e->data.sequence_start.style; +} + +unsigned char * get_sequence_start_tag(yaml_event_t *e) +{ + unsigned char *s = e->data.sequence_start.tag; + if (!s) s = (unsigned char *) ""; + return s; +} + unsigned char * get_mapping_start_anchor(yaml_event_t *e) { return e->data.mapping_start.anchor; +} + +int get_mapping_start_style(yaml_event_t *e) +{ + return e->data.mapping_start.style; +} + +unsigned char * get_mapping_start_tag(yaml_event_t *e) +{ + unsigned char *s = e->data.mapping_start.tag; + if (!s) s = (unsigned char *) ""; + return s; } unsigned char * get_alias_anchor(yaml_event_t *e) diff --git a/c/helper.h b/c/helper.h --- a/c/helper.h +++ b/c/helper.h @@ -28,9 +28,12 @@ unsigned long get_scalar_length(yaml_event_t *e); unsigned char * get_scalar_tag(yaml_event_t *e); -unsigned long get_scalar_tag_len(yaml_event_t *e); +unsigned char * get_sequence_start_tag(yaml_event_t *e); +unsigned char * get_mapping_start_tag(yaml_event_t *e); int get_scalar_style(yaml_event_t *e); +int get_sequence_start_style(yaml_event_t *e); +int get_mapping_start_style(yaml_event_t *e); unsigned char * get_scalar_anchor(yaml_event_t *e); unsigned char * get_sequence_start_anchor(yaml_event_t *e); diff --git a/src/Data/Yaml.hs b/src/Data/Yaml.hs --- a/src/Data/Yaml.hs +++ b/src/Data/Yaml.hs @@ -132,10 +132,10 @@ objToEvents' :: Value -> [Y.Event] -> [Y.Event] --objToEvents' (Scalar s) rest = scalarToEvent s : rest objToEvents' (Array list) rest = - EventSequenceStart Nothing + EventSequenceStart NoTag AnySequence Nothing : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list) objToEvents' (Object pairs) rest = - EventMappingStart Nothing + EventMappingStart NoTag AnyMapping Nothing : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs) -- Empty strings need special handling to ensure they get quoted. This avoids: diff --git a/src/Data/Yaml/Builder.hs b/src/Data/Yaml/Builder.hs --- a/src/Data/Yaml/Builder.hs +++ b/src/Data/Yaml/Builder.hs @@ -62,7 +62,7 @@ mapping :: [(Text, YamlBuilder)] -> YamlBuilder mapping pairs = YamlBuilder $ \rest -> - EventMappingStart Nothing : foldr addPair (EventMappingEnd : rest) pairs + EventMappingStart NoTag AnyMapping Nothing : foldr addPair (EventMappingEnd : rest) pairs where addPair (key, YamlBuilder value) after = EventScalar (encodeUtf8 key) StrTag PlainNoTag Nothing @@ -70,7 +70,7 @@ array :: [YamlBuilder] -> YamlBuilder array bs = - YamlBuilder $ (EventSequenceStart Nothing:) . flip (foldr go) bs . (EventSequenceEnd:) + YamlBuilder $ (EventSequenceStart NoTag AnySequence Nothing:) . flip (foldr go) bs . (EventSequenceEnd:) where go (YamlBuilder b) = b diff --git a/src/Data/Yaml/Internal.hs b/src/Data/Yaml/Internal.hs --- a/src/Data/Yaml/Internal.hs +++ b/src/Data/Yaml/Internal.hs @@ -195,8 +195,8 @@ me <- CL.head case me of Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag - Just (EventSequenceStart a) -> parseS a id - Just (EventMappingStart a) -> parseM a M.empty + Just (EventSequenceStart _ _ a) -> parseS a id + Just (EventMappingStart _ _ a) -> parseM a M.empty Just (EventAlias an) -> do m <- lift get case Map.lookup an m of diff --git a/src/Data/Yaml/Parser.hs b/src/Data/Yaml/Parser.hs --- a/src/Data/Yaml/Parser.hs +++ b/src/Data/Yaml/Parser.hs @@ -162,11 +162,11 @@ go EventDocumentStart = start go (EventAlias a) = return $ Alias a go (EventScalar a b c d) = tell' d $ Scalar a b c d - go (EventSequenceStart mname) = do + go (EventSequenceStart _tag _style mname) = do vals <- goS id let val = Sequence vals mname tell' mname val - go (EventMappingStart mname) = do + go (EventMappingStart _tag _style mname) = do pairs <- goM id let val = Mapping pairs mname tell' mname val diff --git a/src/Text/Libyaml.hs b/src/Text/Libyaml.hs --- a/src/Text/Libyaml.hs +++ b/src/Text/Libyaml.hs @@ -14,6 +14,8 @@ ( -- * The event stream Event (..) , Style (..) + , SequenceStyle (..) + , MappingStyle (..) , Tag (..) , AnchorName , Anchor @@ -49,8 +51,7 @@ import Data.Conduit hiding (Source, Sink, Conduit) import Data.Data -import Data.ByteString (ByteString, packCStringLen) -import qualified Data.ByteString +import Data.ByteString (ByteString, packCString, packCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as BU @@ -62,12 +63,14 @@ | EventDocumentEnd | EventAlias !AnchorName | EventScalar !ByteString !Tag !Style !Anchor - | EventSequenceStart !Anchor + | EventSequenceStart !Tag !SequenceStyle !Anchor | EventSequenceEnd - | EventMappingStart !Anchor + | EventMappingStart !Tag !MappingStyle !Anchor | EventMappingEnd deriving (Show, Eq) +-- | Style for scalars - e.g. quoted / folded +-- data Style = Any | Plain | SingleQuoted @@ -77,6 +80,18 @@ | PlainNoTag deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable) +-- | Style for sequences - e.g. block or flow +-- +-- @since 0.9.0 +data SequenceStyle = AnySequence | BlockSequence | FlowSequence + deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) + +-- | Style for mappings - e.g. block or flow +-- +-- @since 0.9.0 +data MappingStyle = AnyMapping | BlockMapping | FlowMapping + deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable) + data Tag = StrTag | FloatTag | NullTag @@ -217,9 +232,6 @@ foreign import ccall unsafe "get_scalar_tag" c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar) -foreign import ccall unsafe "get_scalar_tag_len" - c_get_scalar_tag_len :: EventRaw -> IO CULong - foreign import ccall unsafe "get_scalar_style" c_get_scalar_style :: EventRaw -> IO CInt @@ -229,12 +241,37 @@ foreign import ccall unsafe "get_sequence_start_anchor" c_get_sequence_start_anchor :: EventRaw -> IO CString +foreign import ccall unsafe "get_sequence_start_style" + c_get_sequence_start_style :: EventRaw -> IO CInt + +foreign import ccall unsafe "get_sequence_start_tag" + c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar) + foreign import ccall unsafe "get_mapping_start_anchor" c_get_mapping_start_anchor :: EventRaw -> IO CString +foreign import ccall unsafe "get_mapping_start_style" + c_get_mapping_start_style :: EventRaw -> IO CInt + +foreign import ccall unsafe "get_mapping_start_tag" + c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar) + foreign import ccall unsafe "get_alias_anchor" c_get_alias_anchor :: EventRaw -> IO CString +readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor +readAnchor getAnchor er = do + yanchor <- getAnchor er + if yanchor == nullPtr + then return Nothing + else Just <$> peekCString yanchor + +readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a +readStyle getStyle er = toEnum . fromEnum <$> getStyle er + +readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag +readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr) + getEvent :: EventRaw -> IO (Maybe Event) getEvent er = do et <- c_get_event_type er @@ -253,37 +290,24 @@ YamlScalarEvent -> do yvalue <- c_get_scalar_value er ylen <- c_get_scalar_length er - ytag <- c_get_scalar_tag er - ytag_len <- c_get_scalar_tag_len er - ystyle <- c_get_scalar_style er - let ytag_len' = fromEnum ytag_len let yvalue' = castPtr yvalue - let ytag' = castPtr ytag let ylen' = fromEnum ylen bs <- packCStringLen (yvalue', ylen') - tagbs <- - if ytag_len' == 0 - then return Data.ByteString.empty - else packCStringLen (ytag', ytag_len') - let style = toEnum $ fromEnum ystyle - yanchor <- c_get_scalar_anchor er - anchor <- if yanchor == nullPtr - then return Nothing - else Just <$> peekCString yanchor - return $ Just $ EventScalar bs (bsToTag tagbs) style anchor + tag <- readTag c_get_scalar_tag er + style <- readStyle c_get_scalar_style er + anchor <- readAnchor c_get_scalar_anchor er + return $ Just $ EventScalar bs tag style anchor YamlSequenceStartEvent -> do - yanchor <- c_get_sequence_start_anchor er - anchor <- if yanchor == nullPtr - then return Nothing - else Just <$> peekCString yanchor - return $ Just $ EventSequenceStart anchor + tag <- readTag c_get_sequence_start_tag er + style <- readStyle c_get_sequence_start_style er + anchor <- readAnchor c_get_sequence_start_anchor er + return $ Just $ EventSequenceStart tag style anchor YamlSequenceEndEvent -> return $ Just EventSequenceEnd YamlMappingStartEvent -> do - yanchor <- c_get_mapping_start_anchor er - anchor <- if yanchor == nullPtr - then return Nothing - else Just <$> peekCString yanchor - return $ Just $ EventMappingStart anchor + tag <- readTag c_get_mapping_start_tag er + style <- readStyle c_get_mapping_start_style er + anchor <- readAnchor c_get_mapping_start_anchor er + return $ Just $ EventMappingStart tag style anchor YamlMappingEndEvent -> return $ Just EventMappingEnd -- Emitter @@ -430,40 +454,48 @@ 0 -- plain_implicit qi -- quoted_implicit style' -- style - EventSequenceStart Nothing -> - c_yaml_sequence_start_event_initialize - er - nullPtr - nullPtr - 1 - 0 -- YAML_ANY_SEQUENCE_STYLE - EventSequenceStart (Just anchor) -> - withCString anchor $ \anchor' -> do - let anchorP = castPtr anchor' + EventSequenceStart tag style Nothing -> + withCString (tagToString tag) $ \tag' -> do + let tagP = castPtr tag' c_yaml_sequence_start_event_initialize - er - anchorP - nullPtr - 1 - 0 -- YAML_ANY_SEQUENCE_STYLE + er + nullPtr + tagP + 1 + (toEnum $ fromEnum style) + EventSequenceStart tag style (Just anchor) -> + withCString (tagToString tag) $ \tag' -> do + let tagP = castPtr tag' + withCString anchor $ \anchor' -> do + let anchorP = castPtr anchor' + c_yaml_sequence_start_event_initialize + er + anchorP + tagP + 1 + (toEnum $ fromEnum style) EventSequenceEnd -> c_yaml_sequence_end_event_initialize er - EventMappingStart Nothing -> - c_yaml_mapping_start_event_initialize - er - nullPtr - nullPtr - 1 - 0 -- YAML_ANY_SEQUENCE_STYLE - EventMappingStart (Just anchor) -> - withCString anchor $ \anchor' -> do - let anchorP = castPtr anchor' + EventMappingStart tag style Nothing -> + withCString (tagToString tag) $ \tag' -> do + let tagP = castPtr tag' c_yaml_mapping_start_event_initialize er - anchorP nullPtr + tagP 1 - 0 -- YAML_ANY_SEQUENCE_STYLE + (toEnum $ fromEnum style) + EventMappingStart tag style (Just anchor) -> + withCString (tagToString tag) $ \tag' -> do + withCString anchor $ \anchor' -> do + let tagP = castPtr tag' + let anchorP = castPtr anchor' + c_yaml_mapping_start_event_initialize + er + anchorP + tagP + 1 + (toEnum $ fromEnum style) EventMappingEnd -> c_yaml_mapping_end_event_initialize er EventAlias anchor -> diff --git a/test/Data/YamlSpec.hs b/test/Data/YamlSpec.hs --- a/test/Data/YamlSpec.hs +++ b/test/Data/YamlSpec.hs @@ -63,6 +63,14 @@ it "count scalars with anchor" caseCountScalarsWithAnchor it "count sequences with anchor" caseCountSequencesWithAnchor it "count mappings with anchor" caseCountMappingsWithAnchor + it "count sequences with custom tag" caseCountSequenceTags + it "count mappings with custom tag" caseCountMappingTags + it "count count sequences with ! tag" caseCountEmptySequenceTags + it "count count mappings with ! tag" caseCountEmptyMappingTags + it "count block style sequences" caseCountBlockStyleSequences + it "count flow style sequences" caseCountFlowStyleSequences + it "count block style mappings" caseCountBlockStyleMappings + it "count flow style mappings" caseCountFlowStyleMappings it "count aliases" caseCountAliases it "count scalars" caseCountScalars it "largest string" caseLargestString @@ -230,7 +238,7 @@ caseHelper yamlString isSequenceStartA 1 where yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3" - isSequenceStartA (Y.EventSequenceStart (Just _)) = True + isSequenceStartA (Y.EventSequenceStart Y.NoTag _ (Just _)) = True isSequenceStartA _ = False caseCountMappingsWithAnchor :: Assertion @@ -238,7 +246,7 @@ caseHelper yamlString isMappingA 1 where yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3" - isMappingA (Y.EventMappingStart (Just _)) = True + isMappingA (Y.EventMappingStart _ _ (Just _)) = True isMappingA _ = False caseCountAliases :: Assertion @@ -248,6 +256,70 @@ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor" isAlias Y.EventAlias{} = True isAlias _ = False + +caseCountMappingTags :: Assertion +caseCountMappingTags = + caseHelper yamlString isCustomTaggedMapping 1 + where + yamlString = "foo: !bar\n k: v\n k2: v2" + isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!bar") _ _) = True + isCustomTaggedMapping _ = False + +caseCountEmptyMappingTags :: Assertion +caseCountEmptyMappingTags = + caseHelper yamlString isCustomTaggedMapping 1 + where + yamlString = "foo: !\n k: v\n k2: v2" + isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!") _ _) = True + isCustomTaggedMapping _ = False + +caseCountSequenceTags :: Assertion +caseCountSequenceTags = + caseHelper yamlString isCustomTaggedSequence 1 + where + yamlString = "foo: !bar [x, y, z]" + isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!bar") _ _) = True + isCustomTaggedSequence _ = False + +caseCountEmptySequenceTags :: Assertion +caseCountEmptySequenceTags = + caseHelper yamlString isCustomTaggedSequence 1 + where + yamlString = "foo: ! [x, y, z]" + isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!") _ _) = True + isCustomTaggedSequence _ = False + +caseCountFlowStyleSequences :: Assertion +caseCountFlowStyleSequences = + caseHelper yamlString isFlowStyleSequence 1 + where + yamlString = "foo: [x, y, z]" + isFlowStyleSequence (Y.EventSequenceStart _ Y.FlowSequence _) = True + isFlowStyleSequence _ = False + +caseCountBlockStyleSequences :: Assertion +caseCountBlockStyleSequences = + caseHelper yamlString isBlockStyleSequence 1 + where + yamlString = "foo:\n- x\n- y\n- z\n" + isBlockStyleSequence (Y.EventSequenceStart _ Y.BlockSequence _) = True + isBlockStyleSequence _ = False + +caseCountFlowStyleMappings :: Assertion +caseCountFlowStyleMappings = + caseHelper yamlString isFlowStyleMapping 1 + where + yamlString = "foo: { bar: 1, baz: 2 }" + isFlowStyleMapping (Y.EventMappingStart _ Y.FlowMapping _) = True + isFlowStyleMapping _ = False + +caseCountBlockStyleMappings :: Assertion +caseCountBlockStyleMappings = + caseHelper yamlString isBlockStyleMapping 1 + where + yamlString = "foo: bar\nbaz: quux" + isBlockStyleMapping (Y.EventMappingStart _ Y.BlockMapping _) = True + isBlockStyleMapping _ = False caseCountScalars :: Assertion caseCountScalars = do diff --git a/yaml.cabal b/yaml.cabal --- a/yaml.cabal +++ b/yaml.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 7a233a8f2ad181b26ff4049e7128d5380951fb67007e81166d2364c7dada6b95 +-- hash: 2de1bae80ae10ae93990897198f5e06bc3ff88eefd9e0087e6384bca7a887515 name: yaml -version: 0.8.32 +version: 0.9.0 synopsis: Support for parsing and rendering YAML documents. description: README and API documentation are available at category: Data