git.iko.soy/typeable/yaml
on master help sign in
encode as unfold; added trivial encodeFile
b9a6cb1Michael Snoyman
Text/Libyaml.hs+53−58
compare with master
unifiedsplit
@@ -19,7 +19,7 @@ module Text.Libyaml
19 -- * Higher level functions
19 -- * Higher level functions
20 , encode
20 , encode
21 , decode
21 , decode
22− -- FIXME , encodeFile
22+ , encodeFile
23 , decodeFile
23 , decodeFile
24 ) where
24 ) where
25
25
@@ -33,9 +33,6 @@ import Foreign.Ptr
33import Foreign.ForeignPtr
33import Foreign.ForeignPtr
34import Foreign.Marshal.Alloc
34import Foreign.Marshal.Alloc
35
35
36−import Control.Applicative
37−import Control.Failure
38−
39import Control.Exception (throwIO, Exception)
36import Control.Exception (throwIO, Exception)
40import Data.Typeable (Typeable)
37import Data.Typeable (Typeable)
41
38
@@ -213,9 +210,8 @@ makeString f a = do
213 cchar <- castPtr `fmap` f a
210 cchar <- castPtr `fmap` f a
214 peekCString cchar
211 peekCString cchar
215
212
216−parserParseOne :: MonadFailure YamlException m
213+parserParseOne :: Parser
217− => Parser
218− -> IO (m Event)
214+ -> IO (Either YamlException Event)
219parserParseOne parser = withEventRaw $ \er -> do
215parserParseOne parser = withEventRaw $ \er -> do
220 res <- c_yaml_parser_parse parser er
216 res <- c_yaml_parser_parse parser er
221 event <-
217 event <-
@@ -225,9 +221,9 @@ parserParseOne parser = withEventRaw $ \er -> do
225 context <- makeString c_get_parser_error_context parser
221 context <- makeString c_get_parser_error_context parser
226 offset <- fromIntegral `fmap`
222 offset <- fromIntegral `fmap`
227 c_get_parser_error_offset parser
223 c_get_parser_error_offset parser
228− return $ failure $
224+ return $ Left $
229 YamlParserException problem context offset
225 YamlParserException problem context offset
230− else return `fmap` getEvent er
226+ else Right `fmap` getEvent er
231 c_yaml_event_delete er
227 c_yaml_event_delete er
232 return event
228 return event
233
229
@@ -296,19 +292,6 @@ getEvent er = do
296 YamlMappingStartEvent -> return EventMappingStart
292 YamlMappingStartEvent -> return EventMappingStart
297 YamlMappingEndEvent -> return EventMappingEnd
293 YamlMappingEndEvent -> return EventMappingEnd
298
294
299−data YAttempt v = YSuccess v | YFailure YamlException
300−instance Functor YAttempt where
301− fmap = liftM
302−instance Applicative YAttempt where
303− pure = return
304− (<*>) = ap
305−instance Monad YAttempt where
306− return = YSuccess
307− YSuccess v >>= f = f v
308− YFailure e >>= _ = YFailure e
309−instance Failure YamlException YAttempt where
310− failure = YFailure
311−
312parserParse :: (a -> Event -> Either a a)
295parserParse :: (a -> Event -> Either a a)
313 -> a
296 -> a
314 -> Parser
297 -> Parser
@@ -316,8 +299,8 @@ parserParse :: (a -> Event -> Either a a)
316parserParse fold accum parser = do
299parserParse fold accum parser = do
317 event' <- parserParseOne parser
300 event' <- parserParseOne parser
318 case event' of
301 case event' of
319− YFailure e -> return $ Left e
302+ Left e -> return $ Left e
320− YSuccess event -> do
303+ Right event -> do
321 case fold accum event of
304 case fold accum event of
322 Left accum' -> return $ Right accum'
305 Left accum' -> return $ Right accum'
323 Right accum' -> parserParse fold accum' parser
306 Right accum' -> parserParse fold accum' parser
@@ -349,34 +332,34 @@ foreign import ccall unsafe "get_buffer_buff"
349foreign import ccall unsafe "get_buffer_used"
332foreign import ccall unsafe "get_buffer_used"
350 c_get_buffer_used :: Buffer -> IO CULong
333 c_get_buffer_used :: Buffer -> IO CULong
351
334
352−withBuffer :: MonadFailure YamlException m
335+withBuffer :: (Buffer -> IO (Either YamlException ()))
353− => (Buffer -> IO (YAttempt ()))
354− -> IO (m B.ByteString)
336+ -> IO (Either YamlException B.ByteString)
355withBuffer f = allocaBytes bufferSize $ \b -> do
337withBuffer f = allocaBytes bufferSize $ \b -> do
356 c_buffer_init b
338 c_buffer_init b
357 aRes <- f b
339 aRes <- f b
358 case aRes of
340 case aRes of
359− YFailure e -> return $ failure e
341+ Left e -> return $ Left e
360− YSuccess () -> do
342+ Right () -> do
361 ptr' <- c_get_buffer_buff b
343 ptr' <- c_get_buffer_buff b
362 len <- c_get_buffer_used b
344 len <- c_get_buffer_used b
363 fptr <- newForeignPtr_ $ castPtr ptr'
345 fptr <- newForeignPtr_ $ castPtr ptr'
364− return $ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
346+ return $ Right $ B.fromForeignPtr fptr 0 $ fromIntegral len
365
347
366foreign import ccall unsafe "my_emitter_set_output"
348foreign import ccall unsafe "my_emitter_set_output"
367 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
349 c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
368
350
369−withEmitter :: MonadFailure YamlException m
351+withEmitter :: (Emitter -> IO (Either YamlException ()))
370− => (Emitter -> IO (YAttempt ()))
371− -> IO (m B.ByteString)
352+ -> IO (Either YamlException B.ByteString)
372withEmitter f = allocaBytes emitterSize $ \e -> do
353withEmitter f = allocaBytes emitterSize $ \e -> do
373− res <- c_yaml_emitter_initialize e
354+ res <- c_yaml_emitter_initialize e
355+ if res == 0
374− when (res == 0) $ throwIO YamlOutOfMemory
356+ then return $ Left YamlOutOfMemory
357+ else do
375− bs <- withBuffer $ \b -> do
358+ bs <- withBuffer $ \b -> do
376− c_my_emitter_set_output e b
359+ c_my_emitter_set_output e b
377− f e
360+ f e
378− c_yaml_emitter_delete e
361+ c_yaml_emitter_delete e
379− return bs
362+ return bs
380
363
381foreign import ccall unsafe "yaml_emitter_emit"
364foreign import ccall unsafe "yaml_emitter_emit"
382 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
365 c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
@@ -384,18 +367,20 @@ foreign import ccall unsafe "yaml_emitter_emit"
384foreign import ccall unsafe "get_emitter_error"
367foreign import ccall unsafe "get_emitter_error"
385 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
368 c_get_emitter_error :: Emitter -> IO (Ptr CUChar)
386
369
387−emitEvents :: MonadFailure YamlException m
370+emitEvents :: (a -> Maybe (Event, a))
371+ -> a
388− => Emitter
372+ -> Emitter
389− -> [Event]
373+ -> IO (Either YamlException ())
390− -> IO (m ())
374+emitEvents unfold src emitter = do
391−emitEvents _ [] = return $ return ()
375+ case unfold src of
392−emitEvents emitter (e:rest) = do
376+ Nothing -> return $ Right ()
377+ Just (e, src') -> do
393− res <- toEventRaw e $ c_yaml_emitter_emit emitter
378+ res <- toEventRaw e $ c_yaml_emitter_emit emitter
394− if res == 0
379+ if res == 0
395− then do
380+ then do
396− problem <- makeString c_get_emitter_error emitter
381+ problem <- makeString c_get_emitter_error emitter
397− return $ failure $ YamlEmitterException problem
382+ return $ Left $ YamlEmitterException problem
398− else emitEvents emitter rest
383+ else emitEvents unfold src' emitter
399
384
400foreign import ccall unsafe "yaml_stream_start_event_initialize"
385foreign import ccall unsafe "yaml_stream_start_event_initialize"
401 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
386 c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
@@ -500,19 +485,29 @@ toEventRaw e f = withEventRaw $ \er -> do
500 c_yaml_mapping_end_event_initialize er
485 c_yaml_mapping_end_event_initialize er
501 EventAlias -> error "toEventRaw: EventAlias not supported"
486 EventAlias -> error "toEventRaw: EventAlias not supported"
502 EventNone -> error "toEventRaw: EventNone not supported"
487 EventNone -> error "toEventRaw: EventNone not supported"
503− unless (ret == 1) $ failure $ ToEventRawException ret
488+ unless (ret == 1) $ throwIO $ ToEventRawException ret
504 f er
489 f er
505
490
506newtype ToEventRawException = ToEventRawException CInt
491newtype ToEventRawException = ToEventRawException CInt
507 deriving (Show, Typeable)
492 deriving (Show, Typeable)
508instance Exception ToEventRawException
493instance Exception ToEventRawException
509
494
510−encode :: MonadFailure YamlException m
511− => [Event]
495+encode :: (a -> Maybe (Event, a))
496+ -> a
512− -> IO (m B.ByteString)
497+ -> IO (Either YamlException B.ByteString)
513−encode = withEmitter . flip emitEvents
498+encode unfold src = withEmitter $ emitEvents unfold src
514
499
500+encodeFile :: FilePath
501+ -> (a -> Maybe (Event, a))
502+ -> a
503+ -> IO (Either YamlException ())
515−-- FIXME encodeFile
504+encodeFile filePath unfold src = do
505+ res <- withEmitter $ emitEvents unfold src
506+ case res of
507+ Left e -> return $ Left e
508+ Right bs -> do
509+ Data.ByteString.writeFile filePath bs
510+ return $ Right ()
516
511
517decode :: B.ByteString
512decode :: B.ByteString
518 -> (a -> Event -> Either a a)
513 -> (a -> Event -> Either a a)
runtests.hs+44
@@ -2,6 +2,7 @@ import Test.Framework (defaultMain)
2
2
3import Text.Libyaml
3import Text.Libyaml
4import qualified Data.ByteString.Char8 as B8
4import qualified Data.ByteString.Char8 as B8
5+import Control.Exception
5
6
6--import Test.Framework (testGroup, Test)
7--import Test.Framework (testGroup, Test)
7import Test.Framework.Providers.HUnit
8import Test.Framework.Providers.HUnit
@@ -13,6 +14,8 @@ main :: IO ()
13main = defaultMain
14main = defaultMain
14 [ testCase "count scalars" caseCountScalars
15 [ testCase "count scalars" caseCountScalars
15 , testCase "largest string" caseLargestString
16 , testCase "largest string" caseLargestString
17+ , testCase "encode/decode" caseEncodeDecode
18+ , testCase "encode/decode file" caseEncodeDecodeFile
16 ]
19 ]
17
20
18caseCountScalars :: Assertion
21caseCountScalars :: Assertion
@@ -45,3 +48,44 @@ caseLargestString = do
45 fold res EventNone = Left res
48 fold res EventNone = Left res
46 fold res _ = Right res
49 fold res _ = Right res
47 accum = (0, "no strings found")
50 accum = (0, "no strings found")
51+
52+toIO :: Exception l => IO (Either l r) -> IO r
53+toIO x = x >>= either throwIO return
54+
55+caseEncodeDecode :: Assertion
56+caseEncodeDecode = do
57+ eList' <- toIO $ decode yamlBS fold id
58+ let eList = eList' []
59+ bs <- toIO $ encode unfold eList
60+ eList2' <- toIO $ decode bs fold id
61+ let eList2 = eList2' []
62+ map MyEvent eList @=? map MyEvent eList2
63+ where
64+ yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"
65+ yamlBS = B8.pack yamlString
66+ fold x EventNone = Left x
67+ fold x e = Right $ x . (:) e
68+ unfold (x:xs) = Just (x, xs)
69+ unfold [] = Nothing
70+
71+caseEncodeDecodeFile :: Assertion
72+caseEncodeDecodeFile = do
73+ eList' <- toIO $ decodeFile filePath fold id
74+ let eList = eList' []
75+ toIO $ encodeFile tmpPath unfold eList
76+ eList2' <- toIO $ decodeFile tmpPath fold id
77+ let eList2 = eList2' []
78+ map MyEvent eList @=? map MyEvent eList2
79+ where
80+ filePath = "test/largest-string.yaml"
81+ tmpPath = "tmp.yaml"
82+ fold x EventNone = Left x
83+ fold x e = Right $ x . (:) e
84+ unfold (x:xs) = Just (x, xs)
85+ unfold [] = Nothing
86+
87+newtype MyEvent = MyEvent Event deriving Show
88+instance Eq MyEvent where
89+ (MyEvent (EventScalar s t _)) == (MyEvent (EventScalar s' t' _)) =
90+ s == s' && t == t'
91+ MyEvent e1 == MyEvent e2 = e1 == e2
yaml.cabal+2−4
@@ -28,8 +28,7 @@ library
28 else
28 else
29 Buildable: True
29 Buildable: True
30 build-depends: base >= 4 && < 5,
30 build-depends: base >= 4 && < 5,
31− bytestring >= 0.9.1.4 && < 0.10,
31+ bytestring >= 0.9.1.4 && < 0.10
32− failure >= 0.0.0 && < 0.1
33 exposed-modules: Text.Libyaml
32 exposed-modules: Text.Libyaml
34 ghc-options: -Wall
33 ghc-options: -Wall
35 c-sources: c/helper.c,
34 c-sources: c/helper.c,
@@ -53,8 +52,7 @@ executable runtests
53 HUnit,
52 HUnit,
54 QuickCheck >= 1 && < 2,
53 QuickCheck >= 1 && < 2,
55 base >= 4 && < 5,
54 base >= 4 && < 5,
56− bytestring >= 0.9.1.4 && < 0.10,
55+ bytestring >= 0.9.1.4 && < 0.10
57− failure >= 0.0.0 && < 0.1
58 else
56 else
59 Buildable: False
57 Buildable: False
60 ghc-options: -Wall
58 ghc-options: -Wall