@@ -19,7 +19,7 @@ module Text.Libyaml
1919 -- * Higher level functions
2020 , encode
2121 , decode
22− -- FIXME , encodeFile
22+ , encodeFile
2323 , decodeFile
2424 ) where
2525
@@ -33,9 +33,6 @@ import Foreign.Ptr
3333import Foreign.ForeignPtr
3434import Foreign.Marshal.Alloc
3535
36−import Control.Applicative
37−import Control.Failure
38−
3936import Control.Exception (throwIO, Exception)
4037import Data.Typeable (Typeable)
4138
@@ -213,9 +210,8 @@ makeString f a = do
213210 cchar <- castPtr `fmap` f a
214211 peekCString cchar
215212
216−parserParseOne :: MonadFailure YamlException m
217− => Parser
218− -> IO (m Event)
213+parserParseOne :: Parser
214+ -> IO (Either YamlException Event)
219215parserParseOne parser = withEventRaw $ \er -> do
220216 res <- c_yaml_parser_parse parser er
221217 event <-
@@ -225,9 +221,9 @@ parserParseOne parser = withEventRaw $ \er -> do
225221 context <- makeString c_get_parser_error_context parser
226222 offset <- fromIntegral `fmap`
227223 c_get_parser_error_offset parser
228− return $ failure $
224+ return $ Left $
229225 YamlParserException problem context offset
230− else return `fmap` getEvent er
226+ else Right `fmap` getEvent er
231227 c_yaml_event_delete er
232228 return event
233229
@@ -296,19 +292,6 @@ getEvent er = do
296292 YamlMappingStartEvent -> return EventMappingStart
297293 YamlMappingEndEvent -> return EventMappingEnd
298294
299−data YAttempt v = YSuccess v | YFailure YamlException
300−instance Functor YAttempt where
301− fmap = liftM
302−instance Applicative YAttempt where
303− pure = return
304− (<*>) = ap
305−instance Monad YAttempt where
306− return = YSuccess
307− YSuccess v >>= f = f v
308− YFailure e >>= _ = YFailure e
309−instance Failure YamlException YAttempt where
310− failure = YFailure
311−
312295parserParse :: (a -> Event -> Either a a)
313296 -> a
314297 -> Parser
@@ -316,8 +299,8 @@ parserParse :: (a -> Event -> Either a a)
316299parserParse fold accum parser = do
317300 event' <- parserParseOne parser
318301 case event' of
319− YFailure e -> return $ Left e
320− YSuccess event -> do
302+ Left e -> return $ Left e
303+ Right event -> do
321304 case fold accum event of
322305 Left accum' -> return $ Right accum'
323306 Right accum' -> parserParse fold accum' parser
@@ -349,34 +332,34 @@ foreign import ccall unsafe "get_buffer_buff"
349332foreign import ccall unsafe "get_buffer_used"
350333 c_get_buffer_used :: Buffer -> IO CULong
351334
352−withBuffer :: MonadFailure YamlException m
353− => (Buffer -> IO (YAttempt ()))
354− -> IO (m B.ByteString)
335+withBuffer :: (Buffer -> IO (Either YamlException ()))
336+ -> IO (Either YamlException B.ByteString)
355337withBuffer f = allocaBytes bufferSize $ \b -> do
356338 c_buffer_init b
357339 aRes <- f b
358340 case aRes of
359− YFailure e -> return $ failure e
360− YSuccess () -> do
341+ Left e -> return $ Left e
342+ Right () -> do
361343 ptr' <- c_get_buffer_buff b
362344 len <- c_get_buffer_used b
363345 fptr <- newForeignPtr_ $ castPtr ptr'
364− return $ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
346+ return $ Right $ B.fromForeignPtr fptr 0 $ fromIntegral len
365347
366348foreign import ccall unsafe "my_emitter_set_output"
367349 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
368350
369−withEmitter :: MonadFailure YamlException m
370− => (Emitter -> IO (YAttempt ()))
371− -> IO (m B.ByteString)
351+withEmitter :: (Emitter -> IO (Either YamlException ()))
352+ -> IO (Either YamlException B.ByteString)
372353withEmitter f = allocaBytes emitterSize $ \e -> do
373− res <- c_yaml_emitter_initialize e
374− when (res == 0) $ throwIO YamlOutOfMemory
375− bs <- withBuffer $ \b -> do
376− c_my_emitter_set_output e b
377− f e
378− c_yaml_emitter_delete e
379− return bs
354+ res <- c_yaml_emitter_initialize e
355+ if res == 0
356+ then return $ Left YamlOutOfMemory
357+ else do
358+ bs <- withBuffer $ \b -> do
359+ c_my_emitter_set_output e b
360+ f e
361+ c_yaml_emitter_delete e
362+ return bs
380363
381364foreign import ccall unsafe "yaml_emitter_emit"
382365 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
@@ -384,18 +367,20 @@ foreign import ccall unsafe "yaml_emitter_emit"
384367foreign import ccall unsafe "get_emitter_error"
385368 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
386369
387−emitEvents :: MonadFailure YamlException m
388− => Emitter
389− -> [Event]
390− -> IO (m ())
391−emitEvents _ [] = return $ return ()
392−emitEvents emitter (e:rest) = do
393− res <- toEventRaw e $ c_yaml_emitter_emit emitter
394− if res == 0
395− then do
396− problem <- makeString c_get_emitter_error emitter
397− return $ failure $ YamlEmitterException problem
398− else emitEvents emitter rest
370+emitEvents :: (a -> Maybe (Event, a))
371+ -> a
372+ -> Emitter
373+ -> IO (Either YamlException ())
374+emitEvents unfold src emitter = do
375+ case unfold src of
376+ Nothing -> return $ Right ()
377+ Just (e, src') -> do
378+ res <- toEventRaw e $ c_yaml_emitter_emit emitter
379+ if res == 0
380+ then do
381+ problem <- makeString c_get_emitter_error emitter
382+ return $ Left $ YamlEmitterException problem
383+ else emitEvents unfold src' emitter
399384
400385foreign import ccall unsafe "yaml_stream_start_event_initialize"
401386 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
@@ -500,19 +485,29 @@ toEventRaw e f = withEventRaw $ \er -> do
500485 c_yaml_mapping_end_event_initialize er
501486 EventAlias -> error "toEventRaw: EventAlias not supported"
502487 EventNone -> error "toEventRaw: EventNone not supported"
503− unless (ret == 1) $ failure $ ToEventRawException ret
488+ unless (ret == 1) $ throwIO $ ToEventRawException ret
504489 f er
505490
506491newtype ToEventRawException = ToEventRawException CInt
507492 deriving (Show, Typeable)
508493instance Exception ToEventRawException
509494
510−encode :: MonadFailure YamlException m
511− => [Event]
512− -> IO (m B.ByteString)
513−encode = withEmitter . flip emitEvents
495+encode :: (a -> Maybe (Event, a))
496+ -> a
497+ -> IO (Either YamlException B.ByteString)
498+encode unfold src = withEmitter $ emitEvents unfold src
514499
515−-- FIXME encodeFile
500+encodeFile :: FilePath
501+ -> (a -> Maybe (Event, a))
502+ -> a
503+ -> IO (Either YamlException ())
504+encodeFile filePath unfold src = do
505+ res <- withEmitter $ emitEvents unfold src
506+ case res of
507+ Left e -> return $ Left e
508+ Right bs -> do
509+ Data.ByteString.writeFile filePath bs
510+ return $ Right ()
516511
517512decode :: B.ByteString
518513 -> (a -> Event -> Either a a)