@@ -2,6 +2,7 @@
22{-# LANGUAGE ForeignFunctionInterface #-}
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE PackageImports #-}
78{-# LANGUAGE TypeFamilies #-}
@@ -16,6 +17,9 @@ module Text.Libyaml
1617 -- * Enumerator
1718 , EnumResult (..)
1819 , RMonadIO (..)
20+ -- * Encoder
21+ , YamlEncoder (..)
22+ , emitEvent
1923 -- * Higher level functions
2024 , encode
2125 , decode
@@ -34,6 +38,7 @@ import Foreign.ForeignPtr
3438import Foreign.Marshal.Alloc
3539import "transformers" Control.Monad.Trans
3640import Control.Failure
41+import Control.Applicative
3742
3843import Control.Exception (throwIO, Exception, SomeException)
3944import Data.Typeable (Typeable)
@@ -160,20 +165,16 @@ foreign import ccall unsafe "fclose"
160165 -> IO ()
161166
162167class 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 }
168+ withR :: ((a -> IO b) -> IO b) -> (a -> m b) -> m b
169+
167170instance RMonadIO IO where
168− type Inside = SimpleIdent
169− ioOut = fmap SimpleIdent
170− ioIn = fmap unSimpleIdent
171+ withR = id
171172
172173allocaBytesR :: RMonadIO m => Int -> (Ptr a -> m b) -> m b
173−allocaBytesR i f = ioIn $ allocaBytes i $ ioOut . f
174+allocaBytesR = withR . allocaBytes
174175
175176withCStringR :: RMonadIO m => String -> (Ptr CChar -> m a) -> m a
176−withCStringR s f = ioIn $ withCString s $ ioOut . f
177+withCStringR = withR . withCString
177178
178179withFileParser :: (MonadFailure YamlException m, RMonadIO m)
179180 => FilePath
@@ -207,11 +208,8 @@ withParser bs f = allocaBytesR parserSize $ \p -> do
207208 liftIO $ c_yaml_parser_delete p -- FIXME use finally
208209 return ret
209210
210−withForeignPtrR :: RMonadIO m
211− => ForeignPtr a
212− -> (Ptr a -> m b)
213− -> m b
214−withForeignPtrR fp f = ioIn $ withForeignPtr fp $ ioOut . f
211+withForeignPtrR :: RMonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
212+withForeignPtrR = withR . withForeignPtr
215213
216214foreign import ccall unsafe "yaml_parser_parse"
217215 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
@@ -359,7 +357,7 @@ withBufferR :: (RMonadIO m, MonadFailure YamlException m)
359357 -> m B.ByteString
360358withBufferR f = allocaBytesR bufferSize $ \b -> do
361359 liftIO $ c_buffer_init b
362− aRes <- f b
360+ f b
363361 ptr' <- liftIO $ c_get_buffer_buff b
364362 len <- liftIO $ c_get_buffer_used b
365363 fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'
@@ -409,19 +407,39 @@ foreign import ccall unsafe "yaml_emitter_emit"
409407foreign import ccall unsafe "get_emitter_error"
410408 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
411409
412−emitEvents :: (MonadFailure YamlException m, RMonadIO m)
413− => (a -> Maybe (Event, a))
414− -> a
415− -> 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
410+emitEvent :: (MonadIO m, MonadFailure YamlException m)
411+ => Event
412+ -> YamlEncoder m ()
413+emitEvent e = YamlEncoder $ \emitter -> do
414+ res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
415+ when (res == 0) $ do
416+ problem <- liftIO $ makeString c_get_emitter_error emitter
417+ failure $ YamlEmitterException e problem
418+
419+data YamlEncoder m v = YamlEncoder { runYamlEncoder :: Emitter -> m v }
420+instance Monad m => Functor (YamlEncoder m) where
421+ fmap f (YamlEncoder e) = YamlEncoder $ \em -> f `liftM` e em
422+instance Monad m => Applicative (YamlEncoder m) where
423+ pure v = YamlEncoder $ const $ return v
424+ (YamlEncoder f') <*> (YamlEncoder v') = YamlEncoder $ \e -> do
425+ f <- f' e
426+ v <- v' e
427+ return $ f v
428+instance Monad m => Monad (YamlEncoder m) where
429+ return = pure
430+ (YamlEncoder v') >>= f = YamlEncoder $ \e -> do
431+ v <- v' e
432+ (runYamlEncoder $ f v) e
433+instance MonadTrans YamlEncoder where
434+ lift = YamlEncoder . const
435+instance MonadIO m => MonadIO (YamlEncoder m) where
436+ liftIO = lift . liftIO
437+instance RMonadIO m => RMonadIO (YamlEncoder m) where
438+ withR orig f = YamlEncoder $ \e -> do
439+ let f' a = (runYamlEncoder $ f a) e
440+ withR orig f'
441+instance MonadFailure e m => Failure e (YamlEncoder m) where
442+ failure = lift . failure
425443
426444foreign import ccall unsafe "yaml_stream_start_event_initialize"
427445 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
@@ -537,18 +555,15 @@ data EnumResult a b = More a | Done b
537555 deriving (Eq, Show)
538556
539557encode :: (RMonadIO m, MonadFailure YamlException m)
540− => (a -> Maybe (Event, a))
541− -> a
558+ => YamlEncoder m ()
542559 -> m B.ByteString
543−encode unfold src = withEmitter $ emitEvents unfold src
560+encode = withEmitter . runYamlEncoder
544561
545562encodeFile :: (RMonadIO m, MonadFailure YamlException m)
546563 => FilePath
547− -> (a -> Maybe (Event, a))
548− -> a
564+ -> YamlEncoder m ()
549565 -> m ()
550−encodeFile filePath unfold src =
551− withEmitterFile filePath $ emitEvents unfold src
566+encodeFile filePath enc = withEmitterFile filePath $ runYamlEncoder enc
552567
553568decode :: (RMonadIO m, MonadFailure YamlException m)
554569 => B.ByteString