@@ -3,6 +3,8 @@
3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PackageImports #-}
7+{-# LANGUAGE TypeFamilies #-}
7module Text.Libyaml
9module Text.Libyaml
8 ( -- * The event stream
10 ( -- * The event stream
@@ -11,13 +13,9 @@ module Text.Libyaml
11 , Tag (..)
13 , Tag (..)
12 -- * Exceptions
14 -- * Exceptions
13 , YamlException (..)
15 , YamlException (..)
19 -- * Enumerator
16 -- * Enumerator
20 , EnumResult (..)
17 , EnumResult (..)
21 -- * Higher level functions
19 -- * Higher level functions
@@ -34,6 +32,8 @@ import Foreign.C
34import Foreign.Ptr
32import Foreign.Ptr
35import Foreign.ForeignPtr
33import Foreign.ForeignPtr
36import Foreign.Marshal.Alloc
34import Foreign.Marshal.Alloc
35+import "transformers" Control.Monad.Trans
36+import Control.Failure
38import Control.Exception (throwIO, Exception, SomeException)
38import Control.Exception (throwIO, Exception, SomeException)
39import Data.Typeable (Typeable)
39import Data.Typeable (Typeable)
@@ -159,42 +159,59 @@ foreign import ccall unsafe "fclose"
159 c_fclose :: File
159 c_fclose :: File
162+class MonadIO m => RMonadIO m where
163+ type Inside :: * -> *
164+ ioOut :: m v -> IO (Inside v)
165+ ioIn :: IO (Inside v) -> m v
166+newtype SimpleIdent x = SimpleIdent { unSimpleIdent :: x }
167+instance RMonadIO IO where
168+ type Inside = SimpleIdent
169+ ioOut = fmap SimpleIdent
170+ ioIn = fmap unSimpleIdent
172+allocaBytesR :: RMonadIO m => Int -> (Ptr a -> m b) -> m b
173+allocaBytesR i f = ioIn $ allocaBytes i $ ioOut . f
175+withCStringR :: RMonadIO m => String -> (Ptr CChar -> m a) -> m a
176+withCStringR s f = ioIn $ withCString s $ ioOut . f
178+withFileParser :: (MonadFailure YamlException m, RMonadIO m)
162−withFileParser :: FilePath
179+ => FilePath
163− -> (Parser -> IO (Either YamlException a))
180+ -> (Parser -> m a)
164− -> IO (Either YamlException a)
181+ -> m a
165−withFileParser fp f = allocaBytes parserSize $ \p ->
182+withFileParser fp f = allocaBytesR parserSize $ \p -> do
167− res <- c_yaml_parser_initialize p
183+ res <- liftIO $ c_yaml_parser_initialize p
168− when (res == 0) $ throwIO YamlOutOfMemory
184+ when (res == 0) $ failure YamlOutOfMemory
169− file <- withCString fp $ \fp' -> withCString "r" $ \r' ->
185+ file <- withCStringR fp $ \fp' -> withCStringR "r" $ \r' ->
170− c_fopen fp' r'
186+ liftIO (c_fopen fp' r')
171− when (file == nullPtr) $ throwIO $ YamlFileNotFound fp
187+ when (file == nullPtr) $ failure $ YamlFileNotFound fp
172− c_yaml_parser_set_input_file p file
188+ liftIO $ c_yaml_parser_set_input_file p file
173− ret <- f p
189+ ret <- f p
174− c_fclose file
190+ liftIO $ c_fclose file
175− c_yaml_parser_delete p
191+ liftIO $ c_yaml_parser_delete p -- could use some finallys here
176− return ret
192+ return ret
194+withParser :: (MonadFailure YamlException m, RMonadIO m)
178−withParser :: B.ByteString
195+ => B.ByteString
179− -> (Parser -> IO (Either YamlException a))
196+ -> (Parser -> m a)
180− -> IO (Either YamlException a)
197+ -> m a
181−withParser bs f = allocaBytes parserSize $ \p -> do
198+withParser bs f = allocaBytesR parserSize $ \p -> do
182− res <- c_yaml_parser_initialize p
199+ res <- liftIO $ c_yaml_parser_initialize p
184− then return (Left YamlOutOfMemory)
200+ when (res == 0) $ failure YamlOutOfMemory
186− let (fptr, offset, len) = B.toForeignPtr bs
201+ let (fptr, offset, len) = B.toForeignPtr bs
187− ret <- withForeignPtr fptr $ \ptr ->
202+ ret <- withForeignPtrR fptr $ \ptr -> do
189− let ptr' = castPtr ptr `plusPtr` offset
203+ let ptr' = castPtr ptr `plusPtr` offset
190− len' = fromIntegral len
204+ len' = fromIntegral len
191− c_yaml_parser_set_input_string p ptr' len'
205+ liftIO $ c_yaml_parser_set_input_string p ptr' len'
193− c_yaml_parser_delete p -- FIXME use finally
207+ liftIO $ c_yaml_parser_delete p -- FIXME use finally
194− return ret
208+ return ret
196−withEventRaw :: (EventRaw -> IO a) -> IO a
210+withForeignPtrR :: RMonadIO m
197−withEventRaw = allocaBytes eventSize
211+ => ForeignPtr a
214+withForeignPtrR fp f = ioIn $ withForeignPtr fp $ ioOut . f
199foreign import ccall unsafe "yaml_parser_parse"
216foreign import ccall unsafe "yaml_parser_parse"
200 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
217 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
@@ -211,26 +228,26 @@ foreign import ccall "get_parser_error_context"
211foreign import ccall unsafe "get_parser_error_offset"
228foreign import ccall unsafe "get_parser_error_offset"
212 c_get_parser_error_offset :: Parser -> IO CULong
229 c_get_parser_error_offset :: Parser -> IO CULong
214−makeString :: (a -> IO (Ptr CUChar)) -> a -> IO String
231+makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
215makeString f a = do
232makeString f a = do
216− cchar <- castPtr `fmap` f a
233+ cchar <- castPtr `liftM` f a
217− peekCString cchar
234+ liftIO $ peekCString cchar
219−parserParseOne :: Parser
236+parserParseOne :: (MonadFailure YamlException m, RMonadIO m)
220− -> IO (Either YamlException Event)
237+ => Parser
221−parserParseOne parser = withEventRaw $ \er -> do
239+parserParseOne parser = allocaBytesR eventSize $ \er -> do
222− res <- c_yaml_parser_parse parser er
240+ res <- liftIO $ c_yaml_parser_parse parser er
224− if res == 0
242+ if res == 0
226− problem <- makeString c_get_parser_error_problem parser
244+ problem <- liftIO $ makeString c_get_parser_error_problem parser
227− context <- makeString c_get_parser_error_context parser
245+ context <- liftIO $ makeString c_get_parser_error_context parser
228− offset <- fromIntegral `fmap`
246+ offset <- liftIO $ fromIntegral `fmap`
229 c_get_parser_error_offset parser
247 c_get_parser_error_offset parser
231− YamlParserException problem context offset
248+ failure $ YamlParserException problem context offset
232− else Right `fmap` getEvent er
249+ else liftIO $ getEvent er
233− c_yaml_event_delete er
250+ liftIO $ c_yaml_event_delete er -- FIXME use finally
234 return event
251 return event
236data EventType = YamlNoEvent
253data EventType = YamlNoEvent
@@ -298,19 +315,17 @@ getEvent er = do
298 YamlMappingStartEvent -> return EventMappingStart
315 YamlMappingStartEvent -> return EventMappingStart
299 YamlMappingEndEvent -> return EventMappingEnd
316 YamlMappingEndEvent -> return EventMappingEnd
318+parserParse :: (MonadFailure YamlException m, RMonadIO m)
301−parserParse :: (a -> Event -> IO (EnumResult a b))
319+ => (a -> Event -> m (EnumResult a b))
303 -> Parser
321 -> Parser
304− -> IO (Either YamlException b)
322+ -> m b
305parserParse fold accum parser = do
323parserParse fold accum parser = do
306− event' <- parserParseOne parser
324+ event <- liftIO $ parserParseOne parser
308− Left e -> return $ Left e
310− res <- fold accum event
325+ res <- fold accum event
311− case res of
326+ case res of
312− Done accum' -> return $ Right accum'
327+ Done accum' -> return accum'
313− More accum' -> parserParse fold accum' parser
328+ More accum' -> parserParse fold accum' parser
315-- Emitter
330-- Emitter
@@ -339,58 +354,54 @@ foreign import ccall unsafe "get_buffer_buff"
339foreign import ccall unsafe "get_buffer_used"
354foreign import ccall unsafe "get_buffer_used"
340 c_get_buffer_used :: Buffer -> IO CULong
355 c_get_buffer_used :: Buffer -> IO CULong
342−withBuffer :: (Buffer -> IO (Either YamlException ()))
357+withBufferR :: (RMonadIO m, MonadFailure YamlException m)
343− -> IO (Either YamlException B.ByteString)
359+ -> m B.ByteString
344−withBuffer f = allocaBytes bufferSize $ \b -> do
360+withBufferR f = allocaBytesR bufferSize $ \b -> do
345− c_buffer_init b
361+ liftIO $ c_buffer_init b
346− aRes <- f b
362+ aRes <- f b
348− Left e -> return $ Left e
350− ptr' <- c_get_buffer_buff b
363+ ptr' <- liftIO $ c_get_buffer_buff b
351− len <- c_get_buffer_used b
364+ len <- liftIO $ c_get_buffer_used b
352− fptr <- newForeignPtr_ $ castPtr ptr'
365+ fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'
353− return $ Right $ B.fromForeignPtr fptr 0 $ fromIntegral len
366+ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
355foreign import ccall unsafe "my_emitter_set_output"
368foreign import ccall unsafe "my_emitter_set_output"
356 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
369 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
358−withEmitter :: (Emitter -> IO (Either YamlException ()))
371+withEmitter :: (RMonadIO m, MonadFailure YamlException m)
372+ => (Emitter -> m ())
359− -> IO (Either YamlException B.ByteString)
373+ -> m B.ByteString
360−withEmitter f = allocaBytes emitterSize $ \e -> do
374+withEmitter f = allocaBytesR emitterSize $ \e -> do
361− res <- c_yaml_emitter_initialize e
375+ res <- liftIO $ c_yaml_emitter_initialize e
363− then return $ Left YamlOutOfMemory
376+ when (res == 0) $ failure YamlOutOfMemory
364− else do
377+ bs <- withBufferR $ \b -> do
365− bs <- withBuffer $ \b -> do
366− c_my_emitter_set_output e b
378+ liftIO $ c_my_emitter_set_output e b
368− c_yaml_emitter_delete e
380+ liftIO $ c_yaml_emitter_delete e -- FIXME finally
369− return bs
381+ return bs
371foreign import ccall unsafe "yaml_emitter_set_output_file"
383foreign import ccall unsafe "yaml_emitter_set_output_file"
372 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
384 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
386+withEmitterFile :: (RMonadIO m, MonadFailure YamlException m)
374−withEmitterFile :: FilePath
387+ => FilePath
375− -> (Emitter -> IO (Either YamlException ()))
388+ -> (Emitter -> m ())
376− -> IO (Either YamlException ())
389+ -> m ()
377−withEmitterFile fp f = allocaBytes emitterSize $ \e -> do
390+withEmitterFile fp f = allocaBytesR emitterSize $ \e -> do
378− res <- c_yaml_emitter_initialize e
391+ res <- liftIO $ c_yaml_emitter_initialize e
380− then return $ Left YamlOutOfMemory
392+ when (res == 0) $ failure YamlOutOfMemory
381− else do
393+ file <- withCStringR fp $ \fp' -> withCStringR "w" $ \w' ->
382− file <- withCString fp $ \fp' -> withCString "w" $ \w' ->
383− c_fopen fp' w'
394+ liftIO (c_fopen fp' w')
385− if file == nullPtr
396+ if file == nullPtr
386− then return $ Left $ YamlFileNotFound fp
397+ then failure $ YamlFileNotFound fp
388− c_yaml_emitter_set_output_file e file
399+ liftIO $ c_yaml_emitter_set_output_file e file
389− res' <- f e
400+ res' <- f e
390− c_yaml_emitter_delete e
401+ liftIO $ c_yaml_emitter_delete e
391− return res'
402+ return res'
392− c_fclose file
403+ liftIO $ c_fclose file -- FIXME use finally
393− return res'
404+ return res'
395foreign import ccall unsafe "yaml_emitter_emit"
406foreign import ccall unsafe "yaml_emitter_emit"
396 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
407 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
@@ -398,20 +409,19 @@ foreign import ccall unsafe "yaml_emitter_emit"
398foreign import ccall unsafe "get_emitter_error"
409foreign import ccall unsafe "get_emitter_error"
399 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
410 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
412+emitEvents :: (MonadFailure YamlException m, RMonadIO m)
401−emitEvents :: (a -> Maybe (Event, a))
413+ => (a -> Maybe (Event, a))
403 -> Emitter
415 -> Emitter
404− -> IO (Either YamlException ())
416+ -> m ()
405−emitEvents unfold src emitter = do
417+emitEvents unfold src emitter = case unfold src of
407− Nothing -> return $ Right ()
418+ Nothing -> return ()
408− Just (e, src') -> do
419+ Just (e, src') -> do
409− res <- toEventRaw e $ c_yaml_emitter_emit emitter
420+ res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
410− if res == 0
421+ when (res == 0) $ do
412− problem <- makeString c_get_emitter_error emitter
422+ problem <- liftIO $ makeString c_get_emitter_error emitter
413− return $ Left $ YamlEmitterException e problem
423+ failure $ YamlEmitterException e problem
414− else emitEvents unfold src' emitter
424+ emitEvents unfold src' emitter
416foreign import ccall unsafe "yaml_stream_start_event_initialize"
426foreign import ccall unsafe "yaml_stream_start_event_initialize"
417 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
427 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
@@ -462,7 +472,7 @@ foreign import ccall unsafe "yaml_mapping_end_event_initialize"
462 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
472 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
464toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
474toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
465−toEventRaw e f = withEventRaw $ \er -> do
475+toEventRaw e f = allocaBytesR eventSize $ \er -> do
466 ret <- case e of
476 ret <- case e of
467 EventStreamStart ->
477 EventStreamStart ->
468 c_yaml_stream_start_event_initialize
478 c_yaml_stream_start_event_initialize
@@ -526,26 +536,30 @@ instance Exception ToEventRawException
526data EnumResult a b = More a | Done b
536data EnumResult a b = More a | Done b
527 deriving (Eq, Show)
537 deriving (Eq, Show)
539+encode :: (RMonadIO m, MonadFailure YamlException m)
529−encode :: (a -> Maybe (Event, a))
540+ => (a -> Maybe (Event, a))
531− -> IO (Either YamlException B.ByteString)
542+ -> m B.ByteString
532encode unfold src = withEmitter $ emitEvents unfold src
543encode unfold src = withEmitter $ emitEvents unfold src
545+encodeFile :: (RMonadIO m, MonadFailure YamlException m)
534−encodeFile :: FilePath
546+ => FilePath
535 -> (a -> Maybe (Event, a))
547 -> (a -> Maybe (Event, a))
537− -> IO (Either YamlException ())
549+ -> m ()
538encodeFile filePath unfold src =
550encodeFile filePath unfold src =
539 withEmitterFile filePath $ emitEvents unfold src
551 withEmitterFile filePath $ emitEvents unfold src
553+decode :: (RMonadIO m, MonadFailure YamlException m)
541−decode :: B.ByteString
554+ => B.ByteString
542− -> (a -> Event -> IO (EnumResult a b))
555+ -> (a -> Event -> m (EnumResult a b))
544− -> IO (Either YamlException b)
557+ -> m b
545decode bs fold accum = withParser bs $ parserParse fold accum
558decode bs fold accum = withParser bs $ parserParse fold accum
560+decodeFile :: (RMonadIO m, MonadFailure YamlException m)
547−decodeFile :: FilePath
561+ => FilePath
548− -> (a -> Event -> IO (EnumResult a b))
562+ -> (a -> Event -> m (EnumResult a b))
550− -> IO (Either YamlException b)
564+ -> m b
551decodeFile fp fold accum = withFileParser fp $ parserParse fold accum
565decodeFile fp fold accum = withFileParser fp $ parserParse fold accum