git.iko.soy/typeable/yaml
on master help sign in
Removed C2HS dependency
commite44fd50a751bc47d8a3485cd4d60d7d9b32dfaba authorMichael Snoyman <michael@snoyman.com> dateWed 5 Aug 2009, 12:45 (17 years ago) parent55c22e0
6 files changed+351−524
compare with master
unifiedsplit
C2HS.hs−220 Text/Libyaml.chs−299 Text/Libyaml.hs+310 c/helper.c+30 c/helper.h+9−1 yaml.cabal+2−4
C2HS.hsdeleted−220
@@ -1,220 +0,0 @@
1−-- C->Haskell Compiler: Marshalling library
2−--
3−-- Copyright (c) [1999...2005] Manuel M T Chakravarty
4−--
5−-- Redistribution and use in source and binary forms, with or without
6−-- modification, are permitted provided that the following conditions are met:
7−--
8−-- 1. Redistributions of source code must retain the above copyright notice,
9−-- this list of conditions and the following disclaimer.
10−-- 2. Redistributions in binary form must reproduce the above copyright
11−-- notice, this list of conditions and the following disclaimer in the
12−-- documentation and/or other materials provided with the distribution.
13−-- 3. The name of the author may not be used to endorse or promote products
14−-- derived from this software without specific prior written permission.
15−--
16−-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
17−-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
18−-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
19−-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
20−-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
21−-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
22−-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23−-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24−-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25−-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26−--
27−--- Description ---------------------------------------------------------------
28−--
29−-- Language: Haskell 98
30−--
31−-- This module provides the marshaling routines for Haskell files produced by
32−-- C->Haskell for binding to C library interfaces. It exports all of the
33−-- low-level FFI (language-independent plus the C-specific parts) together
34−-- with the C->HS-specific higher-level marshalling routines.
35−--
36−
37−module C2HS (
38−
39− -- * Re-export the language-independent component of the FFI
40− module Foreign,
41−
42− -- * Re-export the C language component of the FFI
43− module CForeign,
44−
45− -- * Composite marshalling functions
46− withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,
47− peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,
48−
49− -- * Conditional results using 'Maybe'
50− nothingIf, nothingIfNull,
51−
52− -- * Bit masks
53− combineBitMasks, containsBitMask, extractBitMasks,
54−
55− -- * Conversion between C and Haskell types
56− cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum
57−) where
58−
59−
60−import Foreign
61− hiding (Word)
62− -- Should also hide the Foreign.Marshal.Pool exports in
63− -- compilers that export them
64−import CForeign
65−
66−import Monad (when, liftM)
67−
68−
69−-- Composite marshalling functions
70−-- -------------------------------
71−
72−-- Strings with explicit length
73−--
74−withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)
75−peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)
76−
77−-- Marshalling of numerals
78−--
79−
80−withIntConv :: (Storable b, Integral a, Integral b)
81− => a -> (Ptr b -> IO c) -> IO c
82−withIntConv = with . cIntConv
83−
84−withFloatConv :: (Storable b, RealFloat a, RealFloat b)
85− => a -> (Ptr b -> IO c) -> IO c
86−withFloatConv = with . cFloatConv
87−
88−peekIntConv :: (Storable a, Integral a, Integral b)
89− => Ptr a -> IO b
90−peekIntConv = liftM cIntConv . peek
91−
92−peekFloatConv :: (Storable a, RealFloat a, RealFloat b)
93− => Ptr a -> IO b
94−peekFloatConv = liftM cFloatConv . peek
95−
96−-- Passing Booleans by reference
97−--
98−
99−withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b
100−withBool = with . fromBool
101−
102−peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool
103−peekBool = liftM toBool . peek
104−
105−
106−-- Passing enums by reference
107−--
108−
109−withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c
110−withEnum = with . cFromEnum
111−
112−peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a
113−peekEnum = liftM cToEnum . peek
114−
115−
116−-- Storing of 'Maybe' values
117−-- -------------------------
118−
119−instance Storable a => Storable (Maybe a) where
120− sizeOf _ = sizeOf (undefined :: Ptr ())
121− alignment _ = alignment (undefined :: Ptr ())
122−
123− peek p = do
124− ptr <- peek (castPtr p)
125− if ptr == nullPtr
126− then return Nothing
127− else liftM Just $ peek ptr
128−
129− poke p v = do
130− ptr <- case v of
131− Nothing -> return nullPtr
132− Just v' -> new v'
133− poke (castPtr p) ptr
134−
135−
136−-- Conditional results using 'Maybe'
137−-- ---------------------------------
138−
139−-- Wrap the result into a 'Maybe' type.
140−--
141−-- * the predicate determines when the result is considered to be non-existing,
142−-- ie, it is represented by `Nothing'
143−--
144−-- * the second argument allows to map a result wrapped into `Just' to some
145−-- other domain
146−--
147−nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b
148−nothingIf p f x = if p x then Nothing else Just $ f x
149−
150−-- |Instance for special casing null pointers.
151−--
152−nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b
153−nothingIfNull = nothingIf (== nullPtr)
154−
155−
156−-- Support for bit masks
157−-- ---------------------
158−
159−-- Given a list of enumeration values that represent bit masks, combine these
160−-- masks using bitwise disjunction.
161−--
162−combineBitMasks :: (Enum a, Bits b) => [a] -> b
163−combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)
164−
165−-- Tests whether the given bit mask is contained in the given bit pattern
166−-- (i.e., all bits set in the mask are also set in the pattern).
167−--
168−containsBitMask :: (Bits a, Enum b) => a -> b -> Bool
169−bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm
170− in
171− bm' .&. bits == bm'
172−
173−-- |Given a bit pattern, yield all bit masks that it contains.
174−--
175−-- * This does *not* attempt to compute a minimal set of bit masks that when
176−-- combined yield the bit pattern, instead all contained bit masks are
177−-- produced.
178−--
179−extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b]
180−extractBitMasks bits =
181− [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]
182−
183−
184−-- Conversion routines
185−-- -------------------
186−
187−-- |Integral conversion
188−--
189−cIntConv :: (Integral a, Integral b) => a -> b
190−cIntConv = fromIntegral
191−
192−-- |Floating conversion
193−--
194−cFloatConv :: (RealFloat a, RealFloat b) => a -> b
195−cFloatConv = realToFrac
196−-- As this conversion by default goes via `Rational', it can be very slow...
197−{-# RULES
198− "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;
199− "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x
200− #-}
201−
202−-- |Obtain C value from Haskell 'Bool'.
203−--
204−cFromBool :: Num a => Bool -> a
205−cFromBool = fromBool
206−
207−-- |Obtain Haskell 'Bool' from C value.
208−--
209−cToBool :: Num a => a -> Bool
210−cToBool = toBool
211−
212−-- |Convert a C enumeration to Haskell.
213−--
214−cToEnum :: (Integral i, Enum e) => i -> e
215−cToEnum = toEnum . cIntConv
216−
217−-- |Convert a Haskell enumeration to C.
218−--
219−cFromEnum :: (Enum e, Integral i) => e -> i
220−cFromEnum = cIntConv . fromEnum
Text/Libyaml.chsdeleted−299
@@ -1,299 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
2−module Text.Libyaml
3− ( Event (..)
4− , parserParse
5− , withParser
6− , emitEvents
7− , withEmitter
8− ) where
9−
10−#include <yaml.h>
11−#include <helper.h>
12−
13−import C2HS
14−import qualified Data.ByteString.Internal as B
15−import Control.Monad
16−
17−{#context lib="yaml" #}
18−
19−{#pointer *yaml_parser_t as Parser newtype#}
20−parserSize :: Int
21−parserSize = {#sizeof yaml_parser_t#}
22−
23−{#pointer *yaml_event_t as EventRaw newtype#}
24−eventSize :: Int
25−eventSize = {#sizeof yaml_event_t#}
26−
27−{#fun unsafe yaml_parser_initialize
28− { id `Parser'
29− } -> `Int' #}
30−
31−{#fun unsafe yaml_parser_delete
32− { id `Parser'
33− } -> `()' #}
34−
35−withParser :: B.ByteString -> (Parser -> IO a) -> IO a
36−withParser bs f = do
37− allocaBytes parserSize $ \p ->
38− do
39− let p' = Parser p
40− _res <- yaml_parser_initialize p'
41− -- FIXME check res
42− let (fptr, offset, len) = B.toForeignPtr bs
43− ret <- withForeignPtr fptr $ \ptr ->
44− do
45− let ptr' = castPtr ptr `plusPtr` offset
46− yaml_parser_set_input_string p' ptr' len
47− f p'
48− yaml_parser_delete p'
49− return ret
50−
51−withEventRaw :: (EventRaw -> IO a) -> IO a
52−withEventRaw f = allocaBytes eventSize $ f . EventRaw
53−
54−{#fun unsafe yaml_parser_set_input_string
55− { id `Parser'
56− , id `Ptr CUChar'
57− , `Int'
58− } -> `()' #}
59−
60−{#fun unsafe yaml_parser_parse
61− { id `Parser'
62− , id `EventRaw'
63− } -> `Int' #}
64−
65−{#fun unsafe yaml_event_delete
66− { id `EventRaw'
67− } -> `()' #}
68−
69−parserParse :: Parser -> IO [Event]
70−parserParse parser = do
71− event <- parserParseOne parser
72− case event of
73− EventStreamEnd -> return [event]
74− _ -> do
75− rest <- parserParse parser
76− return $! event : rest
77−
78−{#fun unsafe print_parser_error
79− { id `Parser'
80− } -> `()' #}
81−
82−parserParseOne :: Parser -> IO Event
83−parserParseOne parser = withEventRaw $ \er -> do
84− res <- yaml_parser_parse parser er
85− when (res == 0) $
86− print_parser_error parser >> fail "yaml_parser_parse failed"
87− event <- getEvent er
88− yaml_event_delete er
89− return event
90−
91−data Event =
92− EventNone
93− | EventStreamStart
94− | EventStreamEnd
95− | EventDocumentStart
96− | EventDocumentEnd
97− | EventAlias
98− | EventScalar B.ByteString
99− | EventSequenceStart
100− | EventSequenceEnd
101− | EventMappingStart
102− | EventMappingEnd
103− deriving (Show)
104−
105−{#enum yaml_event_type_e as EventType {underscoreToCase} deriving (Show) #}
106−getEvent :: EventRaw -> IO Event
107−getEvent (EventRaw ptr') = do
108− et <- {#get yaml_event_t.type#} ptr'
109− case toEnum $ fromEnum et of
110− YamlNoEvent -> return EventNone
111− YamlStreamStartEvent -> return EventStreamStart
112− YamlStreamEndEvent -> return EventStreamEnd
113− YamlDocumentStartEvent -> return EventDocumentStart
114− YamlDocumentEndEvent -> return EventDocumentEnd
115− YamlAliasEvent -> return EventAlias
116− YamlScalarEvent -> do
117− yvalue <- {#get yaml_event_t.data.scalar.value#} ptr'
118− ylen <- {#get yaml_event_t.data.scalar.length#} ptr'
119− let yvalue' = castPtr yvalue
120− let ylen' = fromEnum ylen
121− let ylen'' = toEnum $ fromEnum ylen
122− bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
123− return $ EventScalar bs
124− YamlSequenceStartEvent -> return EventSequenceStart
125− YamlSequenceEndEvent -> return EventSequenceEnd
126− YamlMappingStartEvent -> return EventMappingStart
127− YamlMappingEndEvent -> return EventMappingEnd
128−
129−-- Emitter
130−{#pointer *yaml_emitter_t as Emitter newtype#}
131−emitterSize :: Int
132−emitterSize = {#sizeof yaml_emitter_t#}
133−
134−{#fun unsafe yaml_emitter_initialize
135− { id `Emitter'
136− } -> `Int' #}
137−
138−{#fun unsafe yaml_emitter_delete
139− { id `Emitter'
140− } -> `()' #}
141−
142−{#pointer *buffer_t as Buffer newtype#}
143−bufferSize :: Int
144−bufferSize = {#sizeof buffer_t#}
145−
146−{#fun unsafe buffer_init
147− { id `Buffer'
148− } -> `()' #}
149−
150−withBuffer :: (Buffer -> IO ()) -> IO B.ByteString
151−withBuffer f = do
152− allocaBytes bufferSize $ \b -> do
153− let b' = Buffer b
154− buffer_init b'
155− f b'
156− ptr' <- {#get buffer_t.buff#} b
157− len <- {#get buffer_t.used#} b
158− fptr <- newForeignPtr_ $ castPtr ptr'
159− return $! B.fromForeignPtr fptr 0 $ fromIntegral len
160−
161−{#fun unsafe yaml_emitter_set_output
162− { id `Emitter'
163− , id `FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt)'
164− , id `Ptr ()'
165− } -> `()' #}
166−
167−foreign import ccall "buffer.h &buffer_append"
168− buffer_append :: FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt)
169−
170−withEmitter :: (Emitter -> IO ()) -> IO B.ByteString
171−withEmitter f = do
172− allocaBytes emitterSize $ \e -> do
173− let e' = Emitter e
174− _res <- yaml_emitter_initialize e'
175− -- FIXME check res
176− bs <- withBuffer $ \(Buffer b) -> do
177− let fun = buffer_append
178− yaml_emitter_set_output e' buffer_append $ castPtr b
179− f e'
180− yaml_emitter_delete e'
181− return bs
182−
183−{#fun unsafe yaml_emitter_emit
184− { id `Emitter'
185− , id `EventRaw'
186− } -> `Int' #}
187−
188−{#fun unsafe print_emitter_error
189− { id `Emitter'
190− } -> `()' #}
191−
192−emitEvents :: Emitter -> [Event] -> IO ()
193−emitEvents _ [] = return ()
194−emitEvents emitter (e:rest) = do
195− res <- toEventRaw e $ yaml_emitter_emit emitter
196− when (res == 0) $
197− print_emitter_error emitter >> fail "yaml_emitter_emit failed"
198− emitEvents emitter rest
199−
200−{#fun unsafe yaml_stream_start_event_initialize
201− { id `EventRaw'
202− , `Int'
203− } -> `Int' #}
204−
205−{#fun unsafe yaml_stream_end_event_initialize
206− { id `EventRaw'
207− } -> `Int' #}
208−
209−{#fun unsafe yaml_scalar_event_initialize
210− { id `EventRaw'
211− , id `Ptr CUChar' -- anchor
212− , id `Ptr CUChar' -- tag
213− , id `Ptr CUChar' -- value
214− , `Int'
215− , `Int'
216− , `Int'
217− , `Int'
218− } -> `Int' #}
219−
220−{#fun unsafe simple_document_start
221− { id `EventRaw'
222− } -> `Int' #}
223−
224−{#fun unsafe yaml_document_end_event_initialize
225− { id `EventRaw'
226− , `Int'
227− } -> `Int' #}
228−
229−{#fun unsafe yaml_sequence_start_event_initialize
230− { id `EventRaw'
231− , id `Ptr CUChar'
232− , id `Ptr CUChar'
233− , `Int'
234− , `Int'
235− } -> `Int' #}
236−
237−{#fun unsafe yaml_sequence_end_event_initialize
238− { id `EventRaw'
239− } -> `Int' #}
240−
241−{#fun unsafe yaml_mapping_start_event_initialize
242− { id `EventRaw'
243− , id `Ptr CUChar'
244− , id `Ptr CUChar'
245− , `Int'
246− , `Int'
247− } -> `Int' #}
248−
249−{#fun unsafe yaml_mapping_end_event_initialize
250− { id `EventRaw'
251− } -> `Int' #}
252−
253−toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
254−toEventRaw e f = withEventRaw $ \er -> do
255− case e of
256− EventStreamStart ->
257− yaml_stream_start_event_initialize
258− er
259− 0 -- YAML_ANY_ENCODING
260− EventStreamEnd ->
261− yaml_stream_end_event_initialize er
262− EventDocumentStart ->
263− simple_document_start er
264− EventDocumentEnd ->
265− yaml_document_end_event_initialize er 1
266− EventScalar bs -> do
267− let (fvalue, offset, len) = B.toForeignPtr bs
268− withForeignPtr fvalue $ \value -> do
269− let value' = value `plusPtr` offset
270− yaml_scalar_event_initialize
271− er
272− nullPtr
273− nullPtr
274− value'
275− len
276− 0
277− 1
278− 0 -- YAML_ANY_SCALAR_STYLE
279− EventSequenceStart ->
280− yaml_sequence_start_event_initialize
281− er
282− nullPtr
283− nullPtr
284− 1
285− 0 -- YAML_ANY_SEQUENCE_STYLE
286− EventSequenceEnd ->
287− yaml_sequence_end_event_initialize er
288− EventMappingStart ->
289− yaml_mapping_start_event_initialize
290− er
291− nullPtr
292− nullPtr
293− 1
294− 0 -- YAML_ANY_SEQUENCE_STYLE
295− EventMappingEnd ->
296− yaml_mapping_end_event_initialize er
297− EventAlias -> error "toEventRaw: EventAlias not supported"
298− EventNone -> error "toEventRaw: EventNone not supported"
299− f er
Text/Libyaml.hsnew file+310
@@ -0,0 +1,310 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+
4+{-# INCLUDE <yaml.h> #-}
5+{-# INCLUDE <helper.h> #-}
6+module Text.Libyaml
7+{-
8+ (
9+ Event (..)
10+ , parserParse
11+ , withParser
12+ , emitEvents
13+ , withEmitter
14+ )-} where
15+
16+import qualified Data.ByteString.Internal as B
17+import Control.Monad
18+import Foreign.C
19+import Foreign.Ptr
20+import Foreign.ForeignPtr
21+import Foreign.Marshal.Alloc
22+
23+data ParserStruct
24+type Parser = Ptr ParserStruct
25+parserSize :: Int
26+parserSize = 480
27+
28+data EventRawStruct
29+type EventRaw = Ptr EventRawStruct
30+eventSize :: Int
31+eventSize = 104
32+
33+foreign import ccall unsafe "yaml_parser_initialize"
34+ c_yaml_parser_initialize :: Parser -> IO CInt
35+
36+foreign import ccall unsafe "yaml_parser_delete"
37+ c_yaml_parser_delete :: Parser -> IO ()
38+
39+foreign import ccall unsafe "yaml_parser_set_input_string"
40+ c_yaml_parser_set_input_string :: Parser
41+ -> Ptr CUChar
42+ -> CULong
43+ -> IO ()
44+
45+withParser :: B.ByteString -> (Parser -> IO a) -> IO a
46+withParser bs f = do
47+ allocaBytes parserSize $ \p ->
48+ do
49+ _res <- c_yaml_parser_initialize p
50+ -- FIXME check res
51+ let (fptr, offset, len) = B.toForeignPtr bs
52+ ret <- withForeignPtr fptr $ \ptr ->
53+ do
54+ let ptr' = castPtr ptr `plusPtr` offset
55+ len' = fromIntegral len
56+ c_yaml_parser_set_input_string p ptr' len'
57+ f p
58+ c_yaml_parser_delete p
59+ return ret
60+
61+withEventRaw :: (EventRaw -> IO a) -> IO a
62+withEventRaw f = allocaBytes eventSize $ f
63+
64+foreign import ccall unsafe "yaml_parser_parse"
65+ c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
66+
67+foreign import ccall unsafe "yaml_event_delete"
68+ c_yaml_event_delete :: EventRaw -> IO ()
69+
70+foreign import ccall "print_parser_error"
71+ c_print_parser_error :: Parser -> IO ()
72+
73+parserParseOne :: Parser -> IO Event
74+parserParseOne parser = withEventRaw $ \er -> do
75+ res <- c_yaml_parser_parse parser er
76+ when (res == 0) $
77+ c_print_parser_error parser >> fail "yaml_parser_parse failed"
78+ event <- getEvent er
79+ c_yaml_event_delete er
80+ return event
81+
82+data Event =
83+ EventNone
84+ | EventStreamStart
85+ | EventStreamEnd
86+ | EventDocumentStart
87+ | EventDocumentEnd
88+ | EventAlias
89+ | EventScalar B.ByteString
90+ | EventSequenceStart
91+ | EventSequenceEnd
92+ | EventMappingStart
93+ | EventMappingEnd
94+ deriving (Show)
95+
96+data EventType = YamlNoEvent
97+ | YamlStreamStartEvent
98+ | YamlStreamEndEvent
99+ | YamlDocumentStartEvent
100+ | YamlDocumentEndEvent
101+ | YamlAliasEvent
102+ | YamlScalarEvent
103+ | YamlSequenceStartEvent
104+ | YamlSequenceEndEvent
105+ | YamlMappingStartEvent
106+ | YamlMappingEndEvent
107+ deriving (Enum,Show)
108+
109+foreign import ccall unsafe "get_event_type"
110+ c_get_event_type :: EventRaw -> IO CInt
111+
112+foreign import ccall unsafe "get_scalar_value"
113+ c_get_scalar_value :: EventRaw -> IO (Ptr CUChar)
114+
115+foreign import ccall unsafe "get_scalar_length"
116+ c_get_scalar_length :: EventRaw -> IO CULong
117+
118+getEvent :: EventRaw -> IO Event
119+getEvent er = do
120+ et <- c_get_event_type er
121+ case toEnum $ fromEnum et of
122+ YamlNoEvent -> return EventNone
123+ YamlStreamStartEvent -> return EventStreamStart
124+ YamlStreamEndEvent -> return EventStreamEnd
125+ YamlDocumentStartEvent -> return EventDocumentStart
126+ YamlDocumentEndEvent -> return EventDocumentEnd
127+ YamlAliasEvent -> return EventAlias
128+ YamlScalarEvent -> do
129+ yvalue <- c_get_scalar_value er
130+ ylen <- c_get_scalar_length er
131+ let yvalue' = castPtr yvalue
132+ let ylen' = fromEnum ylen
133+ let ylen'' = toEnum $ fromEnum ylen
134+ bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
135+ return $ EventScalar bs
136+ YamlSequenceStartEvent -> return EventSequenceStart
137+ YamlSequenceEndEvent -> return EventSequenceEnd
138+ YamlMappingStartEvent -> return EventMappingStart
139+ YamlMappingEndEvent -> return EventMappingEnd
140+
141+parserParse :: Parser -> IO [Event]
142+parserParse parser = do
143+ event <- parserParseOne parser
144+ case event of
145+ EventStreamEnd -> return [event]
146+ _ -> do
147+ rest <- parserParse parser
148+ return $! event : rest
149+
150+-- Emitter
151+
152+data EmitterStruct
153+type Emitter = Ptr EmitterStruct
154+emitterSize :: Int
155+emitterSize = 432
156+
157+foreign import ccall unsafe "yaml_emitter_initialize"
158+ c_yaml_emitter_initialize :: Emitter -> IO CInt
159+
160+foreign import ccall unsafe "yaml_emitter_delete"
161+ c_yaml_emitter_delete :: Emitter -> IO ()
162+
163+data BufferStruct
164+type Buffer = Ptr BufferStruct
165+bufferSize :: Int
166+bufferSize = 16
167+
168+foreign import ccall unsafe "buffer_init"
169+ c_buffer_init :: Buffer -> IO ()
170+
171+foreign import ccall unsafe "get_buffer_buff"
172+ c_get_buffer_buff :: Buffer -> IO (Ptr CUChar)
173+
174+foreign import ccall unsafe "get_buffer_used"
175+ c_get_buffer_used :: Buffer -> IO CULong
176+
177+withBuffer :: (Buffer -> IO ()) -> IO B.ByteString
178+withBuffer f = do
179+ allocaBytes bufferSize $ \b -> do
180+ c_buffer_init b
181+ f b
182+ ptr' <- c_get_buffer_buff b
183+ len <- c_get_buffer_used b
184+ fptr <- newForeignPtr_ $ castPtr ptr'
185+ return $! B.fromForeignPtr fptr 0 $ fromIntegral len
186+
187+foreign import ccall unsafe "my_emitter_set_output"
188+ c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
189+
190+withEmitter :: (Emitter -> IO ()) -> IO B.ByteString
191+withEmitter f = do
192+ allocaBytes emitterSize $ \e -> do
193+ _res <- c_yaml_emitter_initialize e
194+ -- FIXME check res
195+ bs <- withBuffer $ \b -> do
196+ c_my_emitter_set_output e b
197+ f e
198+ c_yaml_emitter_delete e
199+ return bs
200+
201+foreign import ccall unsafe "yaml_emitter_emit"
202+ c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
203+
204+foreign import ccall unsafe "print_emitter_error"
205+ c_print_emitter_error :: Emitter -> IO ()
206+
207+emitEvents :: Emitter -> [Event] -> IO ()
208+emitEvents _ [] = return ()
209+emitEvents emitter (e:rest) = do
210+ res <- toEventRaw e $ c_yaml_emitter_emit emitter
211+ when (res == 0) $
212+ c_print_emitter_error emitter >> fail "yaml_emitter_emit failed"
213+ emitEvents emitter rest
214+
215+foreign import ccall unsafe "yaml_stream_start_event_initialize"
216+ c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
217+
218+foreign import ccall unsafe "yaml_stream_end_event_initialize"
219+ c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt
220+
221+foreign import ccall unsafe "yaml_scalar_event_initialize"
222+ c_yaml_scalar_event_initialize
223+ :: EventRaw
224+ -> Ptr CUChar -- anchor
225+ -> Ptr CUChar -- tag
226+ -> Ptr CUChar -- value
227+ -> CInt
228+ -> CInt
229+ -> CInt
230+ -> CInt
231+ -> IO CInt
232+
233+foreign import ccall unsafe "simple_document_start"
234+ c_simple_document_start :: EventRaw -> IO CInt
235+
236+foreign import ccall unsafe "yaml_document_end_event_initialize"
237+ c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt
238+
239+foreign import ccall unsafe "yaml_sequence_start_event_initialize"
240+ c_yaml_sequence_start_event_initialize
241+ :: EventRaw
242+ -> Ptr CUChar
243+ -> Ptr CUChar
244+ -> CInt
245+ -> CInt
246+ -> IO CInt
247+
248+foreign import ccall unsafe "yaml_sequence_end_event_initialize"
249+ c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt
250+
251+foreign import ccall unsafe "yaml_mapping_start_event_initialize"
252+ c_yaml_mapping_start_event_initialize
253+ :: EventRaw
254+ -> Ptr CUChar
255+ -> Ptr CUChar
256+ -> CInt
257+ -> CInt
258+ -> IO CInt
259+
260+foreign import ccall unsafe "yaml_mapping_end_event_initialize"
261+ c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
262+
263+toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
264+toEventRaw e f = withEventRaw $ \er -> do
265+ case e of
266+ EventStreamStart ->
267+ c_yaml_stream_start_event_initialize
268+ er
269+ 0 -- YAML_ANY_ENCODING
270+ EventStreamEnd ->
271+ c_yaml_stream_end_event_initialize er
272+ EventDocumentStart ->
273+ c_simple_document_start er
274+ EventDocumentEnd ->
275+ c_yaml_document_end_event_initialize er 1
276+ EventScalar bs -> do
277+ let (fvalue, offset, len) = B.toForeignPtr bs
278+ withForeignPtr fvalue $ \value -> do
279+ let value' = value `plusPtr` offset
280+ len' = fromIntegral len
281+ c_yaml_scalar_event_initialize
282+ er
283+ nullPtr
284+ nullPtr
285+ value'
286+ len'
287+ 0
288+ 1
289+ 0 -- YAML_ANY_SCALAR_STYLE
290+ EventSequenceStart ->
291+ c_yaml_sequence_start_event_initialize
292+ er
293+ nullPtr
294+ nullPtr
295+ 1
296+ 0 -- YAML_ANY_SEQUENCE_STYLE
297+ EventSequenceEnd ->
298+ c_yaml_sequence_end_event_initialize er
299+ EventMappingStart ->
300+ c_yaml_mapping_start_event_initialize
301+ er
302+ nullPtr
303+ nullPtr
304+ 1
305+ 0 -- YAML_ANY_SEQUENCE_STYLE
306+ EventMappingEnd ->
307+ c_yaml_mapping_end_event_initialize er
308+ EventAlias -> error "toEventRaw: EventAlias not supported"
309+ EventNone -> error "toEventRaw: EventNone not supported"
310+ f er
c/helper.c+30
@@ -31,6 +31,21 @@ int buffer_append(void *ext, unsigned char *str, size_t size)
3131 return 1;
3232}
3333
34+unsigned char * get_buffer_buff(buffer_t *b)
35+{
36+ return b->buff;
37+}
38+
39+unsigned int get_buffer_used(buffer_t *b)
40+{
41+ return b->used;
42+}
43+
44+void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b)
45+{
46+ yaml_emitter_set_output(e, buffer_append, b);
47+}
48+
3449void print_parser_error(yaml_parser_t *p)
3550{
3651 fprintf(stderr, "Problem: %s\nContext: %s\nOffset: %u\n",
@@ -53,3 +68,18 @@ int simple_document_start(yaml_event_t *e)
5368 0,
5469 1);
5570}
71+
72+int get_event_type(yaml_event_t *e)
73+{
74+ return e->type;
75+}
76+
77+unsigned char * get_scalar_value(yaml_event_t *e)
78+{
79+ return e->data.scalar.value;
80+}
81+
82+unsigned long get_scalar_length(yaml_event_t *e)
83+{
84+ return e->data.scalar.length;
85+}
c/helper.h+9−1
@@ -4,14 +4,22 @@
44#include <yaml.h>
55
66typedef struct buffer_s {
7− char *buff;
7+ unsigned char *buff;
88 unsigned int size, used;
99} buffer_t;
1010void buffer_init(buffer_t *buffer);
1111int buffer_append(void *ext, unsigned char *str, size_t size);
12+unsigned char * get_buffer_buff(buffer_t *b);
13+unsigned int get_buffer_used(buffer_t *b);
14+
15+void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b);
1216
1317void print_parser_error(yaml_parser_t *p);
1418void print_emitter_error(yaml_emitter_t *e);
1519int simple_document_start(yaml_event_t *e);
1620
21+int get_event_type(yaml_event_t *e);
22+unsigned char * get_scalar_value(yaml_event_t *e);
23+unsigned long get_scalar_length(yaml_event_t *e);
24+
1725#endif /* __HELPER_H__ */
yaml.cabal+2−4
@@ -1,5 +1,5 @@
11name: yaml
2−version: 0.0.1
2+version: 0.0.2
33license: BSD3
44license-file: LICENSE
55author: Michael Snoyman <michael@snoyman.com>
@@ -22,8 +22,7 @@ library
2222 bytestring >= 0.9.1.4 && < 1,
2323 haskell98
2424 exposed-modules: Text.Yaml
25− other-modules: Text.Libyaml,
26− C2HS
25+ other-modules: Text.Libyaml
2726 ghc-options: -Wall
2827 c-sources: c/helper.c,
2928 c/api.c,
@@ -35,4 +34,3 @@ library
3534 c/scanner.c,
3635 c/writer.c
3736 include-dirs: c
38− build-tools: c2hs