@@ -11,6 +11,8 @@ module Data.Yaml.Internal
1111 , parse
1212 , decodeHelper
1313 , decodeHelper_
14+ , decodeAllHelper
15+ , decodeAllHelper_
1416 , textToScientific
1517 , stringScalar
1618 , defaultStringStyle
@@ -41,7 +43,7 @@ import qualified Data.ByteString.Lazy as BL
4143import Data.ByteString.Builder.Scientific (scientificBuilder)
4244import Data.Char (toUpper, ord)
4345import Data.List
44−import Data.Conduit ((.|), ConduitM, runConduit)
46+import Data.Conduit ((.|), ConduitM, Void, runConduit)
4547import qualified Data.Conduit.List as CL
4648import qualified Data.HashMap.Strict as M
4749import qualified Data.HashSet as HashSet
@@ -66,6 +68,7 @@ data ParseException = NonScalarKey
6668 , _expected :: Maybe Event
6769 }
6870 | InvalidYaml (Maybe YamlException)
71+ | MultipleDocuments
6972 | AesonException String
7073 | OtherParseException SomeException
7174 | NonStringKey JSONPath
@@ -115,6 +118,7 @@ prettyPrintParseException pe = case pe of
115118 _ -> ",\n" ++ context ++ ":\n"
116119 , problem
117120 ]
121+ MultipleDocuments -> "Multiple YAML documents encountered"
118122 AesonException s -> "Aeson exception:\n" ++ s
119123 OtherParseException exc -> "Generic parse exception:\n" ++ show exc
120124 NonStringKey path -> formatError path "Non-string keys are not supported"
@@ -158,24 +162,34 @@ requireEvent e = do
158162
159163parse :: ReaderT JSONPath (ConduitM Event o Parse) Value
160164parse = do
165+ docs <- parseAll
166+ case docs of
167+ [] -> return Null
168+ [doc] -> return doc
169+ _ -> liftIO $ throwIO MultipleDocuments
170+
171+parseAll :: ReaderT JSONPath (ConduitM Event o Parse) [Value]
172+parseAll = do
161173 streamStart <- lift CL.head
162174 case streamStart of
163175 Nothing ->
164176 -- empty string input
165− return Null
166− Just EventStreamStart -> do
167− documentStart <- lift CL.head
168− case documentStart of
169− Just EventStreamEnd ->
170− -- empty file input, comment only string/file input
171− return Null
172− Just EventDocumentStart -> do
173− res <- parseO
174− requireEvent EventDocumentEnd
175− requireEvent EventStreamEnd
176− return res
177− _ -> liftIO $ throwIO $ UnexpectedEvent documentStart Nothing
178− _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing
177+ return []
178+ Just EventStreamStart ->
179+ -- empty file input, comment only string/file input
180+ parseDocs
181+ _ -> missed streamStart
182+ where
183+ parseDocs = do
184+ documentStart <- lift CL.head
185+ case documentStart of
186+ Just EventStreamEnd -> return []
187+ Just EventDocumentStart -> do
188+ res <- parseO
189+ requireEvent EventDocumentEnd
190+ (res :) <$> parseDocs
191+ _ -> missed documentStart
192+ missed event = liftIO $ throwIO $ UnexpectedEvent event Nothing
179193
180194parseScalar :: ByteString -> Anchor -> Style -> Tag
181195 -> ReaderT JSONPath (ConduitM Event o Parse) Text
@@ -283,36 +297,56 @@ parseM mergedKeys a front = do
283297
284298 merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)
285299
300+parseSrc :: ReaderT JSONPath (ConduitM Event Void Parse) val
301+ -> ConduitM () Event Parse ()
302+ -> IO (val, ParseState)
303+parseSrc eventParser src = runResourceT $ runStateT
304+ (runConduit $ src .| runReaderT eventParser [])
305+ (ParseState Map.empty [])
306+
307+mkHelper :: ReaderT JSONPath (ConduitM Event Void Parse) val -- ^ parse libyaml events as Value or [Value]
308+ -> (SomeException -> IO (Either ParseException a)) -- ^ what to do with unhandled exceptions
309+ -> ((val, ParseState) -> Either ParseException a) -- ^ further transform and parse results
310+ -> ConduitM () Event Parse () -- ^ the libyaml event (string/file) source
311+ -> IO (Either ParseException a)
312+mkHelper eventParser onOtherExc extractResults src = catches
313+ (extractResults <$> parseSrc eventParser src)
314+ [ Handler $ \pe -> return $ Left (pe :: ParseException)
315+ , Handler $ \ye -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
316+ , Handler $ \sae -> throwIO (sae :: SomeAsyncException)
317+ , Handler onOtherExc
318+ ]
319+
286320decodeHelper :: FromJSON a
287321 => ConduitM () Y.Event Parse ()
288322 -> IO (Either ParseException ([Warning], Either String a))
289−decodeHelper src = do
290− -- This used to be tryAny, but the fact is that catching async
291− -- exceptions is fine here. We'll rethrow them immediately in the
292− -- otherwise clause.
293− x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])
294− case x of
295− Left e
296− | Just pe <- fromException e -> return $ Left pe
297− | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
298− | otherwise -> throwIO e
299− Right (y, st) -> return $ Right (parseStateWarnings st, parseEither parseJSON y)
323+decodeHelper = mkHelper parse throwIO $ \(v, st) ->
324+ Right (parseStateWarnings st, parseEither parseJSON v)
325+
326+decodeAllHelper :: FromJSON a
327+ => ConduitM () Event Parse ()
328+ -> IO (Either ParseException ([Warning], Either String [a]))
329+decodeAllHelper = mkHelper parseAll throwIO $ \(vs, st) ->
330+ Right (parseStateWarnings st, mapM (parseEither parseJSON) vs)
331+
332+catchLeft :: SomeException -> IO (Either ParseException a)
333+catchLeft = return . Left . OtherParseException
300334
301335decodeHelper_ :: FromJSON a
302336 => ConduitM () Event Parse ()
303337 -> IO (Either ParseException ([Warning], a))
304−decodeHelper_ src = do
305− x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])
306− case x of
307− Left e
308− | Just pe <- fromException e -> return $ Left pe
309− | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
310− | Just sae <- fromException e -> throwIO (sae :: SomeAsyncException)
311− | otherwise -> return $ Left $ OtherParseException e
312− Right (y, st) -> return $ either
313− (Left . AesonException)
314− Right
315− ((,) (parseStateWarnings st) <$> parseEither parseJSON y)
338+decodeHelper_ = mkHelper parse catchLeft $ \(v, st) ->
339+ case parseEither parseJSON v of
340+ Left e -> Left $ AesonException e
341+ Right x -> Right (parseStateWarnings st, x)
342+
343+decodeAllHelper_ :: FromJSON a
344+ => ConduitM () Event Parse ()
345+ -> IO (Either ParseException ([Warning], [a]))
346+decodeAllHelper_ = mkHelper parseAll catchLeft $ \(vs, st) ->
347+ case mapM (parseEither parseJSON) vs of
348+ Left e -> Left $ AesonException e
349+ Right xs -> Right (parseStateWarnings st, xs)
316350
317351type StringStyle = Text -> ( Tag, Style )
318352