git.iko.soy/typeable/yaml
on master help sign in
Added anchors and aliases supporting
0fa213eAnton Ageev
Text/Libyaml.hs+113−25
compare with master
unifiedsplit
@@ -26,7 +26,9 @@ module Text.Libyaml
26 , emitStream
26 , emitStream
27 , emitDocument
27 , emitDocument
28 , emitSequence
28 , emitSequence
29+ , emitSequenceWithAnchor
29 , emitMapping
30 , emitMapping
31+ , emitMappingWithAnchor
30 -- * Higher level functions
32 -- * Higher level functions
31 , encode
33 , encode
32 , decode
34 , decode
@@ -57,11 +59,11 @@ data Event =
57 | EventStreamEnd
59 | EventStreamEnd
58 | EventDocumentStart
60 | EventDocumentStart
59 | EventDocumentEnd
61 | EventDocumentEnd
60− | EventAlias
62+ | EventAlias !AnchorName
61− | EventScalar !ByteString !Tag !Style
63+ | EventScalar !ByteString !Tag !Style !Anchor
62− | EventSequenceStart
64+ | EventSequenceStart !Anchor
63 | EventSequenceEnd
65 | EventSequenceEnd
64− | EventMappingStart
66+ | EventMappingStart !Anchor
65 | EventMappingEnd
67 | EventMappingEnd
66 deriving (Show, Eq)
68 deriving (Show, Eq)
67
69
@@ -85,6 +87,9 @@ data Tag = StrTag
85 | NoTag
87 | NoTag
86 deriving (Show, Eq)
88 deriving (Show, Eq)
87
89
90+type AnchorName = String
91+type Anchor = Maybe AnchorName
92+
88tagToString :: Tag -> String
93tagToString :: Tag -> String
89tagToString StrTag = "tag:yaml.org,2002:str"
94tagToString StrTag = "tag:yaml.org,2002:str"
90tagToString FloatTag = "tag:yaml.org,2002:float"
95tagToString FloatTag = "tag:yaml.org,2002:float"
@@ -296,6 +301,18 @@ foreign import ccall unsafe "get_scalar_tag_len"
296foreign import ccall unsafe "get_scalar_style"
301foreign import ccall unsafe "get_scalar_style"
297 c_get_scalar_style :: EventRaw -> IO CInt
302 c_get_scalar_style :: EventRaw -> IO CInt
298
303
304+foreign import ccall unsafe "get_scalar_anchor"
305+ c_get_scalar_anchor :: EventRaw -> IO CString
306+
307+foreign import ccall unsafe "get_sequence_start_anchor"
308+ c_get_sequence_start_anchor :: EventRaw -> IO CString
309+
310+foreign import ccall unsafe "get_mapping_start_anchor"
311+ c_get_mapping_start_anchor :: EventRaw -> IO CString
312+
313+foreign import ccall unsafe "get_alias_anchor"
314+ c_get_alias_anchor :: EventRaw -> IO CString
315+
299getEvent :: EventRaw -> IO Event
316getEvent :: EventRaw -> IO Event
300getEvent er = do
317getEvent er = do
301 et <- c_get_event_type er
318 et <- c_get_event_type er
@@ -305,7 +322,12 @@ getEvent er = do
305 YamlStreamEndEvent -> return EventStreamEnd
322 YamlStreamEndEvent -> return EventStreamEnd
306 YamlDocumentStartEvent -> return EventDocumentStart
323 YamlDocumentStartEvent -> return EventDocumentStart
307 YamlDocumentEndEvent -> return EventDocumentEnd
324 YamlDocumentEndEvent -> return EventDocumentEnd
325+ YamlAliasEvent -> do
326+ yanchor <- c_get_alias_anchor er
327+ anchor <- if yanchor == nullPtr
328+ then error "got YamlAliasEvent with empty anchor"
329+ else peekCString yanchor
308− YamlAliasEvent -> return EventAlias
330+ return $ EventAlias anchor
309 YamlScalarEvent -> do
331 YamlScalarEvent -> do
310 yvalue <- c_get_scalar_value er
332 yvalue <- c_get_scalar_value er
311 ylen <- c_get_scalar_length er
333 ylen <- c_get_scalar_length er
@@ -324,10 +346,24 @@ getEvent er = do
324 else B.create ytag_len'
346 else B.create ytag_len'
325 $ \dest -> B.memcpy dest ytag' (toEnum ytag_len')
347 $ \dest -> B.memcpy dest ytag' (toEnum ytag_len')
326 let style = toEnum $ fromEnum ystyle
348 let style = toEnum $ fromEnum ystyle
349+ yanchor <- c_get_scalar_anchor er
350+ anchor <- if yanchor == nullPtr
351+ then return Nothing
352+ else fmap Just $ peekCString yanchor
327− return $ EventScalar bs (bsToTag tagbs) style
353+ return $ EventScalar bs (bsToTag tagbs) style anchor
328− YamlSequenceStartEvent -> return EventSequenceStart
354+ YamlSequenceStartEvent -> do
355+ yanchor <- c_get_sequence_start_anchor er
356+ anchor <- if yanchor == nullPtr
357+ then return Nothing
358+ else fmap Just $ peekCString yanchor
359+ return $ EventSequenceStart anchor
329 YamlSequenceEndEvent -> return EventSequenceEnd
360 YamlSequenceEndEvent -> return EventSequenceEnd
330− YamlMappingStartEvent -> return EventMappingStart
361+ YamlMappingStartEvent -> do
362+ yanchor <- c_get_mapping_start_anchor er
363+ anchor <- if yanchor == nullPtr
364+ then return Nothing
365+ else fmap Just $ peekCString yanchor
366+ return $ EventMappingStart anchor
331 YamlMappingEndEvent -> return EventMappingEnd
367 YamlMappingEndEvent -> return EventMappingEnd
332
368
333-- Emitter
369-- Emitter
@@ -429,10 +465,19 @@ emitStream, emitDocument, emitSequence, emitMapping
429emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd
465emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd
430emitDocument e = emitEvent EventDocumentStart >> e
466emitDocument e = emitEvent EventDocumentStart >> e
431 >> emitEvent EventDocumentEnd
467 >> emitEvent EventDocumentEnd
468+emitSequence e = emitSequenceWithAnchor e Nothing
469+emitMapping e = emitMappingWithAnchor e Nothing
470+
471+emitSequenceWithAnchor, emitMappingWithAnchor
472+ :: (MonadIO m, MonadFailure YamlException m)
473+ => YamlEncoder m ()
474+ -> Anchor
475+ -> YamlEncoder m ()
432−emitSequence e = emitEvent EventSequenceStart >> e
476+emitSequenceWithAnchor e a = emitEvent (EventSequenceStart a) >> e
433− >> emitEvent EventSequenceEnd
477+ >> emitEvent EventSequenceEnd
434−emitMapping e = emitEvent EventMappingStart >> e
478+emitMappingWithAnchor e a = emitEvent (EventMappingStart a) >> e
435− >> emitEvent EventMappingEnd
479+ >> emitEvent EventMappingEnd
480+
436
481
437parseEvent :: (With m, MonadFailure YamlException m)
482parseEvent :: (With m, MonadFailure YamlException m)
438 => YamlDecoder m Event
483 => YamlDecoder m Event
@@ -489,6 +534,12 @@ foreign import ccall unsafe "yaml_mapping_start_event_initialize"
489foreign import ccall unsafe "yaml_mapping_end_event_initialize"
534foreign import ccall unsafe "yaml_mapping_end_event_initialize"
490 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
535 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
491
536
537+foreign import ccall unsafe "yaml_alias_event_initialize"
538+ c_yaml_alias_event_initialize
539+ :: EventRaw
540+ -> Ptr CUChar
541+ -> IO CInt
542+
492toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
543toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
493toEventRaw e f = allocaBytesR eventSize $ \er -> do
544toEventRaw e f = allocaBytesR eventSize $ \er -> do
494 ret <- case e of
545 ret <- case e of
@@ -502,7 +553,7 @@ toEventRaw e f = allocaBytesR eventSize $ \er -> do
502 c_simple_document_start er
553 c_simple_document_start er
503 EventDocumentEnd ->
554 EventDocumentEnd ->
504 c_yaml_document_end_event_initialize er 1
555 c_yaml_document_end_event_initialize er 1
505− EventScalar bs thetag style -> do
556+ EventScalar bs thetag style anchor -> do
506 let (fvalue, offset, len) = B.toForeignPtr bs
557 let (fvalue, offset, len) = B.toForeignPtr bs
507 withForeignPtr fvalue $ \value -> do
558 withForeignPtr fvalue $ \value -> do
508 let value' = value `plusPtr` offset
559 let value' = value `plusPtr` offset
@@ -515,34 +566,71 @@ toEventRaw e f = allocaBytesR eventSize $ \er -> do
515 let style' = toEnum $ fromEnum style
566 let style' = toEnum $ fromEnum style
516 tagP = castPtr tag'
567 tagP = castPtr tag'
517 qi = if null thetag' then 1 else 0
568 qi = if null thetag' then 1 else 0
569+ case anchor of
570+ Nothing ->
518− c_yaml_scalar_event_initialize
571+ c_yaml_scalar_event_initialize
519− er
572+ er
520− nullPtr -- anchor
573+ nullPtr -- anchor
521− tagP -- tag
574+ tagP -- tag
522− value'' -- value
575+ value'' -- value
523− len' -- length
576+ len' -- length
524− 0 -- plain_implicit
577+ 0 -- plain_implicit
525− qi -- quoted_implicit
578+ qi -- quoted_implicit
579+ style' -- style
580+ Just anchor' ->
581+ withCString anchor' $ \anchorP' -> do
582+ let anchorP = castPtr anchorP'
583+ c_yaml_scalar_event_initialize
584+ er
585+ anchorP -- anchor
586+ tagP -- tag
587+ value'' -- value
588+ len' -- length
589+ 0 -- plain_implicit
590+ qi -- quoted_implicit
526− style' -- style
591+ style' -- style
527− EventSequenceStart ->
592+ EventSequenceStart Nothing ->
528 c_yaml_sequence_start_event_initialize
593 c_yaml_sequence_start_event_initialize
529 er
594 er
530 nullPtr
595 nullPtr
531 nullPtr
596 nullPtr
532 1
597 1
533 0 -- YAML_ANY_SEQUENCE_STYLE
598 0 -- YAML_ANY_SEQUENCE_STYLE
599+ EventSequenceStart (Just anchor) ->
600+ withCString anchor $ \anchor' -> do
601+ let anchorP = castPtr anchor'
602+ c_yaml_sequence_start_event_initialize
603+ er
604+ anchorP
605+ nullPtr
606+ 1
607+ 0 -- YAML_ANY_SEQUENCE_STYLE
534 EventSequenceEnd ->
608 EventSequenceEnd ->
535 c_yaml_sequence_end_event_initialize er
609 c_yaml_sequence_end_event_initialize er
536− EventMappingStart ->
610+ EventMappingStart Nothing ->
537 c_yaml_mapping_start_event_initialize
611 c_yaml_mapping_start_event_initialize
538 er
612 er
539 nullPtr
613 nullPtr
540 nullPtr
614 nullPtr
541 1
615 1
542 0 -- YAML_ANY_SEQUENCE_STYLE
616 0 -- YAML_ANY_SEQUENCE_STYLE
617+ EventMappingStart (Just anchor) ->
618+ withCString anchor $ \anchor' -> do
619+ let anchorP = castPtr anchor'
620+ c_yaml_mapping_start_event_initialize
621+ er
622+ anchorP
623+ nullPtr
624+ 1
625+ 0 -- YAML_ANY_SEQUENCE_STYLE
543 EventMappingEnd ->
626 EventMappingEnd ->
544 c_yaml_mapping_end_event_initialize er
627 c_yaml_mapping_end_event_initialize er
545− EventAlias -> error "toEventRaw: EventAlias not supported"
628+ EventAlias anchor ->
629+ withCString anchor $ \anchorP' -> do
630+ let anchorP = castPtr anchorP'
631+ c_yaml_alias_event_initialize
632+ er
633+ anchorP
546 EventNone -> error "toEventRaw: EventNone not supported"
634 EventNone -> error "toEventRaw: EventNone not supported"
547 unless (ret == 1) $ throwIO $ ToEventRawException ret
635 unless (ret == 1) $ throwIO $ ToEventRawException ret
548 f er
636 f er
c/helper.c+20
@@ -108,6 +108,26 @@ int get_scalar_style(yaml_event_t *e)
108 return e->data.scalar.style;
108 return e->data.scalar.style;
109}
109}
110
110
111+unsigned char * get_scalar_anchor(yaml_event_t *e)
112+{
113+ return e->data.scalar.anchor;
114+}
115+
116+unsigned char * get_sequence_start_anchor(yaml_event_t *e)
117+{
118+ return e->data.sequence_start.anchor;
119+}
120+
121+unsigned char * get_mapping_start_anchor(yaml_event_t *e)
122+{
123+ return e->data.mapping_start.anchor;
124+}
125+
126+unsigned char * get_alias_anchor(yaml_event_t *e)
127+{
128+ return e->data.alias.anchor;
129+}
130+
111int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename)
131int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename)
112{
132{
113 FILE *in = fopen(filename, "r");
133 FILE *in = fopen(filename, "r");
c/helper.h+7
@@ -23,11 +23,18 @@ unsigned char const * get_emitter_error(yaml_emitter_t *e);
23int simple_document_start(yaml_event_t *e);
23int simple_document_start(yaml_event_t *e);
24
24
25int get_event_type(yaml_event_t *e);
25int get_event_type(yaml_event_t *e);
26+
26unsigned char * get_scalar_value(yaml_event_t *e);
27unsigned char * get_scalar_value(yaml_event_t *e);
27unsigned long get_scalar_length(yaml_event_t *e);
28unsigned long get_scalar_length(yaml_event_t *e);
28
29
29unsigned char * get_scalar_tag(yaml_event_t *e);
30unsigned char * get_scalar_tag(yaml_event_t *e);
30unsigned long get_scalar_tag_len(yaml_event_t *e);
31unsigned long get_scalar_tag_len(yaml_event_t *e);
32+
31int get_scalar_style(yaml_event_t *e);
33int get_scalar_style(yaml_event_t *e);
32
34
35+unsigned char * get_scalar_anchor(yaml_event_t *e);
36+unsigned char * get_sequence_start_anchor(yaml_event_t *e);
37+unsigned char * get_mapping_start_anchor(yaml_event_t *e);
38+unsigned char * get_alias_anchor(yaml_event_t *e);
39+
33#endif /* __HELPER_H__ */
40#endif /* __HELPER_H__ */
runtests.hs+65−5
@@ -12,13 +12,73 @@ import Test.HUnit hiding (Test, path)
12
12
13main :: IO ()
13main :: IO ()
14main = defaultMain
14main = defaultMain
15+ [ testCase "count scalars with anchor" caseCountScalarsWithAnchor
16+ , testCase "count sequences with anchor" caseCountSequencesWithAnchor
17+ , testCase "count mappings with anchor" caseCountMappingsWithAnchor
18+ , testCase "count aliases" caseCountAliases
15− [ testCase "count scalars" caseCountScalars
19+ , testCase "count scalars" caseCountScalars
16 , testCase "largest string" caseLargestString
20 , testCase "largest string" caseLargestString
17 , testCase "encode/decode" caseEncodeDecode
21 , testCase "encode/decode" caseEncodeDecode
18 , testCase "encode/decode file" caseEncodeDecodeFile
22 , testCase "encode/decode file" caseEncodeDecodeFile
19 , testCase "interleaved encode/decode" caseInterleave
23 , testCase "interleaved encode/decode" caseInterleave
20 ]
24 ]
21
25
26+caseCountScalarsWithAnchor :: Assertion
27+caseCountScalarsWithAnchor = do
28+ res <- decode yamlBS $ counter (0 :: Int)
29+ res @?= (1 :: Int)
30+ where
31+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"
32+ yamlBS = B8.pack yamlString
33+ counter acc = do
34+ e <- parseEvent
35+ case e of
36+ EventScalar _ _ _ (Just _) -> counter (acc + 1)
37+ EventNone -> return acc
38+ _ -> counter acc
39+
40+caseCountSequencesWithAnchor :: Assertion
41+caseCountSequencesWithAnchor = do
42+ res <- decode yamlBS $ counter (0 :: Int)
43+ res @?= (1 :: Int)
44+ where
45+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"
46+ yamlBS = B8.pack yamlString
47+ counter acc = do
48+ e <- parseEvent
49+ case e of
50+ EventSequenceStart (Just _) -> counter (acc + 1)
51+ EventNone -> return acc
52+ _ -> counter acc
53+
54+caseCountMappingsWithAnchor :: Assertion
55+caseCountMappingsWithAnchor = do
56+ res <- decode yamlBS $ counter (0 :: Int)
57+ res @?= (1 :: Int)
58+ where
59+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"
60+ yamlBS = B8.pack yamlString
61+ counter acc = do
62+ e <- parseEvent
63+ case e of
64+ EventMappingStart (Just _) -> counter (acc + 1)
65+ EventNone -> return acc
66+ _ -> counter acc
67+
68+caseCountAliases :: Assertion
69+caseCountAliases = do
70+ res <- decode yamlBS $ counter (0 :: Int)
71+ res @?= (1 :: Int)
72+ where
73+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"
74+ yamlBS = B8.pack yamlString
75+ counter acc = do
76+ e <- parseEvent
77+ case e of
78+ EventAlias _ -> counter (acc + 1)
79+ EventNone -> return acc
80+ _ -> counter acc
81+
22caseCountScalars :: Assertion
82caseCountScalars :: Assertion
23caseCountScalars = do
83caseCountScalars = do
24 res <- decode yamlBS $ counter accum
84 res <- decode yamlBS $ counter accum
@@ -30,8 +90,8 @@ caseCountScalars = do
30 e <- parseEvent
90 e <- parseEvent
31 case e of
91 case e of
32 EventScalar {} -> counter (s + 1, l, m)
92 EventScalar {} -> counter (s + 1, l, m)
33− EventSequenceStart -> counter (s, l + 1, m)
93+ EventSequenceStart _ -> counter (s, l + 1, m)
34− EventMappingStart -> counter (s, l, m + 1)
94+ EventMappingStart _ -> counter (s, l, m + 1)
35 EventNone -> return (s, l, m)
95 EventNone -> return (s, l, m)
36 _ -> counter (s, l, m)
96 _ -> counter (s, l, m)
37 accum = (0, 0, 0) :: (Int, Int, Int)
97 accum = (0, 0, 0) :: (Int, Int, Int)
@@ -46,7 +106,7 @@ caseLargestString = do
46 dec (i, s) = do
106 dec (i, s) = do
47 e <- parseEvent
107 e <- parseEvent
48 case e of
108 case e of
49− (EventScalar bs _ _) -> do
109+ (EventScalar bs _ _ _) -> do
50 let s' = B8.unpack bs
110 let s' = B8.unpack bs
51 i' = length s'
111 i' = length s'
52 dec $ if i' > i then (i', s') else (i, s)
112 dec $ if i' > i then (i', s') else (i, s)
@@ -86,7 +146,7 @@ caseEncodeDecodeFile = do
86
146
87newtype MyEvent = MyEvent Event deriving Show
147newtype MyEvent = MyEvent Event deriving Show
88instance Eq MyEvent where
148instance Eq MyEvent where
89− (MyEvent (EventScalar s t _)) == (MyEvent (EventScalar s' t' _)) =
149+ (MyEvent (EventScalar s t _ _)) == (MyEvent (EventScalar s' t' _ _)) =
90 s == s' && t == t'
150 s == s' && t == t'
91 MyEvent e1 == MyEvent e2 = e1 == e2
151 MyEvent e1 == MyEvent e2 = e1 == e2
92
152