xml-conduit 1.4.0.4 → 1.5.0

raw patch · 4 files changed

+378/−292 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• Text/XML/Stream/Parse.hs +293/−264
• test/main.hs +74/−27
• xml-conduit.cabal +1/−1

@@ -1,3 +1,13 @@+## 1.5.0++* `tag` function no longer throws an exception when attributes don't match [#93](https://github.com/snoyberg/xml/pull/93)+* Add `many_` combinator to avoid building results in memory [#94](https://github.com/snoyberg/xml/pull/94)+* Turn some functions from `Consumer Event m a` to `ConduitM Event o m a` to allow yielding values+* Replace `takeAllTreesContent` with `takeAnyTreeContent`, that only consumes one tree+* Introduce `NameMatcher` type to refactor tag parsers+* Add a couple of `take*` functions to stream events rather than parse them+* Rename `ignore*` functions to comply with naming convention+ ## 1.4.0.3  * Compatibility with blaze-markup-0.8.0.0 [#95](https://github.com/snoyberg/xml/issues/95)

@@ -1,11 +1,16 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE PatternGuards      #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-} -- | This module provides both a native Haskell solution for parsing XML -- documents into a stream of events, and a set of parser combinators for -- dealing with a stream of events.@@ -98,23 +103,29 @@     , decodeHtmlEntities       -- * Event parsing     , tag-    , tagPredicate-    , tagName+    , tag'     , tagNoAttr     , tagIgnoreAttrs-    , tagPredicateIgnoreAttrs     , content     , contentMaybe       -- * Ignoring tags/trees     , ignoreTag-    , ignoreTagName-    , ignoreAnyTagName-    , ignoreAllTags+    , ignoreEmptyTag     , ignoreTree-    , ignoreTreeName-    , ignoreAnyTreeName-    , ignoreAllTrees+    , ignoreTreeContent+    , ignoreAnyTreeContent     , ignoreAllTreesContent+      -- * Streaming events+    , takeContent+    , takeTree+    , takeTreeContent+    , takeAnyTreeContent+    , takeAllTreesContent+      -- * Tag name matching+    , NameMatcher(..)+    , matching+    , anyOf+    , anyName       -- * Attribute parsing     , AttrParser     , attr@@ -127,63 +138,62 @@     , orE     , choose     , many+    , many_     , manyIgnore     , many'     , force       -- * Streaming combinators     , manyYield-    , manyIgnoreYield     , manyYield'-    , takeAllTreesContent+    , manyIgnoreYield       -- * Exceptions     , XmlException (..)       -- * Other types     , PositionRange     , EventPos     ) where-import qualified Control.Applicative          as A+import           Blaze.ByteString.Builder     (fromWord32be, toByteString) import           Control.Applicative          ((<$>))+import           Control.Applicative          (Alternative (empty, (<|>)),+                                               Applicative (..), (<$>))+import qualified Control.Applicative          as A+import           Control.Arrow                ((***))+import           Control.Exception            (Exception (..), SomeException)+import           Control.Monad                (ap, guard, liftM, void) import           Control.Monad.Fix            (fix)+import           Control.Monad.Trans.Class    (lift)+import           Control.Monad.Trans.Maybe    (MaybeT (..)) import           Control.Monad.Trans.Resource (MonadResource, MonadThrow (..),                                                monadThrow) import           Data.Attoparsec.Text         (Parser, anyChar, char, manyTill,                                                skipWhile, string, takeWhile,                                                takeWhile1, try) import qualified Data.Attoparsec.Text         as AT-import           Data.Conduit.Attoparsec      (PositionRange, conduitParser)-import           Data.List                    (intercalate)-import           Data.XML.Types               (Content (..), Event (..),-                                               ExternalID (..),-                                               Instruction (..), Name (..))--import           Blaze.ByteString.Builder     (fromWord32be, toByteString)-import           Control.Applicative          (Alternative (empty, (<|>)),-                                               Applicative (..), (<$>))-import           Control.Arrow                ((***))-import           Control.Exception            (Exception (..), SomeException)-import           Control.Monad                (ap, guard, liftM, void)-import           Control.Monad.Trans.Class    (lift) import qualified Data.ByteString              as S import qualified Data.ByteString.Lazy         as L import           Data.Char                    (isSpace) import           Data.Conduit+import           Data.Conduit.Attoparsec      (PositionRange, conduitParser) import           Data.Conduit.Binary          (sourceFile)-import qualified Data.Conduit.Internal        as CI import qualified Data.Conduit.List            as CL import qualified Data.Conduit.Text            as CT import           Data.Default                 (Default (..))+import           Data.List                    (intercalate) import           Data.List                    (foldl') import qualified Data.Map                     as Map import           Data.Maybe                   (fromMaybe, isNothing)+import           Data.String                  (IsString (..)) import           Data.Text                    (Text, pack) import qualified Data.Text                    as T-import qualified Data.Text                    as TS import           Data.Text.Encoding           (decodeUtf32BEWith,                                                decodeUtf8With) import           Data.Text.Encoding.Error     (ignore, lenientDecode) import           Data.Text.Read               (Reader, decimal, hexadecimal) import           Data.Typeable                (Typeable) import           Data.Word                    (Word32)+import           Data.XML.Types               (Content (..), Event (..),+                                               ExternalID (..),+                                               Instruction (..), Name (..)) import           Prelude                      hiding (takeWhile) import           Text.XML.Stream.Token @@ -259,7 +269,7 @@ -- first checks for BOMs, removing them as necessary, and then check for the -- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It -- defaults to assuming UTF-8.-detectUtf :: MonadThrow m => Conduit S.ByteString m TS.Text+detectUtf :: MonadThrow m => Conduit S.ByteString m T.Text detectUtf =     conduit id   where@@ -295,7 +305,7 @@ checkXMLDecl :: MonadThrow m              => S.ByteString              -> Maybe CT.Codec-             -> Conduit S.ByteString m TS.Text+             -> Conduit S.ByteString m T.Text checkXMLDecl bs (Just codec) = leftover bs >> CT.decode codec checkXMLDecl bs0 Nothing =     loop [] (AT.parse (parseToken decodeXmlEntities)) bs0@@ -313,7 +323,7 @@          findEncoding [] = fallback         findEncoding ((TName _ "encoding", [ContentText enc]):_) =-            case TS.toLower enc of+            case T.toLower enc of                 "iso-8859-1" -> complete CT.iso8859_1                 "utf-8"      -> complete CT.utf8                 _            -> complete CT.utf8@@ -339,7 +349,7 @@               -> Conduit S.ByteString m EventPos parseBytesPos ps = detectUtf =$= parseTextPos ps -dropBOM :: Monad m => Conduit TS.Text m TS.Text+dropBOM :: Monad m => Conduit T.Text m T.Text dropBOM =     await >>= maybe (return ()) push   where@@ -362,13 +372,13 @@ -- Since 1.2.4 parseText' :: MonadThrow m            => ParseSettings-           -> Conduit TS.Text m Event+           -> Conduit T.Text m Event parseText' = mapOutput snd . parseTextPos  {-# DEPRECATED parseText "Please use 'parseText'' or 'parseTextPos'." #-} parseText :: MonadThrow m           => ParseSettings-          -> Conduit TS.Text m EventPos+          -> Conduit T.Text m EventPos parseText = parseTextPos  -- | Same as 'parseText'', but includes the position of each event.@@ -376,7 +386,7 @@ -- Since 1.2.4 parseTextPos :: MonadThrow m           => ParseSettings-          -> Conduit TS.Text m EventPos+          -> Conduit T.Text m EventPos parseTextPos de =     dropBOM         =$= tokenize@@ -420,7 +430,7 @@         , psRetainNamespaces = False         } -conduitToken :: MonadThrow m => ParseSettings -> Conduit TS.Text m (PositionRange, Token)+conduitToken :: MonadThrow m => ParseSettings -> Conduit T.Text m (PositionRange, Token) conduitToken = conduitParser . parseToken . psDecodeEntities  parseToken :: DecodeEntities -> Parser Token@@ -559,22 +569,18 @@              -> Bool -- break on double quote              -> Bool -- break on single quote              -> Parser Content-parseContent de breakDouble breakSingle =-    parseEntity <|> parseText'-  where-    parseEntity = do-        char' '&'-        t <- takeWhile1 (/= ';')-        char' ';'-        return $ de t-    parseText' = do-        bs <- takeWhile1 valid-        return $ ContentText bs-    valid '"'  = not breakDouble-    valid '\'' = not breakSingle-    valid '&'  = False -- amp-    valid '<'  = False -- lt-    valid _    = True+parseContent de breakDouble breakSingle = parseEntity <|> parseTextContent where+  parseEntity = do+    char' '&'+    t <- takeWhile1 (/= ';')+    char' ';'+    return $ de t+  parseTextContent = ContentText <$> takeWhile1 valid+  valid '"'  = not breakDouble+  valid '\'' = not breakSingle+  valid '&'  = False -- amp+  valid '<'  = False -- lt+  valid _    = True  skipSpace :: Parser () skipSpace = skipWhile isXMLSpace@@ -598,8 +604,7 @@ char' :: Char -> Parser () char' = void . char -data ContentType =-    Ignore | IsContent Text | IsError String | NotContent+data ContentType = Ignore | IsContent Text | IsError String | NotContent  -- | Grabs the next piece of content if available. This function skips over any -- comments and instructions and concatenates all content until the next start@@ -639,64 +644,66 @@ content :: MonadThrow m => Consumer Event m Text content = fromMaybe T.empty <$> contentMaybe --- | The most generic way to parse a tag. It takes a predicate for checking if--- this is the correct tag name, an 'AttrParser' for handling attributes, and--- then a parser for dealing with content.++isWhitespace :: Event -> Bool+isWhitespace EventBeginDocument             = True+isWhitespace EventEndDocument               = True+isWhitespace EventBeginDoctype{}            = True+isWhitespace EventEndDoctype                = True+isWhitespace EventInstruction{}             = True+isWhitespace (EventContent (ContentText t)) = T.all isSpace t+isWhitespace EventComment{}                 = True+isWhitespace (EventCDATA t)                 = T.all isSpace t+isWhitespace _                              = False+++-- | The most generic way to parse a tag. It takes a 'NameMatcher' to check whether+-- this is a correct tag name, an 'AttrParser' to handle attributes, and+-- then a parser to deal with content. ----- 'Events' are consumed if and only if the predicate holds.+-- 'Events' are consumed if and only if the tag name and its attributes match. -- -- This function automatically absorbs its balancing closing tag, and will -- throw an exception if not all of the attributes or child elements are -- consumed. If you want to allow extra attributes, see 'ignoreAttrs'. -- -- This function automatically ignores comments, instructions and whitespace.-{-# DEPRECATED tag "The signature of this function will change in next release." #-} tag :: MonadThrow m-    => (Name -> Maybe a) -- ^ Check if this is a correct tag name-                         --   and return a value that can be used to get an @AttrParser@.-                         --   If this returns @Nothing@, the function will also return @Nothing@+    => NameMatcher a -- ^ Check if this is a correct tag name+                     --   and return a value that can be used to get an @AttrParser@.+                     --   If this fails, the function will return @Nothing@     -> (a -> AttrParser b) -- ^ Given the value returned by the name checker, this function will                            --   be used to get an @AttrParser@ appropriate for the specific tag.-    -> (b -> CI.ConduitM Event o m c) -- ^ Handler function to handle the attributes and children-                                      --   of a tag, given the value return from the @AttrParser@-    -> CI.ConduitM Event o m (Maybe c)-tag checkName attrParser f = do-    (x, leftovers) <- dropWS []-    res <- case x of-        Just (EventBeginElement name as) ->-            case checkName name of-                Just y ->-                    case runAttrParser' (attrParser y) as of-                        Left e -> lift $ monadThrow e-                        Right z -> do-                            z' <- f z-                            (a, _leftovers') <- dropWS []-                            case a of-                                Just (EventEndElement name')-                                    | name == name' -> return (Just z')-                                _ -> lift $ monadThrow $ InvalidEndElement name a-                Nothing -> return Nothing-        _ -> return Nothing+                           --   If the @AttrParser@ fails, the function will also return @Nothing@+    -> (b -> ConduitM Event o m c) -- ^ Handler function to handle the attributes and children+                                   --   of a tag, given the value return from the @AttrParser@+    -> ConduitM Event o m (Maybe c)+tag nameMatcher attrParser f = do+  (x, leftovers) <- dropWS []+  res <- case x of+    Just (EventBeginElement name as) -> case runNameMatcher nameMatcher name of+      Just y -> case runAttrParser' (attrParser y) as of+        Left _ -> return Nothing+        Right z -> do+          z' <- f z+          (a, _leftovers') <- dropWS []+          case a of+            Just (EventEndElement name')+              | name == name' -> return (Just z')+            _ -> lift $ monadThrow $ InvalidEndElement name a+      Nothing -> return Nothing+    _ -> return Nothing -    case res of-        -- Did not parse, put back all of the leading whitespace events and the-        -- final observed event generated by dropWS-        Nothing -> mapM_ leftover leftovers-        -- Parse succeeded, discard all of those whitespace events and the-        -- first parsed event-        Just _  -> return ()+  case res of+    -- Did not parse, put back all of the leading whitespace events and the+    -- final observed event generated by dropWS+    Nothing -> mapM_ leftover leftovers+    -- Parse succeeded, discard all of those whitespace events and the+    -- first parsed event+    Just _  -> return () -    return res+  return res   where-    isWhitespace EventBeginDocument             = True-    isWhitespace EventEndDocument               = True-    isWhitespace EventBeginDoctype{}            = True-    isWhitespace EventEndDoctype                = True-    isWhitespace EventInstruction{}             = True-    isWhitespace (EventContent (ContentText t)) = T.all isSpace t-    isWhitespace EventComment{}                 = True-    isWhitespace _                              = False-     -- Drop Events until we encounter a non-whitespace element. Return all of     -- the events consumed here (including the first non-whitespace event) so     -- that the calling function can treat them as leftovers if the parse fails@@ -713,125 +720,72 @@             Right ([], x)   -> Right x             Right (attr, _) -> Left $ toException $ UnparsedAttributes attr --- | A simplified version of 'tag' which matches against boolean predicates.-{-# DEPRECATED tagPredicate "This function will be removed in next release." #-}-tagPredicate :: MonadThrow m-             => (Name -> Bool) -- ^ Name predicate that returns @True@ if the name matches the parser-             -> AttrParser a -- ^ The attribute parser to be used for tags matching the predicate-             -> (a -> CI.ConduitM Event o m b) -- ^ Handler function to handle the attributes and children-                                               --   of a tag, given the value return from the @AttrParser@-             -> CI.ConduitM Event o m (Maybe b)-tagPredicate p attrParser = tag (guard . p) (const attrParser)---- | A simplified version of 'tag' which matches for specific tag names instead--- of taking a predicate function. This is often sufficient, and when combined--- with OverloadedStrings and the IsString instance of 'Name', can prove to be--- very concise.--- .--- Note that @Name@ is namespace sensitive. When using the @IsString@ instance of name,--- use--- > "{http://a/b}c" :: Name--- to match the tag @c@ in the XML namespace @http://a/b@-{-# DEPRECATED tagName "This function will be removed in next release." #-}-tagName :: MonadThrow m-     => Name -- ^ The tag name this parser matches to (includes namespaces)-     -> AttrParser a -- ^ The attribute parser to be used for tags matching the predicate-     -> (a -> CI.ConduitM Event o m b) -- ^ Handler function to handle the attributes and children-                                       --   of a tag, given the value return from the @AttrParser@-     -> CI.ConduitM Event o m (Maybe b)-tagName name = tagPredicate (== name)+-- | A simplified version of 'tag' where the 'NameMatcher' result isn't forwarded to the attributes parser.+--+-- Since 1.5.0+tag' :: MonadThrow m+     => NameMatcher a -> AttrParser b -> (b -> ConduitM Event o m c)+     -> ConduitM Event o m (Maybe c)+tag' a b = tag a (const b)  -- | A further simplified tag parser, which requires that no attributes exist.-{-# DEPRECATED tagNoAttr "The signature of this function will change in next release." #-} tagNoAttr :: MonadThrow m-          => Name -- ^ The name this parser matches to-          -> CI.ConduitM Event o m a -- ^ Handler function to handle the children of the matched tag-          -> CI.ConduitM Event o m (Maybe a)-tagNoAttr name f = tagName name (return ()) $ const f+          => NameMatcher a -- ^ Check if this is a correct tag name+          -> ConduitM Event o m b -- ^ Handler function to handle the children of the matched tag+          -> ConduitM Event o m (Maybe b)+tagNoAttr name f = tag' name (return ()) $ const f   -- | A further simplified tag parser, which ignores all attributes, if any exist-{-# DEPRECATED tagIgnoreAttrs "The signature of this function will change in next release." #-} tagIgnoreAttrs :: MonadThrow m-               => Name -- ^ The name this parser matches to-               -> CI.ConduitM Event o m a -- ^ Handler function to handle the children of the matched tag-               -> CI.ConduitM Event o m (Maybe a)-tagIgnoreAttrs name f = tagName name ignoreAttrs $ const f+               => NameMatcher a -- ^ Check if this is a correct tag name+               -> ConduitM Event o m b -- ^ Handler function to handle the children of the matched tag+               -> ConduitM Event o m (Maybe b)+tagIgnoreAttrs name f = tag' name ignoreAttrs $ const f --- | A further simplified tag parser, which ignores all attributes, if any exist-{-# DEPRECATED tagPredicateIgnoreAttrs "This function will be removed in next release." #-}-tagPredicateIgnoreAttrs :: MonadThrow m-                        => (Name -> Bool) -- ^ The name predicate this parser matches to-                        -> CI.ConduitM Event o m a -- ^ Handler function to handle the children of the matched tag-                        -> CI.ConduitM Event o m (Maybe a)-tagPredicateIgnoreAttrs namePred f = tagPredicate namePred ignoreAttrs $ const f --- | Ignore an empty tag and all of its attributes by predicate.+-- | Ignore an empty tag and all of its attributes. --   This does not ignore the tag recursively --   (i.e. it assumes there are no child elements).---   This functions returns 'Just' if the tag matched.-{-# DEPRECATED ignoreTag "The signature of this function will change in next release." #-}-ignoreTag :: MonadThrow m-          => (Name -> Bool) -- ^ The predicate name to match to+--   This function returns @Just ()@ if the tag matched.+--+-- Since 1.5.0+ignoreEmptyTag :: MonadThrow m+          => NameMatcher a -- ^ Check if this is a correct tag name           -> ConduitM Event o m (Maybe ())-ignoreTag namePred = tagPredicateIgnoreAttrs namePred (return ())+ignoreEmptyTag nameMatcher = tagIgnoreAttrs nameMatcher (return ()) --- | Like 'ignoreTag', but matches an exact name-{-# DEPRECATED ignoreTagName "This function will be removed in next release." #-}-ignoreTagName :: MonadThrow m-              => Name -- ^ The name to match to-              -> ConduitM Event o m (Maybe ())-ignoreTagName name = ignoreTag (== name) --- | Like 'ignoreTagName', but matches any name from a list of names.-{-# DEPRECATED ignoreAnyTagName "This function will be removed in next release." #-}-ignoreAnyTagName :: MonadThrow m-                 => [Name] -- ^ The name to match to-                 -> ConduitM Event o m (Maybe ())-ignoreAnyTagName names = ignoreTag (`elem` names)+{-# DEPRECATED ignoreTag "Please use 'ignoreEmptyTag'." #-}+ignoreTag :: MonadThrow m+          => NameMatcher a -- ^ Check if this is a correct tag name+          -> ConduitM Event o m (Maybe ())+ignoreTag = ignoreEmptyTag --- | Like 'ignoreTag', but matches all tag name.------   > ignoreAllTags = ignoreTag (const True)-{-# DEPRECATED ignoreAllTags "This function will be removed in next release." #-}-ignoreAllTags :: MonadThrow m => ConduitM Event o m (Maybe ())-ignoreAllTags = ignoreTag $ const True --- | Ignore an empty tag, its attributes and its children subtree recursively.+-- | Ignore a tag, its attributes and its children subtrees recursively. --   Both content and text events are ignored.---   This functions returns 'Just' if the tag matched.-{-# DEPRECATED ignoreTree "The signature of this function will change in next release." #-}-ignoreTree :: MonadThrow m-          => (Name -> Bool) -- ^ The predicate name to match to-          -> ConduitM Event o m (Maybe ())-ignoreTree namePred =-    tagPredicateIgnoreAttrs namePred (void $ many ignoreAllTreesContent)---- | Like 'ignoreTagName', but also ignores non-empty tabs-{-# DEPRECATED ignoreTreeName "This function will be removed in next release." #-}-ignoreTreeName :: MonadThrow m-               => Name-               -> ConduitM Event o m (Maybe ())-ignoreTreeName name = ignoreTree (== name)+--   This function returns @Just ()@ if the tag matched.+--+-- Since 1.5.0+ignoreTreeContent :: MonadThrow m+                  => NameMatcher a -- ^ Check if this is a correct tag name+                  -> ConduitM Event o m (Maybe ())+ignoreTreeContent namePred = tagIgnoreAttrs namePred (void $ many ignoreAnyTreeContent) --- | Like 'ignoreTagName', but matches any name from a list of names.-{-# DEPRECATED ignoreAnyTreeName "This function will be removed in next release." #-}-ignoreAnyTreeName :: MonadThrow m-                 => [Name] -- ^ The name to match to-                 -> ConduitM Event o m (Maybe ())-ignoreAnyTreeName names = ignoreTree (`elem` names)+{-# DEPRECATED ignoreTree "Please use 'ignoreTreeContent'." #-}+ignoreTree :: MonadThrow m+           => NameMatcher a -- ^ Check if this is a correct tag name+           -> ConduitM Event o m (Maybe ())+ignoreTree = ignoreTreeContent --- | Like 'ignoreAllTags', but ignores entire subtrees.------   > ignoreAllTrees = ignoreTree (const True)-{-# DEPRECATED ignoreAllTrees "This function will be removed in next release." #-}-ignoreAllTrees :: MonadThrow m => ConduitM Event o m (Maybe ())-ignoreAllTrees = ignoreTree $ const True+-- | Like 'ignoreTreeContent', but matches any name and also ignores content events.+ignoreAnyTreeContent :: MonadThrow m => ConduitM Event o m (Maybe ())+ignoreAnyTreeContent = (void <$> contentMaybe) `orE` ignoreTreeContent anyName --- | Like 'ignoreAllTrees', but also ignores all content events-{-# DEPRECATED ignoreAllTreesContent "This function will be renamed into @ignoreAnyTreeContent@ in next release." #-}+{-# DEPRECATED ignoreAllTreesContent "Please use 'ignoreAnyTreeContent'." #-} ignoreAllTreesContent :: MonadThrow m => ConduitM Event o m (Maybe ())-ignoreAllTreesContent = (void <$> contentMaybe) `orE` ignoreAllTrees+ignoreAllTreesContent = ignoreAnyTreeContent  -- | Get the value of the first parser which returns 'Just'. If no parsers -- succeed (i.e., return @Just@), this function returns 'Nothing'.@@ -891,7 +845,7 @@ #if MIN_VERSION_base(4, 8, 0)   displayException (XmlException msg (Just event)) = "Error while parsing XML event " ++ show event ++ ": " ++ msg   displayException (XmlException msg _) = "Error while parsing XML: " ++ msg-  displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected </" ++ TS.unpack (nameLocalName name) ++ ">, got " ++ show event+  displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected </" ++ T.unpack (nameLocalName name) ++ ">, got " ++ show event   displayException (InvalidEndElement name _) = "Error while parsing XML event: expected </" ++ show name ++ ">, got nothing"   displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ show event ++ ": " ++ msg   displayException (InvalidEntity msg _) = "Error while parsing XML entity: " ++ msg@@ -899,6 +853,48 @@   displayException (UnparsedAttributes attrs) = show (length attrs) ++ " remaining unparsed attributes: \n" ++ intercalate "\n" (show <$> attrs) #endif ++-- | A @NameMatcher@ describes which names a tag parser is allowed to match.+--+-- Since 1.5.0+newtype NameMatcher a = NameMatcher { runNameMatcher :: Name -> Maybe a }++deriving instance Functor NameMatcher++instance Applicative NameMatcher where+  pure a = NameMatcher $ const $ pure a+  NameMatcher f <*> NameMatcher a = NameMatcher $ \name -> f name <*> a name++-- | 'NameMatcher's can be combined with @\<|\>@+instance Alternative NameMatcher where+  empty = NameMatcher $ const Nothing+  NameMatcher f <|> NameMatcher g = NameMatcher (\a -> f a <|> g a)++-- | Match a single 'Name' in a concise way.+-- Note that 'Name' is namespace sensitive: when using the 'IsString' instance,+-- use @"{http:\/\/a\/b}c"@ to match the tag @c@ in the XML namespace @http://a/b@+instance (a ~ Name) => IsString (NameMatcher a) where+  fromString s = matching (== fromString s)++-- | @matching f@ matches @name@ iff @f name@ is true. Returns the matched 'Name'.+--+-- Since 1.5.0+matching :: (Name -> Bool) -> NameMatcher Name+matching f = NameMatcher $ \name -> if f name then Just name else Nothing++-- | Matches any 'Name'. Returns the matched 'Name'.+--+-- Since 1.5.0+anyName :: NameMatcher Name+anyName = matching (const True)++-- | Matches any 'Name' from the given list. Returns the matched 'Name'.+--+-- Since 1.5.0+anyOf :: [Name] -> NameMatcher Name+anyOf values = matching (`elem` values)++ -- | A monad for parsing attributes. By default, it requires you to deal with -- all attributes present on an element, and will throw an exception if there -- are unhandled attributes. Use the 'requireAttr', 'attr' et al@@ -967,32 +963,37 @@  -- | Keep parsing elements as long as the parser returns 'Just'. many :: Monad m-     => Consumer Event m (Maybe a)-     -> Consumer Event m [a]+     => ConduitM Event o m (Maybe a)+     -> ConduitM Event o m [a] many i = manyIgnore i $ return Nothing +-- | Like 'many' but discards the results without building an intermediate list.+--+-- Since 1.5.0+many_ :: MonadThrow m+      => ConduitM Event o m (Maybe a)+      -> ConduitM Event o m ()+many_ consumer = manyIgnoreYield (return Nothing) (void <$> consumer)+ -- | Keep parsing elements as long as the parser returns 'Just' --   or the ignore parser returns 'Just'. manyIgnore :: Monad m-           => Consumer Event m (Maybe a)-           -> Consumer Event m (Maybe ())-           -> Consumer Event m [a]-manyIgnore i ignored =-    go id-  where-    go front = i >>=-        maybe (onFail front) (\y -> go $ front . (:) y)-    -- onFail is called if the main parser fails-    onFail front =-        ignored >>= maybe (return $ front []) (const $ go front)+           => ConduitM Event o m (Maybe a)+           -> ConduitM Event o m (Maybe b)+           -> ConduitM Event o m [a]+manyIgnore i ignored = go id where+  go front = i >>= maybe (onFail front) (\y -> go $ front . (:) y)+  -- onFail is called if the main parser fails+  onFail front = ignored >>= maybe (return $ front []) (const $ go front)  -- | Like @many@, but any tags and content the consumer doesn't match on --   are silently ignored. many' :: MonadThrow m-      => Consumer Event m (Maybe a)-      -> Consumer Event m [a]+      => ConduitM Event o m (Maybe a)+      -> ConduitM Event o m [a] many' consumer = manyIgnore consumer ignoreAllTreesContent + -- | Like 'many', but uses 'yield' so the result list can be streamed --   to downstream conduits without waiting for 'manyYield' to finish manyYield :: Monad m@@ -1001,70 +1002,98 @@ manyYield consumer = fix $ \loop ->   consumer >>= maybe (return ()) (\x -> yield x >> loop) --- | Like @manyIgnore@, but uses 'yield' so the result list can be streamed---   to downstream conduits without waiting for 'manyYield' to finish+-- | Like 'manyIgnore', but uses 'yield' so the result list can be streamed+--   to downstream conduits without waiting for 'manyIgnoreYield' to finish manyIgnoreYield :: MonadThrow m                 => ConduitM Event b m (Maybe b) -- ^ Consuming parser that generates the result stream-                -> Consumer Event m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored+                -> ConduitM Event b m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored                 -> Conduit Event m b manyIgnoreYield consumer ignoreParser = fix $ \loop ->   consumer >>= maybe (onFail loop) (\x -> yield x >> loop)   where onFail loop = ignoreParser >>= maybe (return ()) (const loop) --- | Like @many'@, but uses 'yield' so the result list can be streamed---   to downstream conduits without waiting for 'manyYield' to finish+-- | Like 'many'', but uses 'yield' so the result list can be streamed+--   to downstream conduits without waiting for 'manyYield'' to finish manyYield' :: MonadThrow m            => ConduitM Event b m (Maybe b)            -> Conduit Event m b manyYield' consumer = manyIgnoreYield consumer ignoreAllTreesContent  --- | Like 'ignoreAllTreesContent', but stream the corresponding 'Event's rather than ignoring them.--- Incomplete elements (without a closing-tag) will trigger an 'XmlException'.+-- | Stream a content 'Event'. If next event isn't a content, nothing is consumed. ----- >>> runResourceT $ parseLBS def "text<a></a>" $$ takeAllTreesContent =$= consume--- Just [ EventContent (ContentText "text"), EventBeginElement "a" [], EventEndElement "a"]+-- Returns @Just ()@ if a content 'Event' was consumed, @Nothing@ otherwise. ----- >>> runResourceT $ parseLBS def "</a><b></b>" $$ takeAllTreesContent =$= consume--- Just [ ]+-- Since 1.5.0+takeContent :: MonadThrow m => ConduitM Event Event m (Maybe ())+takeContent = do+  event <- await+  case event of+    Just e@(EventContent ContentText{}) -> yield e >> return (Just ())+    Just e@EventCDATA{}                 -> yield e >> return (Just ())+    Just e -> if isWhitespace e then yield e >> takeContent else leftover e >> return Nothing+    _ -> return Nothing++-- | Stream 'Event's corresponding to a single element that matches given 'NameMatcher' and 'AttrParser', from the opening- to the closing-tag. ----- >>> runResourceT $ parseLBS def "<b><c></c></b></a>text" $$ takeAllTreesContent =$= consume--- Just [ EventBeginElement "b" [], EventBeginElement "c" [], EventEndElement "c", EventEndElement "b" ]+-- If next 'Event' isn't an element, nothing is consumed. ----- Since 1.4.0-{-# DEPRECATED takeAllTreesContent "This function will be removed in next release." #-}-takeAllTreesContent :: MonadThrow m => Conduit Event m Event-takeAllTreesContent = do+-- If an opening-tag is consumed but no matching closing-tag is found, an 'XmlException' is thrown.+--+-- This function automatically ignores comments, instructions and whitespace.+--+-- Returns @Just ()@ if an element was consumed, 'Nothing' otherwise.+--+-- Since 1.5.0+takeTree :: MonadThrow m => NameMatcher a -> AttrParser b -> ConduitM Event Event m (Maybe ())+takeTree nameMatcher attrParser = do   event <- await   case event of-    Just e@EventBeginDoctype{} -> do-      yield e-      takeAllTreesContent-      endEvent <- await-      case endEvent of-        Just e@EventEndDoctype -> yield e >> takeAllTreesContent-        _ -> lift $ monadThrow $ XmlException "Expected end of doctype" endEvent-    Just e@EventBeginDocument -> do-      yield e-      takeAllTreesContent-      endEvent <- await-      case endEvent of-        Just e@EventEndDocument -> yield e >> takeAllTreesContent-        _ -> lift $ monadThrow $ XmlException "Expected end of document" endEvent-    Just e@(EventBeginElement name _) -> do-      yield e-      takeAllTreesContent-      endEvent <- await-      case endEvent of-        Just e@(EventEndElement name') | name == name' -> yield e >> takeAllTreesContent-        _ -> lift $ monadThrow $ InvalidEndElement name endEvent-    Just e@EventComment{} -> yield e >> takeAllTreesContent-    Just e@EventContent{} -> yield e >> takeAllTreesContent-    Just e@EventInstruction{} -> yield e >> takeAllTreesContent-    Just e@EventCDATA{} -> yield e >> takeAllTreesContent-    Just e -> leftover e-    _ -> return ()+    Just e@(EventBeginElement name as) -> case runNameMatcher nameMatcher name of+      Just _ -> case runAttrParser attrParser as of+        Right _ -> do+          yield e+          whileJust takeAnyTreeContent+          endEvent <- await+          case endEvent of+            Just e'@(EventEndElement name') | name == name' -> yield e' >> return (Just ())+            _ -> lift $ monadThrow $ InvalidEndElement name endEvent+        _ -> leftover e >> return Nothing+      _ -> leftover e >> return Nothing +    Just e -> if isWhitespace e then yield e >> takeTree nameMatcher attrParser else leftover e >> return Nothing+    _ -> return Nothing+  where+    whileJust f = fix $ \loop -> f >>= maybe (return ()) (const loop)++-- | Like 'takeTree', but can also stream a content 'Event'.+--+-- Since 1.5.0+takeTreeContent :: MonadThrow m+                => NameMatcher a+                -> AttrParser b+                -> ConduitM Event Event m (Maybe ())+takeTreeContent nameMatcher attrParser = runMaybeT $ MaybeT (takeTree nameMatcher attrParser) <|> MaybeT takeContent++-- | Like 'takeTreeContent', without checking for tag name or attributes.+--+-- >>> runResourceT $ parseLBS def "text<a></a>" $$ takeAnyTreeContent =$= consume+-- Just [ EventContent (ContentText "text") ]+--+-- >>> runResourceT $ parseLBS def "</a><b></b>" $$ takeAnyTreeContent =$= consume+-- Just [ ]+--+-- >>> runResourceT $ parseLBS def "<b><c></c></b></a>text" $$ takeAnyTreeContent =$= consume+-- Just [ EventBeginElement "b" [], EventBeginElement "c" [], EventEndElement "c", EventEndElement "b" ]+--+-- Since 1.5.0+takeAnyTreeContent :: MonadThrow m+                => ConduitM Event Event m (Maybe ())+takeAnyTreeContent = takeTreeContent anyName ignoreAttrs++{-# DEPRECATED takeAllTreesContent "Please use 'takeAnyTreeContent'." #-}+takeAllTreesContent :: MonadThrow m => ConduitM Event Event m (Maybe ())+takeAllTreesContent = takeAnyTreeContent  type DecodeEntities = Text -> Content 

@@ -1,36 +1,37 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings  #-}  import           Control.Exception            (Exception, toException) import           Control.Monad.IO.Class       (liftIO)+import qualified Data.ByteString.Char8        as S+import qualified Data.ByteString.Lazy.Char8   as L import           Data.Typeable                (Typeable) import           Data.XML.Types-import           Test.HUnit                   hiding (Test) import           Test.Hspec-import qualified Data.ByteString.Char8        as S-import qualified Data.ByteString.Lazy.Char8   as L-import qualified Text.XML.Unresolved          as D-import qualified Text.XML.Stream.Parse        as P+import           Test.HUnit                   hiding (Test) import qualified Text.XML                     as Res import qualified Text.XML.Cursor              as Cu import           Text.XML.Stream.Parse        (def)+import qualified Text.XML.Stream.Parse        as P+import qualified Text.XML.Unresolved          as D -import Text.XML.Cursor ((&/), (&//), (&.//), ($|), ($/), ($//), ($.//))-import Data.Text(Text)-import Control.Monad-import Control.Applicative ((<$>))-import Control.Monad.Trans.Class (lift)-import qualified Data.Text as T-import qualified Data.Set as Set+import           Control.Applicative          ((<$>))+import           Control.Monad+import           Control.Monad.Trans.Class    (lift)+import qualified Data.Set                     as Set+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Text.XML.Cursor              (($.//), ($/), ($//), ($|),+                                               (&.//), (&/), (&//)) -import Data.Conduit ((=$=))-import qualified Data.Conduit as C-import Control.Monad.Trans.Resource (runResourceT)+import           Control.Monad.Trans.Resource (runResourceT) import qualified Control.Monad.Trans.Resource as C-import qualified Data.Conduit.List as CL-import qualified Data.Map as Map-import Text.Blaze (toMarkup)-import Text.Blaze.Renderer.String (renderMarkup)+import           Data.Conduit                 ((=$=))+import qualified Data.Conduit                 as C+import qualified Data.Conduit.List            as CL+import qualified Data.Map                     as Map+import           Text.Blaze                   (toMarkup)+import           Text.Blaze.Renderer.String   (renderMarkup)  main :: IO () main = hspec $ do@@ -41,7 +42,9 @@         it "has working many function" testMany         it "has working many' function" testMany'         it "has working manyYield function" testManyYield-        it "has working takeAllTreesContent function" testTakeAllTreesContent+        it "has working takeContent function" testTakeContent+        it "has working takeTree function" testTakeTree+        it "has working takeAnyTreeContent function" testTakeAnyTreeContent         it "has working orE" testOrE         it "is idempotent to parse and pretty render a document" documentParsePrettyRender         it "ignores the BOM" parseIgnoreBOM@@ -135,7 +138,7 @@  combinators :: Assertion combinators = runResourceT $ P.parseLBS def input C.$$ do-    P.force "need hello" $ P.tagName "hello" (P.requireAttr "world") $ \world -> do+    P.force "need hello" $ P.tag' "hello" (P.requireAttr "world") $ \world -> do         liftIO $ world @?= "true"         P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()         P.force "need child2" $ P.tagNoAttr "child2" $ return ()@@ -382,10 +385,51 @@         , "</hello>"         ] -testTakeAllTreesContent :: Assertion-testTakeAllTreesContent = do+testTakeContent :: Assertion+testTakeContent = do     result <- runResourceT $ P.parseLBS def input C.$$ rootParser     result @?= Just+      [ EventContent (ContentText "Hello world !")+      ]+  where+    rootParser = P.tagNoAttr "root" $ void (P.takeContent >> P.takeContent) =$= CL.consume+    input = L.concat+        [ "<?xml version='1.0'?>"+        , "<!DOCTYPE foo []>\n"+        , "<root>"+        , "Hello world !"+        , "</root>"+        ]++testTakeTree :: Assertion+testTakeTree = do+    result <- runResourceT $ P.parseLBS def input C.$$ rootParser+    result @?=+      [ EventBeginDocument+      , EventBeginDoctype "foo" Nothing+      , EventEndDoctype+      , EventBeginElement "a" []+      , EventBeginElement "em" []+      , EventContent (ContentText "Hello world !")+      , EventEndElement "em"+      , EventEndElement "a"+      ]+  where+    rootParser = void (P.takeTree "a" P.ignoreAttrs) =$= CL.consume+    input = L.concat+        [ "<?xml version='1.0'?>"+        , "<!DOCTYPE foo []>\n"+        , "<a>"+        , "<em>Hello world !</em>"+        , "</a>"+        , "<b>"+        , "</b>"+        ]++testTakeAnyTreeContent :: Assertion+testTakeAnyTreeContent = do+    result <- runResourceT $ P.parseLBS def input C.$$ rootParser+    result @?= Just       [ EventBeginElement "b" []       , EventContent (ContentText "Hello ")       , EventBeginElement "em" []@@ -393,10 +437,9 @@       , EventEndElement "em"       , EventContent (ContentText " !")       , EventEndElement "b"-      , EventContent (ContentText " Welcome !")       ]   where-    rootParser = P.tagNoAttr "root" $ P.takeAllTreesContent =$= CL.consume+    rootParser = P.tagNoAttr "root" $ (P.takeAnyTreeContent >> void P.ignoreAnyTreeContent) =$= CL.consume     input = L.concat         [ "<?xml version='1.0'?>"         , "<!DOCTYPE foo []>\n"@@ -449,13 +492,17 @@     P.force "need hello" $ P.tagNoAttr "hello" $ do         x <- P.tagNoAttr "failure" (return 1) `P.orE`              P.tagNoAttr "success" (return 2)+        y <- P.tag' "success" (P.requireAttr "failure") (const $ return 1) `P.orE`+             P.tag' "success" (P.requireAttr "success") (const $ return 2)         liftIO $ x @?= Just (2 :: Int)+        liftIO $ y @?= Just (2 :: Int)   where     input = L.concat         [ "<?xml version='1.0'?>"         , "<!DOCTYPE foo []>\n"         , "<hello>"         , "<success/>"+        , "<success success=\"0\"/>"         , "</hello>"         ] @@ -760,7 +807,7 @@         rs = def { Res.rsAttrOrder = \name m ->                         case name of                             "foo" -> reverse $ Map.toAscList m-                            _ -> Map.toAscList m+                            _     -> Map.toAscList m                  }         attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")]         doc = Res.Document (Res.Prologue [] Nothing [])

@@ -1,5 +1,5 @@ name:            xml-conduit-version:         1.4.0.4+version:         1.5.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>