@@ -18,13 +18,16 @@ module Text.Libyaml
1818 , EnumResult (..)
1919 , RMonadIO (..)
2020 -- * Encoder
21− , YamlEncoder (..)
21+ , YamlEncoder
22+ , YamlDecoder
23+ , parseEvent
2224 , emitEvent
2325 -- * Higher level functions
2426 , encode
2527 , decode
2628 , encodeFile
2729 , decodeFile
30+ , decodeFile'
2831 ) where
2932
3033import qualified Data.ByteString.Internal as B
@@ -38,7 +41,7 @@ import Foreign.ForeignPtr
3841import Foreign.Marshal.Alloc
3942import "transformers" Control.Monad.Trans
4043import Control.Failure
41−import Control.Applicative
44+import Control.Monad.Trans.Reader
4245
4346import Control.Exception (throwIO, Exception, SomeException)
4447import Data.Typeable (Typeable)
@@ -319,7 +322,7 @@ parserParse :: (MonadFailure YamlException m, RMonadIO m)
319322 -> Parser
320323 -> m b
321324parserParse fold accum parser = do
322− event <- liftIO $ parserParseOne parser
325+ event <- parserParseOne parser
323326 res <- fold accum event
324327 case res of
325328 Done accum' -> return accum'
@@ -410,35 +413,25 @@ foreign import ccall unsafe "get_emitter_error"
410413emitEvent :: (MonadIO m, MonadFailure YamlException m)
411414 => Event
412415 -> YamlEncoder m ()
413−emitEvent e = YamlEncoder $ \emitter -> do
416+emitEvent e = do
417+ emitter <- ask
414418 res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
415419 when (res == 0) $ do
416420 problem <- liftIO $ makeString c_get_emitter_error emitter
417421 failure $ YamlEmitterException e problem
418422
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
423+parseEvent :: (RMonadIO m, MonadFailure YamlException m)
424+ => YamlDecoder m Event
425+parseEvent = ask >>= parserParseOne
426+
427+type YamlDecoder = ReaderT Parser
428+type YamlEncoder = ReaderT Emitter
429+
430+instance RMonadIO m => RMonadIO (ReaderT r m) where
431+ withR orig f = ReaderT $ \r -> do
432+ let f' a = (runReaderT $ f a) r
440433 withR orig f'
441−instance MonadFailure e m => Failure e (YamlEncoder m) where
434+instance MonadFailure e m => Failure e (ReaderT r m) where
442435 failure = lift . failure
443436
444437foreign import ccall unsafe "yaml_stream_start_event_initialize"
@@ -557,13 +550,13 @@ data EnumResult a b = More a | Done b
557550encode :: (RMonadIO m, MonadFailure YamlException m)
558551 => YamlEncoder m ()
559552 -> m B.ByteString
560−encode = withEmitter . runYamlEncoder
553+encode = withEmitter . runReaderT
561554
562555encodeFile :: (RMonadIO m, MonadFailure YamlException m)
563556 => FilePath
564557 -> YamlEncoder m ()
565558 -> m ()
566−encodeFile filePath enc = withEmitterFile filePath $ runYamlEncoder enc
559+encodeFile filePath = withEmitterFile filePath . runReaderT
567560
568561decode :: (RMonadIO m, MonadFailure YamlException m)
569562 => B.ByteString
@@ -578,3 +571,9 @@ decodeFile :: (RMonadIO m, MonadFailure YamlException m)
578571 -> a
579572 -> m b
580573decodeFile fp fold accum = withFileParser fp $ parserParse fold accum
574+
575+decodeFile' :: (RMonadIO m, MonadFailure YamlException m)
576+ => FilePath
577+ -> YamlDecoder m a
578+ -> m a
579+decodeFile' fp dec = withFileParser fp $ runReaderT dec