module Text.Libyaml
(
Event (..)
, Style (..)
, Tag (..)
, YamlException (..)
, With (..)
, YamlEncoder
, YamlDecoder
, parseEvent
, emitEvent
, 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
import "transformers" Control.Monad.Trans
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
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