diff --git a/C2HS.hs b/C2HS.hs deleted file mode 100644 --- a/C2HS.hs +++ /dev/null @@ -1,220 +0,0 @@ --- C->Haskell Compiler: Marshalling library --- --- Copyright (c) [1999...2005] Manuel M T Chakravarty --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- 1. Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- 2. Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- 3. The name of the author may not be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR --- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES --- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN --- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- ---- Description --------------------------------------------------------------- --- --- Language: Haskell 98 --- --- This module provides the marshaling routines for Haskell files produced by --- C->Haskell for binding to C library interfaces. It exports all of the --- low-level FFI (language-independent plus the C-specific parts) together --- with the C->HS-specific higher-level marshalling routines. --- - -module C2HS ( - - -- * Re-export the language-independent component of the FFI - module Foreign, - - -- * Re-export the C language component of the FFI - module CForeign, - - -- * Composite marshalling functions - withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, - peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, - - -- * Conditional results using 'Maybe' - nothingIf, nothingIfNull, - - -- * Bit masks - combineBitMasks, containsBitMask, extractBitMasks, - - -- * Conversion between C and Haskell types - cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum -) where - - -import Foreign - hiding (Word) - -- Should also hide the Foreign.Marshal.Pool exports in - -- compilers that export them -import CForeign - -import Monad (when, liftM) - - --- Composite marshalling functions --- ------------------------------- - --- Strings with explicit length --- -withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) -peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) - --- Marshalling of numerals --- - -withIntConv :: (Storable b, Integral a, Integral b) - => a -> (Ptr b -> IO c) -> IO c -withIntConv = with . cIntConv - -withFloatConv :: (Storable b, RealFloat a, RealFloat b) - => a -> (Ptr b -> IO c) -> IO c -withFloatConv = with . cFloatConv - -peekIntConv :: (Storable a, Integral a, Integral b) - => Ptr a -> IO b -peekIntConv = liftM cIntConv . peek - -peekFloatConv :: (Storable a, RealFloat a, RealFloat b) - => Ptr a -> IO b -peekFloatConv = liftM cFloatConv . peek - --- Passing Booleans by reference --- - -withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b -withBool = with . fromBool - -peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool -peekBool = liftM toBool . peek - - --- Passing enums by reference --- - -withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c -withEnum = with . cFromEnum - -peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a -peekEnum = liftM cToEnum . peek - - --- Storing of 'Maybe' values --- ------------------------- - -instance Storable a => Storable (Maybe a) where - sizeOf _ = sizeOf (undefined :: Ptr ()) - alignment _ = alignment (undefined :: Ptr ()) - - peek p = do - ptr <- peek (castPtr p) - if ptr == nullPtr - then return Nothing - else liftM Just $ peek ptr - - poke p v = do - ptr <- case v of - Nothing -> return nullPtr - Just v' -> new v' - poke (castPtr p) ptr - - --- Conditional results using 'Maybe' --- --------------------------------- - --- Wrap the result into a 'Maybe' type. --- --- * the predicate determines when the result is considered to be non-existing, --- ie, it is represented by `Nothing' --- --- * the second argument allows to map a result wrapped into `Just' to some --- other domain --- -nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b -nothingIf p f x = if p x then Nothing else Just $ f x - --- |Instance for special casing null pointers. --- -nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b -nothingIfNull = nothingIf (== nullPtr) - - --- Support for bit masks --- --------------------- - --- Given a list of enumeration values that represent bit masks, combine these --- masks using bitwise disjunction. --- -combineBitMasks :: (Enum a, Bits b) => [a] -> b -combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) - --- Tests whether the given bit mask is contained in the given bit pattern --- (i.e., all bits set in the mask are also set in the pattern). --- -containsBitMask :: (Bits a, Enum b) => a -> b -> Bool -bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm - in - bm' .&. bits == bm' - --- |Given a bit pattern, yield all bit masks that it contains. --- --- * This does *not* attempt to compute a minimal set of bit masks that when --- combined yield the bit pattern, instead all contained bit masks are --- produced. --- -extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] -extractBitMasks bits = - [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] - - --- Conversion routines --- ------------------- - --- |Integral conversion --- -cIntConv :: (Integral a, Integral b) => a -> b -cIntConv = fromIntegral - --- |Floating conversion --- -cFloatConv :: (RealFloat a, RealFloat b) => a -> b -cFloatConv = realToFrac --- As this conversion by default goes via `Rational', it can be very slow... -{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; - "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x - #-} - --- |Obtain C value from Haskell 'Bool'. --- -cFromBool :: Num a => Bool -> a -cFromBool = fromBool - --- |Obtain Haskell 'Bool' from C value. --- -cToBool :: Num a => a -> Bool -cToBool = toBool - --- |Convert a C enumeration to Haskell. --- -cToEnum :: (Integral i, Enum e) => i -> e -cToEnum = toEnum . cIntConv - --- |Convert a Haskell enumeration to C. --- -cFromEnum :: (Enum e, Integral i) => e -> i -cFromEnum = cIntConv . fromEnum diff --git a/Text/Libyaml.chs b/Text/Libyaml.chs deleted file mode 100644 --- a/Text/Libyaml.chs +++ /dev/null @@ -1,299 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module Text.Libyaml - ( Event (..) - , parserParse - , withParser - , emitEvents - , withEmitter - ) where - -#include -#include - -import C2HS -import qualified Data.ByteString.Internal as B -import Control.Monad - -{#context lib="yaml" #} - -{#pointer *yaml_parser_t as Parser newtype#} -parserSize :: Int -parserSize = {#sizeof yaml_parser_t#} - -{#pointer *yaml_event_t as EventRaw newtype#} -eventSize :: Int -eventSize = {#sizeof yaml_event_t#} - -{#fun unsafe yaml_parser_initialize - { id `Parser' - } -> `Int' #} - -{#fun unsafe yaml_parser_delete - { id `Parser' - } -> `()' #} - -withParser :: B.ByteString -> (Parser -> IO a) -> IO a -withParser bs f = do - allocaBytes parserSize $ \p -> - do - let p' = Parser p - _res <- yaml_parser_initialize p' - -- FIXME check res - let (fptr, offset, len) = B.toForeignPtr bs - ret <- withForeignPtr fptr $ \ptr -> - do - let ptr' = castPtr ptr `plusPtr` offset - yaml_parser_set_input_string p' ptr' len - f p' - yaml_parser_delete p' - return ret - -withEventRaw :: (EventRaw -> IO a) -> IO a -withEventRaw f = allocaBytes eventSize $ f . EventRaw - -{#fun unsafe yaml_parser_set_input_string - { id `Parser' - , id `Ptr CUChar' - , `Int' - } -> `()' #} - -{#fun unsafe yaml_parser_parse - { id `Parser' - , id `EventRaw' - } -> `Int' #} - -{#fun unsafe yaml_event_delete - { id `EventRaw' - } -> `()' #} - -parserParse :: Parser -> IO [Event] -parserParse parser = do - event <- parserParseOne parser - case event of - EventStreamEnd -> return [event] - _ -> do - rest <- parserParse parser - return $! event : rest - -{#fun unsafe print_parser_error - { id `Parser' - } -> `()' #} - -parserParseOne :: Parser -> IO Event -parserParseOne parser = withEventRaw $ \er -> do - res <- yaml_parser_parse parser er - when (res == 0) $ - print_parser_error parser >> fail "yaml_parser_parse failed" - event <- getEvent er - yaml_event_delete er - return event - -data Event = - EventNone - | EventStreamStart - | EventStreamEnd - | EventDocumentStart - | EventDocumentEnd - | EventAlias - | EventScalar B.ByteString - | EventSequenceStart - | EventSequenceEnd - | EventMappingStart - | EventMappingEnd - deriving (Show) - -{#enum yaml_event_type_e as EventType {underscoreToCase} deriving (Show) #} -getEvent :: EventRaw -> IO Event -getEvent (EventRaw ptr') = do - et <- {#get yaml_event_t.type#} ptr' - 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 <- {#get yaml_event_t.data.scalar.value#} ptr' - ylen <- {#get yaml_event_t.data.scalar.length#} ptr' - 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 - --- Emitter -{#pointer *yaml_emitter_t as Emitter newtype#} -emitterSize :: Int -emitterSize = {#sizeof yaml_emitter_t#} - -{#fun unsafe yaml_emitter_initialize - { id `Emitter' - } -> `Int' #} - -{#fun unsafe yaml_emitter_delete - { id `Emitter' - } -> `()' #} - -{#pointer *buffer_t as Buffer newtype#} -bufferSize :: Int -bufferSize = {#sizeof buffer_t#} - -{#fun unsafe buffer_init - { id `Buffer' - } -> `()' #} - -withBuffer :: (Buffer -> IO ()) -> IO B.ByteString -withBuffer f = do - allocaBytes bufferSize $ \b -> do - let b' = Buffer b - buffer_init b' - f b' - ptr' <- {#get buffer_t.buff#} b - len <- {#get buffer_t.used#} b - fptr <- newForeignPtr_ $ castPtr ptr' - return $! B.fromForeignPtr fptr 0 $ fromIntegral len - -{#fun unsafe yaml_emitter_set_output - { id `Emitter' - , id `FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt)' - , id `Ptr ()' - } -> `()' #} - -foreign import ccall "buffer.h &buffer_append" - buffer_append :: FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt) - -withEmitter :: (Emitter -> IO ()) -> IO B.ByteString -withEmitter f = do - allocaBytes emitterSize $ \e -> do - let e' = Emitter e - _res <- yaml_emitter_initialize e' - -- FIXME check res - bs <- withBuffer $ \(Buffer b) -> do - let fun = buffer_append - yaml_emitter_set_output e' buffer_append $ castPtr b - f e' - yaml_emitter_delete e' - return bs - -{#fun unsafe yaml_emitter_emit - { id `Emitter' - , id `EventRaw' - } -> `Int' #} - -{#fun unsafe print_emitter_error - { id `Emitter' - } -> `()' #} - -emitEvents :: Emitter -> [Event] -> IO () -emitEvents _ [] = return () -emitEvents emitter (e:rest) = do - res <- toEventRaw e $ yaml_emitter_emit emitter - when (res == 0) $ - print_emitter_error emitter >> fail "yaml_emitter_emit failed" - emitEvents emitter rest - -{#fun unsafe yaml_stream_start_event_initialize - { id `EventRaw' - , `Int' - } -> `Int' #} - -{#fun unsafe yaml_stream_end_event_initialize - { id `EventRaw' - } -> `Int' #} - -{#fun unsafe yaml_scalar_event_initialize - { id `EventRaw' - , id `Ptr CUChar' -- anchor - , id `Ptr CUChar' -- tag - , id `Ptr CUChar' -- value - , `Int' - , `Int' - , `Int' - , `Int' - } -> `Int' #} - -{#fun unsafe simple_document_start - { id `EventRaw' - } -> `Int' #} - -{#fun unsafe yaml_document_end_event_initialize - { id `EventRaw' - , `Int' - } -> `Int' #} - -{#fun unsafe yaml_sequence_start_event_initialize - { id `EventRaw' - , id `Ptr CUChar' - , id `Ptr CUChar' - , `Int' - , `Int' - } -> `Int' #} - -{#fun unsafe yaml_sequence_end_event_initialize - { id `EventRaw' - } -> `Int' #} - -{#fun unsafe yaml_mapping_start_event_initialize - { id `EventRaw' - , id `Ptr CUChar' - , id `Ptr CUChar' - , `Int' - , `Int' - } -> `Int' #} - -{#fun unsafe yaml_mapping_end_event_initialize - { id `EventRaw' - } -> `Int' #} - -toEventRaw :: Event -> (EventRaw -> IO a) -> IO a -toEventRaw e f = withEventRaw $ \er -> do - case e of - EventStreamStart -> - yaml_stream_start_event_initialize - er - 0 -- YAML_ANY_ENCODING - EventStreamEnd -> - yaml_stream_end_event_initialize er - EventDocumentStart -> - simple_document_start er - EventDocumentEnd -> - 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 - yaml_scalar_event_initialize - er - nullPtr - nullPtr - value' - len - 0 - 1 - 0 -- YAML_ANY_SCALAR_STYLE - EventSequenceStart -> - yaml_sequence_start_event_initialize - er - nullPtr - nullPtr - 1 - 0 -- YAML_ANY_SEQUENCE_STYLE - EventSequenceEnd -> - yaml_sequence_end_event_initialize er - EventMappingStart -> - yaml_mapping_start_event_initialize - er - nullPtr - nullPtr - 1 - 0 -- YAML_ANY_SEQUENCE_STYLE - EventMappingEnd -> - yaml_mapping_end_event_initialize er - EventAlias -> error "toEventRaw: EventAlias not supported" - EventNone -> error "toEventRaw: EventNone not supported" - f er diff --git a/Text/Libyaml.hs b/Text/Libyaml.hs new file mode 100644 --- /dev/null +++ b/Text/Libyaml.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +{-# INCLUDE #-} +{-# INCLUDE #-} +module Text.Libyaml +{- + ( + Event (..) + , parserParse + , withParser + , emitEvents + , withEmitter + )-} 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 + -- FIXME check res + 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 + +-- Emitter + +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 + -- FIXME check res + 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 -- anchor + -> Ptr CUChar -- tag + -> Ptr CUChar -- value + -> 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 -- YAML_ANY_ENCODING + 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 -- YAML_ANY_SCALAR_STYLE + EventSequenceStart -> + c_yaml_sequence_start_event_initialize + er + nullPtr + nullPtr + 1 + 0 -- YAML_ANY_SEQUENCE_STYLE + EventSequenceEnd -> + c_yaml_sequence_end_event_initialize er + EventMappingStart -> + c_yaml_mapping_start_event_initialize + er + nullPtr + nullPtr + 1 + 0 -- YAML_ANY_SEQUENCE_STYLE + EventMappingEnd -> + c_yaml_mapping_end_event_initialize er + EventAlias -> error "toEventRaw: EventAlias not supported" + EventNone -> error "toEventRaw: EventNone not supported" + f er diff --git a/c/helper.c b/c/helper.c --- a/c/helper.c +++ b/c/helper.c @@ -31,6 +31,21 @@ return 1; } +unsigned char * get_buffer_buff(buffer_t *b) +{ + return b->buff; +} + +unsigned int get_buffer_used(buffer_t *b) +{ + return b->used; +} + +void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b) +{ + yaml_emitter_set_output(e, buffer_append, b); +} + void print_parser_error(yaml_parser_t *p) { fprintf(stderr, "Problem: %s\nContext: %s\nOffset: %u\n", @@ -52,4 +67,19 @@ 0, 0, 1); +} + +int get_event_type(yaml_event_t *e) +{ + return e->type; +} + +unsigned char * get_scalar_value(yaml_event_t *e) +{ + return e->data.scalar.value; +} + +unsigned long get_scalar_length(yaml_event_t *e) +{ + return e->data.scalar.length; } diff --git a/c/helper.h b/c/helper.h --- a/c/helper.h +++ b/c/helper.h @@ -4,14 +4,22 @@ #include typedef struct buffer_s { - char *buff; + unsigned char *buff; unsigned int size, used; } buffer_t; void buffer_init(buffer_t *buffer); int buffer_append(void *ext, unsigned char *str, size_t size); +unsigned char * get_buffer_buff(buffer_t *b); +unsigned int get_buffer_used(buffer_t *b); +void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b); + void print_parser_error(yaml_parser_t *p); void print_emitter_error(yaml_emitter_t *e); int simple_document_start(yaml_event_t *e); + +int get_event_type(yaml_event_t *e); +unsigned char * get_scalar_value(yaml_event_t *e); +unsigned long get_scalar_length(yaml_event_t *e); #endif /* __HELPER_H__ */ diff --git a/yaml.cabal b/yaml.cabal --- a/yaml.cabal +++ b/yaml.cabal @@ -1,5 +1,5 @@ name: yaml -version: 0.0.1 +version: 0.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,8 +22,7 @@ bytestring >= 0.9.1.4 && < 1, haskell98 exposed-modules: Text.Yaml - other-modules: Text.Libyaml, - C2HS + other-modules: Text.Libyaml ghc-options: -Wall c-sources: c/helper.c, c/api.c, @@ -35,4 +34,3 @@ c/scanner.c, c/writer.c include-dirs: c - build-tools: c2hs