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