commit ghc-xml-conduit for openSUSE:Factory
![](https://seccdn.libravatar.org/avatar/000404b9c3cf99a2a21283776f57d3b5.jpg?s=120&d=mm&r=g)
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 - psimons@suse.com
+
+- Update to version 1.4.0.4 with cabal2obs.
+
+-------------------------------------------------------------------
+Sun Feb 12 14:15:41 UTC 2017 - psimons@suse.com
+
+- 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
participants (1)
-
root@hilbertn.suse.de