git.iko.soy/typeable/yaml
on master help sign in
Encoding via iteratee
1536f41Michael Snoyman
Text/Libyaml.hs+54−54
compare with master
unifiedsplit
@@ -66,6 +66,8 @@ import qualified Data.Iteratee.Base.StreamChunk as SC
66import Control.Applicative
66import Control.Applicative
67import Control.Monad.CatchIO (MonadCatchIO, finally)
67import Control.Monad.CatchIO (MonadCatchIO, finally)
68
68
69+import qualified Data.ListLike as LL
70+
69data Event =
71data Event =
70 EventNone
72 EventNone
71 | EventStreamStart
73 | EventStreamStart
@@ -379,55 +381,12 @@ foreign import ccall unsafe "get_buffer_buff"
379foreign import ccall unsafe "get_buffer_used"
381foreign import ccall unsafe "get_buffer_used"
380 c_get_buffer_used :: Buffer -> IO CULong
382 c_get_buffer_used :: Buffer -> IO CULong
381
383
382−withBufferR :: (With m, MonadFailure YamlException m)
383− => (Buffer -> m ())
384− -> m B.ByteString
385−withBufferR f = allocaBytesR bufferSize $ \b -> do
386− liftIO $ c_buffer_init b
387− f b
388− ptr' <- liftIO $ c_get_buffer_buff b
389− len <- liftIO $ c_get_buffer_used b
390− fptr <- liftIO $ newForeignPtr_ $ castPtr ptr'
391− return $ B.fromForeignPtr fptr 0 $ fromIntegral len
392−
393foreign import ccall unsafe "my_emitter_set_output"
384foreign import ccall unsafe "my_emitter_set_output"
394 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
385 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
395
386
396−withEmitter :: (With m, MonadFailure YamlException m)
397− => (Emitter -> m ())
398− -> m B.ByteString
399−withEmitter f = allocaBytesR emitterSize $ \e -> do
400− res <- liftIO $ c_yaml_emitter_initialize e
401− when (res == 0) $ failure YamlOutOfMemory
402− bs <- withBufferR $ \b -> do
403− liftIO $ c_my_emitter_set_output e b
404− f e
405− liftIO $ c_yaml_emitter_delete e -- FIXME finally
406− return bs
407−
408foreign import ccall unsafe "yaml_emitter_set_output_file"
387foreign import ccall unsafe "yaml_emitter_set_output_file"
409 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
388 c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
410
389
411−withEmitterFile :: (With m, MonadFailure YamlException m)
412− => FilePath
413− -> (Emitter -> m ())
414− -> m ()
415−withEmitterFile fp f = allocaBytesR emitterSize $ \e -> do
416− res <- liftIO $ c_yaml_emitter_initialize e
417− when (res == 0) $ failure YamlOutOfMemory
418− file <- withCStringR fp $ \fp' -> withCStringR "w" $ \w' ->
419− liftIO (c_fopen fp' w')
420− res' <-
421− if file == nullPtr
422− then failure $ YamlFileNotFound fp
423− else do
424− liftIO $ c_yaml_emitter_set_output_file e file
425− res' <- f e
426− liftIO $ c_yaml_emitter_delete e
427− return res'
428− liftIO $ c_fclose file -- FIXME use finally
429− return res'
430−
431foreign import ccall unsafe "yaml_emitter_emit"
390foreign import ccall unsafe "yaml_emitter_emit"
432 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
391 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
433
392
@@ -625,17 +584,6 @@ newtype ToEventRawException = ToEventRawException CInt
625 deriving (Show, Typeable)
584 deriving (Show, Typeable)
626instance Exception ToEventRawException
585instance Exception ToEventRawException
627
586
628−encode :: (With m, MonadFailure YamlException m)
629− => YamlEncoder m ()
630− -> m B.ByteString
631−encode = withEmitter . runReaderT
632−
633−encodeFile :: (With m, MonadFailure YamlException m)
634− => FilePath
635− -> YamlEncoder m ()
636− -> m ()
637−encodeFile filePath = withEmitterFile filePath . runReaderT
638−
639decode :: SC.StreamChunk c Event
587decode :: SC.StreamChunk c Event
640 => MonadCatchIO m
588 => MonadCatchIO m
641 => B.ByteString
589 => B.ByteString
@@ -709,3 +657,55 @@ parserParseOne' parser = allocaBytesR eventSize $ \er -> do
709 c_get_parser_error_offset parser
657 c_get_parser_error_offset parser
710 return $ Left $ YamlParserException problem context offset
658 return $ Left $ YamlParserException problem context offset
711 else liftIO $ Right <$> getEvent er
659 else liftIO $ Right <$> getEvent er
660+
661+encode :: SC.StreamChunk c Event
662+ => MonadIO m
663+ => IterateeG c Event m B.ByteString
664+encode = joinIM $ liftIO $ do
665+ fp <- mallocForeignPtrBytes emitterSize
666+ res <- withForeignPtr fp c_yaml_emitter_initialize
667+ when (res == 0) $ fail "c_yaml_emitter_initialize failed"
668+ buf <- mallocForeignPtrBytes bufferSize
669+ withForeignPtr buf c_buffer_init
670+ withForeignPtr fp $
671+ \emitter -> withForeignPtr buf $
672+ \b -> c_my_emitter_set_output emitter b
673+ return $ runEmitter (go buf) fp
674+ where
675+ go buf = withForeignPtr buf $ \b -> do
676+ ptr' <- c_get_buffer_buff b
677+ len <- c_get_buffer_used b
678+ fptr <- newForeignPtr_ $ castPtr ptr'
679+ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
680+
681+
682+encodeFile :: SC.StreamChunk c Event
683+ => MonadIO m
684+ => FilePath
685+ -> IterateeG c Event m ()
686+encodeFile filePath = joinIM $ liftIO $ do
687+ fp <- mallocForeignPtrBytes emitterSize
688+ res <- withForeignPtr fp c_yaml_emitter_initialize
689+ when (res == 0) $ fail "c_yaml_emitter_initialize failed"
690+ file <- withCStringR filePath $
691+ \filePath' -> withCStringR "w" $
692+ \w' -> c_fopen filePath' w'
693+ when (file == nullPtr) $ fail $ "could not open file for write: " ++ filePath
694+ withForeignPtr fp $ flip c_yaml_emitter_set_output_file file
695+ return $ runEmitter (c_fclose file) fp
696+
697+runEmitter :: SC.StreamChunk c Event
698+ => MonadIO m
699+ => IO a
700+ -> ForeignPtr EmitterStruct
701+ -> IterateeG c Event m a
702+runEmitter close fp = IterateeG go
703+ where
704+ go (EOF x) = do
705+ liftIO $ withForeignPtr fp c_yaml_emitter_delete
706+ a <- liftIO close
707+ return $ Done a $ EOF x
708+ go (Chunk c) = do
709+ liftIO $ withForeignPtr fp $ \emitter ->
710+ LL.mapM_ (\e -> toEventRaw e $ c_yaml_emitter_emit emitter) c
711+ return $ Cont (runEmitter close fp) Nothing
runtests.hs+16−19
@@ -4,19 +4,16 @@ import Test.Framework (defaultMain)
4
4
5import Text.Libyaml
5import Text.Libyaml
6import qualified Data.ByteString.Char8 as B8
6import qualified Data.ByteString.Char8 as B8
7−#if MIN_VERSION_transformers(0,2,0)
8−import "transformers" Control.Monad.Trans.Class
9−#else
10−import "transformers" Control.Monad.Trans
11−#endif
12
7
13import Test.Framework.Providers.HUnit
8import Test.Framework.Providers.HUnit
14import Test.HUnit hiding (Test, path)
9import Test.HUnit hiding (Test, path)
15
10
16−import Control.Exception
17import Data.Iteratee hiding (filter, length, foldl')
11import Data.Iteratee hiding (filter, length, foldl')
18import Data.List (foldl')
12import Data.List (foldl')
19
13
14+import System.Directory
15+import Control.Monad
16+
20main :: IO ()
17main :: IO ()
21main = defaultMain
18main = defaultMain
22 [ testCase "count scalars with anchor" caseCountScalarsWithAnchor
19 [ testCase "count scalars with anchor" caseCountScalarsWithAnchor
@@ -27,7 +24,7 @@ main = defaultMain
27 , testCase "largest string" caseLargestString
24 , testCase "largest string" caseLargestString
28 , testCase "encode/decode" caseEncodeDecode
25 , testCase "encode/decode" caseEncodeDecode
29 , testCase "encode/decode file" caseEncodeDecodeFile
26 , testCase "encode/decode file" caseEncodeDecodeFile
30− --, testCase "interleaved encode/decode" caseInterleave
27+ , testCase "interleaved encode/decode" caseInterleave
31 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument
28 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument
32 ]
29 ]
33
30
@@ -128,7 +125,7 @@ instance Eq MyEvent where
128caseEncodeDecode :: Assertion
125caseEncodeDecode :: Assertion
129caseEncodeDecode = do
126caseEncodeDecode = do
130 eList <- decode yamlBS (dec []) >>= run
127 eList <- decode yamlBS (dec []) >>= run
131− bs <- encode $ mapM_ emitEvent eList
128+ bs <- enumPure1Chunk eList encode >>= run
132 eList2 <- decode bs (dec []) >>= run
129 eList2 <- decode bs (dec []) >>= run
133 map MyEvent eList @=? map MyEvent eList2
130 map MyEvent eList @=? map MyEvent eList2
134 where
131 where
@@ -139,10 +136,16 @@ caseEncodeDecode = do
139 EOF x -> return $ Done front $ EOF x
136 EOF x -> return $ Done front $ EOF x
140 Chunk c -> return $ Cont (dec $ front ++ c) Nothing
137 Chunk c -> return $ Cont (dec $ front ++ c) Nothing
141
138
139+removeFile' :: FilePath -> IO ()
140+removeFile' fp = do
141+ x <- doesFileExist fp
142+ when x $ removeFile fp
143+
142caseEncodeDecodeFile :: Assertion
144caseEncodeDecodeFile :: Assertion
143caseEncodeDecodeFile = do
145caseEncodeDecodeFile = do
146+ removeFile' tmpPath
144 eList <- decodeFile filePath (dec []) >>= run
147 eList <- decodeFile filePath (dec []) >>= run
145− encodeFile tmpPath $ mapM_ emitEvent eList
148+ enumPure1Chunk eList (encodeFile tmpPath) >>= run
146 eList2 <- decodeFile filePath (dec []) >>= run
149 eList2 <- decodeFile filePath (dec []) >>= run
147 map MyEvent eList @=? map MyEvent eList2
150 map MyEvent eList @=? map MyEvent eList2
148 where
151 where
@@ -153,11 +156,12 @@ caseEncodeDecodeFile = do
153 EOF x -> return $ Done front $ EOF x
156 EOF x -> return $ Done front $ EOF x
154 Chunk c -> return $ Cont (dec $ front ++ c) Nothing
157 Chunk c -> return $ Cont (dec $ front ++ c) Nothing
155
158
156−{-
157caseInterleave :: Assertion
159caseInterleave :: Assertion
158caseInterleave = do
160caseInterleave = do
161+ removeFile' tmpPath
162+ removeFile' tmpPath2
159− decodeFile filePath $ encodeFile tmpPath inside
163+ decodeFile filePath (encodeFile tmpPath :: IterateeG [] Event IO ()) >>= run
160− decodeFile tmpPath $ encodeFile tmpPath2 inside
164+ decodeFile tmpPath (encodeFile tmpPath2 :: IterateeG [] Event IO ()) >>= run
161 f1 <- readFile tmpPath
165 f1 <- readFile tmpPath
162 f2 <- readFile tmpPath2
166 f2 <- readFile tmpPath2
163 f1 @=? f2
167 f1 @=? f2
@@ -165,13 +169,6 @@ caseInterleave = do
165 filePath = "test/largest-string.yaml"
169 filePath = "test/largest-string.yaml"
166 tmpPath = "tmp.yaml"
170 tmpPath = "tmp.yaml"
167 tmpPath2 = "tmp2.yaml"
171 tmpPath2 = "tmp2.yaml"
168− inside :: YamlEncoder (YamlDecoder IO) ()
169− inside = do
170− e <- lift parseEvent
171− case e of
172− EventNone -> return ()
173− _ -> emitEvent e >> inside
174−-}
175
172
176caseDecodeInvalidDocument :: Assertion
173caseDecodeInvalidDocument :: Assertion
177caseDecodeInvalidDocument = do
174caseDecodeInvalidDocument = do
yaml.cabal+6−3
@@ -32,7 +32,8 @@ library
32 control-monad-failure >= 0.6.0 && < 0.7,
32 control-monad-failure >= 0.6.0 && < 0.7,
33 bytestring >= 0.9.1.4 && < 0.10,
33 bytestring >= 0.9.1.4 && < 0.10,
34 iteratee >= 0.3.5 && < 0.4,
34 iteratee >= 0.3.5 && < 0.4,
35− MonadCatchIO-transformers >= 0.2.2 && < 0.3
35+ MonadCatchIO-transformers >= 0.2.2 && < 0.3,
36+ ListLike >= 1.0.1 && < 1.1
36 exposed-modules: Text.Libyaml
37 exposed-modules: Text.Libyaml
37 ghc-options: -Wall -auto-all -caf-all
38 ghc-options: -Wall -auto-all -caf-all
38 c-sources: c/helper.c,
39 c-sources: c/helper.c,
@@ -52,13 +53,15 @@ executable runtests
52 cpp-options: -DTEST
53 cpp-options: -DTEST
53 build-depends: test-framework,
54 build-depends: test-framework,
54 test-framework-hunit,
55 test-framework-hunit,
55− base >= 4 && < 5,
56 HUnit,
56 HUnit,
57+ directory,
58+ base >= 4 && < 5,
57 transformers >= 0.1 && < 0.3,
59 transformers >= 0.1 && < 0.3,
58 control-monad-failure >= 0.6.0 && < 0.7,
60 control-monad-failure >= 0.6.0 && < 0.7,
59 bytestring >= 0.9.1.4 && < 0.10,
61 bytestring >= 0.9.1.4 && < 0.10,
60 iteratee >= 0.3.5 && < 0.4,
62 iteratee >= 0.3.5 && < 0.4,
61− MonadCatchIO-transformers >= 0.2.2 && < 0.3
63+ MonadCatchIO-transformers >= 0.2.2 && < 0.3,
64+ ListLike >= 1.0.1 && < 1.1
62 else
65 else
63 Buildable: False
66 Buildable: False
64 ghc-options: -Wall
67 ghc-options: -Wall