f01e81c · typeable/yaml

git.iko.soy/typeable/yaml

Merge pull request #141 from curvelogic/feature/expose-mapping-tags

Expose tags and styles for sequences and mappings in Text.Libyaml

commitf01e81ced5baa538aa225fe4516e3735169463c1 authorMichael Snoyman <michael@snoyman.com> dateTue 10 Jul 2018, 18:30 (8 years ago) parentdbbcfe1 b419d51

10 files changed+206−76

compare with master

unifiedsplit

ChangeLog.md+4 c/helper.c+24−5 c/helper.h+4−1 package.yaml+1−1 src/Data/Yaml.hs+2−2 src/Data/Yaml/Builder.hs+2−2 src/Data/Yaml/Internal.hs+2−2 src/Data/Yaml/Parser.hs+2−2 src/Text/Libyaml.hs+91−59 test/Data/YamlSpec.hs+74−2

ChangeLog.md+4

@@ -1,5 +1,9 @@

11# ChangeLog for yaml

3+## 0.9.0

5+* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)

37## 0.8.32

59* Escape keys as necessary [#137](https://github.com/snoyberg/yaml/issues/137)

c/helper.c+24−5

@@ -108,11 +108,6 @@ unsigned char * get_scalar_tag(yaml_event_t *e)

108108 return s;

109109}

110110

111−unsigned long get_scalar_tag_len(yaml_event_t *e)

112−{

113− return strlen((char *) get_scalar_tag(e));

114−}

115−

116111int get_scalar_style(yaml_event_t *e)

117112{

118113 return e->data.scalar.style;

@@ -128,11 +123,35 @@ unsigned char * get_sequence_start_anchor(yaml_event_t *e)

128123 return e->data.sequence_start.anchor;

129124}

130125

126+int get_sequence_start_style(yaml_event_t *e)

127+{

128+ return e->data.sequence_start.style;

129+}

130+

131+unsigned char * get_sequence_start_tag(yaml_event_t *e)

132+{

133+ unsigned char *s = e->data.sequence_start.tag;

134+ if (!s) s = (unsigned char *) "";

135+ return s;

136+}

137+

131138unsigned char * get_mapping_start_anchor(yaml_event_t *e)

132139{

133140 return e->data.mapping_start.anchor;

134141}

135142

143+int get_mapping_start_style(yaml_event_t *e)

144+{

145+ return e->data.mapping_start.style;

146+}

147+

148+unsigned char * get_mapping_start_tag(yaml_event_t *e)

149+{

150+ unsigned char *s = e->data.mapping_start.tag;

151+ if (!s) s = (unsigned char *) "";

152+ return s;

153+}

154+

136155unsigned char * get_alias_anchor(yaml_event_t *e)

137156{

138157 return e->data.alias.anchor;

c/helper.h+4−1

@@ -28,9 +28,12 @@ unsigned char * get_scalar_value(yaml_event_t *e);

2828unsigned long get_scalar_length(yaml_event_t *e);

2929

3030unsigned char * get_scalar_tag(yaml_event_t *e);

31−unsigned long get_scalar_tag_len(yaml_event_t *e);

31+unsigned char * get_sequence_start_tag(yaml_event_t *e);

32+unsigned char * get_mapping_start_tag(yaml_event_t *e);

3233

3334int get_scalar_style(yaml_event_t *e);

35+int get_sequence_start_style(yaml_event_t *e);

36+int get_mapping_start_style(yaml_event_t *e);

3437

3538unsigned char * get_scalar_anchor(yaml_event_t *e);

3639unsigned char * get_sequence_start_anchor(yaml_event_t *e);

package.yaml+1−1

@@ -1,5 +1,5 @@

11name: yaml

2−version: 0.8.32

2+version: 0.9.0

33synopsis: Support for parsing and rendering YAML documents.

44description: README and API documentation are available at <https://www.stackage.org/package/yaml>

55category: Data

src/Data/Yaml.hs+2−2

@@ -132,10 +132,10 @@ scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing

132132objToEvents' :: Value -> [Y.Event] -> [Y.Event]

133133--objToEvents' (Scalar s) rest = scalarToEvent s : rest

134134objToEvents' (Array list) rest =

135− EventSequenceStart Nothing

135+ EventSequenceStart NoTag AnySequence Nothing

136136 : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list)

137137objToEvents' (Object pairs) rest =

138− EventMappingStart Nothing

138+ EventMappingStart NoTag AnyMapping Nothing

139139 : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs)

140140

141141-- Empty strings need special handling to ensure they get quoted. This avoids:

src/Data/Yaml/Builder.hs+2−2

@@ -62,7 +62,7 @@ instance ToYaml Int where

6262

6363mapping :: [(Text, YamlBuilder)] -> YamlBuilder

6464mapping pairs = YamlBuilder $ \rest ->

65− EventMappingStart Nothing : foldr addPair (EventMappingEnd : rest) pairs

65+ EventMappingStart NoTag AnyMapping Nothing : foldr addPair (EventMappingEnd : rest) pairs

6666 where

6767 addPair (key, YamlBuilder value) after

6868 = EventScalar (encodeUtf8 key) StrTag PlainNoTag Nothing

@@ -70,7 +70,7 @@ mapping pairs = YamlBuilder $ \rest ->

7070

7171array :: [YamlBuilder] -> YamlBuilder

7272array bs =

73− YamlBuilder $ (EventSequenceStart Nothing:) . flip (foldr go) bs . (EventSequenceEnd:)

73+ YamlBuilder $ (EventSequenceStart NoTag AnySequence Nothing:) . flip (foldr go) bs . (EventSequenceEnd:)

7474 where

7575 go (YamlBuilder b) = b

7676

src/Data/Yaml/Internal.hs+2−2

@@ -195,8 +195,8 @@ parseO = do

195195 me <- CL.head

196196 case me of

197197 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag

198− Just (EventSequenceStart a) -> parseS a id

199− Just (EventMappingStart a) -> parseM a M.empty

198+ Just (EventSequenceStart _ _ a) -> parseS a id

199+ Just (EventMappingStart _ _ a) -> parseM a M.empty

200200 Just (EventAlias an) -> do

201201 m <- lift get

202202 case Map.lookup an m of

src/Data/Yaml/Parser.hs+2−2

@@ -162,11 +162,11 @@ sinkValue =

162162 go EventDocumentStart = start

163163 go (EventAlias a) = return $ Alias a

164164 go (EventScalar a b c d) = tell' d $ Scalar a b c d

165− go (EventSequenceStart mname) = do

165+ go (EventSequenceStart _tag _style mname) = do

166166 vals <- goS id

167167 let val = Sequence vals mname

168168 tell' mname val

169− go (EventMappingStart mname) = do

169+ go (EventMappingStart _tag _style mname) = do

170170 pairs <- goM id

171171 let val = Mapping pairs mname

172172 tell' mname val

src/Text/Libyaml.hs+91−59

@@ -14,6 +14,8 @@ module Text.Libyaml

1414 ( -- * The event stream

1515 Event (..)

1616 , Style (..)

17+ , SequenceStyle (..)

18+ , MappingStyle (..)

1719 , Tag (..)

1820 , AnchorName

1921 , Anchor

@@ -49,8 +51,7 @@ import Control.Monad.Trans.Resource

4951import Data.Conduit hiding (Source, Sink, Conduit)

5052import Data.Data

5153

52−import Data.ByteString (ByteString, packCStringLen)

53−import qualified Data.ByteString

54+import Data.ByteString (ByteString, packCString, packCStringLen)

5455import qualified Data.ByteString.Char8 as B8

5556import qualified Data.ByteString.Internal as B

5657import qualified Data.ByteString.Unsafe as BU

@@ -62,12 +63,14 @@ data Event =

6263 | EventDocumentEnd

6364 | EventAlias !AnchorName

6465 | EventScalar !ByteString !Tag !Style !Anchor

65− | EventSequenceStart !Anchor

66+ | EventSequenceStart !Tag !SequenceStyle !Anchor

6667 | EventSequenceEnd

67− | EventMappingStart !Anchor

68+ | EventMappingStart !Tag !MappingStyle !Anchor

6869 | EventMappingEnd

6970 deriving (Show, Eq)

7071

72+-- | Style for scalars - e.g. quoted / folded

73+--

7174data Style = Any

7275 | Plain

7376 | SingleQuoted

@@ -77,6 +80,18 @@ data Style = Any

7780 | PlainNoTag

7881 deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable)

7982

83+-- | Style for sequences - e.g. block or flow

84+--

85+-- @since 0.9.0

86+data SequenceStyle = AnySequence | BlockSequence | FlowSequence

87+ deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable)

88+

89+-- | Style for mappings - e.g. block or flow

90+--

91+-- @since 0.9.0

92+data MappingStyle = AnyMapping | BlockMapping | FlowMapping

93+ deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable)

94+

8095data Tag = StrTag

8196 | FloatTag

8297 | NullTag

@@ -217,9 +232,6 @@ foreign import ccall unsafe "get_scalar_length"

217232foreign import ccall unsafe "get_scalar_tag"

218233 c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)

219234

220−foreign import ccall unsafe "get_scalar_tag_len"

221− c_get_scalar_tag_len :: EventRaw -> IO CULong

222−

223235foreign import ccall unsafe "get_scalar_style"

224236 c_get_scalar_style :: EventRaw -> IO CInt

225237

@@ -229,12 +241,37 @@ foreign import ccall unsafe "get_scalar_anchor"

229241foreign import ccall unsafe "get_sequence_start_anchor"

230242 c_get_sequence_start_anchor :: EventRaw -> IO CString

231243

244+foreign import ccall unsafe "get_sequence_start_style"

245+ c_get_sequence_start_style :: EventRaw -> IO CInt

246+

247+foreign import ccall unsafe "get_sequence_start_tag"

248+ c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar)

249+

232250foreign import ccall unsafe "get_mapping_start_anchor"

233251 c_get_mapping_start_anchor :: EventRaw -> IO CString

234252

253+foreign import ccall unsafe "get_mapping_start_style"

254+ c_get_mapping_start_style :: EventRaw -> IO CInt

255+

256+foreign import ccall unsafe "get_mapping_start_tag"

257+ c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar)

258+

235259foreign import ccall unsafe "get_alias_anchor"

236260 c_get_alias_anchor :: EventRaw -> IO CString

237261

262+readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor

263+readAnchor getAnchor er = do

264+ yanchor <- getAnchor er

265+ if yanchor == nullPtr

266+ then return Nothing

267+ else Just <$> peekCString yanchor

268+

269+readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a

270+readStyle getStyle er = toEnum . fromEnum <$> getStyle er

271+

272+readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag

273+readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr)

274+

238275getEvent :: EventRaw -> IO (Maybe Event)

239276getEvent er = do

240277 et <- c_get_event_type er

@@ -253,37 +290,24 @@ getEvent er = do

253290 YamlScalarEvent -> do

254291 yvalue <- c_get_scalar_value er

255292 ylen <- c_get_scalar_length er

256− ytag <- c_get_scalar_tag er

257− ytag_len <- c_get_scalar_tag_len er

258− ystyle <- c_get_scalar_style er

259− let ytag_len' = fromEnum ytag_len

260293 let yvalue' = castPtr yvalue

261− let ytag' = castPtr ytag

262294 let ylen' = fromEnum ylen

263295 bs <- packCStringLen (yvalue', ylen')

264− tagbs <-

265− if ytag_len' == 0

266− then return Data.ByteString.empty

267− else packCStringLen (ytag', ytag_len')

268− let style = toEnum $ fromEnum ystyle

269− yanchor <- c_get_scalar_anchor er

270− anchor <- if yanchor == nullPtr

271− then return Nothing

272− else Just <$> peekCString yanchor

273− return $ Just $ EventScalar bs (bsToTag tagbs) style anchor

296+ tag <- readTag c_get_scalar_tag er

297+ style <- readStyle c_get_scalar_style er

298+ anchor <- readAnchor c_get_scalar_anchor er

299+ return $ Just $ EventScalar bs tag style anchor

274300 YamlSequenceStartEvent -> do

275− yanchor <- c_get_sequence_start_anchor er

276− anchor <- if yanchor == nullPtr

277− then return Nothing

278− else Just <$> peekCString yanchor

279− return $ Just $ EventSequenceStart anchor

301+ tag <- readTag c_get_sequence_start_tag er

302+ style <- readStyle c_get_sequence_start_style er

303+ anchor <- readAnchor c_get_sequence_start_anchor er

304+ return $ Just $ EventSequenceStart tag style anchor

280305 YamlSequenceEndEvent -> return $ Just EventSequenceEnd

281306 YamlMappingStartEvent -> do

282− yanchor <- c_get_mapping_start_anchor er

283− anchor <- if yanchor == nullPtr

284− then return Nothing

285− else Just <$> peekCString yanchor

286− return $ Just $ EventMappingStart anchor

307+ tag <- readTag c_get_mapping_start_tag er

308+ style <- readStyle c_get_mapping_start_style er

309+ anchor <- readAnchor c_get_mapping_start_anchor er

310+ return $ Just $ EventMappingStart tag style anchor

287311 YamlMappingEndEvent -> return $ Just EventMappingEnd

288312

289313-- Emitter

@@ -430,40 +454,48 @@ toEventRaw e f = allocaBytes eventSize $ \er -> do

430454 0 -- plain_implicit

431455 qi -- quoted_implicit

432456 style' -- style

433− EventSequenceStart Nothing ->

434− c_yaml_sequence_start_event_initialize

435− er

436− nullPtr

437− nullPtr

438− 1

439− 0 -- YAML_ANY_SEQUENCE_STYLE

440− EventSequenceStart (Just anchor) ->

441− withCString anchor $ \anchor' -> do

442− let anchorP = castPtr anchor'

457+ EventSequenceStart tag style Nothing ->

458+ withCString (tagToString tag) $ \tag' -> do

459+ let tagP = castPtr tag'

443460 c_yaml_sequence_start_event_initialize

444− er

445− anchorP

446− nullPtr

447− 1

448− 0 -- YAML_ANY_SEQUENCE_STYLE

461+ er

462+ nullPtr

463+ tagP

464+ 1

465+ (toEnum $ fromEnum style)

466+ EventSequenceStart tag style (Just anchor) ->

467+ withCString (tagToString tag) $ \tag' -> do

468+ let tagP = castPtr tag'

469+ withCString anchor $ \anchor' -> do

470+ let anchorP = castPtr anchor'

471+ c_yaml_sequence_start_event_initialize

472+ er

473+ anchorP

474+ tagP

475+ 1

476+ (toEnum $ fromEnum style)

449477 EventSequenceEnd ->

450478 c_yaml_sequence_end_event_initialize er

451− EventMappingStart Nothing ->

452− c_yaml_mapping_start_event_initialize

453− er

454− nullPtr

455− nullPtr

456− 1

457− 0 -- YAML_ANY_SEQUENCE_STYLE

458− EventMappingStart (Just anchor) ->

459− withCString anchor $ \anchor' -> do

460− let anchorP = castPtr anchor'

479+ EventMappingStart tag style Nothing ->

480+ withCString (tagToString tag) $ \tag' -> do

481+ let tagP = castPtr tag'

461482 c_yaml_mapping_start_event_initialize

462483 er

463− anchorP

464484 nullPtr

485+ tagP

465486 1

466− 0 -- YAML_ANY_SEQUENCE_STYLE

487+ (toEnum $ fromEnum style)

488+ EventMappingStart tag style (Just anchor) ->

489+ withCString (tagToString tag) $ \tag' -> do

490+ withCString anchor $ \anchor' -> do

491+ let tagP = castPtr tag'

492+ let anchorP = castPtr anchor'

493+ c_yaml_mapping_start_event_initialize

494+ er

495+ anchorP

496+ tagP

497+ 1

498+ (toEnum $ fromEnum style)

467499 EventMappingEnd ->

468500 c_yaml_mapping_end_event_initialize er

469501 EventAlias anchor ->

test/Data/YamlSpec.hs+74−2

@@ -63,6 +63,14 @@ spec = do

6363 it "count scalars with anchor" caseCountScalarsWithAnchor

6464 it "count sequences with anchor" caseCountSequencesWithAnchor

6565 it "count mappings with anchor" caseCountMappingsWithAnchor

66+ it "count sequences with custom tag" caseCountSequenceTags

67+ it "count mappings with custom tag" caseCountMappingTags

68+ it "count count sequences with ! tag" caseCountEmptySequenceTags

69+ it "count count mappings with ! tag" caseCountEmptyMappingTags

70+ it "count block style sequences" caseCountBlockStyleSequences

71+ it "count flow style sequences" caseCountFlowStyleSequences

72+ it "count block style mappings" caseCountBlockStyleMappings

73+ it "count flow style mappings" caseCountFlowStyleMappings

6674 it "count aliases" caseCountAliases

6775 it "count scalars" caseCountScalars

6876 it "largest string" caseLargestString

@@ -230,7 +238,7 @@ caseCountSequencesWithAnchor =

230238 caseHelper yamlString isSequenceStartA 1

231239 where

232240 yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"

233− isSequenceStartA (Y.EventSequenceStart (Just _)) = True

241+ isSequenceStartA (Y.EventSequenceStart Y.NoTag _ (Just _)) = True

234242 isSequenceStartA _ = False

235243

236244caseCountMappingsWithAnchor :: Assertion

@@ -238,7 +246,7 @@ caseCountMappingsWithAnchor =

238246 caseHelper yamlString isMappingA 1

239247 where

240248 yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"

241− isMappingA (Y.EventMappingStart (Just _)) = True

249+ isMappingA (Y.EventMappingStart _ _ (Just _)) = True

242250 isMappingA _ = False

243251

244252caseCountAliases :: Assertion

@@ -249,6 +257,70 @@ caseCountAliases =

249257 isAlias Y.EventAlias{} = True

250258 isAlias _ = False

251259

260+caseCountMappingTags :: Assertion

261+caseCountMappingTags =

262+ caseHelper yamlString isCustomTaggedMapping 1

263+ where

264+ yamlString = "foo: !bar\n k: v\n k2: v2"

265+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!bar") _ _) = True

266+ isCustomTaggedMapping _ = False

267+

268+caseCountEmptyMappingTags :: Assertion

269+caseCountEmptyMappingTags =

270+ caseHelper yamlString isCustomTaggedMapping 1

271+ where

272+ yamlString = "foo: !\n k: v\n k2: v2"

273+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!") _ _) = True

274+ isCustomTaggedMapping _ = False

275+

276+caseCountSequenceTags :: Assertion

277+caseCountSequenceTags =

278+ caseHelper yamlString isCustomTaggedSequence 1

279+ where

280+ yamlString = "foo: !bar [x, y, z]"

281+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!bar") _ _) = True

282+ isCustomTaggedSequence _ = False

283+

284+caseCountEmptySequenceTags :: Assertion

285+caseCountEmptySequenceTags =

286+ caseHelper yamlString isCustomTaggedSequence 1

287+ where

288+ yamlString = "foo: ! [x, y, z]"

289+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!") _ _) = True

290+ isCustomTaggedSequence _ = False

291+

292+caseCountFlowStyleSequences :: Assertion

293+caseCountFlowStyleSequences =

294+ caseHelper yamlString isFlowStyleSequence 1

295+ where

296+ yamlString = "foo: [x, y, z]"

297+ isFlowStyleSequence (Y.EventSequenceStart _ Y.FlowSequence _) = True

298+ isFlowStyleSequence _ = False

299+

300+caseCountBlockStyleSequences :: Assertion

301+caseCountBlockStyleSequences =

302+ caseHelper yamlString isBlockStyleSequence 1

303+ where

304+ yamlString = "foo:\n- x\n- y\n- z\n"

305+ isBlockStyleSequence (Y.EventSequenceStart _ Y.BlockSequence _) = True

306+ isBlockStyleSequence _ = False

307+

308+caseCountFlowStyleMappings :: Assertion

309+caseCountFlowStyleMappings =

310+ caseHelper yamlString isFlowStyleMapping 1

311+ where

312+ yamlString = "foo: { bar: 1, baz: 2 }"

313+ isFlowStyleMapping (Y.EventMappingStart _ Y.FlowMapping _) = True

314+ isFlowStyleMapping _ = False

315+

316+caseCountBlockStyleMappings :: Assertion

317+caseCountBlockStyleMappings =

318+ caseHelper yamlString isBlockStyleMapping 1

319+ where

320+ yamlString = "foo: bar\nbaz: quux"

321+ isBlockStyleMapping (Y.EventMappingStart _ Y.BlockMapping _) = True

322+ isBlockStyleMapping _ = False

323+

252324caseCountScalars :: Assertion

253325caseCountScalars = do

254326 res <- runConduitRes $ Y.decode yamlBS .| CL.fold adder accum