git.iko.soy/typeable/yaml
on 8381f21 help sign in
typeable/yaml/Text/Libyaml.hs
646 lines 22 kB history raw
1{-# LANGUAGE EmptyDataDecls #-}
2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PackageImports #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE CPP #-}
11{-# LANGUAGE TypeFamilies #-}
13-- | Low-level, streaming YAML interface. For a higher-level interface, see
14-- "Data.Yaml".
15module Text.Libyaml
16 ( -- * The event stream
17 Event (..)
18 , Style (..)
19 , Tag (..)
20 , AnchorName
21 , Anchor
22 -- * Encoding and decoding
23 , encode
24 , decode
25 , encodeFile
26 , decodeFile
27 -- * Error handling
28 , YamlException (..)
29 , YamlMark (..)
30 ) where
32import qualified Data.ByteString.Internal as B
33import qualified Data.ByteString.Char8 as B8
34import qualified Data.ByteString
35import qualified Data.ByteString.Unsafe as BU
36import Data.ByteString (ByteString, packCStringLen)
37import Control.Monad
38import Foreign.C
39import Foreign.Ptr
40import Foreign.ForeignPtr
41import Foreign.Marshal.Alloc
42import Data.Data
44import Control.Monad.IO.Class
46import Control.Exception (throwIO, Exception, finally)
47import Control.Applicative
48import Control.Monad.Trans.Resource
49import Data.Conduit hiding (Source, Sink, Conduit)
50import Control.Exception (mask_)
52data Event =
53 EventStreamStart
54 | EventStreamEnd
55 | EventDocumentStart
56 | EventDocumentEnd
57 | EventAlias !AnchorName
58 | EventScalar !ByteString !Tag !Style !Anchor
59 | EventSequenceStart !Anchor
60 | EventSequenceEnd
61 | EventMappingStart !Anchor
62 | EventMappingEnd
63 deriving (Show, Eq)
65data Style = Any
66 | Plain
67 | SingleQuoted
68 | DoubleQuoted
69 | Literal
70 | Folded
71 | PlainNoTag
72 deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable)
74data Tag = StrTag
75 | FloatTag
76 | NullTag
77 | BoolTag
78 | SetTag
79 | IntTag
80 | SeqTag
81 | MapTag
82 | UriTag String
83 | NoTag
84 deriving (Show, Eq, Read, Data, Typeable)
86type AnchorName = String
87type Anchor = Maybe AnchorName
89tagToString :: Tag -> String
90tagToString StrTag = "tag:yaml.org,2002:str"
91tagToString FloatTag = "tag:yaml.org,2002:float"
92tagToString NullTag = "tag:yaml.org,2002:null"
93tagToString BoolTag = "tag:yaml.org,2002:bool"
94tagToString SetTag = "tag:yaml.org,2002:set"
95tagToString IntTag = "tag:yaml.org,2002:int"
96tagToString SeqTag = "tag:yaml.org,2002:seq"
97tagToString MapTag = "tag:yaml.org,2002:map"
98tagToString (UriTag s) = s
99tagToString NoTag = ""
101bsToTag :: ByteString -> Tag
102bsToTag = stringToTag . B8.unpack
104stringToTag :: String -> Tag
105stringToTag "tag:yaml.org,2002:str" = StrTag
106stringToTag "tag:yaml.org,2002:float" = FloatTag
107stringToTag "tag:yaml.org,2002:null" = NullTag
108stringToTag "tag:yaml.org,2002:bool" = BoolTag
109stringToTag "tag:yaml.org,2002:set" = SetTag
110stringToTag "tag:yaml.org,2002:int" = IntTag
111stringToTag "tag:yaml.org,2002:seq" = SeqTag
112stringToTag "tag:yaml.org,2002:map" = MapTag
113stringToTag "" = NoTag
114stringToTag s = UriTag s
116data ParserStruct
117type Parser = Ptr ParserStruct
118parserSize :: Int
119parserSize = 480
121data EventRawStruct
122type EventRaw = Ptr EventRawStruct
123eventSize :: Int
124eventSize = 104
126foreign import ccall unsafe "yaml_parser_initialize"
127 c_yaml_parser_initialize :: Parser -> IO CInt
129foreign import ccall unsafe "yaml_parser_delete"
130 c_yaml_parser_delete :: Parser -> IO ()
132foreign import ccall unsafe "yaml_parser_set_input_string"
133 c_yaml_parser_set_input_string :: Parser
134 -> Ptr CUChar
135 -> CULong
136 -> IO ()
138foreign import ccall unsafe "yaml_parser_set_input_file"
139 c_yaml_parser_set_input_file :: Parser
140 -> File
141 -> IO ()
143data FileStruct
144type File = Ptr FileStruct
146foreign import ccall unsafe "fopen"
147 c_fopen :: Ptr CChar
148 -> Ptr CChar
149 -> IO File
151foreign import ccall unsafe "fclose"
152 c_fclose :: File
153 -> IO ()
155foreign import ccall unsafe "fclose_helper"
156 c_fclose_helper :: File -> IO ()
158foreign import ccall unsafe "yaml_parser_parse"
159 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
161foreign import ccall unsafe "yaml_event_delete"
162 c_yaml_event_delete :: EventRaw -> IO ()
164foreign import ccall "get_parser_error_problem"
165 c_get_parser_error_problem :: Parser -> IO (Ptr CUChar)
167foreign import ccall "get_parser_error_context"
168 c_get_parser_error_context :: Parser -> IO (Ptr CUChar)
170foreign import ccall unsafe "get_parser_error_index"
171 c_get_parser_error_index :: Parser -> IO CULong
173foreign import ccall unsafe "get_parser_error_line"
174 c_get_parser_error_line :: Parser -> IO CULong
176foreign import ccall unsafe "get_parser_error_column"
177 c_get_parser_error_column :: Parser -> IO CULong
179makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
180makeString f a = do
181 cchar <- castPtr `liftM` f a
182 if cchar == nullPtr
183 then return ""
184 else liftIO $ peekCString cchar
186data EventType = YamlNoEvent
187 | YamlStreamStartEvent
188 | YamlStreamEndEvent
189 | YamlDocumentStartEvent
190 | YamlDocumentEndEvent
191 | YamlAliasEvent
192 | YamlScalarEvent
193 | YamlSequenceStartEvent
194 | YamlSequenceEndEvent
195 | YamlMappingStartEvent
196 | YamlMappingEndEvent
197 deriving (Enum,Show)
199foreign import ccall unsafe "get_event_type"
200 c_get_event_type :: EventRaw -> IO CInt
202foreign import ccall unsafe "get_scalar_value"
203 c_get_scalar_value :: EventRaw -> IO (Ptr CUChar)
205foreign import ccall unsafe "get_scalar_length"
206 c_get_scalar_length :: EventRaw -> IO CULong
208foreign import ccall unsafe "get_scalar_tag"
209 c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)
211foreign import ccall unsafe "get_scalar_tag_len"
212 c_get_scalar_tag_len :: EventRaw -> IO CULong
214foreign import ccall unsafe "get_scalar_style"
215 c_get_scalar_style :: EventRaw -> IO CInt
217foreign import ccall unsafe "get_scalar_anchor"
218 c_get_scalar_anchor :: EventRaw -> IO CString
220foreign import ccall unsafe "get_sequence_start_anchor"
221 c_get_sequence_start_anchor :: EventRaw -> IO CString
223foreign import ccall unsafe "get_mapping_start_anchor"
224 c_get_mapping_start_anchor :: EventRaw -> IO CString
226foreign import ccall unsafe "get_alias_anchor"
227 c_get_alias_anchor :: EventRaw -> IO CString
229getEvent :: EventRaw -> IO (Maybe Event)
230getEvent er = do
231 et <- c_get_event_type er
232 case toEnum $ fromEnum et of
233 YamlNoEvent -> return Nothing
234 YamlStreamStartEvent -> return $ Just EventStreamStart
235 YamlStreamEndEvent -> return $ Just EventStreamEnd
236 YamlDocumentStartEvent -> return $ Just EventDocumentStart
237 YamlDocumentEndEvent -> return $ Just EventDocumentEnd
238 YamlAliasEvent -> do
239 yanchor <- c_get_alias_anchor er
240 anchor <- if yanchor == nullPtr
241 then error "got YamlAliasEvent with empty anchor"
242 else peekCString yanchor
243 return $ Just $ EventAlias anchor
244 YamlScalarEvent -> do
245 yvalue <- c_get_scalar_value er
246 ylen <- c_get_scalar_length er
247 ytag <- c_get_scalar_tag er
248 ytag_len <- c_get_scalar_tag_len er
249 ystyle <- c_get_scalar_style er
250 let ytag_len' = fromEnum ytag_len
251 let yvalue' = castPtr yvalue
252 let ytag' = castPtr ytag
253 let ylen' = fromEnum ylen
254 bs <- packCStringLen (yvalue', ylen')
255 tagbs <-
256 if ytag_len' == 0
257 then return Data.ByteString.empty
258 else packCStringLen (ytag', ytag_len')
259 let style = toEnum $ fromEnum ystyle
260 yanchor <- c_get_scalar_anchor er
261 anchor <- if yanchor == nullPtr
262 then return Nothing
263 else fmap Just $ peekCString yanchor
264 return $ Just $ EventScalar bs (bsToTag tagbs) style anchor
265 YamlSequenceStartEvent -> do
266 yanchor <- c_get_sequence_start_anchor er
267 anchor <- if yanchor == nullPtr
268 then return Nothing
269 else fmap Just $ peekCString yanchor
270 return $ Just $ EventSequenceStart anchor
271 YamlSequenceEndEvent -> return $ Just EventSequenceEnd
272 YamlMappingStartEvent -> do
273 yanchor <- c_get_mapping_start_anchor er
274 anchor <- if yanchor == nullPtr
275 then return Nothing
276 else fmap Just $ peekCString yanchor
277 return $ Just $ EventMappingStart anchor
278 YamlMappingEndEvent -> return $ Just EventMappingEnd
280-- Emitter
282data EmitterStruct
283type Emitter = Ptr EmitterStruct
284emitterSize :: Int
285emitterSize = 432
287foreign import ccall unsafe "yaml_emitter_initialize"
288 c_yaml_emitter_initialize :: Emitter -> IO CInt
290foreign import ccall unsafe "yaml_emitter_delete"
291 c_yaml_emitter_delete :: Emitter -> IO ()
293data BufferStruct
294type Buffer = Ptr BufferStruct
295bufferSize :: Int
296bufferSize = 16
298foreign import ccall unsafe "buffer_init"
299 c_buffer_init :: Buffer -> IO ()
301foreign import ccall unsafe "get_buffer_buff"
302 c_get_buffer_buff :: Buffer -> IO (Ptr CUChar)
304foreign import ccall unsafe "get_buffer_used"
305 c_get_buffer_used :: Buffer -> IO CULong
307foreign import ccall unsafe "my_emitter_set_output"
308 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
310foreign import ccall unsafe "yaml_emitter_set_output_file"
311 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
313foreign import ccall unsafe "yaml_emitter_emit"
314 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
316foreign import ccall unsafe "yaml_stream_start_event_initialize"
317 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
319foreign import ccall unsafe "yaml_stream_end_event_initialize"
320 c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt
322foreign import ccall unsafe "yaml_scalar_event_initialize"
323 c_yaml_scalar_event_initialize
324 :: EventRaw
325 -> Ptr CUChar -- anchor
326 -> Ptr CUChar -- tag
327 -> Ptr CUChar -- value
328 -> CInt -- length
329 -> CInt -- plain_implicit
330 -> CInt -- quoted_implicit
331 -> CInt -- style
332 -> IO CInt
334foreign import ccall unsafe "simple_document_start"
335 c_simple_document_start :: EventRaw -> IO CInt
337foreign import ccall unsafe "yaml_document_end_event_initialize"
338 c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt
340foreign import ccall unsafe "yaml_sequence_start_event_initialize"
341 c_yaml_sequence_start_event_initialize
342 :: EventRaw
343 -> Ptr CUChar
344 -> Ptr CUChar
345 -> CInt
346 -> CInt
347 -> IO CInt
349foreign import ccall unsafe "yaml_sequence_end_event_initialize"
350 c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt
352foreign import ccall unsafe "yaml_mapping_start_event_initialize"
353 c_yaml_mapping_start_event_initialize
354 :: EventRaw
355 -> Ptr CUChar
356 -> Ptr CUChar
357 -> CInt
358 -> CInt
359 -> IO CInt
361foreign import ccall unsafe "yaml_mapping_end_event_initialize"
362 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
364foreign import ccall unsafe "yaml_alias_event_initialize"
365 c_yaml_alias_event_initialize
366 :: EventRaw
367 -> Ptr CUChar
368 -> IO CInt
370toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
371toEventRaw e f = allocaBytes eventSize $ \er -> do
372 ret <- case e of
373 EventStreamStart ->
374 c_yaml_stream_start_event_initialize
375 er
376 0 -- YAML_ANY_ENCODING
377 EventStreamEnd ->
378 c_yaml_stream_end_event_initialize er
379 EventDocumentStart ->
380 c_simple_document_start er
381 EventDocumentEnd ->
382 c_yaml_document_end_event_initialize er 1
383 EventScalar bs thetag style0 anchor -> do
384 BU.unsafeUseAsCStringLen bs $ \(value, len) -> do
385 let value' = castPtr value :: Ptr CUChar
386 len' = fromIntegral len :: CInt
387 let thetag' = tagToString thetag
388 withCString thetag' $ \tag' -> do
389 let (pi, style) =
390 case style0 of
391 PlainNoTag -> (1, Plain)
392 x -> (0, x)
393 style' = toEnum $ fromEnum style
394 tagP = castPtr tag'
395 qi = if null thetag' then 1 else 0
396 case anchor of
397 Nothing ->
398 c_yaml_scalar_event_initialize
399 er
400 nullPtr -- anchor
401 tagP -- tag
402 value' -- value
403 len' -- length
404 pi -- plain_implicit
405 qi -- quoted_implicit
406 style' -- style
407 Just anchor' ->
408 withCString anchor' $ \anchorP' -> do
409 let anchorP = castPtr anchorP'
410 c_yaml_scalar_event_initialize
411 er
412 anchorP -- anchor
413 tagP -- tag
414 value' -- value
415 len' -- length
416 0 -- plain_implicit
417 qi -- quoted_implicit
418 style' -- style
419 EventSequenceStart Nothing ->
420 c_yaml_sequence_start_event_initialize
421 er
422 nullPtr
423 nullPtr
424 1
425 0 -- YAML_ANY_SEQUENCE_STYLE
426 EventSequenceStart (Just anchor) ->
427 withCString anchor $ \anchor' -> do
428 let anchorP = castPtr anchor'
429 c_yaml_sequence_start_event_initialize
430 er
431 anchorP
432 nullPtr
433 1
434 0 -- YAML_ANY_SEQUENCE_STYLE
435 EventSequenceEnd ->
436 c_yaml_sequence_end_event_initialize er
437 EventMappingStart Nothing ->
438 c_yaml_mapping_start_event_initialize
439 er
440 nullPtr
441 nullPtr
442 1
443 0 -- YAML_ANY_SEQUENCE_STYLE
444 EventMappingStart (Just anchor) ->
445 withCString anchor $ \anchor' -> do
446 let anchorP = castPtr anchor'
447 c_yaml_mapping_start_event_initialize
448 er
449 anchorP
450 nullPtr
451 1
452 0 -- YAML_ANY_SEQUENCE_STYLE
453 EventMappingEnd ->
454 c_yaml_mapping_end_event_initialize er
455 EventAlias anchor ->
456 withCString anchor $ \anchorP' -> do
457 let anchorP = castPtr anchorP'
458 c_yaml_alias_event_initialize
459 er
460 anchorP
461 unless (ret == 1) $ throwIO $ ToEventRawException ret
462 f er
464newtype ToEventRawException = ToEventRawException CInt
465 deriving (Show, Typeable)
466instance Exception ToEventRawException
468decode :: MonadResource m => B.ByteString
469#if MIN_VERSION_conduit(1, 0, 0)
470 -> Producer m Event
471#else
472 -> GSource m Event
473#endif
474decode bs | B8.null bs = return ()
475decode bs =
476 bracketP alloc cleanup (runParser . fst)
477 where
478 alloc = mask_ $ do
479 ptr <- mallocBytes parserSize
480 res <- c_yaml_parser_initialize ptr
481 if res == 0
482 then do
483 c_yaml_parser_delete ptr
484 free ptr
485 throwIO $ YamlException "Yaml out of memory"
486 else do
487 let (bsfptr, offset, len) = B.toForeignPtr bs
488 let bsptrOrig = unsafeForeignPtrToPtr bsfptr
489 let bsptr = castPtr bsptrOrig `plusPtr` offset
490 c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)
491 return (ptr, bsfptr)
492 cleanup (ptr, bsfptr) = do
493 touchForeignPtr bsfptr
494 c_yaml_parser_delete ptr
495 free ptr
497decodeFile :: MonadResource m => FilePath
498#if MIN_VERSION_conduit(1, 0, 0)
499 -> Producer m Event
500#else
501 -> GSource m Event
502#endif
503decodeFile file =
504 bracketP alloc cleanup (runParser . fst)
505 where
506 alloc = mask_ $ do
507 ptr <- mallocBytes parserSize
508 res <- c_yaml_parser_initialize ptr
509 if res == 0
510 then do
511 c_yaml_parser_delete ptr
512 free ptr
513 throwIO $ YamlException "Yaml out of memory"
514 else do
515 file' <- liftIO
516 $ withCString file $ \file' -> withCString "r" $ \r' ->
517 c_fopen file' r'
518 if file' == nullPtr
519 then do
520 c_fclose_helper file'
521 c_yaml_parser_delete ptr
522 free ptr
523 throwIO $ YamlException
524 $ "Yaml file not found: " ++ file
525 else do
526 c_yaml_parser_set_input_file ptr file'
527 return (ptr, file')
528 cleanup (ptr, file') = do
529 c_fclose_helper file'
530 c_yaml_parser_delete ptr
531 free ptr
533runParser :: MonadResource m => Parser
534#if MIN_VERSION_conduit(1, 0, 0)
535 -> Producer m Event
536#else
537 -> GSource m Event
538#endif
539runParser parser = do
540 e <- liftIO $ parserParseOne' parser
541 case e of
542 Left err -> liftIO $ throwIO err
543 Right Nothing -> return ()
544 Right (Just ev) -> yield ev >> runParser parser
546parserParseOne' :: Parser
547 -> IO (Either YamlException (Maybe Event))
548parserParseOne' parser = allocaBytes eventSize $ \er -> do
549 res <- liftIO $ c_yaml_parser_parse parser er
550 flip finally (c_yaml_event_delete er) $
551 if res == 0
552 then do
553 problem <- makeString c_get_parser_error_problem parser
554 context <- makeString c_get_parser_error_context parser
555 index <- c_get_parser_error_index parser
556 line <- c_get_parser_error_line parser
557 column <- c_get_parser_error_column parser
558 let problemMark = YamlMark (fromIntegral index) (fromIntegral line) (fromIntegral column)
559 return $ Left $ YamlParseException problem context problemMark
560 else Right <$> getEvent er
562encode :: MonadResource m
563#if MIN_VERSION_conduit(1, 0, 0)
564 => Consumer Event m ByteString
565#else
566 => GSink Event m ByteString
567#endif
568encode =
569 runEmitter alloc close
570 where
571 alloc emitter = do
572 fbuf <- mallocForeignPtrBytes bufferSize
573 withForeignPtr fbuf c_buffer_init
574 withForeignPtr fbuf $ c_my_emitter_set_output emitter
575 return fbuf
576 close _ fbuf = withForeignPtr fbuf $ \b -> do
577 ptr' <- c_get_buffer_buff b
578 len <- c_get_buffer_used b
579 fptr <- newForeignPtr_ $ castPtr ptr'
580 return $ B.fromForeignPtr fptr 0 $ fromIntegral len
582encodeFile :: MonadResource m
583 => FilePath
584#if MIN_VERSION_conduit(1, 0, 0)
585 -> Consumer Event m ()
586#else
587 -> GInfSink Event m
588#endif
589encodeFile filePath =
590 bracketP getFile c_fclose $ \file -> runEmitter (alloc file) (\u _ -> return u)
591 where
592 getFile = do
593 file <- withCString filePath $
594 \filePath' -> withCString "w" $
595 \w' -> c_fopen filePath' w'
596 if (file == nullPtr)
597 then throwIO $ YamlException $ "could not open file for write: " ++ filePath
598 else return file
600 alloc file emitter = c_yaml_emitter_set_output_file emitter file
602runEmitter :: MonadResource m
603 => (Emitter -> IO a) -- ^ alloc
604#if MIN_VERSION_conduit(1, 0, 0)
605 -> (() -> a -> IO b) -- ^ close
606 -> Consumer Event m b
607#else
608 -> (u -> a -> IO b) -- ^ close
609 -> Pipe l Event o u m b
610#endif
611runEmitter allocI closeI =
612 bracketP alloc cleanup go
613 where
614 alloc = mask_ $ do
615 emitter <- mallocBytes emitterSize
616 res <- c_yaml_emitter_initialize emitter
617 when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed"
618 a <- allocI emitter
619 return (emitter, a)
620 cleanup (emitter, _) = do
621 c_yaml_emitter_delete emitter
622 free emitter
624 go (emitter, a) =
625 loop
626 where
627#if MIN_VERSION_conduit(1, 0, 0)
628 loop = await >>= maybe (close ()) push
629#else
630 loop = awaitE >>= either close push
631#endif
633 push e = do
634 _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
635 loop
636 close u = liftIO $ closeI u a
638-- | The pointer position
639data YamlMark = YamlMark { yamlIndex :: Int, yamlLine :: Int, yamlColumn :: Int }
640 deriving Show
642data YamlException = YamlException String
643 -- | problem, context, index, position line, position column
644 | YamlParseException { yamlProblem :: String, yamlContext :: String, yamlProblemMark :: YamlMark }
645 deriving (Show, Typeable)
646instance Exception YamlException