55e60e6 · typeable/yaml

44import Control.Exception (throwIO, Exception, finally)

45import Control.Applicative

46import Control.Monad.Trans.Resource

47−import qualified Data.Conduit as C

47+import Data.Conduit

48import Control.Exception (mask_)

49

50data Event =

452 deriving (Show, Typeable)

453instance Exception ToEventRawException

454

455−decode :: C.MonadResource m => B.ByteString -> C.Source m Event

455+decode :: MonadResource m => B.ByteString -> Source m Event

456decode bs =

457− C.sourceIO alloc cleanup (runParser . fst)

457+ bracketP alloc cleanup (runParser . fst)

458 where

459 alloc = mask_ $ do

460 ptr <- mallocBytes parserSize

475 c_yaml_parser_delete ptr

476 free ptr

477

478−decodeFile :: C.MonadResource m => FilePath -> C.Source m Event

478+decodeFile :: MonadResource m => FilePath -> Source m Event

479decodeFile file =

480− C.sourceIO alloc cleanup (runParser . fst)

480+ bracketP alloc cleanup (runParser . fst)

481 where

482 alloc = mask_ $ do

483 ptr <- mallocBytes parserSize

506 c_yaml_parser_delete ptr

507 free ptr

508

509−runParser :: C.MonadResource m => Parser -> m (C.SourceIOResult Event)

509+runParser :: MonadResource m => Parser -> GSource m Event

510−runParser parser = liftIO $ do

510+runParser parser = do

511− e <- parserParseOne' parser

511+ e <- liftIO $ parserParseOne' parser

512 case e of

513− Left err -> throwIO $ YamlException err

513+ Left err -> liftIO $ throwIO $ YamlException err

514− Right Nothing -> return $ C.IOClosed

514+ Right Nothing -> return ()

515− Right (Just ev) -> return $ C.IOOpen ev

515+ Right (Just ev) -> yield ev >> runParser parser

516

517parserParseOne' :: Parser

518 -> IO (Either String (Maybe Event))

535 ]

536 else Right <$> getEvent er

537

538−encode :: C.MonadResource m => C.Sink Event m ByteString

538+encode :: MonadResource m => Sink Event m ByteString

539encode =

540 runEmitter alloc close

541 where

550 fptr <- newForeignPtr_ $ castPtr ptr'

551 return $ B.fromForeignPtr fptr 0 $ fromIntegral len

552

553−encodeFile :: C.MonadResource m

553+encodeFile :: MonadResource m

554 => FilePath

555− -> C.Sink Event m ()

555+ -> Sink Event m ()

556encodeFile filePath =

557− C.PipeM msink (return ())

557+ bracketP getFile c_fclose $ \file -> runEmitter (alloc file) return

558 where

559− msink = do

559+ getFile = do

560− (_releaseKey, file) <- flip allocate c_fclose $ do

561− file <- liftIO $ withCString filePath $

560+ file <- withCString filePath $

562− \filePath' -> withCString "w" $

561+ \filePath' -> withCString "w" $

563− \w' -> c_fopen filePath' w'

562+ \w' -> c_fopen filePath' w'

564− if (file == nullPtr)

563+ if (file == nullPtr)

565− then throwIO $ YamlException $ "could not open file for write: " ++ filePath

564+ then throwIO $ YamlException $ "could not open file for write: " ++ filePath

566− else return file

565+ else return file

567− return $ runEmitter (alloc file) (return) -- FIXME close file early

566+

568 alloc file emitter = do

567 alloc file emitter = do

569 c_yaml_emitter_set_output_file emitter file

568 c_yaml_emitter_set_output_file emitter file

570 return ()

569 return ()

571

570

572−runEmitter :: C.MonadResource m

571+runEmitter :: MonadResource m

573 => (Emitter -> IO a) -- ^ alloc

572 => (Emitter -> IO a) -- ^ alloc

574 -> (a -> IO b) -- ^ close

573 -> (a -> IO b) -- ^ close

575− -> C.Sink Event m b

574+ -> Sink Event m b

576runEmitter allocI closeI =

575runEmitter allocI closeI =

577− C.sinkIO alloc cleanup push close

576+ bracketP alloc cleanup go

578 where

577 where

579 alloc = mask_ $ do

578 alloc = mask_ $ do

580 emitter <- mallocBytes emitterSize

579 emitter <- mallocBytes emitterSize

585 cleanup (emitter, _) = do

584 cleanup (emitter, _) = do

586 c_yaml_emitter_delete emitter

585 c_yaml_emitter_delete emitter

587 free emitter

586 free emitter

587+

588− push (emitter, _) e = do

588+ go (emitter, a) =

589+ loop

590+ where

591+ loop = await >>= maybe close push

592+ push e = do

589− _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

593+ _ <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

590− return C.IOProcessing

594+ loop

591− close (_, a) = liftIO $ closeI a

595+ close = liftIO $ closeI a

592

596

593data YamlException = YamlException String

597data YamlException = YamlException String

594 deriving (Show, Typeable)

598 deriving (Show, Typeable)