module Text.Libyaml
where
import qualified Data.ByteString.Internal as B
import Control.Monad
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
data ParserStruct
type Parser = Ptr ParserStruct
parserSize :: Int
parserSize = 480
data EventRawStruct
type EventRaw = Ptr EventRawStruct
eventSize :: Int
eventSize = 104
foreign import ccall unsafe "yaml_parser_initialize"
c_yaml_parser_initialize :: Parser -> IO CInt
foreign import ccall unsafe "yaml_parser_delete"
c_yaml_parser_delete :: Parser -> IO ()
foreign import ccall unsafe "yaml_parser_set_input_string"
c_yaml_parser_set_input_string :: Parser
-> Ptr CUChar
-> CULong
-> IO ()
withParser :: B.ByteString -> (Parser -> IO a) -> IO a
withParser bs f = do
allocaBytes parserSize $ \p ->
do
_res <- c_yaml_parser_initialize p
let (fptr, offset, len) = B.toForeignPtr bs
ret <- withForeignPtr fptr $ \ptr ->
do
let ptr' = castPtr ptr `plusPtr` offset
len' = fromIntegral len
c_yaml_parser_set_input_string p ptr' len'
f p
c_yaml_parser_delete p
return ret
withEventRaw :: (EventRaw -> IO a) -> IO a
withEventRaw f = allocaBytes eventSize $ f
foreign import ccall unsafe "yaml_parser_parse"
c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
foreign import ccall unsafe "yaml_event_delete"
c_yaml_event_delete :: EventRaw -> IO ()
foreign import ccall "print_parser_error"
c_print_parser_error :: Parser -> IO ()
parserParseOne :: Parser -> IO Event
parserParseOne parser = withEventRaw $ \er -> do
res <- c_yaml_parser_parse parser er
when (res == 0) $
c_print_parser_error parser >> fail "yaml_parser_parse failed"
event <- getEvent er
c_yaml_event_delete er
return event
data Event =
EventNone
| EventStreamStart
| EventStreamEnd
| EventDocumentStart
| EventDocumentEnd
| EventAlias
| EventScalar B.ByteString
| EventSequenceStart
| EventSequenceEnd
| EventMappingStart
| EventMappingEnd
deriving (Show)
data EventType = YamlNoEvent
| YamlStreamStartEvent
| YamlStreamEndEvent
| YamlDocumentStartEvent
| YamlDocumentEndEvent
| YamlAliasEvent
| YamlScalarEvent
| YamlSequenceStartEvent
| YamlSequenceEndEvent
| YamlMappingStartEvent
| YamlMappingEndEvent
deriving (Enum,Show)
foreign import ccall unsafe "get_event_type"
c_get_event_type :: EventRaw -> IO CInt
foreign import ccall unsafe "get_scalar_value"
c_get_scalar_value :: EventRaw -> IO (Ptr CUChar)
foreign import ccall unsafe "get_scalar_length"
c_get_scalar_length :: EventRaw -> IO CULong
getEvent :: EventRaw -> IO Event
getEvent er = do
et <- c_get_event_type er
case toEnum $ fromEnum et of
YamlNoEvent -> return EventNone
YamlStreamStartEvent -> return EventStreamStart
YamlStreamEndEvent -> return EventStreamEnd
YamlDocumentStartEvent -> return EventDocumentStart
YamlDocumentEndEvent -> return EventDocumentEnd
YamlAliasEvent -> return EventAlias
YamlScalarEvent -> do
yvalue <- c_get_scalar_value er
ylen <- c_get_scalar_length er
let yvalue' = castPtr yvalue
let ylen' = fromEnum ylen
let ylen'' = toEnum $ fromEnum ylen
bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
return $ EventScalar bs
YamlSequenceStartEvent -> return EventSequenceStart
YamlSequenceEndEvent -> return EventSequenceEnd
YamlMappingStartEvent -> return EventMappingStart
YamlMappingEndEvent -> return EventMappingEnd
parserParse :: Parser -> IO [Event]
parserParse parser = do
event <- parserParseOne parser
case event of
EventStreamEnd -> return [event]
_ -> do
rest <- parserParse parser
return $! event : rest
data EmitterStruct
type Emitter = Ptr EmitterStruct
emitterSize :: Int
emitterSize = 432
foreign import ccall unsafe "yaml_emitter_initialize"
c_yaml_emitter_initialize :: Emitter -> IO CInt
foreign import ccall unsafe "yaml_emitter_delete"
c_yaml_emitter_delete :: Emitter -> IO ()
data BufferStruct
type Buffer = Ptr BufferStruct
bufferSize :: Int
bufferSize = 16
foreign import ccall unsafe "buffer_init"
c_buffer_init :: Buffer -> IO ()
foreign import ccall unsafe "get_buffer_buff"
c_get_buffer_buff :: Buffer -> IO (Ptr CUChar)
foreign import ccall unsafe "get_buffer_used"
c_get_buffer_used :: Buffer -> IO CULong
withBuffer :: (Buffer -> IO ()) -> IO B.ByteString
withBuffer f = do
allocaBytes bufferSize $ \b -> do
c_buffer_init b
f b
ptr' <- c_get_buffer_buff b
len <- c_get_buffer_used b
fptr <- newForeignPtr_ $ castPtr ptr'
return $! B.fromForeignPtr fptr 0 $ fromIntegral len
foreign import ccall unsafe "my_emitter_set_output"
c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
withEmitter :: (Emitter -> IO ()) -> IO B.ByteString
withEmitter f = do
allocaBytes emitterSize $ \e -> do
_res <- c_yaml_emitter_initialize e
bs <- withBuffer $ \b -> do
c_my_emitter_set_output e b
f e
c_yaml_emitter_delete e
return bs
foreign import ccall unsafe "yaml_emitter_emit"
c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
foreign import ccall unsafe "print_emitter_error"
c_print_emitter_error :: Emitter -> IO ()
emitEvents :: Emitter -> [Event] -> IO ()
emitEvents _ [] = return ()
emitEvents emitter (e:rest) = do
res <- toEventRaw e $ c_yaml_emitter_emit emitter
when (res == 0) $
c_print_emitter_error emitter >> fail "yaml_emitter_emit failed"
emitEvents emitter rest
foreign import ccall unsafe "yaml_stream_start_event_initialize"
c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
foreign import ccall unsafe "yaml_stream_end_event_initialize"
c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt
foreign import ccall unsafe "yaml_scalar_event_initialize"
c_yaml_scalar_event_initialize
:: EventRaw
-> Ptr CUChar
-> Ptr CUChar
-> Ptr CUChar
-> CInt
-> CInt
-> CInt
-> CInt
-> IO CInt
foreign import ccall unsafe "simple_document_start"
c_simple_document_start :: EventRaw -> IO CInt
foreign import ccall unsafe "yaml_document_end_event_initialize"
c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt
foreign import ccall unsafe "yaml_sequence_start_event_initialize"
c_yaml_sequence_start_event_initialize
:: EventRaw
-> Ptr CUChar
-> Ptr CUChar
-> CInt
-> CInt
-> IO CInt
foreign import ccall unsafe "yaml_sequence_end_event_initialize"
c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt
foreign import ccall unsafe "yaml_mapping_start_event_initialize"
c_yaml_mapping_start_event_initialize
:: EventRaw
-> Ptr CUChar
-> Ptr CUChar
-> CInt
-> CInt
-> IO CInt
foreign import ccall unsafe "yaml_mapping_end_event_initialize"
c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
toEventRaw e f = withEventRaw $ \er -> do
case e of
EventStreamStart ->
c_yaml_stream_start_event_initialize
er
0
EventStreamEnd ->
c_yaml_stream_end_event_initialize er
EventDocumentStart ->
c_simple_document_start er
EventDocumentEnd ->
c_yaml_document_end_event_initialize er 1
EventScalar bs -> do
let (fvalue, offset, len) = B.toForeignPtr bs
withForeignPtr fvalue $ \value -> do
let value' = value `plusPtr` offset
len' = fromIntegral len
c_yaml_scalar_event_initialize
er
nullPtr
nullPtr
value'
len'
0
1
0
EventSequenceStart ->
c_yaml_sequence_start_event_initialize
er
nullPtr
nullPtr
1
0
EventSequenceEnd ->
c_yaml_sequence_end_event_initialize er
EventMappingStart ->
c_yaml_mapping_start_event_initialize
er
nullPtr
nullPtr
1
0
EventMappingEnd ->
c_yaml_mapping_end_event_initialize er
EventAlias -> error "toEventRaw: EventAlias not supported"
EventNone -> error "toEventRaw: EventNone not supported"
f er