@@ -3,6 +3,8 @@
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PackageImports #-}
7+{-# LANGUAGE TypeFamilies #-}
68
79module Text.Libyaml
810 ( -- * The event stream
@@ -11,13 +13,9 @@ module Text.Libyaml
1113 , Tag (..)
1214 -- * Exceptions
1315 , YamlException (..)
14− -- * Low level
15− , withEmitter
16− , emitEvents
17− , withParser
18− , parserParse
1916 -- * Enumerator
2017 , EnumResult (..)
18+ , RMonadIO (..)
2119 -- * Higher level functions
2220 , encode
2321 , decode
@@ -34,6 +32,8 @@ import Foreign.C
3432import Foreign.Ptr
3533import Foreign.ForeignPtr
3634import Foreign.Marshal.Alloc
35+import "transformers" Control.Monad.Trans
36+import Control.Failure
3737
3838import Control.Exception (throwIO, Exception, SomeException)
3939import Data.Typeable (Typeable)
@@ -159,42 +159,59 @@ foreign import ccall unsafe "fclose"
159159 c_fclose :: File
160160 -> IO ()
161161
162−withFileParser :: FilePath
163− -> (Parser -> IO (Either YamlException a))
164− -> IO (Either YamlException a)
165−withFileParser fp f = allocaBytes parserSize $ \p ->
166− do
167− res <- c_yaml_parser_initialize p
168− when (res == 0) $ throwIO YamlOutOfMemory
169− file <- withCString fp $ \fp' -> withCString "r" $ \r' ->
170− c_fopen fp' r'
171− when (file == nullPtr) $ throwIO $ YamlFileNotFound fp
172− c_yaml_parser_set_input_file p file
173− ret <- f p
174− c_fclose file
175− c_yaml_parser_delete p
176− return ret
177−
178−withParser :: B.ByteString
179− -> (Parser -> IO (Either YamlException a))
180− -> IO (Either YamlException a)
181−withParser bs f = allocaBytes parserSize $ \p -> do
182− res <- c_yaml_parser_initialize p
183− if res == 0
184− then return (Left YamlOutOfMemory)
185− else do
186− let (fptr, offset, len) = B.toForeignPtr bs
187− ret <- withForeignPtr fptr $ \ptr ->
188− do
189− let ptr' = castPtr ptr `plusPtr` offset
190− len' = fromIntegral len
191− c_yaml_parser_set_input_string p ptr' len'
192− f p
193− c_yaml_parser_delete p -- FIXME use finally
194− return ret
195−
196−withEventRaw :: (EventRaw -> IO a) -> IO a
197−withEventRaw = allocaBytes eventSize
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
171+
172+allocaBytesR :: RMonadIO m => Int -> (Ptr a -> m b) -> m b
173+allocaBytesR i f = ioIn $ allocaBytes i $ ioOut . f
174+
175+withCStringR :: RMonadIO m => String -> (Ptr CChar -> m a) -> m a
176+withCStringR s f = ioIn $ withCString s $ ioOut . f
177+
178+withFileParser :: (MonadFailure YamlException m, RMonadIO m)
179+ => FilePath
180+ -> (Parser -> m a)
181+ -> m a
182+withFileParser fp f = allocaBytesR parserSize $ \p -> do
183+ res <- liftIO $ c_yaml_parser_initialize p
184+ when (res == 0) $ failure YamlOutOfMemory
185+ file <- withCStringR fp $ \fp' -> withCStringR "r" $ \r' ->
186+ liftIO (c_fopen fp' r')
187+ when (file == nullPtr) $ failure $ YamlFileNotFound fp
188+ liftIO $ c_yaml_parser_set_input_file p file
189+ ret <- f p
190+ liftIO $ c_fclose file
191+ liftIO $ c_yaml_parser_delete p -- could use some finallys here
192+ return ret
193+
194+withParser :: (MonadFailure YamlException m, RMonadIO m)
195+ => B.ByteString
196+ -> (Parser -> m a)
197+ -> m a
198+withParser bs f = allocaBytesR parserSize $ \p -> do
199+ res <- liftIO $ c_yaml_parser_initialize p
200+ when (res == 0) $ failure YamlOutOfMemory
201+ let (fptr, offset, len) = B.toForeignPtr bs
202+ ret <- withForeignPtrR fptr $ \ptr -> do
203+ let ptr' = castPtr ptr `plusPtr` offset
204+ len' = fromIntegral len
205+ liftIO $ c_yaml_parser_set_input_string p ptr' len'
206+ f p
207+ liftIO $ c_yaml_parser_delete p -- FIXME use finally
208+ return ret
209+
210+withForeignPtrR :: RMonadIO m
211+ => ForeignPtr a
212+ -> (Ptr a -> m b)
213+ -> m b
214+withForeignPtrR fp f = ioIn $ withForeignPtr fp $ ioOut . f
198215
199216foreign import ccall unsafe "yaml_parser_parse"
200217 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
@@ -211,26 +228,26 @@ foreign import ccall "get_parser_error_context"
211228foreign import ccall unsafe "get_parser_error_offset"
212229 c_get_parser_error_offset :: Parser -> IO CULong
213230
214−makeString :: (a -> IO (Ptr CUChar)) -> a -> IO String
231+makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
215232makeString f a = do
216− cchar <- castPtr `fmap` f a
217− peekCString cchar
218−
219−parserParseOne :: Parser
220− -> IO (Either YamlException Event)
221−parserParseOne parser = withEventRaw $ \er -> do
222− res <- c_yaml_parser_parse parser er
233+ cchar <- castPtr `liftM` f a
234+ liftIO $ peekCString cchar
235+
236+parserParseOne :: (MonadFailure YamlException m, RMonadIO m)
237+ => Parser
238+ -> m Event
239+parserParseOne parser = allocaBytesR eventSize $ \er -> do
240+ res <- liftIO $ c_yaml_parser_parse parser er
223241 event <-
224− if res == 0
225− then do
226− problem <- makeString c_get_parser_error_problem parser
227− context <- makeString c_get_parser_error_context parser
228− offset <- fromIntegral `fmap`
242+ if res == 0
243+ then do
244+ problem <- liftIO $ makeString c_get_parser_error_problem parser
245+ context <- liftIO $ makeString c_get_parser_error_context parser
246+ offset <- liftIO $ fromIntegral `fmap`
229247 c_get_parser_error_offset parser
230− return $ Left $
231− YamlParserException problem context offset
232− else Right `fmap` getEvent er
233− c_yaml_event_delete er
248+ failure $ YamlParserException problem context offset
249+ else liftIO $ getEvent er
250+ liftIO $ c_yaml_event_delete er -- FIXME use finally
234251 return event
235252
236253data EventType = YamlNoEvent
@@ -298,19 +315,17 @@ getEvent er = do
298315 YamlMappingStartEvent -> return EventMappingStart
299316 YamlMappingEndEvent -> return EventMappingEnd
300317
301−parserParse :: (a -> Event -> IO (EnumResult a b))
318+parserParse :: (MonadFailure YamlException m, RMonadIO m)
319+ => (a -> Event -> m (EnumResult a b))
302320 -> a
303321 -> Parser
304− -> IO (Either YamlException b)
322+ -> m b
305323parserParse fold accum parser = do
306− event' <- parserParseOne parser
307− case event' of
308− Left e -> return $ Left e
309− Right event -> do
310− res <- fold accum event
311− case res of
312− Done accum' -> return $ Right accum'
313− More accum' -> parserParse fold accum' parser
324+ event <- liftIO $ parserParseOne parser
325+ res <- fold accum event
326+ case res of
327+ Done accum' -> return accum'
328+ More accum' -> parserParse fold accum' parser
314329
315330-- Emitter
316331
@@ -339,58 +354,54 @@ foreign import ccall unsafe "get_buffer_buff"
339354foreign import ccall unsafe "get_buffer_used"
340355 c_get_buffer_used :: Buffer -> IO CULong
341356
342−withBuffer :: (Buffer -> IO (Either YamlException ()))
343− -> IO (Either YamlException B.ByteString)
344−withBuffer f = allocaBytes bufferSize $ \b -> do
345− c_buffer_init b
346− aRes <- f b
347− case aRes of
348− Left e -> return $ Left e
349− Right () -> do
350− ptr' <- c_get_buffer_buff b
351− len <- c_get_buffer_used b
352− fptr <- newForeignPtr_ $ castPtr ptr'
353− return $ Right $ B.fromForeignPtr fptr 0 $ fromIntegral len
357+withBufferR :: (RMonadIO m, MonadFailure YamlException m)
358+ => (Buffer -> m ())
359+ -> m B.ByteString
360+withBufferR f = allocaBytesR bufferSize $ \b -> do
361+ liftIO $ c_buffer_init b
362+ aRes <- f b
363+ ptr' <- liftIO $ c_get_buffer_buff b
364+ len <- liftIO $ c_get_buffer_used b
365+ fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'
366+ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
354367
355368foreign import ccall unsafe "my_emitter_set_output"
356369 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
357370
358−withEmitter :: (Emitter -> IO (Either YamlException ()))
359− -> IO (Either YamlException B.ByteString)
360−withEmitter f = allocaBytes emitterSize $ \e -> do
361− res <- c_yaml_emitter_initialize e
362− if res == 0
363− then return $ Left YamlOutOfMemory
364− else do
365− bs <- withBuffer $ \b -> do
366− c_my_emitter_set_output e b
367− f e
368− c_yaml_emitter_delete e
369− return bs
371+withEmitter :: (RMonadIO m, MonadFailure YamlException m)
372+ => (Emitter -> m ())
373+ -> m B.ByteString
374+withEmitter f = allocaBytesR emitterSize $ \e -> do
375+ res <- liftIO $ c_yaml_emitter_initialize e
376+ when (res == 0) $ failure YamlOutOfMemory
377+ bs <- withBufferR $ \b -> do
378+ liftIO $ c_my_emitter_set_output e b
379+ f e
380+ liftIO $ c_yaml_emitter_delete e -- FIXME finally
381+ return bs
370382
371383foreign import ccall unsafe "yaml_emitter_set_output_file"
372384 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
373385
374−withEmitterFile :: FilePath
375− -> (Emitter -> IO (Either YamlException ()))
376− -> IO (Either YamlException ())
377−withEmitterFile fp f = allocaBytes emitterSize $ \e -> do
378− res <- c_yaml_emitter_initialize e
379− if res == 0
380− then return $ Left YamlOutOfMemory
381− else do
382− file <- withCString fp $ \fp' -> withCString "w" $ \w' ->
383− c_fopen fp' w'
384− res' <-
385− if file == nullPtr
386− then return $ Left $ YamlFileNotFound fp
387− else do
388− c_yaml_emitter_set_output_file e file
389− res' <- f e
390− c_yaml_emitter_delete e
391− return res'
392− c_fclose file
393− return res'
386+withEmitterFile :: (RMonadIO m, MonadFailure YamlException m)
387+ => FilePath
388+ -> (Emitter -> m ())
389+ -> m ()
390+withEmitterFile fp f = allocaBytesR emitterSize $ \e -> do
391+ res <- liftIO $ c_yaml_emitter_initialize e
392+ when (res == 0) $ failure YamlOutOfMemory
393+ file <- withCStringR fp $ \fp' -> withCStringR "w" $ \w' ->
394+ liftIO (c_fopen fp' w')
395+ res' <-
396+ if file == nullPtr
397+ then failure $ YamlFileNotFound fp
398+ else do
399+ liftIO $ c_yaml_emitter_set_output_file e file
400+ res' <- f e
401+ liftIO $ c_yaml_emitter_delete e
402+ return res'
403+ liftIO $ c_fclose file -- FIXME use finally
404+ return res'
394405
395406foreign import ccall unsafe "yaml_emitter_emit"
396407 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
@@ -398,20 +409,19 @@ foreign import ccall unsafe "yaml_emitter_emit"
398409foreign import ccall unsafe "get_emitter_error"
399410 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
400411
401−emitEvents :: (a -> Maybe (Event, a))
412+emitEvents :: (MonadFailure YamlException m, RMonadIO m)
413+ => (a -> Maybe (Event, a))
402414 -> a
403415 -> Emitter
404− -> IO (Either YamlException ())
405−emitEvents unfold src emitter = do
406− case unfold src of
407− Nothing -> return $ Right ()
408− Just (e, src') -> do
409− res <- toEventRaw e $ c_yaml_emitter_emit emitter
410− if res == 0
411− then do
412− problem <- makeString c_get_emitter_error emitter
413− return $ Left $ YamlEmitterException e problem
414− else emitEvents unfold src' emitter
416+ -> m ()
417+emitEvents unfold src emitter = case unfold src of
418+ Nothing -> return ()
419+ Just (e, src') -> do
420+ res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
421+ when (res == 0) $ do
422+ problem <- liftIO $ makeString c_get_emitter_error emitter
423+ failure $ YamlEmitterException e problem
424+ emitEvents unfold src' emitter
415425
416426foreign import ccall unsafe "yaml_stream_start_event_initialize"
417427 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
@@ -462,7 +472,7 @@ foreign import ccall unsafe "yaml_mapping_end_event_initialize"
462472 c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
463473
464474toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
465−toEventRaw e f = withEventRaw $ \er -> do
475+toEventRaw e f = allocaBytesR eventSize $ \er -> do
466476 ret <- case e of
467477 EventStreamStart ->
468478 c_yaml_stream_start_event_initialize
@@ -526,26 +536,30 @@ instance Exception ToEventRawException
526536data EnumResult a b = More a | Done b
527537 deriving (Eq, Show)
528538
529−encode :: (a -> Maybe (Event, a))
539+encode :: (RMonadIO m, MonadFailure YamlException m)
540+ => (a -> Maybe (Event, a))
530541 -> a
531− -> IO (Either YamlException B.ByteString)
542+ -> m B.ByteString
532543encode unfold src = withEmitter $ emitEvents unfold src
533544
534−encodeFile :: FilePath
545+encodeFile :: (RMonadIO m, MonadFailure YamlException m)
546+ => FilePath
535547 -> (a -> Maybe (Event, a))
536548 -> a
537− -> IO (Either YamlException ())
549+ -> m ()
538550encodeFile filePath unfold src =
539551 withEmitterFile filePath $ emitEvents unfold src
540552
541−decode :: B.ByteString
542− -> (a -> Event -> IO (EnumResult a b))
553+decode :: (RMonadIO m, MonadFailure YamlException m)
554+ => B.ByteString
555+ -> (a -> Event -> m (EnumResult a b))
543556 -> a
544− -> IO (Either YamlException b)
557+ -> m b
545558decode bs fold accum = withParser bs $ parserParse fold accum
546559
547−decodeFile :: FilePath
548− -> (a -> Event -> IO (EnumResult a b))
560+decodeFile :: (RMonadIO m, MonadFailure YamlException m)
561+ => FilePath
562+ -> (a -> Event -> m (EnumResult a b))
549563 -> a
550− -> IO (Either YamlException b)
564+ -> m b
551565decodeFile fp fold accum = withFileParser fp $ parserParse fold accum