Hello community, here is the log from the commit of package ghc-xml-conduit for openSUSE:Factory checked in at 2017-03-03 17:52:45 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-xml-conduit (Old) and /work/SRC/openSUSE:Factory/.ghc-xml-conduit.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-xml-conduit" Fri Mar 3 17:52:45 2017 rev:11 rq:461701 version:1.4.0.4 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-xml-conduit/ghc-xml-conduit.changes 2016-07-27 16:11:31.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-xml-conduit.new/ghc-xml-conduit.changes 2017-03-03 17:52:46.271322152 +0100 @@ -1,0 +2,10 @@ +Mon Feb 20 08:41:07 UTC 2017 - [email protected] + +- Update to version 1.4.0.4 with cabal2obs. + +------------------------------------------------------------------- +Sun Feb 12 14:15:41 UTC 2017 - [email protected] + +- Update to version 1.4.0.3 with cabal2obs. + +------------------------------------------------------------------- Old: ---- xml-conduit-1.3.5.tar.gz New: ---- xml-conduit-1.4.0.4.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-xml-conduit.spec ++++++ --- /var/tmp/diff_new_pack.M6iLbp/_old 2017-03-03 17:52:46.779250411 +0100 +++ /var/tmp/diff_new_pack.M6iLbp/_new 2017-03-03 17:52:46.783249846 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-xml-conduit # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,15 +19,14 @@ %global pkg_name xml-conduit %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.3.5 +Version: 1.4.0.4 Release: 0 Summary: Pure-Haskell utilities for dealing with XML with the conduit package License: MIT -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-attoparsec-devel BuildRequires: ghc-blaze-builder-devel BuildRequires: ghc-blaze-html-devel @@ -49,7 +48,6 @@ BuildRequires: ghc-HUnit-devel BuildRequires: ghc-hspec-devel %endif -# End cabal-rpm deps %description Hackage documentation generation is not reliable. For up to date documentation, @@ -69,20 +67,14 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache ++++++ xml-conduit-1.3.5.tar.gz -> xml-conduit-1.4.0.4.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/ChangeLog.md new/xml-conduit-1.4.0.4/ChangeLog.md --- old/xml-conduit-1.3.5/ChangeLog.md 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/ChangeLog.md 2017-02-13 20:32:23.000000000 +0100 @@ -1,3 +1,21 @@ +## 1.4.0.3 + +* Compatibility with blaze-markup-0.8.0.0 [#95](https://github.com/snoyberg/xml/issues/95) + +## 1.4.0.2 + +* Parse XML encoding case-insensitively +* Remove extra EOL when printing XmlException + +## 1.4.0.1 + +* Handle CDATA in takeAllTreesContent [#88](https://github.com/snoyberg/xml/pull/88) + +## 1.4.0 + +* Improve XmlException definition and usage +* Add 'takeAllTreesContent' function + ## 1.3.5 * Improvements for using xml-conduit for streaming XML protocols [#85](https://github.com/snoyberg/xml/pull/85) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/Text/XML/Cursor.hs new/xml-conduit-1.4.0.4/Text/XML/Cursor.hs --- old/xml-conduit-1.3.5/Text/XML/Cursor.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/Text/XML/Cursor.hs 2017-02-13 20:32:23.000000000 +0100 @@ -60,33 +60,34 @@ import Control.Exception (Exception) import Control.Monad -import Data.Function (on) -import Text.XML import Control.Monad.Trans.Resource (MonadThrow, monadThrow) -import qualified Data.Text as T +import Data.Function (on) import qualified Data.Map as Map -import qualified Text.XML.Cursor.Generic as CG -import Text.XML.Cursor.Generic (node, child, parent, descendant, orSelf) import Data.Maybe (maybeToList) +import qualified Data.Text as T +import Text.XML +import Text.XML.Cursor.Generic (child, descendant, node, orSelf, + parent) +import qualified Text.XML.Cursor.Generic as CG -- TODO: Consider [Cursor] -> [Cursor]? -- | The type of an Axis that returns a list of Cursors. -- They are roughly modeled after <http://www.w3.org/TR/xpath/#axes>. --- +-- -- Axes can be composed with '>=>', where e.g. @f >=> g@ means that on all results of --- the @f@ axis, the @g@ axis will be applied, and all results joined together. +-- the @f@ axis, the @g@ axis will be applied, and all results joined together. -- Because Axis is just a type synonym for @Cursor -> [Cursor]@, it is possible to use -- other standard functions like '>>=' or 'concatMap' similarly. --- +-- -- The operators '&|', '&/', '&//' and '&.//' can be used to combine axes so that the second --- axis works on the context nodes, children, descendants, respectively the context node as +-- axis works on the context nodes, children, descendants, respectively the context node as -- well as its descendants of the results of the first axis. --- +-- -- The operators '$|', '$/', '$//' and '$.//' can be used to apply an axis (right-hand side) -- to a cursor so that it is applied on the cursor itself, its children, its descendants, -- respectively itself and its descendants. --- --- Note that many of these operators also work on /generalised Axes/ that can return +-- +-- Note that many of these operators also work on /generalised Axes/ that can return -- lists of something other than Cursors, for example Content elements. type Axis = Cursor -> [Cursor] @@ -97,11 +98,11 @@ class Boolean a where bool :: a -> Bool -instance Boolean Bool where +instance Boolean Bool where bool = id -instance Boolean [a] where +instance Boolean [a] where bool = not . null -instance Boolean (Maybe a) where +instance Boolean (Maybe a) where bool (Just _) = True bool _ = False instance Boolean (Either a b) where @@ -125,29 +126,25 @@ CG.toCursor cs where cs (NodeElement (Element _ _ x)) = x - cs _ = [] + cs _ = [] -- | Filter cursors that don't pass a check. check :: Boolean b => (Cursor -> b) -> Axis -check f c = case bool $ f c of - False -> [] - True -> [c] +check f c = [c | bool $ f c] -- | Filter nodes that don't pass a check. checkNode :: Boolean b => (Node -> b) -> Axis -checkNode f c = check (f . node) c +checkNode f = check (f . node) -- | Filter elements that don't pass a check, and remove all non-elements. checkElement :: Boolean b => (Element -> b) -> Axis checkElement f c = case node c of - NodeElement e -> case bool $ f e of - True -> [c] - False -> [] + NodeElement e -> [c | bool $ f e] _ -> [] -- | Filter elements that don't pass a name check, and remove all non-elements. checkName :: Boolean b => (Name -> b) -> Axis -checkName f c = checkElement (f . elementName) c +checkName f = checkElement (f . elementName) -- | Remove all non-elements. Compare roughly to XPath: -- /A node test * is true for any node of the principal node type. For example, child::* will select all element children of the context node [...]/. @@ -166,7 +163,7 @@ -- | Select only text nodes, and directly give the 'Content' values. XPath: -- /The node test text() is true for any text node./ --- +-- -- Note that this is not strictly an 'Axis', but will work with most combinators. content :: Cursor -> [T.Text] content c = case node c of @@ -175,23 +172,23 @@ -- | Select attributes on the current element (or nothing if it is not an element). XPath: -- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/ --- +-- -- Note that this is not strictly an 'Axis', but will work with most combinators. --- --- The return list of the generalised axis contains as elements lists of 'Content' +-- +-- The return list of the generalised axis contains as elements lists of 'Content' -- elements, each full list representing an attribute value. attribute :: Name -> Cursor -> [T.Text] attribute n c = case node c of NodeElement e -> maybeToList $ Map.lookup n $ elementAttributes e - _ -> [] + _ -> [] -- | Select attributes on the current element (or nothing if it is not an element). Namespace and case are ignored. XPath: -- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/ --- +-- -- Note that this is not strictly an 'Axis', but will work with most combinators. --- --- The return list of the generalised axis contains as elements lists of 'Content' +-- +-- The return list of the generalised axis contains as elements lists of 'Content' -- elements, each full list representing an attribute value. laxAttribute :: T.Text -> Cursor -> [T.Text] laxAttribute n c = @@ -213,13 +210,13 @@ attributeIs :: Name -> T.Text -> Axis attributeIs n v c = case node c of - NodeElement (Element _ as _) -> if Just v == Map.lookup n as then [c] else [] - _ -> [] + NodeElement (Element _ as _) -> [ c | Just v == Map.lookup n as] + _ -> [] force :: (Exception e, MonadThrow f) => e -> [a] -> f a -force e [] = monadThrow e +force e [] = monadThrow e force _ (x:_) = return x forceM :: (Exception e, MonadThrow f) => e -> [f a] -> f a -forceM e [] = monadThrow e +forceM e [] = monadThrow e forceM _ (x:_) = x diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/Text/XML/Stream/Parse.hs new/xml-conduit-1.4.0.4/Text/XML/Stream/Parse.hs --- old/xml-conduit-1.3.5/Text/XML/Stream/Parse.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/Text/XML/Stream/Parse.hs 2017-02-13 20:32:23.000000000 +0100 @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} -- | 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. @@ -132,6 +134,7 @@ , manyYield , manyIgnoreYield , manyYield' + , takeAllTreesContent -- * Exceptions , XmlException (..) -- * Other types @@ -139,6 +142,8 @@ , EventPos ) where import qualified Control.Applicative as A +import Control.Applicative ((<$>)) +import Control.Monad.Fix (fix) import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), monadThrow) import Data.Attoparsec.Text (Parser, anyChar, char, manyTill, @@ -146,6 +151,7 @@ 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 (..)) @@ -172,7 +178,8 @@ 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 (decodeUtf32BEWith, + decodeUtf8With) import Data.Text.Encoding.Error (ignore, lenientDecode) import Data.Text.Read (Reader, decimal, hexadecimal) import Data.Typeable (Typeable) @@ -189,7 +196,7 @@ (es, n', if isClosed then [begin, end] else [begin]) where l0 = case n of - [] -> NSLevel Nothing Map.empty + [] -> NSLevel Nothing Map.empty x:_ -> x (as', l') = foldl' go (id, l0) as go (front, l) (TName kpref kname, val) = @@ -229,7 +236,7 @@ where (l, n') = case n of - [] -> (NSLevel Nothing Map.empty, []) + [] -> (NSLevel Nothing Map.empty, []) x:xs -> (x, xs) tokenToEvent _ es n (TokenContent (ContentEntity e)) | Just t <- lookup e es = (es, n, [EventContent $ ContentText t]) @@ -274,15 +281,15 @@ (x, y) = S.splitAt 4 bs (toDrop, mcodec) = case S.unpack x of - [0x00, 0x00, 0xFE, 0xFF] -> (4, Just $ CT.utf32_be) - [0xFF, 0xFE, 0x00, 0x00] -> (4, Just $ CT.utf32_le) - 0xFE : 0xFF: _ -> (2, Just $ CT.utf16_be) - 0xFF : 0xFE: _ -> (2, Just $ CT.utf16_le) - 0xEF : 0xBB: 0xBF : _ -> (3, Just $ CT.utf8) - [0x00, 0x00, 0x00, 0x3C] -> (0, Just $ CT.utf32_be) - [0x3C, 0x00, 0x00, 0x00] -> (0, Just $ CT.utf32_le) - [0x00, 0x3C, 0x00, 0x3F] -> (0, Just $ CT.utf16_be) - [0x3C, 0x00, 0x3F, 0x00] -> (0, Just $ CT.utf16_le) + [0x00, 0x00, 0xFE, 0xFF] -> (4, Just CT.utf32_be) + [0xFF, 0xFE, 0x00, 0x00] -> (4, Just CT.utf32_le) + 0xFE : 0xFF: _ -> (2, Just CT.utf16_be) + 0xFF : 0xFE: _ -> (2, Just CT.utf16_le) + 0xEF : 0xBB: 0xBF : _ -> (3, Just CT.utf8) + [0x00, 0x00, 0x00, 0x3C] -> (0, Just CT.utf32_be) + [0x3C, 0x00, 0x00, 0x00] -> (0, Just CT.utf32_le) + [0x00, 0x3C, 0x00, 0x3F] -> (0, Just CT.utf16_be) + [0x3C, 0x00, 0x3F, 0x00] -> (0, Just CT.utf16_le) _ -> (0, Nothing) -- Assuming UTF-8 checkXMLDecl :: MonadThrow m @@ -295,10 +302,10 @@ where loop chunks0 parser nextChunk = case parser $ decodeUtf8With lenientDecode nextChunk of - AT.Fail _ _ _ -> fallback + AT.Fail{} -> fallback AT.Partial f -> await >>= maybe fallback (loop chunks f) AT.Done _ (TokenBeginDocument attrs) -> findEncoding attrs - AT.Done _ _ -> fallback + AT.Done{} -> fallback where chunks = nextChunk : chunks0 fallback = complete CT.utf8 @@ -306,10 +313,10 @@ findEncoding [] = fallback findEncoding ((TName _ "encoding", [ContentText enc]):_) = - case enc of + case TS.toLower enc of "iso-8859-1" -> complete CT.iso8859_1 - "utf-8" -> complete CT.utf8 - _ -> complete CT.utf8 + "utf-8" -> complete CT.utf8 + _ -> complete CT.utf8 findEncoding (_:xs) = findEncoding xs type EventPos = (Maybe PositionRange, Event) @@ -395,7 +402,7 @@ (es', levels', events) = tokenToEvent ps es levels token data ParseSettings = ParseSettings - { psDecodeEntities :: DecodeEntities + { psDecodeEntities :: DecodeEntities , psRetainNamespaces :: Bool -- ^ Whether the original xmlns attributes should be retained in the parsed -- values. For more information on motivation, see: @@ -442,7 +449,7 @@ char' '-' char' '-' c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead - return $ TokenComment c + return $ TokenComment c parseCdata = do _ <- string "[CDATA[" t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead @@ -453,7 +460,7 @@ name <- parseName let i = case name of - TName Nothing x -> x + TName Nothing x -> x TName (Just x) y -> T.concat [x, ":", y] skipSpace eid <- fmap Just parsePublicID <|> @@ -530,23 +537,23 @@ parseName = name <$> parseIdent <*> A.optional (char ':' >> parseIdent) where - name i1 Nothing = TName Nothing i1 + name i1 Nothing = TName Nothing i1 name i1 (Just i2) = TName (Just i1) i2 parseIdent :: Parser Text parseIdent = takeWhile1 valid where - valid '&' = False - valid '<' = False - valid '>' = False - valid ':' = False - valid '?' = False - valid '=' = False - valid '"' = False + valid '&' = False + valid '<' = False + valid '>' = False + valid ':' = False + valid '?' = False + valid '=' = False + valid '"' = False valid '\'' = False - valid '/' = False - valid c = not $ isXMLSpace c + valid '/' = False + valid c = not $ isXMLSpace c parseContent :: DecodeEntities -> Bool -- break on double quote @@ -563,11 +570,11 @@ parseText' = do bs <- takeWhile1 valid return $ ContentText bs - valid '"' = not breakDouble + valid '"' = not breakDouble valid '\'' = not breakSingle - valid '&' = False -- amp - valid '<' = False -- lt - valid _ = True + valid '&' = False -- amp + valid '<' = False -- lt + valid _ = True skipSpace :: Parser () skipSpace = skipWhile isXMLSpace @@ -579,14 +586,14 @@ -- -- in <http://www.w3.org/TR/2008/REC-xml-20081126/#sec-common-syn>. isXMLSpace :: Char -> Bool -isXMLSpace ' ' = True +isXMLSpace ' ' = True isXMLSpace '\t' = True isXMLSpace '\r' = True isXMLSpace '\n' = True -isXMLSpace _ = False +isXMLSpace _ = False newline :: Parser () -newline = ((char '\r' >> char '\n') <|> char '\n') >> return () +newline = void $ (char '\r' >> char '\n') <|> char '\n' char' :: Char -> Parser () char' = void . char @@ -601,12 +608,12 @@ contentMaybe = do x <- CL.peek case pc' x of - Ignore -> CL.drop 1 >> contentMaybe + Ignore -> CL.drop 1 >> contentMaybe IsContent t -> CL.drop 1 >> fmap Just (takeContents (t:)) - IsError e -> lift $ monadThrow $ XmlException e x - NotContent -> return Nothing + IsError e -> lift $ monadThrow $ InvalidEntity e x + NotContent -> return Nothing where - pc' Nothing = NotContent + pc' Nothing = NotContent pc' (Just x) = pc x pc (EventContent (ContentText t)) = IsContent t pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e @@ -622,10 +629,10 @@ takeContents front = do x <- CL.peek case pc' x of - Ignore -> CL.drop 1 >> takeContents front + Ignore -> CL.drop 1 >> takeContents front IsContent t -> CL.drop 1 >> takeContents (front . (:) t) - IsError e -> lift $ monadThrow $ XmlException e x - NotContent -> return $ T.concat $ front [] + IsError e -> lift $ monadThrow $ InvalidEntity e x + NotContent -> return $ T.concat $ front [] -- | Grabs the next piece of content. If none if available, returns 'T.empty'. -- This is simply a wrapper around 'contentMaybe'. @@ -636,11 +643,14 @@ -- this is the correct tag name, an 'AttrParser' for handling attributes, and -- then a parser for dealing with content. -- +-- 'Events' are consumed if and only if the predicate holds. +-- -- 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@. @@ -664,7 +674,7 @@ case a of Just (EventEndElement name') | name == name' -> return (Just z') - _ -> lift $ monadThrow $ XmlException ("Expected end tag for: " ++ show name) a + _ -> lift $ monadThrow $ InvalidEndElement name a Nothing -> return Nothing _ -> return Nothing @@ -674,42 +684,37 @@ Nothing -> mapM_ leftover leftovers -- Parse succeeded, discard all of those whitespace events and the -- first parsed event - Just _ -> return () + Just _ -> return () 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 dropWS leftovers = do x <- await - let isWS = - case x of - Just EventBeginDocument -> True - Just EventEndDocument -> True - Just EventBeginDoctype{} -> True - Just EventEndDoctype -> True - Just EventInstruction{} -> True - Just EventBeginElement{} -> False - Just EventEndElement{} -> False - Just (EventContent (ContentText t)) - | T.all isSpace t -> True - | otherwise -> False - Just (EventContent ContentEntity{}) -> False - Just EventComment{} -> True - Just EventCDATA{} -> False - Nothing -> False - leftovers' = maybe id (:) x leftovers - if isWS - then dropWS leftovers' - else return (x, leftovers') + let leftovers' = maybe id (:) x leftovers + + case isWhitespace <$> x of + Just True -> dropWS leftovers' + _ -> return (x, leftovers') runAttrParser' p as = case runAttrParser p as of - Left e -> Left e - Right ([], x) -> Right x + Left e -> Left e + 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 @@ -727,15 +732,17 @@ -- 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 + -> 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 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 @@ -744,6 +751,7 @@ -- | 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 @@ -751,6 +759,7 @@ tagIgnoreAttrs name f = tagName 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 @@ -761,18 +770,21 @@ -- 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 -> ConduitM Event o m (Maybe ()) ignoreTag namePred = tagPredicateIgnoreAttrs namePred (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 ()) @@ -781,25 +793,29 @@ -- | 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. -- 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 (const () <$> many ignoreAllTreesContent) + 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) -- | 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 ()) @@ -808,10 +824,12 @@ -- | 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 'ignoreAllTrees', but also ignores all content events +{-# DEPRECATED ignoreAllTreesContent "This function will be renamed into @ignoreAnyTreeContent@ in next release." #-} ignoreAllTreesContent :: MonadThrow m => ConduitM Event o m (Maybe ()) ignoreAllTreesContent = (void <$> contentMaybe) `orE` ignoreAllTrees @@ -822,9 +840,8 @@ orE :: Monad m => Consumer Event m (Maybe a) -- ^ The first (preferred) parser -> Consumer Event m (Maybe a) -- ^ The second parser, only executed if the first parser fails - -> Consumer Event m (Maybe a) -orE a b = - a >>= \x -> maybe b (const $ return x) x + -> Consumer Event m (Maybe a) +orE a b = a >>= \x -> maybe b (const $ return x) x -- | Get the value of the first parser which returns 'Just'. If no parsers -- succeed (i.e., return 'Just'), this function returns 'Nothing'. @@ -832,9 +849,8 @@ => [ConduitM Event o m (Maybe a)] -- ^ List of parsers that will be tried in order. -> ConduitM Event o m (Maybe a) -- ^ Result of the first parser to succeed, or @Nothing@ -- if no parser succeeded -choose [] = return Nothing -choose (i:is) = - i >>= maybe (choose is) (return . Just) +choose [] = return Nothing +choose (i:is) = i >>= maybe (choose is) (return . Just) -- | Force an optional parser into a required parser. All of the 'tag' -- functions, 'attr', 'choose' and 'many' deal with 'Maybe' parsers. Use this when you @@ -863,21 +879,33 @@ data XmlException = XmlException { xmlErrorMessage :: String - , xmlBadInput :: Maybe Event + , xmlBadInput :: Maybe Event } - | InvalidEndElement Name - | InvalidEntity Text + | InvalidEndElement Name (Maybe Event) + | InvalidEntity String (Maybe Event) + | MissingAttribute String | UnparsedAttributes [(Name, [Content])] deriving (Show, Typeable) -instance Exception XmlException + +instance Exception XmlException where +#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 _) = "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 + displayException (MissingAttribute msg) = "Missing required attribute: " ++ msg + displayException (UnparsedAttributes attrs) = show (length attrs) ++ " remaining unparsed attributes: \n" ++ intercalate "\n" (show <$> attrs) +#endif -- | 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', 'optionalAttr' et al +-- are unhandled attributes. Use the 'requireAttr', 'attr' et al -- functions for handling an attribute, and 'ignoreAttrs' if you would like to -- skip the rest of the attributes on an element. -- --- 'Alternative' instance behave like 'First' monoid. It chooses first +-- 'Alternative' instance behaves like 'First' monoid: it chooses first -- parser which doesn't fail. newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either SomeException ([(Name, [Content])], a) } @@ -909,28 +937,27 @@ requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b requireAttrRaw msg f = optionalAttrRaw f >>= - maybe (AttrParser $ const $ Left $ toException $ XmlException msg Nothing) + maybe (AttrParser $ const $ Left $ toException $ MissingAttribute msg) return -- | Return the value for an attribute if present. attr :: Name -> AttrParser (Maybe Text) -attr = optionalAttr +attr n = optionalAttrRaw + (\(x, y) -> if x == n then Just (contentsToText y) else Nothing) -- | Shortcut composition of 'force' and 'attr'. requireAttr :: Name -> AttrParser Text requireAttr n = force ("Missing attribute: " ++ show n) $ attr n + {-# DEPRECATED optionalAttr "Please use 'attr'." #-} optionalAttr :: Name -> AttrParser (Maybe Text) -optionalAttr n = optionalAttrRaw - (\(x, y) -> if x == n then Just (contentsToText y) else Nothing) +optionalAttr = attr contentsToText :: [Content] -> Text -contentsToText = - T.concat . map toText - where - toText (ContentText t) = t - toText (ContentEntity e) = T.concat ["&", e, ";"] +contentsToText = T.concat . map toText where + toText (ContentText t) = t + toText (ContentEntity e) = T.concat ["&", e, ";"] -- | Skip the remaining attributes on an element. Since this will clear the -- list of attributes, you must call this /after/ any calls to 'requireAttr', @@ -942,12 +969,7 @@ many :: Monad m => Consumer Event m (Maybe a) -> Consumer Event m [a] -many i = - go id - where - go front = i >>= - maybe (return $ front []) - (\y -> go $ front . (:) y) +many i = manyIgnore i $ return Nothing -- | Keep parsing elements as long as the parser returns 'Just' -- or the ignore parser returns 'Just'. @@ -967,39 +989,83 @@ -- | 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] + => Consumer Event m (Maybe a) + -> Consumer Event 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 finished +-- to downstream conduits without waiting for 'manyYield' to finish manyYield :: Monad m => ConduitM a b m (Maybe b) -> Conduit a m b -manyYield consumer = - loop - where - loop = consumer >>= maybe (return ()) (\x -> yield x >> loop) +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 finished +-- to downstream conduits without waiting for 'manyYield' 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 -> Conduit Event m b -manyIgnoreYield consumer ignoreParser = - loop - where - loop = consumer >>= maybe onFail (\x -> yield x >> loop) - onFail = ignoreParser >>= maybe (return ()) (const loop) +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 finished +-- 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'. +-- +-- >>> runResourceT $ parseLBS def "text<a></a>" $$ takeAllTreesContent =$= consume +-- Just [ EventContent (ContentText "text"), EventBeginElement "a" [], EventEndElement "a"] +-- +-- >>> runResourceT $ parseLBS def "</a><b></b>" $$ takeAllTreesContent =$= consume +-- Just [ ] +-- +-- >>> runResourceT $ parseLBS def "<b><c></c></b></a>text" $$ takeAllTreesContent =$= consume +-- Just [ EventBeginElement "b" [], EventBeginElement "c" [], EventEndElement "c", EventEndElement "b" ] +-- +-- Since 1.4.0 +{-# DEPRECATED takeAllTreesContent "This function will be removed in next release." #-} +takeAllTreesContent :: MonadThrow m => Conduit Event m Event +takeAllTreesContent = 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 () + + type DecodeEntities = Text -> Content -- | Default implementation of 'DecodeEntities': handles numeric entities and diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/Text/XML/Stream/Render.hs new/xml-conduit-1.4.0.4/Text/XML/Stream/Render.hs --- old/xml-conduit-1.3.5/Text/XML/Stream/Render.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/Text/XML/Stream/Render.hs 2017-02-13 20:32:23.000000000 +0100 @@ -29,6 +29,7 @@ ) where import Blaze.ByteString.Builder +import Control.Applicative ((<$>)) import Control.Monad.Trans.Resource (MonadThrow) import Data.ByteString (ByteString) import Data.Conduit @@ -108,7 +109,7 @@ where order elt attrMap = let initialAttrs = fromMaybe [] $ lookup elt orderSpec - mkPair attr = fmap ((,) attr) $ Map.lookup attr attrMap + mkPair attr = (,) attr <$> Map.lookup attr attrMap otherAttrMap = Map.filterWithKey (const . not . (`elem` initialAttrs)) attrMap in mapMaybe mkPair initialAttrs ++ Map.toAscList otherAttrMap @@ -138,7 +139,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 } = do +renderEvent yield' RenderSettings { rsPretty = isPretty, rsNamespaces = namespaces0, rsUseCDATA = useCDATA } = loop [] where loop nslevels = await >>= maybe (return ()) (go nslevels) @@ -178,8 +179,8 @@ (tokenToBuilder $ TokenEndElement $ nameToTName sl name, s') where (sl:s') = s -eventToToken s useCDATA (EventContent c) - | useCDATA c = +eventToToken s useCDATA (EventContent c) + | useCDATA c = case c of ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) ContentEntity txt -> (tokenToBuilder $ TokenCDATA txt, s) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/Text/XML/Unresolved.hs new/xml-conduit-1.4.0.4/Text/XML/Unresolved.hs --- old/xml-conduit-1.3.5/Text/XML/Unresolved.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/Text/XML/Unresolved.hs 2017-02-13 20:32:23.000000000 +0100 @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -- | DOM-based XML parsing and rendering. -- -- In this module, attribute values and content nodes can contain either raw @@ -43,31 +43,31 @@ , R.rsNamespaces ) where -import Prelude hiding (writeFile, readFile) -import Data.XML.Types -import Control.Exception (Exception, SomeException) -import Data.Typeable (Typeable) -import Blaze.ByteString.Builder (Builder) -import qualified Text.XML.Stream.Render as R -import qualified Text.XML.Stream.Parse as P -import Text.XML.Stream.Parse (ParseSettings) -import Data.ByteString (ByteString) -import Data.Text (Text) -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (when) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Char (isSpace) -import qualified Data.ByteString.Lazy as L -import System.IO.Unsafe (unsafePerformIO) -import Data.Conduit -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Binary as CB -import Control.Exception (throw) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Resource (MonadThrow, monadThrow, runExceptionT, runResourceT) -import Control.Monad.ST (runST) -import Data.Conduit.Lazy (lazyConsume) +import Blaze.ByteString.Builder (Builder) +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (Exception, SomeException, throw) +import Control.Monad (when) +import Control.Monad.ST (runST) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Resource (MonadThrow, monadThrow, + runExceptionT, runResourceT) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Char (isSpace) +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Lazy (lazyConsume) +import qualified Data.Conduit.List as CL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Typeable (Typeable) +import Data.XML.Types +import Prelude hiding (readFile, writeFile) +import System.IO.Unsafe (unsafePerformIO) +import Text.XML.Stream.Parse (ParseSettings) +import qualified Text.XML.Stream.Parse as P +import qualified Text.XML.Stream.Render as R readFile :: P.ParseSettings -> FilePath -> IO Document readFile ps fp = runResourceT $ CB.sourceFile fp $$ sinkDoc ps @@ -114,7 +114,7 @@ show UnterminatedInlineDoctype = "Unterminated doctype declaration" mShowPos :: Maybe P.PositionRange -> String -mShowPos Nothing = "" +mShowPos Nothing = "" mShowPos (Just pos) = show pos ++ ": " prettyShowE :: Event -> String @@ -140,7 +140,7 @@ x <- f case x of Nothing -> return $ front [] - Just y -> go (front . (:) y) + Just y -> go (front . (:) y) dropReturn :: Monad m => a -> ConduitM i o m a dropReturn x = CL.drop 1 >> return x @@ -211,7 +211,7 @@ x <- CL.peek case x of Just (_, EventBeginElement n as) -> Just <$> goE' n as - _ -> return Nothing + _ -> return Nothing goE' n as = do CL.drop 1 ns <- manyTries goN @@ -237,11 +237,11 @@ where goP (Prologue before doctype after) = goM before . maybe id goD doctype . goM after - goM [] = id - goM [x] = (goM' x :) + goM [] = id + goM [x] = (goM' x :) goM (x:xs) = (goM' x :) . goM xs goM' (MiscInstruction i) = EventInstruction i - goM' (MiscComment t) = EventComment t + goM' (MiscComment t) = EventComment t goD (Doctype name meid) = (:) (EventBeginDoctype name meid) . (:) EventEndDoctype @@ -259,13 +259,13 @@ (EventBeginElement name as :) . goN ns . (EventEndElement name :) - goN [] = id - goN [x] = goN' x + goN [] = id + goN [x] = goN' x goN (x:xs) = goN' x . goN xs - goN' (NodeElement e) = goE e + goN' (NodeElement e) = goE e goN' (NodeInstruction i) = (EventInstruction i :) - goN' (NodeContent c) = (EventContent c :) - goN' (NodeComment t) = (EventComment t :) + goN' (NodeContent c) = (EventContent c :) + goN' (NodeComment t) = (EventComment t :) compressNodes :: [Node] -> [Node] compressNodes [] = [] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/Text/XML.hs new/xml-conduit-1.4.0.4/Text/XML.hs --- old/xml-conduit-1.3.5/Text/XML.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/Text/XML.hs 2017-02-13 20:32:23.000000000 +0100 @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} -- | DOM-based parsing and rendering. -- -- This module requires that all entities be resolved at parsing. If you need @@ -73,58 +73,56 @@ , fromXMLElement ) where -import qualified Data.XML.Types as X -import Data.XML.Types - ( Prologue (..) - , Miscellaneous (..) - , Instruction (..) - , Name (..) - , Doctype (..) - , ExternalID (..) - ) -import Data.Typeable (Typeable) -import Data.Data (Data) -import Control.DeepSeq(NFData(rnf)) -import Data.Text (Text) -import qualified Text.XML.Stream.Parse as P -import qualified Text.XML.Unresolved as D -import qualified Text.XML.Stream.Render as R -import qualified Data.Text as T -import Data.Either (partitionEithers) -import Control.Monad.Trans.Resource (MonadThrow, monadThrow, runExceptionT, runResourceT) -import Prelude hiding (readFile, writeFile) -import Control.Exception (SomeException, Exception, throwIO, handle) -import Text.XML.Stream.Parse (ParseSettings, def, psDecodeEntities) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L -import Control.Monad.ST (runST) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Set (Set) - -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE -import Data.Conduit -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Binary as CB -import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (throw) -import Control.Monad.Trans.Resource (runExceptionT) -import Control.Monad.Trans.Class (lift) -import Data.Conduit.Lazy (lazyConsume) - -import qualified Text.Blaze as B -import qualified Text.Blaze.Html as B -import qualified Text.Blaze.Html5 as B5 -import qualified Text.Blaze.Internal as BI -import Data.Monoid (mempty, mappend) -import Data.String (fromString) -import Data.List (foldl') -import Control.Arrow (first) +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData (rnf)) +import Control.Exception (Exception, SomeException, handle, + throw, throwIO) +import Control.Monad.ST (runST) +import Control.Monad.Trans.Resource (MonadThrow, monadThrow, + runExceptionT, runResourceT) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Data (Data) +import Data.Either (partitionEithers) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Data.XML.Types (Doctype (..), ExternalID (..), + Instruction (..), + Miscellaneous (..), Name (..), + Prologue (..)) +import qualified Data.XML.Types as X +import Prelude hiding (readFile, writeFile) +import Text.XML.Stream.Parse (ParseSettings, def, + psDecodeEntities) +import qualified Text.XML.Stream.Parse as P +import qualified Text.XML.Stream.Render as R +import qualified Text.XML.Unresolved as D + +import Control.Monad.Trans.Class (lift) +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Lazy (lazyConsume) +import qualified Data.Conduit.List as CL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import System.IO.Unsafe (unsafePerformIO) + +import Control.Arrow (first) +import Data.List (foldl') +import Data.Monoid (mappend, mempty) +import Data.String (fromString) +import qualified Text.Blaze as B +import qualified Text.Blaze.Html as B +import qualified Text.Blaze.Html5 as B5 +import qualified Text.Blaze.Internal as BI data Document = Document { documentPrologue :: Prologue - , documentRoot :: Element + , documentRoot :: Element , documentEpilogue :: [Miscellaneous] } deriving (Show, Eq, Typeable, Data) @@ -143,16 +141,16 @@ #if MIN_VERSION_containers(0, 4, 2) instance NFData Node where - rnf (NodeElement e) = rnf e `seq` () + rnf (NodeElement e) = rnf e `seq` () rnf (NodeInstruction i) = rnf i `seq` () - rnf (NodeContent t) = rnf t `seq` () - rnf (NodeComment t) = rnf t `seq` () + rnf (NodeContent t) = rnf t `seq` () + rnf (NodeComment t) = rnf t `seq` () #endif data Element = Element - { elementName :: Name + { elementName :: Name , elementAttributes :: Map.Map Name Text - , elementNodes :: [Node] + , elementNodes :: [Node] } deriving (Show, Eq, Ord, Typeable, Data) @@ -186,24 +184,24 @@ toXMLNode = toXMLNode' def toXMLNode' :: R.RenderSettings -> Node -> X.Node -toXMLNode' rs (NodeElement e) = X.NodeElement $ toXMLElement' rs e -toXMLNode' _ (NodeContent t) = X.NodeContent $ X.ContentText t -toXMLNode' _ (NodeComment c) = X.NodeComment c +toXMLNode' rs (NodeElement e) = X.NodeElement $ toXMLElement' rs e +toXMLNode' _ (NodeContent t) = X.NodeContent $ X.ContentText t +toXMLNode' _ (NodeComment c) = X.NodeComment c toXMLNode' _ (NodeInstruction i) = X.NodeInstruction i fromXMLDocument :: X.Document -> Either (Set Text) Document fromXMLDocument (X.Document a b c) = case fromXMLElement b of - Left es -> Left es + Left es -> Left es Right b' -> Right $ Document a b' c fromXMLElement :: X.Element -> Either (Set Text) Element fromXMLElement (X.Element name as nodes) = case (lnodes, las) of ([], []) -> Right $ Element name ras rnodes - (x, []) -> Left $ Set.unions x - ([], y) -> Left $ Set.unions y - (x, y) -> Left $ Set.unions x `Set.union` Set.unions y + (x, []) -> Left $ Set.unions x + ([], y) -> Left $ Set.unions y + (x, y) -> Left $ Set.unions x `Set.union` Set.unions y where enodes = map fromXMLNode nodes (lnodes, rnodes) = partitionEithers enodes @@ -212,16 +210,15 @@ ras = Map.fromList ras' go (x, y) = case go' [] id y of - Left es -> Left es + Left es -> Left es Right y' -> Right (x, y') - go' [] front [] = Right $ T.concat $ front [] - go' errs _ [] = Left $ Set.fromList errs - go' errs front (X.ContentText t:ys) = go' errs (front . (:) t) ys + go' [] front [] = Right $ T.concat $ front [] + go' errs _ [] = Left $ Set.fromList errs + go' errs front (X.ContentText t:ys) = go' errs (front . (:) t) ys go' errs front (X.ContentEntity t:ys) = go' (t : errs) front ys fromXMLNode :: X.Node -> Either (Set Text) Node -fromXMLNode (X.NodeElement e) = - either Left (Right . NodeElement) $ fromXMLElement e +fromXMLNode (X.NodeElement e) = NodeElement <$> fromXMLElement e fromXMLNode (X.NodeContent (X.ContentText t)) = Right $ NodeContent t fromXMLNode (X.NodeContent (X.ContentEntity t)) = Left $ Set.singleton t fromXMLNode (X.NodeComment c) = Right $ NodeComment c @@ -324,14 +321,18 @@ childrenHtml = case (name `elem` ["style", "script"], children) of (True, [NodeContent t]) -> B.preEscapedToMarkup t - _ -> mapM_ B.toMarkup children + _ -> mapM_ B.toMarkup children isVoid = nameLocalName name' `Set.member` voidElems parent :: B.Html -> B.Html parent = BI.Parent tag open close leaf :: B.Html +#if MIN_VERSION_blaze_markup(0,8,0) + leaf = BI.Leaf tag open (fromString " />") () +#else leaf = BI.Leaf tag open (fromString " />") +#endif name = T.unpack $ nameLocalName name' tag = fromString name @@ -339,13 +340,13 @@ close = fromString $ concat ["</", name, ">"] attrs' :: [B.Attribute] - attrs' = map goAttr $ map (first nameLocalName) $ Map.toList attrs + attrs' = map (goAttr . first nameLocalName) $ Map.toList attrs goAttr (key, value) = B.customAttribute (B.textTag key) $ B.toValue value instance B.ToMarkup Node where toMarkup (NodeElement e) = B.toMarkup e toMarkup (NodeContent t) = B.toMarkup t - toMarkup _ = mempty + toMarkup _ = mempty voidElems :: Set.Set T.Text voidElems = Set.fromAscList $ T.words $ T.pack "area base br col command embed hr img input keygen link meta param source track wbr" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/test/main.hs new/xml-conduit-1.4.0.4/test/main.hs --- old/xml-conduit-1.3.5/test/main.hs 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/test/main.hs 2017-02-13 20:32:23.000000000 +0100 @@ -1,9 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Exception (Exception) +import Control.Exception (Exception, toException) import Control.Monad.IO.Class (liftIO) import Data.Typeable (Typeable) import Data.XML.Types @@ -24,9 +22,10 @@ import Control.Monad.Trans.Class (lift) import qualified Data.Text as T import qualified Data.Set as Set -import Control.Exception (toException) +import Data.Conduit ((=$=)) import qualified Data.Conduit as C +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 @@ -42,6 +41,7 @@ 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 orE" testOrE it "is idempotent to parse and pretty render a document" documentParsePrettyRender it "ignores the BOM" parseIgnoreBOM @@ -94,7 +94,7 @@ it "parsing CDATA" caseParseCdata it "retains namespaces when asked" caseRetainNamespaces it "handles iso-8859-1" caseIso8859_1 - it "renders CDATA when asked" caseRenderCDATA + it "renders CDATA when asked" caseRenderCDATA it "escapes CDATA closing tag in CDATA" caseEscapesCDATA documentParseRender :: IO () @@ -134,7 +134,7 @@ ] combinators :: Assertion -combinators = C.runResourceT $ P.parseLBS def input C.$$ do +combinators = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagName "hello" (P.requireAttr "world") $ \world -> do liftIO $ world @?= "true" P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return () @@ -181,7 +181,7 @@ testChooseElemOrTextIsChunkedText2 testChooseElemOrTextIsText :: Assertion -testChooseElemOrTextIsText = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsText = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -198,7 +198,7 @@ ] testChooseElemOrTextIsEncoded :: Assertion -testChooseElemOrTextIsEncoded = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsEncoded = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -215,7 +215,7 @@ ] testChooseElemOrTextIsEncodedNBSP :: Assertion -testChooseElemOrTextIsEncodedNBSP = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsEncodedNBSP = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -233,7 +233,7 @@ testChooseElemOrTextIsWhiteSpace :: Assertion -testChooseElemOrTextIsWhiteSpace = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsWhiteSpace = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -248,7 +248,7 @@ ] testChooseTextOrElemIsWhiteSpace :: Assertion -testChooseTextOrElemIsWhiteSpace = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseTextOrElemIsWhiteSpace = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.contentMaybe @@ -263,7 +263,7 @@ ] testChooseElemOrTextIsChunkedText :: Assertion -testChooseElemOrTextIsChunkedText = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsChunkedText = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -278,7 +278,7 @@ ] testChooseElemOrTextIsChunkedText2 :: Assertion -testChooseElemOrTextIsChunkedText2 = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsChunkedText2 = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return "boom" @@ -293,7 +293,7 @@ ] testChooseElemOrTextIsElem :: Assertion -testChooseElemOrTextIsElem = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseElemOrTextIsElem = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "success" $ return "success" @@ -310,7 +310,7 @@ ] testChooseTextOrElemIsText :: Assertion -testChooseTextOrElemIsText = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseTextOrElemIsText = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.contentMaybe @@ -327,7 +327,7 @@ ] testChooseTextOrElemIsElem :: Assertion -testChooseTextOrElemIsElem = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseTextOrElemIsElem = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.contentMaybe @@ -344,7 +344,7 @@ ] testChooseEitherElem :: Assertion -testChooseEitherElem = C.runResourceT $ P.parseLBS def input C.$$ do +testChooseEitherElem = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.choose [ P.tagNoAttr "failure" $ return 1 @@ -363,9 +363,9 @@ testManyYield :: Assertion testManyYield = do -- Basically the same as testMany, but consume the streamed result - result <- C.runResourceT $ + result <- runResourceT $ P.parseLBS def input C.$$ helloParser - C.$= CL.consume + =$= CL.consume length result @?= 5 where helloParser = void $ P.tagNoAttr "hello" $ P.manyYield successParser @@ -382,8 +382,32 @@ , "</hello>" ] +testTakeAllTreesContent :: Assertion +testTakeAllTreesContent = do + result <- runResourceT $ P.parseLBS def input C.$$ rootParser + result @?= Just + [ EventBeginElement "b" [] + , EventContent (ContentText "Hello ") + , EventBeginElement "em" [] + , EventContent (ContentText "world") + , EventEndElement "em" + , EventContent (ContentText " !") + , EventEndElement "b" + , EventContent (ContentText " Welcome !") + ] + where + rootParser = P.tagNoAttr "root" $ P.takeAllTreesContent =$= CL.consume + input = L.concat + [ "<?xml version='1.0'?>" + , "<!DOCTYPE foo []>\n" + , "<root>" + , "<b>Hello <em>world</em> !</b> Welcome !" + , "</root>" + ] + + testMany :: Assertion -testMany = C.runResourceT $ P.parseLBS def input C.$$ do +testMany = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.many $ P.tagNoAttr "success" $ return () liftIO $ length x @?= 5 @@ -401,7 +425,7 @@ ] testMany' :: Assertion -testMany' = C.runResourceT $ P.parseLBS def input C.$$ do +testMany' = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.many' $ P.tagNoAttr "success" $ return () liftIO $ length x @?= 5 @@ -421,7 +445,7 @@ ] testOrE :: IO () -testOrE = C.runResourceT $ P.parseLBS def input C.$$ do +testOrE = runResourceT $ P.parseLBS def input C.$$ do P.force "need hello" $ P.tagNoAttr "hello" $ do x <- P.tagNoAttr "failure" (return 1) `P.orE` P.tagNoAttr "success" (return 2) @@ -436,10 +460,10 @@ ] testConduitParser :: Assertion -testConduitParser = C.runResourceT $ do +testConduitParser = runResourceT $ do x <- P.parseLBS def input - C.$= (P.force "need hello" $ P.tagNoAttr "hello" f) - C.$$ CL.consume + C.$$ (P.force "need hello" $ P.tagNoAttr "hello" f) + =$= CL.consume liftIO $ x @?= [1, 1, 1] where input = L.concat diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-conduit-1.3.5/xml-conduit.cabal new/xml-conduit-1.4.0.4/xml-conduit.cabal --- old/xml-conduit-1.3.5/xml-conduit.cabal 2016-05-11 13:03:26.000000000 +0200 +++ new/xml-conduit-1.4.0.4/xml-conduit.cabal 2017-02-13 20:32:23.000000000 +0100 @@ -1,5 +1,5 @@ name: xml-conduit -version: 1.3.5 +version: 1.4.0.4 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]>, Aristid Breitkreuz <[email protected]>
