git.iko.soy/typeable/yaml
on master help sign in
Parsing via iteratee package
5c6adc4Michael Snoyman
Text/Libyaml.hs+81−42
compare with master
unifiedsplit
@@ -23,7 +23,9 @@ module Text.Libyaml
23 -- * Encoder
23 -- * Encoder
24 , YamlEncoder
24 , YamlEncoder
25 , YamlDecoder
25 , YamlDecoder
26+ , Parser
26 , parseEvent
27 , parseEvent
28+ , parserParseOne
27 , emitEvent
29 , emitEvent
28 -- ** Combinators
30 -- ** Combinators
29 , emitStream
31 , emitStream
@@ -59,6 +61,10 @@ import Control.Monad.Trans.Reader
59
61
60import Control.Exception (throwIO, Exception, SomeException)
62import Control.Exception (throwIO, Exception, SomeException)
61import Data.Typeable (Typeable)
63import Data.Typeable (Typeable)
64+import Data.Iteratee
65+import qualified Data.Iteratee.Base.StreamChunk as SC
66+import Control.Applicative
67+import Control.Monad.CatchIO (MonadCatchIO, finally)
62
68
63data Event =
69data Event =
64 EventNone
70 EventNone
@@ -205,40 +211,11 @@ allocaBytesR i = with (allocaBytes i)
205withCStringR :: With m => String -> (Ptr CChar -> m a) -> m a
211withCStringR :: With m => String -> (Ptr CChar -> m a) -> m a
206withCStringR s = with (withCString s)
212withCStringR s = with (withCString s)
207
213
208−withFileParser :: (MonadFailure YamlException m, With m)
209− => FilePath
210− -> (Parser -> m a)
211− -> m a
212−withFileParser fp f = allocaBytesR parserSize $ \p -> do
213− res <- liftIO $ c_yaml_parser_initialize p
214− when (res == 0) $ failure YamlOutOfMemory
215− file <- withCStringR fp $ \fp' -> withCStringR "r" $ \r' ->
216− liftIO (c_fopen fp' r')
217− when (file == nullPtr) $ failure $ YamlFileNotFound fp
218− liftIO $ c_yaml_parser_set_input_file p file
219− ret <- f p
220− liftIO $ c_fclose file
221− liftIO $ c_yaml_parser_delete p -- could use some finallys here
222− return ret
223−
224−withParser :: (MonadFailure YamlException m, With m)
225− => B.ByteString
226− -> (Parser -> m a)
227− -> m a
228−withParser bs f = allocaBytesR parserSize $ \p -> do
229− res <- liftIO $ c_yaml_parser_initialize p
230− when (res == 0) $ failure YamlOutOfMemory
231− let (fptr, offset, len) = B.toForeignPtr bs
232− ret <- withForeignPtrR fptr $ \ptr -> do
233− let ptr' = castPtr ptr `plusPtr` offset
234− len' = fromIntegral len
235− liftIO $ c_yaml_parser_set_input_string p ptr' len'
236− f p
237− liftIO $ c_yaml_parser_delete p -- FIXME use finally
238− return ret
239−
240−withForeignPtrR :: With m => ForeignPtr a -> (Ptr a -> m b) -> m b
214+withForeignPtr' :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b
241−withForeignPtrR fp = with (withForeignPtr fp)
215+withForeignPtr' fp f = do
216+ r <- f $ unsafeForeignPtrToPtr fp
217+ liftIO $ touchForeignPtr fp
218+ return r
242
219
243foreign import ccall unsafe "yaml_parser_parse"
220foreign import ccall unsafe "yaml_parser_parse"
244 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
221 c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
@@ -659,14 +636,76 @@ encodeFile :: (With m, MonadFailure YamlException m)
659 -> m ()
636 -> m ()
660encodeFile filePath = withEmitterFile filePath . runReaderT
637encodeFile filePath = withEmitterFile filePath . runReaderT
661
638
662−decode :: (With m, MonadFailure YamlException m)
639+decode :: SC.StreamChunk c Event
640+ => MonadCatchIO m
663 => B.ByteString
641 => B.ByteString
664− -> YamlDecoder m a
642+ -> EnumeratorGM c Event m a
665− -> m a
643+decode bs i = do
666−decode bs dec = withParser bs $ runReaderT dec
644+ fp <- liftIO $ mallocForeignPtrBytes parserSize
645+ res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize
646+ flip finally (liftIO $ withForeignPtr fp c_yaml_parser_delete) $
647+ if (res == 0)
648+ then return $ throwErr $ Err "Yaml out of memory"
649+ else do
650+ let (fptr, offset, len) = B.toForeignPtr bs
651+ withForeignPtr' fptr $ \ptr -> do
652+ let ptr' = castPtr ptr `plusPtr` offset
653+ len' = fromIntegral len
654+ liftIO $ withForeignPtr fp $ \p ->
655+ c_yaml_parser_set_input_string p ptr' len'
656+ runParser fp i
667
657
668−decodeFile :: (With m, MonadFailure YamlException m)
658+decodeFile :: SC.StreamChunk c Event
659+ => MonadCatchIO m
669 => FilePath
660 => FilePath
670− -> YamlDecoder m a
661+ -> EnumeratorGM c Event m a
671− -> m a
662+decodeFile file i = do
672−decodeFile fp dec = withFileParser fp $ runReaderT dec
663+ fp <- liftIO $ mallocForeignPtrBytes parserSize
664+ res <- liftIO $ withForeignPtr fp c_yaml_parser_initialize
665+ flip finally (liftIO $ withForeignPtr fp c_yaml_parser_delete) $
666+ if (res == 0)
667+ then return $ throwErr $ Err "Yaml out of memory"
668+ else do
669+ file' <- liftIO
670+ $ withCStringR file $ \file' -> withCStringR "r" $ \r' ->
671+ c_fopen file' r'
672+ if (file' == nullPtr)
673+ then return $ throwErr $ Err
674+ $ "Yaml file not found: " ++ file
675+ else do
676+ liftIO $ withForeignPtr fp $ \p ->
677+ c_yaml_parser_set_input_file p file'
678+ finally (runParser fp i) $ liftIO $ do
679+ c_fclose file'
680+ withForeignPtr fp c_yaml_parser_delete
681+
682+runParser :: SC.StreamChunk c Event
683+ => MonadCatchIO m
684+ => ForeignPtr ParserStruct
685+ -> IterateeG c Event m a
686+ -> m (IterateeG c Event m a)
687+runParser fp iter = do
688+ e <- liftIO $ withForeignPtr fp parserParseOne'
689+ case e of
690+ Left err -> return $ throwErr $ Err $ show err
691+ Right EventNone -> return iter
692+ Right ev -> do
693+ igv <- runIter iter $ Chunk $ SC.fromList [ev]
694+ case igv of
695+ Done a _ -> return $ return a
696+ Cont iter' Nothing -> runParser fp iter'
697+ Cont _ (Just err) -> return $ throwErr err
698+
699+parserParseOne' :: Parser
700+ -> IO (Either YamlException Event)
701+parserParseOne' parser = allocaBytesR eventSize $ \er -> do
702+ res <- liftIO $ c_yaml_parser_parse parser er
703+ flip finally (c_yaml_event_delete er) $
704+ if res == 0
705+ then do
706+ problem <- makeString c_get_parser_error_problem parser
707+ context <- makeString c_get_parser_error_context parser
708+ offset <- fromIntegral `fmap`
709+ c_get_parser_error_offset parser
710+ return $ Left $ YamlParserException problem context offset
711+ else liftIO $ Right <$> getEvent er
runtests.hs+102−102
@@ -10,13 +10,12 @@ import "transformers" Control.Monad.Trans.Class
10import "transformers" Control.Monad.Trans
10import "transformers" Control.Monad.Trans
11#endif
11#endif
12
12
13−--import Test.Framework (testGroup, Test)
14import Test.Framework.Providers.HUnit
13import Test.Framework.Providers.HUnit
15−--import Test.Framework.Providers.QuickCheck (testProperty)
16import Test.HUnit hiding (Test, path)
14import Test.HUnit hiding (Test, path)
17−--import Test.QuickCheck
18
15
19import Control.Exception
16import Control.Exception
17+import Data.Iteratee hiding (filter, length, foldl')
18+import Data.List (foldl')
20
19
21main :: IO ()
20main :: IO ()
22main = defaultMain
21main = defaultMain
@@ -28,137 +27,133 @@ main = defaultMain
28 , testCase "largest string" caseLargestString
27 , testCase "largest string" caseLargestString
29 , testCase "encode/decode" caseEncodeDecode
28 , testCase "encode/decode" caseEncodeDecode
30 , testCase "encode/decode file" caseEncodeDecodeFile
29 , testCase "encode/decode file" caseEncodeDecodeFile
31− , testCase "interleaved encode/decode" caseInterleave
30+ --, testCase "interleaved encode/decode" caseInterleave
32 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument
31 , testCase "decode invalid document (without segfault)" caseDecodeInvalidDocument
33 ]
32 ]
34
33
34+counter :: (Event -> Bool) -> Int -> IterateeG [] Event IO Int
35+counter pred' acc =
36+ IterateeG go
37+ where
38+ go (EOF x) = return $ Done acc $ EOF x
39+ go (Chunk c) =
40+ let acc' = length (filter pred' c) + acc
41+ in return $ Cont (counter pred' acc') Nothing
42+
43+caseHelper :: String
44+ -> (Event -> Bool)
45+ -> Int
46+ -> Assertion
47+caseHelper yamlString pred' expRes = do
48+ res <- decode (B8.pack yamlString) (counter pred' 0) >>= run
49+ res @?= expRes
50+
35caseCountScalarsWithAnchor :: Assertion
51caseCountScalarsWithAnchor :: Assertion
36−caseCountScalarsWithAnchor = do
52+caseCountScalarsWithAnchor =
37− res <- decode yamlBS $ counter (0 :: Int)
53+ caseHelper yamlString isScalarA 1
38− res @?= (1 :: Int)
39− where
54+ where
40− yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"
55+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"
41− yamlBS = B8.pack yamlString
42− counter acc = do
43− e <- parseEvent
44− case e of
45− EventScalar _ _ _ (Just _) -> counter (acc + 1)
56+ isScalarA (EventScalar _ _ _ (Just _)) = True
46− EventNone -> return acc
57+ isScalarA _ = False
47− _ -> counter acc
48
58
49caseCountSequencesWithAnchor :: Assertion
59caseCountSequencesWithAnchor :: Assertion
50−caseCountSequencesWithAnchor = do
60+caseCountSequencesWithAnchor =
51− res <- decode yamlBS $ counter (0 :: Int)
61+ caseHelper yamlString isSequenceStartA 1
52− res @?= (1 :: Int)
53− where
62+ where
54− yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"
63+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"
55− yamlBS = B8.pack yamlString
56− counter acc = do
57− e <- parseEvent
58− case e of
59− EventSequenceStart (Just _) -> counter (acc + 1)
64+ isSequenceStartA (EventSequenceStart (Just _)) = True
60− EventNone -> return acc
65+ isSequenceStartA _ = False
61− _ -> counter acc
62
66
63caseCountMappingsWithAnchor :: Assertion
67caseCountMappingsWithAnchor :: Assertion
64−caseCountMappingsWithAnchor = do
68+caseCountMappingsWithAnchor =
65− res <- decode yamlBS $ counter (0 :: Int)
69+ caseHelper yamlString isMappingA 1
66− res @?= (1 :: Int)
67− where
70+ where
68− yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"
71+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"
69− yamlBS = B8.pack yamlString
70− counter acc = do
71− e <- parseEvent
72− case e of
73− EventMappingStart (Just _) -> counter (acc + 1)
72+ isMappingA (EventMappingStart (Just _)) = True
74− EventNone -> return acc
73+ isMappingA _ = False
75− _ -> counter acc
76
74
77caseCountAliases :: Assertion
75caseCountAliases :: Assertion
78−caseCountAliases = do
76+caseCountAliases =
79− res <- decode yamlBS $ counter (0 :: Int)
77+ caseHelper yamlString isAlias 1
80− res @?= (1 :: Int)
81− where
78+ where
82− yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"
79+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"
83− yamlBS = B8.pack yamlString
84− counter acc = do
85− e <- parseEvent
86− case e of
87− EventAlias _ -> counter (acc + 1)
80+ isAlias EventAlias{} = True
88− EventNone -> return acc
81+ isAlias _ = False
89− _ -> counter acc
90
82
91caseCountScalars :: Assertion
83caseCountScalars :: Assertion
92caseCountScalars = do
84caseCountScalars = do
93− res <- decode yamlBS $ counter accum
85+ res <- decode yamlBS (counter' accum) >>= run
94 res @?= (7, 1, 2)
86 res @?= (7, 1, 2)
95 where
87 where
96 yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"
88 yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"
97 yamlBS = B8.pack yamlString
89 yamlBS = B8.pack yamlString
98− counter (s, l, m) = do
90+ counter' acc = IterateeG $ \s ->
99− e <- parseEvent
100− case e of
91+ case s of
92+ EOF x -> return $ Done acc $ EOF x
93+ Chunk c ->
94+ let acc' = foldl' adder acc c
95+ in return $ Cont (counter' acc') Nothing
101− EventScalar {} -> counter (s + 1, l, m)
96+ adder (s, l, m) (EventScalar{}) = (s + 1, l, m)
102− EventSequenceStart _ -> counter (s, l + 1, m)
97+ adder (s, l, m) (EventSequenceStart{}) = (s, l + 1, m)
103− EventMappingStart _ -> counter (s, l, m + 1)
98+ adder (s, l, m) (EventMappingStart{}) = (s, l, m + 1)
104− EventNone -> return (s, l, m)
99+ adder a _ = a
105− _ -> counter (s, l, m)
106 accum = (0, 0, 0) :: (Int, Int, Int)
100 accum = (0, 0, 0) :: (Int, Int, Int)
107
101
108caseLargestString :: Assertion
102caseLargestString :: Assertion
109caseLargestString = do
103caseLargestString = do
110− res <- decodeFile filePath $ dec accum
104+ res <- decodeFile filePath (dec accum) >>= run
111 res @?= (length expected, expected)
105 res @?= (length expected, expected)
112 where
106 where
113 expected = "this one is just a little bit bigger than the others"
107 expected = "this one is just a little bit bigger than the others"
114 filePath = "test/largest-string.yaml"
108 filePath = "test/largest-string.yaml"
115− dec (i, s) = do
109+ dec acc = IterateeG $ \s ->
116− e <- parseEvent
117− case e of
110+ case s of
111+ EOF x -> return $ Done acc $ EOF x
112+ Chunk c ->
113+ let acc' = foldl' adder acc c
114+ in return $ Cont (dec acc') Nothing
118− (EventScalar bs _ _ _) -> do
115+ adder (i, s) (EventScalar bs _ _ _) =
119− let s' = B8.unpack bs
116+ let s' = B8.unpack bs
120− i' = length s'
117+ i' = length s'
121− dec $ if i' > i then (i', s') else (i, s)
118+ in if i' > i then (i', s') else (i, s)
122− EventNone -> return (i, s)
119+ adder acc _ = acc
123− _ -> dec (i, s)
124 accum = (0, "no strings found")
120 accum = (0, "no strings found")
125
121
122+newtype MyEvent = MyEvent Event deriving Show
123+instance Eq MyEvent where
124+ (MyEvent (EventScalar s t _ _)) == (MyEvent (EventScalar s' t' _ _)) =
125+ s == s' && t == t'
126+ MyEvent e1 == MyEvent e2 = e1 == e2
127+
126caseEncodeDecode :: Assertion
128caseEncodeDecode :: Assertion
127caseEncodeDecode = do
129caseEncodeDecode = do
128− eList <- decode yamlBS $ dec id
130+ eList <- decode yamlBS (dec []) >>= run
129 bs <- encode $ mapM_ emitEvent eList
131 bs <- encode $ mapM_ emitEvent eList
130− eList2 <- decode bs $ dec id
132+ eList2 <- decode bs (dec []) >>= run
131 map MyEvent eList @=? map MyEvent eList2
133 map MyEvent eList @=? map MyEvent eList2
132 where
134 where
133 yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"
135 yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"
134 yamlBS = B8.pack yamlString
136 yamlBS = B8.pack yamlString
135− dec front = do
137+ dec front = IterateeG $ \s ->
136− e <- parseEvent
137− case e of
138+ case s of
138− EventNone -> return $ front []
139+ EOF x -> return $ Done front $ EOF x
139− _ -> dec $ front . (:) e
140+ Chunk c -> return $ Cont (dec $ front ++ c) Nothing
140
141
141caseEncodeDecodeFile :: Assertion
142caseEncodeDecodeFile :: Assertion
142caseEncodeDecodeFile = do
143caseEncodeDecodeFile = do
143− eList <- decodeFile filePath $ dec id
144+ eList <- decodeFile filePath (dec []) >>= run
144 encodeFile tmpPath $ mapM_ emitEvent eList
145 encodeFile tmpPath $ mapM_ emitEvent eList
145− eList2 <- decodeFile filePath $ dec id
146+ eList2 <- decodeFile filePath (dec []) >>= run
146 map MyEvent eList @=? map MyEvent eList2
147 map MyEvent eList @=? map MyEvent eList2
147 where
148 where
148 filePath = "test/largest-string.yaml"
149 filePath = "test/largest-string.yaml"
149 tmpPath = "tmp.yaml"
150 tmpPath = "tmp.yaml"
150− dec front = do
151+ dec front = IterateeG $ \s ->
151− e <- parseEvent
152− case e of
152+ case s of
153− EventNone -> return $ front []
153+ EOF x -> return $ Done front $ EOF x
154− _ -> dec $ front . (:) e
154+ Chunk c -> return $ Cont (dec $ front ++ c) Nothing
155−
156−newtype MyEvent = MyEvent Event deriving Show
157−instance Eq MyEvent where
158− (MyEvent (EventScalar s t _ _)) == (MyEvent (EventScalar s' t' _ _)) =
159− s == s' && t == t'
160− MyEvent e1 == MyEvent e2 = e1 == e2
161
155
156+{-
162caseInterleave :: Assertion
157caseInterleave :: Assertion
163caseInterleave = do
158caseInterleave = do
164 decodeFile filePath $ encodeFile tmpPath inside
159 decodeFile filePath $ encodeFile tmpPath inside
@@ -176,17 +171,22 @@ caseInterleave = do
176 case e of
171 case e of
177 EventNone -> return ()
172 EventNone -> return ()
178 _ -> emitEvent e >> inside
173 _ -> emitEvent e >> inside
174+-}
179
175
180caseDecodeInvalidDocument :: Assertion
176caseDecodeInvalidDocument :: Assertion
181caseDecodeInvalidDocument = do
177caseDecodeInvalidDocument = do
182− handle (\(YamlParserException {}) -> return ()) $ do
183− _ <- decode yamlBS $ dec id
178+ x <- decode yamlBS ignore
179+ y <- runIter x $ EOF Nothing
180+ case y of
181+ Cont _ _ -> return ()
182+ _ -> do
183+ putStrLn $ "bad return value: " ++ show y
184− assertFailure "expected parsing exception, but got no errors"
184+ assertFailure "expected parsing exception, but got no errors"
185− where
185+ where
186− yamlString = " - foo\n - baz\nbuz"
186+ yamlString = " - foo\n - baz\nbuz"
187− yamlBS = B8.pack yamlString
187+ yamlBS = B8.pack yamlString
188− dec front = do
188+ ignore :: IterateeG [] Event IO ()
189− e <- parseEvent
189+ ignore = IterateeG $ \s ->
190− case e of
190+ case s of
191− EventNone -> return $ front []
191+ EOF x -> return $ Done () $ EOF x
192− _ -> dec $ front . (:) e
192+ Chunk _c -> return $ Cont ignore Nothing
yaml.cabal+18−3
@@ -1,5 +1,5 @@
1name: yaml
1name: yaml
2−version: 0.4.0
2+version: 0.5.0
3license: BSD3
3license: BSD3
4license-file: LICENSE
4license-file: LICENSE
5author: Michael Snoyman <michael@snoyman.com>
5author: Michael Snoyman <michael@snoyman.com>
@@ -15,15 +15,24 @@ extra-source-files: c/helper.h,
15 c/yaml_private.h,
15 c/yaml_private.h,
16 c/yaml.h
16 c/yaml.h
17
17
18+flag nolib
19+ description: Skip building the library
20+ default: False
18flag buildtests
21flag buildtests
19 description: Build the executable to run unit tests
22 description: Build the executable to run unit tests
20 default: False
23 default: False
21
24
22library
25library
26+ if flag(nolib)
27+ Buildable: False
28+ else
29+ Buildable: True
23 build-depends: base >= 4 && < 5,
30 build-depends: base >= 4 && < 5,
24 transformers >= 0.1 && < 0.3,
31 transformers >= 0.1 && < 0.3,
25 control-monad-failure >= 0.6.0 && < 0.7,
32 control-monad-failure >= 0.6.0 && < 0.7,
26− bytestring >= 0.9.1.4 && < 0.10
33+ bytestring >= 0.9.1.4 && < 0.10,
34+ iteratee >= 0.3.5 && < 0.4,
35+ MonadCatchIO-transformers >= 0.2.2 && < 0.3
27 exposed-modules: Text.Libyaml
36 exposed-modules: Text.Libyaml
28 ghc-options: -Wall -auto-all -caf-all
37 ghc-options: -Wall -auto-all -caf-all
29 c-sources: c/helper.c,
38 c-sources: c/helper.c,
@@ -43,7 +52,13 @@ executable runtests
43 cpp-options: -DTEST
52 cpp-options: -DTEST
44 build-depends: test-framework,
53 build-depends: test-framework,
45 test-framework-hunit,
54 test-framework-hunit,
55+ base >= 4 && < 5,
46− HUnit
56+ HUnit,
57+ transformers >= 0.1 && < 0.3,
58+ control-monad-failure >= 0.6.0 && < 0.7,
59+ bytestring >= 0.9.1.4 && < 0.10,
60+ iteratee >= 0.3.5 && < 0.4,
61+ MonadCatchIO-transformers >= 0.2.2 && < 0.3
47 else
62 else
48 Buildable: False
63 Buildable: False
49 ghc-options: -Wall
64 ghc-options: -Wall