245bf65 · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Encoding via Monad, can now interleave

245bf65Michael Snoyman17 years ago

Text/Libyaml.hs+50−35

compare with master

unifiedsplit

@@ -2,6 +2,7 @@

2{-# LANGUAGE ForeignFunctionInterface #-}

3{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE PackageImports #-}

7{-# LANGUAGE PackageImports #-}

7{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

@@ -16,6 +17,9 @@ module Text.Libyaml

16 -- * Enumerator

17 -- * Enumerator

17 , EnumResult (..)

18 , EnumResult (..)

18 , RMonadIO (..)

19 , RMonadIO (..)

20+ -- * Encoder

21+ , YamlEncoder (..)

22+ , emitEvent

19 -- * Higher level functions

23 -- * Higher level functions

20 , encode

24 , encode

21 , decode

25 , decode

@@ -34,6 +38,7 @@ import Foreign.ForeignPtr

34import Foreign.Marshal.Alloc

38import Foreign.Marshal.Alloc

35import "transformers" Control.Monad.Trans

39import "transformers" Control.Monad.Trans

36import Control.Failure

40import Control.Failure

41+import Control.Applicative

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

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

39import Data.Typeable (Typeable)

44import Data.Typeable (Typeable)

@@ -160,20 +165,16 @@ foreign import ccall unsafe "fclose"

160 -> IO ()

165 -> IO ()

161

166

162class MonadIO m => RMonadIO m where

167class MonadIO m => RMonadIO m where

163− type Inside :: * -> *

168+ withR :: ((a -> IO b) -> IO b) -> (a -> m b) -> m b

164− ioOut :: m v -> IO (Inside v)

169+

165− ioIn :: IO (Inside v) -> m v

166−newtype SimpleIdent x = SimpleIdent { unSimpleIdent :: x }

167instance RMonadIO IO where

170instance RMonadIO IO where

168− type Inside = SimpleIdent

171+ withR = id

169− ioOut = fmap SimpleIdent

170− ioIn = fmap unSimpleIdent

171

172

172allocaBytesR :: RMonadIO m => Int -> (Ptr a -> m b) -> m b

173allocaBytesR :: RMonadIO m => Int -> (Ptr a -> m b) -> m b

173−allocaBytesR i f = ioIn $ allocaBytes i $ ioOut . f

174+allocaBytesR = withR . allocaBytes

174

175

175withCStringR :: RMonadIO m => String -> (Ptr CChar -> m a) -> m a

176withCStringR :: RMonadIO m => String -> (Ptr CChar -> m a) -> m a

176−withCStringR s f = ioIn $ withCString s $ ioOut . f

177+withCStringR = withR . withCString

177

178

178withFileParser :: (MonadFailure YamlException m, RMonadIO m)

179withFileParser :: (MonadFailure YamlException m, RMonadIO m)

179 => FilePath

180 => FilePath

@@ -207,11 +208,8 @@ withParser bs f = allocaBytesR parserSize $ \p -> do

207 liftIO $ c_yaml_parser_delete p -- FIXME use finally

208 liftIO $ c_yaml_parser_delete p -- FIXME use finally

208 return ret

209 return ret

209

210

210−withForeignPtrR :: RMonadIO m

211+withForeignPtrR :: RMonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b

211− => ForeignPtr a

212− -> (Ptr a -> m b)

213− -> m b

214−withForeignPtrR fp f = ioIn $ withForeignPtr fp $ ioOut . f

212+withForeignPtrR = withR . withForeignPtr

215

213

216foreign import ccall unsafe "yaml_parser_parse"

214foreign import ccall unsafe "yaml_parser_parse"

217 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt

215 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt

@@ -359,7 +357,7 @@ withBufferR :: (RMonadIO m, MonadFailure YamlException m)

359 -> m B.ByteString

357 -> m B.ByteString

360withBufferR f = allocaBytesR bufferSize $ \b -> do

358withBufferR f = allocaBytesR bufferSize $ \b -> do

361 liftIO $ c_buffer_init b

359 liftIO $ c_buffer_init b

362− aRes <- f b

360+ f b

363 ptr' <- liftIO $ c_get_buffer_buff b

361 ptr' <- liftIO $ c_get_buffer_buff b

364 len <- liftIO $ c_get_buffer_used b

362 len <- liftIO $ c_get_buffer_used b

365 fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'

363 fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'

@@ -409,19 +407,39 @@ foreign import ccall unsafe "yaml_emitter_emit"

409foreign import ccall unsafe "get_emitter_error"

407foreign import ccall unsafe "get_emitter_error"

410 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)

408 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)

411

409

412−emitEvents :: (MonadFailure YamlException m, RMonadIO m)

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

413− => (a -> Maybe (Event, a))

411+ => Event

414− -> a

412+ -> YamlEncoder m ()

415− -> Emitter

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

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

414+ res <- liftIO $ toEventRaw e $ c_yaml_emitter_emit emitter

421− when (res == 0) $ do

415+ when (res == 0) $ do

422− problem <- liftIO $ makeString c_get_emitter_error emitter

416+ problem <- liftIO $ makeString c_get_emitter_error emitter

423− failure $ YamlEmitterException e problem

417+ failure $ YamlEmitterException e problem

424− emitEvents unfold src' emitter

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

425

443

426foreign import ccall unsafe "yaml_stream_start_event_initialize"

444foreign import ccall unsafe "yaml_stream_start_event_initialize"

427 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt

445 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt

@@ -537,18 +555,15 @@ data EnumResult a b = More a | Done b

537 deriving (Eq, Show)

555 deriving (Eq, Show)

538

556

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

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

540− => (a -> Maybe (Event, a))

558+ => YamlEncoder m ()

541− -> a

542 -> m B.ByteString

559 -> m B.ByteString

543−encode unfold src = withEmitter $ emitEvents unfold src

560+encode = withEmitter . runYamlEncoder

544

561

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

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

546 => FilePath

563 => FilePath

547− -> (a -> Maybe (Event, a))

564+ -> YamlEncoder m ()

548− -> a

549 -> m ()

565 -> m ()

550−encodeFile filePath unfold src =

551− withEmitterFile filePath $ emitEvents unfold src

566+encodeFile filePath enc = withEmitterFile filePath $ runYamlEncoder enc

552

567

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

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

554 => B.ByteString

569 => B.ByteString

runtests.hs+17−6

@@ -15,6 +15,7 @@ main = defaultMain

15 , testCase "largest string" caseLargestString

16 , testCase "encode/decode" caseEncodeDecode

17 , testCase "encode/decode file" caseEncodeDecodeFile

18+ , testCase "interleaved encode/decode" caseInterleave

18 ]

19 ]

20caseCountScalars :: Assertion

21caseCountScalars :: Assertion

@@ -52,7 +53,7 @@ caseEncodeDecode :: Assertion

52caseEncodeDecode = do

53caseEncodeDecode = do

53 eList' <- decode yamlBS fold id

54 eList' <- decode yamlBS fold id

54 let eList = eList' []

55 let eList = eList' []

55− bs <- encode unfold eList

56+ bs <- encode $ mapM_ emitEvent eList

56 eList2' <- decode bs fold id

57 eList2' <- decode bs fold id

57 let eList2 = eList2' []

58 let eList2 = eList2' []

58 map MyEvent eList @=? map MyEvent eList2

59 map MyEvent eList @=? map MyEvent eList2

@@ -61,14 +62,12 @@ caseEncodeDecode = do

61 yamlBS = B8.pack yamlString

62 yamlBS = B8.pack yamlString

62 fold x EventNone = return $ Done x

63 fold x EventNone = return $ Done x

63 fold x e = return $ More $ x . (:) e

64 fold x e = return $ More $ x . (:) e

64− unfold (x:xs) = Just (x, xs)

65− unfold [] = Nothing

67caseEncodeDecodeFile :: Assertion

66caseEncodeDecodeFile :: Assertion

68caseEncodeDecodeFile = do

67caseEncodeDecodeFile = do

69 eList' <- decodeFile filePath fold id

68 eList' <- decodeFile filePath fold id

70 let eList = eList' []

69 let eList = eList' []

71− encodeFile tmpPath unfold eList

70+ encodeFile tmpPath $ mapM_ emitEvent eList

72 eList2' <- decodeFile filePath fold id

71 eList2' <- decodeFile filePath fold id

73 let eList2 = eList2' []

72 let eList2 = eList2' []

74 map MyEvent eList @=? map MyEvent eList2

73 map MyEvent eList @=? map MyEvent eList2

@@ -77,11 +76,23 @@ caseEncodeDecodeFile = do

77 tmpPath = "tmp.yaml"

76 tmpPath = "tmp.yaml"

78 fold x EventNone = return $ Done x

77 fold x EventNone = return $ Done x

79 fold x e = return $ More $ x . (:) e

78 fold x e = return $ More $ x . (:) e

80− unfold (x:xs) = Just (x, xs)

81− unfold [] = Nothing

83newtype MyEvent = MyEvent Event deriving Show

80newtype MyEvent = MyEvent Event deriving Show

84instance Eq MyEvent where

81instance Eq MyEvent where

85 (MyEvent (EventScalar s t _)) == (MyEvent (EventScalar s' t' _)) =

82 (MyEvent (EventScalar s t _)) == (MyEvent (EventScalar s' t' _)) =

86 s == s' && t == t'

83 s == s' && t == t'

87 MyEvent e1 == MyEvent e2 = e1 == e2

84 MyEvent e1 == MyEvent e2 = e1 == e2

85+

86+caseInterleave :: Assertion

87+caseInterleave = do

88+ encodeFile tmpPath $ decodeFile filePath emitEvent' ()

89+ encodeFile tmpPath2 $ decodeFile tmpPath emitEvent' ()

90+ f1 <- readFile tmpPath

91+ f2 <- readFile tmpPath2

92+ f1 @=? f2

93+ where

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

95+ tmpPath = "tmp.yaml"

96+ tmpPath2 = "tmp2.yaml"

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

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