Hello community, here is the log from the commit of package ghc-xml-conduit for openSUSE:Factory checked in at 2017-08-31 21:02:01 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-xml-conduit (Old) and /work/SRC/openSUSE:Factory/.ghc-xml-conduit.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-xml-conduit" Thu Aug 31 21:02:01 2017 rev:12 rq:513545 version:1.5.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-xml-conduit/ghc-xml-conduit.changes 2017-03-03 17:52:46.271322152 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-xml-conduit.new/ghc-xml-conduit.changes 2017-08-31 21:02:04.524107249 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:43 UTC 2017 - [email protected] + +- Update to version 1.5.1. + +------------------------------------------------------------------- Old: ---- xml-conduit-1.4.0.4.tar.gz New: ---- xml-conduit-1.5.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-xml-conduit.spec ++++++ --- /var/tmp/diff_new_pack.g1jony/_old 2017-08-31 21:02:05.611954404 +0200 +++ /var/tmp/diff_new_pack.g1jony/_new 2017-08-31 21:02:05.639950470 +0200 @@ -19,7 +19,7 @@ %global pkg_name xml-conduit %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.4.0.4 +Version: 1.5.1 Release: 0 Summary: Pure-Haskell utilities for dealing with XML with the conduit package License: MIT ++++++ xml-conduit-1.4.0.4.tar.gz -> xml-conduit-1.5.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/ChangeLog.md new/xml-conduit-1.5.1/ChangeLog.md --- old/xml-conduit-1.4.0.4/ChangeLog.md 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/ChangeLog.md 2017-05-21 00:05:14.000000000 +0200 @@ -1,3 +1,17 @@ +## 1.5.1 + +* New render setting, `rsXMLDeclaration`; setting it to `False` omits the XML declaration. + +## 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/Text/XML/Stream/Parse.hs new/xml-conduit-1.5.1/Text/XML/Stream/Parse.hs --- old/xml-conduit-1.4.0.4/Text/XML/Stream/Parse.hs 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/Text/XML/Stream/Parse.hs 2017-05-21 00:05:14.000000000 +0200 @@ -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. @@ -29,10 +34,12 @@ -- > data Person = Person Int Text -- > deriving Show -- > --- > parsePerson = tagName "person" (requireAttr "age") $ \age -> do +-- > parsePerson :: MonadThrow m => Consumer Event m (Maybe Person) +-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do -- > name <- content -- > return $ Person (read $ unpack age) name -- > +-- > parsePeople :: MonadThrow m => Sink Event m (Maybe [Person]) -- > parsePeople = tagNoAttr "people" $ many parsePerson -- > -- > main = do @@ -42,7 +49,7 @@ -- -- will produce: -- --- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}] +-- > [Person 25 "Michael",Person 2 "Eliezer"] -- -- This module also supports streaming results using 'yield'. -- This allows parser results to be processed using conduits @@ -53,21 +60,23 @@ -- See http://stackoverflow.com/q/21367423/2597135 for a related discussion. -- -- > {-# LANGUAGE OverloadedStrings #-} +-- > import Control.Monad (void) +-- > import Control.Monad.Trans.Class (lift) -- > import Control.Monad.Trans.Resource -- > import Data.Conduit +-- > import qualified Data.Conduit.List as CL -- > import Data.Text (Text, unpack) +-- > import Data.XML.Types (Event) -- > import Text.XML.Stream.Parse --- > import Text.XML (Name) --- > import Control.Monad.Trans.Class (lift) --- > import Control.Monad (void) --- > import qualified Data.Conduit.List as CL -- > -- > data Person = Person Int Text deriving Show -- > --- > parsePerson = tagName "person" (requireAttr "age") $ \age -> do +-- > parsePerson :: MonadThrow m => Consumer Event m (Maybe Person) +-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do -- > name <- content -- > return $ Person (read $ unpack age) name -- > +-- > parsePeople :: MonadThrow m => Conduit Event m Person -- > parsePeople = void $ tagNoAttr "people" $ manyYield parsePerson -- > -- > main = runResourceT $ @@ -98,23 +107,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,70 +142,69 @@ , 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 type Ents = [(Text, Text)] tokenToEvent :: ParseSettings -> Ents -> [NSLevel] -> Token -> (Ents, [NSLevel], [Event]) -tokenToEvent _ es n (TokenBeginDocument _) = (es, n, []) +tokenToEvent _ es n (TokenXMLDeclaration _) = (es, n, []) tokenToEvent _ es n (TokenInstruction i) = (es, n, [EventInstruction i]) tokenToEvent ps es n (TokenBeginElement name as isClosed _) = (es, n', if isClosed then [begin, end] else [begin]) @@ -259,7 +273,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 +309,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 @@ -304,7 +318,7 @@ case parser $ decodeUtf8With lenientDecode nextChunk of AT.Fail{} -> fallback AT.Partial f -> await >>= maybe fallback (loop chunks f) - AT.Done _ (TokenBeginDocument attrs) -> findEncoding attrs + AT.Done _ (TokenXMLDeclaration attrs) -> findEncoding attrs AT.Done{} -> fallback where chunks = nextChunk : chunks0 @@ -313,7 +327,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 +353,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 +376,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 +390,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 +434,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 @@ -440,7 +454,7 @@ char' '?' char' '>' newline <|> return () - return $ TokenBeginDocument as + return $ TokenXMLDeclaration as else do skipSpace x <- T.pack <$> manyTill anyChar (try $ string "?>") @@ -559,22 +573,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 +608,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 +648,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 - - 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 () + -- 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 () - 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 +724,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." #-} +-- 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 ()) +ignoreEmptyTag nameMatcher = tagIgnoreAttrs nameMatcher (return ()) + + +{-# DEPRECATED ignoreTag "Please use 'ignoreEmptyTag'." #-} ignoreTag :: MonadThrow m - => (Name -> Bool) -- ^ The predicate name to match to + => NameMatcher a -- ^ Check if this is a correct tag name -> ConduitM Event o m (Maybe ()) -ignoreTag namePred = tagPredicateIgnoreAttrs namePred (return ()) +ignoreTag = ignoreEmptyTag --- | 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) - --- | 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) +-- 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 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) - --- | 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) - --- | 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 +{-# 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 '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 +849,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 +857,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 +967,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 +1006,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. +-- +-- 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. -- --- Since 1.4.0 -{-# DEPRECATED takeAllTreesContent "This function will be removed in next release." #-} -takeAllTreesContent :: MonadThrow m => Conduit Event m Event -takeAllTreesContent = do +-- 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/Text/XML/Stream/Render.hs new/xml-conduit-1.5.1/Text/XML/Stream/Render.hs --- old/xml-conduit-1.4.0.4/Text/XML/Stream/Render.hs 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/Text/XML/Stream/Render.hs 2017-05-21 00:05:14.000000000 +0200 @@ -18,6 +18,7 @@ , rsNamespaces , rsAttrOrder , rsUseCDATA + , rsXMLDeclaration , orderAttrs -- * Event rendering , tag @@ -83,6 +84,12 @@ -- Default: @False@ -- -- @since 1.3.3 + , rsXMLDeclaration :: Bool + -- ^ Determines whether the XML declaration will be output. + -- + -- Default: @True@ + -- + -- @since 1.5.1 } instance Default RenderSettings where @@ -91,6 +98,7 @@ , rsNamespaces = [] , rsAttrOrder = const Map.toList , rsUseCDATA = const False + , rsXMLDeclaration = True } -- | Convenience function to create an ordering function suitable for @@ -139,7 +147,7 @@ renderEvent' = renderEvent yield' settings renderEvent :: Monad m => (Flush Builder -> Producer m o) -> RenderSettings -> Conduit (Flush Event) m o -renderEvent yield' RenderSettings { rsPretty = isPretty, rsNamespaces = namespaces0, rsUseCDATA = useCDATA } = +renderEvent yield' RenderSettings { rsPretty = isPretty, rsNamespaces = namespaces0, rsUseCDATA = useCDATA, rsXMLDeclaration = useXMLDecl } = loop [] where loop nslevels = await >>= maybe (return ()) (go nslevels) @@ -159,34 +167,35 @@ yield' $ Chunk token loop nslevels' _ -> do - let (token, nslevels') = eventToToken nslevels useCDATA e + let (token, nslevels') = eventToToken nslevels useCDATA useXMLDecl e yield' $ Chunk token loop nslevels' -eventToToken :: Stack -> (Content -> Bool) -> Event -> (Builder, [NSLevel]) -eventToToken s _ EventBeginDocument = - (tokenToBuilder $ TokenBeginDocument +eventToToken :: Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, [NSLevel]) +eventToToken s _ True EventBeginDocument = + (tokenToBuilder $ TokenXMLDeclaration [ ("version", [ContentText "1.0"]) , ("encoding", [ContentText "UTF-8"]) ] , s) -eventToToken s _ EventEndDocument = (mempty, s) -eventToToken s _ (EventInstruction i) = (tokenToBuilder $ TokenInstruction i, s) -eventToToken s _ (EventBeginDoctype n meid) = (tokenToBuilder $ TokenDoctype n meid [], s) -eventToToken s _ EventEndDoctype = (mempty, s) -eventToToken s _ (EventCDATA t) = (tokenToBuilder $ TokenCDATA t, s) -eventToToken s _ (EventEndElement name) = +eventToToken s _ False EventBeginDocument = (mempty, s) +eventToToken s _ _ EventEndDocument = (mempty, s) +eventToToken s _ _ (EventInstruction i) = (tokenToBuilder $ TokenInstruction i, s) +eventToToken s _ _ (EventBeginDoctype n meid) = (tokenToBuilder $ TokenDoctype n meid [], s) +eventToToken s _ _ EventEndDoctype = (mempty, s) +eventToToken s _ _ (EventCDATA t) = (tokenToBuilder $ TokenCDATA t, s) +eventToToken s _ _ (EventEndElement name) = (tokenToBuilder $ TokenEndElement $ nameToTName sl name, s') where (sl:s') = s -eventToToken s useCDATA (EventContent c) +eventToToken s useCDATA _ (EventContent c) | useCDATA c = case c of ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) ContentEntity txt -> (tokenToBuilder $ TokenCDATA txt, s) | otherwise = (tokenToBuilder $ TokenContent c, s) -eventToToken s _ (EventComment t) = (tokenToBuilder $ TokenComment t, s) -eventToToken _ _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs +eventToToken s _ _ (EventComment t) = (tokenToBuilder $ TokenComment t, s) +eventToToken _ _ _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs type Stack = [NSLevel] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/Text/XML/Stream/Token.hs new/xml-conduit-1.5.1/Text/XML/Stream/Token.hs --- old/xml-conduit-1.4.0.4/Text/XML/Stream/Token.hs 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/Text/XML/Stream/Token.hs 2017-05-21 00:05:14.000000000 +0200 @@ -27,7 +27,7 @@ oneSpace :: Builder oneSpace = copyByteString " " -data Token = TokenBeginDocument [TAttribute] +data Token = TokenXMLDeclaration [TAttribute] | TokenInstruction Instruction | TokenBeginElement TName [TAttribute] Bool Int -- ^ indent | TokenEndElement TName @@ -37,7 +37,7 @@ | TokenCDATA Text deriving Show tokenToBuilder :: Token -> Builder -tokenToBuilder (TokenBeginDocument attrs) = +tokenToBuilder (TokenXMLDeclaration attrs) = fromByteString "<?xml" `mappend` foldAttrs oneSpace attrs (fromByteString "?>") tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/Text/XML.hs new/xml-conduit-1.5.1/Text/XML.hs --- old/xml-conduit-1.4.0.4/Text/XML.hs 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/Text/XML.hs 2017-05-21 00:05:14.000000000 +0200 @@ -63,6 +63,7 @@ , R.rsNamespaces , R.rsAttrOrder , R.rsUseCDATA + , R.rsXMLDeclaration , R.orderAttrs -- * Conversion , toXMLDocument diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/test/main.hs new/xml-conduit-1.5.1/test/main.hs --- old/xml-conduit-1.4.0.4/test/main.hs 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/test/main.hs 2017-05-21 00:05:14.000000000 +0200 @@ -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 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 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 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,13 +42,16 @@ 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 it "strips duplicated attributes" stripDuplicateAttributes it "displays comments" testRenderComments it "conduit parser" testConduitParser + it "can omit the XML declaration" omitXMLDeclaration describe "XML Cursors" $ do it "has correct parent" cursorParent it "has correct ancestor" cursorAncestor @@ -135,7 +139,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,8 +386,49 @@ , "</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" [] @@ -393,10 +438,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 +493,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>" ] @@ -480,6 +528,14 @@ ma <- P.tagNoAttr "item" (return 1) maybe (return ()) (\a -> C.yield a >> f) ma +omitXMLDeclaration :: Assertion +omitXMLDeclaration = Res.renderLBS settings input @?= spec + where + settings = def { Res.rsXMLDeclaration = False } + input = Res.Document (Prologue [] Nothing []) + (Res.Element "foo" Map.empty [Res.NodeContent "bar"]) + [] + spec = "<foo>bar</foo>" name :: [Cu.Cursor] -> [Text] name [] = [] @@ -760,7 +816,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 []) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.4.0.4/xml-conduit.cabal new/xml-conduit-1.5.1/xml-conduit.cabal --- old/xml-conduit-1.4.0.4/xml-conduit.cabal 2017-02-13 20:32:23.000000000 +0100 +++ new/xml-conduit-1.5.1/xml-conduit.cabal 2017-05-21 00:05:14.000000000 +0200 @@ -1,5 +1,5 @@ name: xml-conduit -version: 1.4.0.4 +version: 1.5.1 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]>, Aristid Breitkreuz <[email protected]>
