bca93d6 · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Added monadic decoding function

bca93d6Michael Snoyman17 years ago

Text/Libyaml.hs+27−28

compare with master

unifiedsplit

@@ -18,13 +18,16 @@ module Text.Libyaml

18 , EnumResult (..)

19 , RMonadIO (..)

20 -- * Encoder

21− , YamlEncoder (..)

21+ , YamlEncoder

22+ , YamlDecoder

23+ , parseEvent

22 , emitEvent

24 , emitEvent

23 -- * Higher level functions

25 -- * Higher level functions

24 , encode

26 , encode

25 , decode

27 , decode

26 , encodeFile

28 , encodeFile

27 , decodeFile

29 , decodeFile

30+ , decodeFile'

28 ) where

31 ) where

30import qualified Data.ByteString.Internal as B

33import qualified Data.ByteString.Internal as B

@@ -38,7 +41,7 @@ import Foreign.ForeignPtr

38import Foreign.Marshal.Alloc

41import Foreign.Marshal.Alloc

39import "transformers" Control.Monad.Trans

42import "transformers" Control.Monad.Trans

40import Control.Failure

43import Control.Failure

41−import Control.Applicative

44+import Control.Monad.Trans.Reader

43import Control.Exception (throwIO, Exception, SomeException)

46import Control.Exception (throwIO, Exception, SomeException)

44import Data.Typeable (Typeable)

47import Data.Typeable (Typeable)

@@ -319,7 +322,7 @@ parserParse :: (MonadFailure YamlException m, RMonadIO m)

319 -> Parser

322 -> Parser

320 -> m b

323 -> m b

321parserParse fold accum parser = do

324parserParse fold accum parser = do

322− event <- liftIO $ parserParseOne parser

325+ event <- parserParseOne parser

323 res <- fold accum event

326 res <- fold accum event

324 case res of

327 case res of

325 Done accum' -> return accum'

328 Done accum' -> return accum'

@@ -410,35 +413,25 @@ foreign import ccall unsafe "get_emitter_error"

410emitEvent :: (MonadIO m, MonadFailure YamlException m)

413emitEvent :: (MonadIO m, MonadFailure YamlException m)

411 => Event

414 => Event

412 -> YamlEncoder m ()

415 -> YamlEncoder m ()

413−emitEvent e = YamlEncoder $ \emitter -> do

416+emitEvent e = do

417+ emitter <- ask

414 res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

418 res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

415 when (res == 0) $ do

419 when (res == 0) $ do

416 problem <- liftIO $ makeString c_get_emitter_error emitter

420 problem <- liftIO $ makeString c_get_emitter_error emitter

417 failure $ YamlEmitterException e problem

421 failure $ YamlEmitterException e problem

418

422

419−data YamlEncoder m v = YamlEncoder { runYamlEncoder :: Emitter -> m v }

423+parseEvent :: (RMonadIO m, MonadFailure YamlException m)

420−instance Monad m => Functor (YamlEncoder m) where

424+ => YamlDecoder m Event

421− fmap f (YamlEncoder e) = YamlEncoder $ \em -> f `liftM` e em

425+parseEvent = ask >>= parserParseOne

422−instance Monad m => Applicative (YamlEncoder m) where

426+

423− pure v = YamlEncoder $ const $ return v

427+type YamlDecoder = ReaderT Parser

424− (YamlEncoder f') <*> (YamlEncoder v') = YamlEncoder $ \e -> do

428+type YamlEncoder = ReaderT Emitter

425− f <- f' e

429+

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

430+instance RMonadIO m => RMonadIO (ReaderT r m) where

438− withR orig f = YamlEncoder $ \e -> do

431+ withR orig f = ReaderT $ \r -> do

439− let f' a = (runYamlEncoder $ f a) e

432+ let f' a = (runReaderT $ f a) r

440 withR orig f'

433 withR orig f'

441−instance MonadFailure e m => Failure e (YamlEncoder m) where

434+instance MonadFailure e m => Failure e (ReaderT r m) where

442 failure = lift . failure

435 failure = lift . failure

443

436

444foreign import ccall unsafe "yaml_stream_start_event_initialize"

437foreign import ccall unsafe "yaml_stream_start_event_initialize"

@@ -557,13 +550,13 @@ data EnumResult a b = More a | Done b

557encode :: (RMonadIO m, MonadFailure YamlException m)

550encode :: (RMonadIO m, MonadFailure YamlException m)

558 => YamlEncoder m ()

551 => YamlEncoder m ()

559 -> m B.ByteString

552 -> m B.ByteString

560−encode = withEmitter . runYamlEncoder

553+encode = withEmitter . runReaderT

561

554

562encodeFile :: (RMonadIO m, MonadFailure YamlException m)

555encodeFile :: (RMonadIO m, MonadFailure YamlException m)

563 => FilePath

556 => FilePath

564 -> YamlEncoder m ()

557 -> YamlEncoder m ()

565 -> m ()

558 -> m ()

566−encodeFile filePath enc = withEmitterFile filePath $ runYamlEncoder enc

559+encodeFile filePath = withEmitterFile filePath . runReaderT

567

560

568decode :: (RMonadIO m, MonadFailure YamlException m)

561decode :: (RMonadIO m, MonadFailure YamlException m)

569 => B.ByteString

562 => B.ByteString

@@ -578,3 +571,9 @@ decodeFile :: (RMonadIO m, MonadFailure YamlException m)

578 -> a

571 -> a

579 -> m b

572 -> m b

580decodeFile fp fold accum = withFileParser fp $ parserParse fold accum

573decodeFile 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

runtests.hs+20

@@ -2,6 +2,7 @@ import Test.Framework (defaultMain)

3import Text.Libyaml

4import qualified Data.ByteString.Char8 as B8

5+import Control.Monad.Trans

6--import Test.Framework (testGroup, Test)

7--import Test.Framework (testGroup, Test)

7import Test.Framework.Providers.HUnit

8import Test.Framework.Providers.HUnit

@@ -16,6 +17,7 @@ main = defaultMain

16 , testCase "encode/decode" caseEncodeDecode

17 , testCase "encode/decode" caseEncodeDecode

17 , testCase "encode/decode file" caseEncodeDecodeFile

18 , testCase "encode/decode file" caseEncodeDecodeFile

18 , testCase "interleaved encode/decode" caseInterleave

19 , testCase "interleaved encode/decode" caseInterleave

20+ , testCase "interleaved encode/decode monadic" caseInterleaveMonad

19 ]

21 ]

21caseCountScalars :: Assertion

23caseCountScalars :: Assertion

@@ -96,3 +98,21 @@ caseInterleave = do

96 tmpPath2 = "tmp2.yaml"

98 tmpPath2 = "tmp2.yaml"

97 emitEvent' () EventNone = return $ Done ()

99 emitEvent' () EventNone = return $ Done ()

98 emitEvent' () e = emitEvent e >> return (More ())

100 emitEvent' () e = emitEvent e >> return (More ())

101+

102+caseInterleaveMonad :: Assertion

103+caseInterleaveMonad = do

104+ decodeFile' filePath $ encodeFile tmpPath inside

105+ decodeFile' tmpPath $ encodeFile tmpPath2 inside

106+ f1 <- readFile tmpPath

107+ f2 <- readFile tmpPath2

108+ f1 @=? f2

109+ where

110+ filePath = "test/largest-string.yaml"

111+ tmpPath = "tmp.yaml"

112+ tmpPath2 = "tmp2.yaml"

113+ inside :: YamlEncoder (YamlDecoder IO) ()

114+ inside = do

115+ e <- lift parseEvent

116+ case e of

117+ EventNone -> return ()

118+ _ -> emitEvent e >> inside