git.iko.soy/typeable/yaml
on master help sign in
Added anchors and aliases supporting
commit0fa213efbe875fbd28dc343d9b2eab39fe6f7861 authorAnton Ageev <antage@gmail.com> dateMon 10 May 2010, 08:39 (16 years ago) parentd21fafe
4 files changed+205−30
compare with master
unifiedsplit
Text/Libyaml.hs+113−25 c/helper.c+20 c/helper.h+7 runtests.hs+65−5
Text/Libyaml.hs+113−25
@@ -26,7 +26,9 @@ module Text.Libyaml
2626 , emitStream
2727 , emitDocument
2828 , emitSequence
29+ , emitSequenceWithAnchor
2930 , emitMapping
31+ , emitMappingWithAnchor
3032 -- * Higher level functions
3133 , encode
3234 , decode
@@ -57,11 +59,11 @@ data Event =
5759 | EventStreamEnd
5860 | EventDocumentStart
5961 | EventDocumentEnd
60− | EventAlias
61− | EventScalar !ByteString !Tag !Style
62− | EventSequenceStart
62+ | EventAlias !AnchorName
63+ | EventScalar !ByteString !Tag !Style !Anchor
64+ | EventSequenceStart !Anchor
6365 | EventSequenceEnd
64− | EventMappingStart
66+ | EventMappingStart !Anchor
6567 | EventMappingEnd
6668 deriving (Show, Eq)
6769
@@ -85,6 +87,9 @@ data Tag = StrTag
8587 | NoTag
8688 deriving (Show, Eq)
8789
90+type AnchorName = String
91+type Anchor = Maybe AnchorName
92+
8893tagToString :: Tag -> String
8994tagToString StrTag = "tag:yaml.org,2002:str"
9095tagToString FloatTag = "tag:yaml.org,2002:float"
@@ -296,6 +301,18 @@ foreign import ccall unsafe "get_scalar_tag_len"
296301foreign import ccall unsafe "get_scalar_style"
297302 c_get_scalar_style :: EventRaw -> IO CInt
298303
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+
299316getEvent :: EventRaw -> IO Event
300317getEvent er = do
301318 et <- c_get_event_type er
@@ -305,7 +322,12 @@ getEvent er = do
305322 YamlStreamEndEvent -> return EventStreamEnd
306323 YamlDocumentStartEvent -> return EventDocumentStart
307324 YamlDocumentEndEvent -> return EventDocumentEnd
308− YamlAliasEvent -> return EventAlias
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
330+ return $ EventAlias anchor
309331 YamlScalarEvent -> do
310332 yvalue <- c_get_scalar_value er
311333 ylen <- c_get_scalar_length er
@@ -324,10 +346,24 @@ getEvent er = do
324346 else B.create ytag_len'
325347 $ \dest -> B.memcpy dest ytag' (toEnum ytag_len')
326348 let style = toEnum $ fromEnum ystyle
327− return $ EventScalar bs (bsToTag tagbs) style
328− YamlSequenceStartEvent -> return EventSequenceStart
349+ yanchor <- c_get_scalar_anchor er
350+ anchor <- if yanchor == nullPtr
351+ then return Nothing
352+ else fmap Just $ peekCString yanchor
353+ return $ EventScalar bs (bsToTag tagbs) style anchor
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
329360 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
331367 YamlMappingEndEvent -> return EventMappingEnd
332368
333369-- Emitter
@@ -429,10 +465,19 @@ emitStream, emitDocument, emitSequence, emitMapping
429465emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd
430466emitDocument e = emitEvent EventDocumentStart >> e
431467 >> emitEvent EventDocumentEnd
432−emitSequence e = emitEvent EventSequenceStart >> e
433− >> emitEvent EventSequenceEnd
434−emitMapping e = emitEvent EventMappingStart >> e
435− >> emitEvent EventMappingEnd
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 ()
476+emitSequenceWithAnchor e a = emitEvent (EventSequenceStart a) >> e
477+ >> emitEvent EventSequenceEnd
478+emitMappingWithAnchor e a = emitEvent (EventMappingStart a) >> e
479+ >> emitEvent EventMappingEnd
480+
436481
437482parseEvent :: (With m, MonadFailure YamlException m)
438483 => YamlDecoder m Event
@@ -489,6 +534,12 @@ foreign import ccall unsafe "yaml_mapping_start_event_initialize"
489534foreign import ccall unsafe "yaml_mapping_end_event_initialize"
490535 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
491536
537+foreign import ccall unsafe "yaml_alias_event_initialize"
538+ c_yaml_alias_event_initialize
539+ :: EventRaw
540+ -> Ptr CUChar
541+ -> IO CInt
542+
492543toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
493544toEventRaw e f = allocaBytesR eventSize $ \er -> do
494545 ret <- case e of
@@ -502,7 +553,7 @@ toEventRaw e f = allocaBytesR eventSize $ \er -> do
502553 c_simple_document_start er
503554 EventDocumentEnd ->
504555 c_yaml_document_end_event_initialize er 1
505− EventScalar bs thetag style -> do
556+ EventScalar bs thetag style anchor -> do
506557 let (fvalue, offset, len) = B.toForeignPtr bs
507558 withForeignPtr fvalue $ \value -> do
508559 let value' = value `plusPtr` offset
@@ -515,34 +566,71 @@ toEventRaw e f = allocaBytesR eventSize $ \er -> do
515566 let style' = toEnum $ fromEnum style
516567 tagP = castPtr tag'
517568 qi = if null thetag' then 1 else 0
518− c_yaml_scalar_event_initialize
519− er
520− nullPtr -- anchor
521− tagP -- tag
522− value'' -- value
523− len' -- length
524− 0 -- plain_implicit
525− qi -- quoted_implicit
526− style' -- style
527− EventSequenceStart ->
569+ case anchor of
570+ Nothing ->
571+ c_yaml_scalar_event_initialize
572+ er
573+ nullPtr -- anchor
574+ tagP -- tag
575+ value'' -- value
576+ len' -- length
577+ 0 -- plain_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
591+ style' -- style
592+ EventSequenceStart Nothing ->
528593 c_yaml_sequence_start_event_initialize
529594 er
530595 nullPtr
531596 nullPtr
532597 1
533598 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
534608 EventSequenceEnd ->
535609 c_yaml_sequence_end_event_initialize er
536− EventMappingStart ->
610+ EventMappingStart Nothing ->
537611 c_yaml_mapping_start_event_initialize
538612 er
539613 nullPtr
540614 nullPtr
541615 1
542616 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
543626 EventMappingEnd ->
544627 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
546634 EventNone -> error "toEventRaw: EventNone not supported"
547635 unless (ret == 1) $ throwIO $ ToEventRawException ret
548636 f er
c/helper.c+20
@@ -108,6 +108,26 @@ int get_scalar_style(yaml_event_t *e)
108108 return e->data.scalar.style;
109109}
110110
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+
111131int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename)
112132{
113133 FILE *in = fopen(filename, "r");
c/helper.h+7
@@ -23,11 +23,18 @@ unsigned char const * get_emitter_error(yaml_emitter_t *e);
2323int simple_document_start(yaml_event_t *e);
2424
2525int get_event_type(yaml_event_t *e);
26+
2627unsigned char * get_scalar_value(yaml_event_t *e);
2728unsigned long get_scalar_length(yaml_event_t *e);
2829
2930unsigned char * get_scalar_tag(yaml_event_t *e);
3031unsigned long get_scalar_tag_len(yaml_event_t *e);
32+
3133int get_scalar_style(yaml_event_t *e);
3234
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+
3340#endif /* __HELPER_H__ */
runtests.hs+65−5
@@ -12,13 +12,73 @@ import Test.HUnit hiding (Test, path)
1212
1313main :: IO ()
1414main = defaultMain
15− [ testCase "count scalars" caseCountScalars
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
19+ , testCase "count scalars" caseCountScalars
1620 , testCase "largest string" caseLargestString
1721 , testCase "encode/decode" caseEncodeDecode
1822 , testCase "encode/decode file" caseEncodeDecodeFile
1923 , testCase "interleaved encode/decode" caseInterleave
2024 ]
2125
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+
2282caseCountScalars :: Assertion
2383caseCountScalars = do
2484 res <- decode yamlBS $ counter accum
@@ -30,8 +90,8 @@ caseCountScalars = do
3090 e <- parseEvent
3191 case e of
3292 EventScalar {} -> counter (s + 1, l, m)
33− EventSequenceStart -> counter (s, l + 1, m)
34− EventMappingStart -> counter (s, l, m + 1)
93+ EventSequenceStart _ -> counter (s, l + 1, m)
94+ EventMappingStart _ -> counter (s, l, m + 1)
3595 EventNone -> return (s, l, m)
3696 _ -> counter (s, l, m)
3797 accum = (0, 0, 0) :: (Int, Int, Int)
@@ -46,7 +106,7 @@ caseLargestString = do
46106 dec (i, s) = do
47107 e <- parseEvent
48108 case e of
49− (EventScalar bs _ _) -> do
109+ (EventScalar bs _ _ _) -> do
50110 let s' = B8.unpack bs
51111 i' = length s'
52112 dec $ if i' > i then (i', s') else (i, s)
@@ -86,7 +146,7 @@ caseEncodeDecodeFile = do
86146
87147newtype MyEvent = MyEvent Event deriving Show
88148instance Eq MyEvent where
89− (MyEvent (EventScalar s t _)) == (MyEvent (EventScalar s' t' _)) =
149+ (MyEvent (EventScalar s t _ _)) == (MyEvent (EventScalar s' t' _ _)) =
90150 s == s' && t == t'
91151 MyEvent e1 == MyEvent e2 = e1 == e2
92152