@@ -44,7 +44,7 @@ import Control.Monad.IO.Class
4444import Control.Exception (throwIO, Exception, finally)
4545import Control.Applicative
4646import Control.Monad.Trans.Resource
47−import qualified Data.Conduit as C
47+import Data.Conduit
4848import Control.Exception (mask_)
4949
5050data Event =
@@ -452,9 +452,9 @@ newtype ToEventRawException = ToEventRawException CInt
452452 deriving (Show, Typeable)
453453instance Exception ToEventRawException
454454
455−decode :: C.MonadResource m => B.ByteString -> C.Source m Event
455+decode :: MonadResource m => B.ByteString -> Source m Event
456456decode bs =
457− C.sourceIO alloc cleanup (runParser . fst)
457+ bracketP alloc cleanup (runParser . fst)
458458 where
459459 alloc = mask_ $ do
460460 ptr <- mallocBytes parserSize
@@ -475,9 +475,9 @@ decode bs =
475475 c_yaml_parser_delete ptr
476476 free ptr
477477
478−decodeFile :: C.MonadResource m => FilePath -> C.Source m Event
478+decodeFile :: MonadResource m => FilePath -> Source m Event
479479decodeFile file =
480− C.sourceIO alloc cleanup (runParser . fst)
480+ bracketP alloc cleanup (runParser . fst)
481481 where
482482 alloc = mask_ $ do
483483 ptr <- mallocBytes parserSize
@@ -506,13 +506,13 @@ decodeFile file =
506506 c_yaml_parser_delete ptr
507507 free ptr
508508
509−runParser :: C.MonadResource m => Parser -> m (C.SourceIOResult Event)
510−runParser parser = liftIO $ do
511− e <- parserParseOne' parser
509+runParser :: MonadResource m => Parser -> GSource m Event
510+runParser parser = do
511+ e <- liftIO $ parserParseOne' parser
512512 case e of
513− Left err -> throwIO $ YamlException err
514− Right Nothing -> return $ C.IOClosed
515− Right (Just ev) -> return $ C.IOOpen ev
513+ Left err -> liftIO $ throwIO $ YamlException err
514+ Right Nothing -> return ()
515+ Right (Just ev) -> yield ev >> runParser parser
516516
517517parserParseOne' :: Parser
518518 -> IO (Either String (Maybe Event))
@@ -535,7 +535,7 @@ parserParseOne' parser = allocaBytes eventSize $ \er -> do
535535 ]
536536 else Right <$> getEvent er
537537
538−encode :: C.MonadResource m => C.Sink Event m ByteString
538+encode :: MonadResource m => Sink Event m ByteString
539539encode =
540540 runEmitter alloc close
541541 where
@@ -550,31 +550,30 @@ encode =
550550 fptr <- newForeignPtr_ $ castPtr ptr'
551551 return $ B.fromForeignPtr fptr 0 $ fromIntegral len
552552
553−encodeFile :: C.MonadResource m
553+encodeFile :: MonadResource m
554554 => FilePath
555− -> C.Sink Event m ()
555+ -> Sink Event m ()
556556encodeFile filePath =
557− C.PipeM msink (return ())
557+ bracketP getFile c_fclose $ \file -> runEmitter (alloc file) return
558558 where
559− msink = do
560− (_releaseKey, file) <- flip allocate c_fclose $ do
561− file <- liftIO $ withCString filePath $
562− \filePath' -> withCString "w" $
563− \w' -> c_fopen filePath' w'
564− if (file == nullPtr)
565− then throwIO $ YamlException $ "could not open file for write: " ++ filePath
566− else return file
567− return $ runEmitter (alloc file) (return) -- FIXME close file early
559+ getFile = do
560+ file <- withCString filePath $
561+ \filePath' -> withCString "w" $
562+ \w' -> c_fopen filePath' w'
563+ if (file == nullPtr)
564+ then throwIO $ YamlException $ "could not open file for write: " ++ filePath
565+ else return file
566+
568567 alloc file emitter = do
569568 c_yaml_emitter_set_output_file emitter file
570569 return ()
571570
572−runEmitter :: C.MonadResource m
571+runEmitter :: MonadResource m
573572 => (Emitter -> IO a) -- ^ alloc
574573 -> (a -> IO b) -- ^ close
575− -> C.Sink Event m b
574+ -> Sink Event m b
576575runEmitter allocI closeI =
577− C.sinkIO alloc cleanup push close
576+ bracketP alloc cleanup go
578577 where
579578 alloc = mask_ $ do
580579 emitter <- mallocBytes emitterSize
@@ -585,10 +584,15 @@ runEmitter allocI closeI =
585584 cleanup (emitter, _) = do
586585 c_yaml_emitter_delete emitter
587586 free emitter
588− push (emitter, _) e = do
589− _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
590− return C.IOProcessing
591− close (_, a) = liftIO $ closeI a
587+
588+ go (emitter, a) =
589+ loop
590+ where
591+ loop = await >>= maybe close push
592+ push e = do
593+ _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter
594+ loop
595+ close = liftIO $ closeI a
592596
593597data YamlException = YamlException String
594598 deriving (Show, Typeable)