module Text.Libyaml
(
Event (..)
, Style (..)
, Tag (..)
, YamlException (..)
, With (..)
, YamlEncoder
, YamlDecoder
, parseEvent
, emitEvent
, emitStream
, emitDocument
, emitSequence
, emitMapping
, encode
, decode
, encodeFile
, decodeFile
) where
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString
import Data.ByteString (ByteString)
import Control.Monad
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
#if TRANSFORMERS_02
import "transformers" Control.Monad.IO.Class
#else
import "transformers" Control.Monad.Trans
#endif
import Control.Monad.Failure.Transformers
import qualified Control.Monad.Trans.Error as ErrorT
import Control.Monad.Trans.Reader
import Control.Exception (throwIO, Exception, SomeException)
import Data.Typeable (Typeable)
data Event =
EventNone
| EventStreamStart
| EventStreamEnd
| EventDocumentStart
| EventDocumentEnd
| EventAlias
| EventScalar !ByteString !Tag !Style
| EventSequenceStart
| EventSequenceEnd
| EventMappingStart
| EventMappingEnd
deriving (Show, Eq)
data Style = Any
| Plain
| SingleQuoted
| DoubleQuoted
| Literal
| Folded
deriving (Show, Eq, Enum, Bounded, Ord)
data Tag = StrTag
| FloatTag
| NullTag
| BoolTag
| SetTag
| IntTag
| SeqTag
| MapTag
| UriTag String
| NoTag
deriving (Show, Eq)
tagToString :: Tag -> String
tagToString StrTag = "tag:yaml.org,2002:str"
tagToString FloatTag = "tag:yaml.org,2002:float"
tagToString NullTag = "tag:yaml.org,2002:null"
tagToString BoolTag = "tag:yaml.org,2002:bool"
tagToString SetTag = "tag:yaml.org,2002:set"
tagToString IntTag = "tag:yaml.org,2002:int"
tagToString SeqTag = "tag:yaml.org,2002:seq"
tagToString MapTag = "tag:yaml.org,2002:map"
tagToString (UriTag s) = s
tagToString NoTag = ""
bsToTag :: ByteString -> Tag
bsToTag = stringToTag . B8.unpack
stringToTag :: String -> Tag
stringToTag "tag:yaml.org,2002:str" = StrTag
stringToTag "tag:yaml.org,2002:float" = FloatTag
stringToTag "tag:yaml.org,2002:null" = NullTag
stringToTag "tag:yaml.org,2002:bool" = BoolTag
stringToTag "tag:yaml.org,2002:set" = SetTag
stringToTag "tag:yaml.org,2002:int" = IntTag
stringToTag "tag:yaml.org,2002:seq" = SeqTag
stringToTag "tag:yaml.org,2002:map" = MapTag
stringToTag "" = NoTag
stringToTag s = UriTag s
data YamlException =
YamlParserException
{ parserProblem :: String
, parserContext :: String
, parserOffset :: Int
}
| YamlEmitterException
{ emitterEvent :: Event
, emitterProblem :: String
}
| YamlOutOfMemory
| YamlInvalidEventStreamBeginning [Event]
| YamlInvalidEventStreamEnd [Event]
| YamlPrematureEventStreamEnd
| YamlNonScalarKey
| YamlInvalidStartingEvent Event
| YamlFileNotFound FilePath
| YamlOtherException SomeException
| YamlStringException String
deriving (Show, Typeable)
instance Exception YamlException
instance ErrorT.Error YamlException where
strMsg = YamlStringException
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 ()
foreign import ccall unsafe "yaml_parser_set_input_file"
c_yaml_parser_set_input_file :: Parser
-> File
-> IO ()
data FileStruct
type File = Ptr FileStruct
foreign import ccall unsafe "fopen"
c_fopen :: Ptr CChar
-> Ptr CChar
-> IO File
foreign import ccall unsafe "fclose"
c_fclose :: File
-> IO ()
class MonadIO m => With m where
with :: (forall b'. (a -> IO b') -> IO b') -> (a -> m b) -> m b
instance With IO where
with = id
instance With m => With (ReaderT r m) where
with orig f = ReaderT $ \r -> do
let f' a = (runReaderT $ f a) r
with orig f'
instance (ErrorT.Error e, With m) => With (ErrorT.ErrorT e m) where
with orig f = ErrorT.ErrorT $ with orig $ ErrorT.runErrorT . f
allocaBytesR :: With m => Int -> (Ptr a -> m b) -> m b
allocaBytesR i = with (allocaBytes i)
withCStringR :: With m => String -> (Ptr CChar -> m a) -> m a
withCStringR s = with (withCString s)
withFileParser :: (MonadFailure YamlException m, With m)
=> FilePath
-> (Parser -> m a)
-> m a
withFileParser fp f = allocaBytesR parserSize $ \p -> do
res <- liftIO $ c_yaml_parser_initialize p
when (res == 0) $ failure YamlOutOfMemory
file <- withCStringR fp $ \fp' -> withCStringR "r" $ \r' ->
liftIO (c_fopen fp' r')
when (file == nullPtr) $ failure $ YamlFileNotFound fp
liftIO $ c_yaml_parser_set_input_file p file
ret <- f p
liftIO $ c_fclose file
liftIO $ c_yaml_parser_delete p
return ret
withParser :: (MonadFailure YamlException m, With m)
=> B.ByteString
-> (Parser -> m a)
-> m a
withParser bs f = allocaBytesR parserSize $ \p -> do
res <- liftIO $ c_yaml_parser_initialize p
when (res == 0) $ failure YamlOutOfMemory
let (fptr, offset, len) = B.toForeignPtr bs
ret <- withForeignPtrR fptr $ \ptr -> do
let ptr' = castPtr ptr `plusPtr` offset
len' = fromIntegral len
liftIO $ c_yaml_parser_set_input_string p ptr' len'
f p
liftIO $ c_yaml_parser_delete p
return ret
withForeignPtrR :: With m => ForeignPtr a -> (Ptr a -> m b) -> m b
withForeignPtrR fp = with (withForeignPtr fp)
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 "get_parser_error_problem"
c_get_parser_error_problem :: Parser -> IO (Ptr CUChar)
foreign import ccall "get_parser_error_context"
c_get_parser_error_context :: Parser -> IO (Ptr CUChar)
foreign import ccall unsafe "get_parser_error_offset"
c_get_parser_error_offset :: Parser -> IO CULong
makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
makeString f a = do
cchar <- castPtr `liftM` f a
liftIO $ peekCString cchar
parserParseOne :: (MonadFailure YamlException m, With m)
=> Parser
-> m Event
parserParseOne parser = allocaBytesR eventSize $ \er -> do
res <- liftIO $ c_yaml_parser_parse parser er
event <-
if res == 0
then do
problem <- liftIO $ makeString c_get_parser_error_problem parser
context <- liftIO $ makeString c_get_parser_error_context parser
offset <- liftIO $ fromIntegral `fmap`
c_get_parser_error_offset parser
failure $ YamlParserException problem context offset
else liftIO $ getEvent er
liftIO $ c_yaml_event_delete er
return event
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
foreign import ccall unsafe "get_scalar_tag"
c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)
foreign import ccall unsafe "get_scalar_tag_len"
c_get_scalar_tag_len :: EventRaw -> IO CULong
foreign import ccall unsafe "get_scalar_style"
c_get_scalar_style :: EventRaw -> IO CInt
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
ytag <- c_get_scalar_tag er
ytag_len <- c_get_scalar_tag_len er
ystyle <- c_get_scalar_style er
let ytag_len' = fromEnum ytag_len
let yvalue' = castPtr yvalue
let ytag' = castPtr ytag
let ylen' = fromEnum ylen
let ylen'' = toEnum $ fromEnum ylen
bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
tagbs <-
if ytag_len' == 0
then return Data.ByteString.empty
else B.create ytag_len'
$ \dest -> B.memcpy dest ytag' (toEnum ytag_len')
let style = toEnum $ fromEnum ystyle
return $ EventScalar bs (bsToTag tagbs) style
YamlSequenceStartEvent -> return EventSequenceStart
YamlSequenceEndEvent -> return EventSequenceEnd
YamlMappingStartEvent -> return EventMappingStart
YamlMappingEndEvent -> return EventMappingEnd
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
withBufferR :: (With m, MonadFailure YamlException m)
=> (Buffer -> m ())
-> m B.ByteString
withBufferR f = allocaBytesR bufferSize $ \b -> do
liftIO $ c_buffer_init b
f b
ptr' <- liftIO $ c_get_buffer_buff b
len <- liftIO $ c_get_buffer_used b
fptr <- liftIO $ 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 :: (With m, MonadFailure YamlException m)
=> (Emitter -> m ())
-> m B.ByteString
withEmitter f = allocaBytesR emitterSize $ \e -> do
res <- liftIO $ c_yaml_emitter_initialize e
when (res == 0) $ failure YamlOutOfMemory
bs <- withBufferR $ \b -> do
liftIO $ c_my_emitter_set_output e b
f e
liftIO $ c_yaml_emitter_delete e
return bs
foreign import ccall unsafe "yaml_emitter_set_output_file"
c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
withEmitterFile :: (With m, MonadFailure YamlException m)
=> FilePath
-> (Emitter -> m ())
-> m ()
withEmitterFile fp f = allocaBytesR emitterSize $ \e -> do
res <- liftIO $ c_yaml_emitter_initialize e
when (res == 0) $ failure YamlOutOfMemory
file <- withCStringR fp $ \fp' -> withCStringR "w" $ \w' ->
liftIO (c_fopen fp' w')
res' <-
if file == nullPtr
then failure $ YamlFileNotFound fp
else do
liftIO $ c_yaml_emitter_set_output_file e file
res' <- f e
liftIO $ c_yaml_emitter_delete e
return res'
liftIO $ c_fclose file
return res'
foreign import ccall unsafe "yaml_emitter_emit"
c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
foreign import ccall unsafe "get_emitter_error"
c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
emitEvent :: (MonadIO m, MonadFailure YamlException m)
=> Event
-> YamlEncoder m ()
emitEvent e = do
emitter <- ask
res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
when (res == 0) $ do
problem <- liftIO $ makeString c_get_emitter_error emitter
failure $ YamlEmitterException e problem
emitStream, emitDocument, emitSequence, emitMapping
:: (MonadIO m, MonadFailure YamlException m)
=> YamlEncoder m ()
-> YamlEncoder m ()
emitStream e = emitEvent EventStreamStart >> e >> emitEvent EventStreamEnd
emitDocument e = emitEvent EventDocumentStart >> e
>> emitEvent EventDocumentEnd
emitSequence e = emitEvent EventSequenceStart >> e
>> emitEvent EventSequenceEnd
emitMapping e = emitEvent EventMappingStart >> e
>> emitEvent EventMappingEnd
parseEvent :: (With m, MonadFailure YamlException m)
=> YamlDecoder m Event
parseEvent = ask >>= parserParseOne
type YamlDecoder = ReaderT Parser
type YamlEncoder = ReaderT Emitter
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 = allocaBytesR eventSize $ \er -> do
ret <- 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 thetag style -> do
let (fvalue, offset, len) = B.toForeignPtr bs
withForeignPtr fvalue $ \value -> do
let value' = value `plusPtr` offset
len' = fromIntegral len
value'' = if ptrToIntPtr value' == 0
then intPtrToPtr 1
else value'
let thetag' = tagToString thetag
withCString thetag' $ \tag' -> do
let style' = toEnum $ fromEnum style
tagP = castPtr tag'
qi = if null thetag' then 1 else 0
c_yaml_scalar_event_initialize
er
nullPtr
tagP
value''
len'
0
qi
style'
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"
unless (ret == 1) $ throwIO $ ToEventRawException ret
f er
newtype ToEventRawException = ToEventRawException CInt
deriving (Show, Typeable)
instance Exception ToEventRawException
encode :: (With m, MonadFailure YamlException m)
=> YamlEncoder m ()
-> m B.ByteString
encode = withEmitter . runReaderT
encodeFile :: (With m, MonadFailure YamlException m)
=> FilePath
-> YamlEncoder m ()
-> m ()
encodeFile filePath = withEmitterFile filePath . runReaderT
decode :: (With m, MonadFailure YamlException m)
=> B.ByteString
-> YamlDecoder m a
-> m a
decode bs dec = withParser bs $ runReaderT dec
decodeFile :: (With m, MonadFailure YamlException m)
=> FilePath
-> YamlDecoder m a
-> m a
decodeFile fp dec = withFileParser fp $ runReaderT dec