xml-conduit 1.8.0 → 1.8.0.1
raw patch · 6 files changed
+1050/−1030 lines, 6 filesdep +doctestdep −monad-controldep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: doctest
Dependencies removed: monad-control
Dependency ranges changed: base
API changes (from Hackage documentation)
- Text.XML.Stream.Parse: instance a ~ Data.XML.Types.Name => Data.String.IsString (Text.XML.Stream.Parse.NameMatcher a)
+ Text.XML.Stream.Parse: instance (a ~ Data.XML.Types.Name) => Data.String.IsString (Text.XML.Stream.Parse.NameMatcher a)
+ Text.XML.Stream.Render: instance GHC.Base.Semigroup Text.XML.Stream.Render.Attributes
- Text.XML: data Doctype :: *
+ Text.XML: data Doctype
- Text.XML: data ExternalID :: *
+ Text.XML: data ExternalID
- Text.XML: data Instruction :: *
+ Text.XML: data Instruction
- Text.XML: data Miscellaneous :: *
+ Text.XML: data Miscellaneous
- Text.XML: data Name :: *
+ Text.XML: data Name
- Text.XML: data Prologue :: *
+ Text.XML: data Prologue
- Text.XML.Cursor: (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
+ Text.XML.Cursor: (>=>) :: Monad m => a -> m b -> b -> m c -> a -> m c
- Text.XML.Cursor.Generic: (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
+ Text.XML.Cursor.Generic: (>=>) :: Monad m => a -> m b -> b -> m c -> a -> m c
- Text.XML.Stream.Parse: NameMatcher :: (Name -> Maybe a) -> NameMatcher a
+ Text.XML.Stream.Parse: NameMatcher :: Name -> Maybe a -> NameMatcher a
- Text.XML.Stream.Parse: data PositionRange :: *
+ Text.XML.Stream.Parse: data PositionRange
Files
- ChangeLog.md +4/−0
- Text/XML/Stream/Parse.hs +77/−69
- test/doctest.hs +3/−0
- test/main.hs +0/−955
- test/unit.hs +955/−0
- xml-conduit.cabal +11/−6
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.8.0.1++* Use doctest to validate code examples from documentation+ ## 1.8.0 * Upgrade to conduit 1.3.0
Text/XML/Stream/Parse.hs view
@@ -9,49 +9,39 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | This module provides both a native Haskell solution for parsing XML -- documents into a stream of events, and a set of parser combinators for -- dealing with a stream of events. ----- As a simple example, if you have the following XML file:+-- As a simple example: ----- > <?xml version="1.0" encoding="utf-8"?>--- > <people>--- > <person age="25">Michael</person>--- > <person age="2">Eliezer</person>--- > </people>+-- >>> :set -XOverloadedStrings+-- >>> import Data.Conduit (runConduit, (.|))+-- >>> import Data.Text (Text, unpack)+-- >>> import Data.XML.Types (Event)+-- >>> data Person = Person Int Text Text deriving Show+-- >>> :{+-- let parsePerson :: MonadThrow m => ConduitT Event o m (Maybe Person)+-- parsePerson = tag' "person" parseAttributes $ \(age, goodAtHaskell) -> do+-- name <- content+-- return $ Person (read $ unpack age) name goodAtHaskell+-- where parseAttributes = (,) <$> requireAttr "age" <*> requireAttr "goodAtHaskell" <* ignoreAttrs+-- parsePeople :: MonadThrow m => ConduitT Event o m (Maybe [Person])+-- parsePeople = tagNoAttr "people" $ many parsePerson+-- inputXml = mconcat+-- [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>"+-- , "<people>"+-- , " <person age=\"25\" goodAtHaskell=\"yes\">Michael</person>"+-- , " <person age=\"2\" goodAtHaskell=\"might become\">Eliezer</person>"+-- , "</people>"+-- ]+-- :} ----- Then this code:+-- >>> runConduit $ parseLBS def inputXml .| force "people required" parsePeople+-- [Person 25 "Michael" "yes",Person 2 "Eliezer" "might become"] ----- > {-# LANGUAGE OverloadedStrings #-}--- > import Control.Monad.Trans.Resource--- > import Data.Conduit (Consumer, Sink, ($$))--- > import Data.Text (Text, unpack)--- > import Text.XML.Stream.Parse--- > import Data.XML.Types (Event)--- >--- > data Person = Person Int Text--- > deriving Show--- >--- > parsePerson :: MonadThrow m => ConduitT Event o m (Maybe Person)--- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do--- > name <- content--- > return $ Person (read $ unpack age) name--- >--- > parsePeople :: MonadThrow m => Sink Event m (Maybe [Person])--- > parsePeople = tagNoAttr "people" $ many parsePerson--- >--- > main = do--- > people <- runResourceT $--- > parseFile def "people.xml" $$ force "people required" parsePeople--- > print people ----- will produce:------ > [Person 25 "Michael",Person 2 "Eliezer"]--- -- This module also supports streaming results using 'yield'. -- This allows parser results to be processed using conduits -- while a particular parser (e.g. 'many') is still running.@@ -60,29 +50,16 @@ -- to process by using streaming results. -- See http://stackoverflow.com/q/21367423/2597135 for a related discussion. ----- > {-# LANGUAGE OverloadedStrings #-}--- > import Control.Monad (void)--- > import Control.Monad.Trans.Class (lift)--- > import Control.Monad.Trans.Resource--- > import Data.Conduit--- > import qualified Data.Conduit.List as CL--- > import Data.Text (Text, unpack)--- > import Data.XML.Types (Event)--- > import Text.XML.Stream.Parse--- >--- > data Person = Person Int Text deriving Show--- >--- > parsePerson :: MonadThrow m => ConduitT Event o m (Maybe Person)--- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do--- > name <- content--- > return $ Person (read $ unpack age) name--- >--- > parsePeople :: MonadThrow m => Conduit Event m Person--- > parsePeople = void $ tagNoAttr "people" $ manyYield parsePerson--- >--- > main = runResourceT $--- > parseFile def "people.xml" $$ parsePeople .| CL.mapM_ (lift . print)+-- >>> import Data.Conduit.List as CL+-- >>> :{+-- let parsePeople' :: MonadThrow m => ConduitT Event Person m (Maybe ())+-- parsePeople' = tagNoAttr "people" $ manyYield parsePerson+-- :} --+-- >>> runConduit $ parseLBS def inputXml .| force "people required" parsePeople' .| CL.mapM_ print+-- Person 25 "Michael" "yes"+-- Person 2 "Eliezer" "might become"+-- -- Previous versions of this module contained a number of more sophisticated -- functions written by Aristid Breitkreuz and Dmitry Olshansky. To keep this -- package simpler, those functions are being moved to a separate package. This@@ -159,6 +136,7 @@ , PositionRange , EventPos ) where+import Conduit import Control.Applicative (Alternative (empty, (<|>)), Applicative (..), (<$>)) import qualified Control.Applicative as A@@ -178,12 +156,10 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Char (isSpace)-import Conduit-import qualified Data.Conduit.Text as CT import Data.Conduit.Attoparsec (PositionRange, conduitParser)+import qualified Data.Conduit.Text as CT import Data.Default.Class (Default (..))-import Data.List (intercalate)-import Data.List (foldl')+import Data.List (foldl', intercalate) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isNothing) import Data.String (IsString (..))@@ -773,8 +749,8 @@ _ -> 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' where the 'NameMatcher' result isn't forwarded to the attributes parser.@@ -837,6 +813,16 @@ ignoreTree = ignoreTreeContent -- | Like 'ignoreTreeContent', but matches any name and also ignores content events.+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.Conduit+-- >>> import Data.Conduit.List (consume)+--+-- >>> runConduit $ parseLBS def "<a>content</a><b></b>" .| (ignoreAnyTreeContent >> consume)+-- [EventBeginElement (Name {nameLocalName = "b", ...}) [],EventEndElement (Name {nameLocalName = "b", ...}),EventEndDocument]+--+-- >>> runConduit $ parseLBS def "text<b></b>" .| (ignoreAnyTreeContent >> consume)+-- [EventBeginElement (Name {nameLocalName = "b", ...}) [],EventEndElement (Name {nameLocalName = "b", ...}),EventEndDocument] ignoreAnyTreeContent :: MonadThrow m => ConduitT Event o m (Maybe ()) ignoreAnyTreeContent = (void <$> contentMaybe) `orE` ignoreTreeContent anyName @@ -1091,12 +1077,29 @@ Just e -> if isWhitespace e then yield e >> takeContent else leftover e >> return Nothing _ -> return Nothing --- | Stream 'Event's corresponding to a single element that matches given 'NameMatcher' and 'AttrParser', from the opening- to the closing-tag.+-- | Stream 'Event's corresponding to a single XML element that matches given 'NameMatcher' and 'AttrParser', from the opening- to the closing-tag. --+-- >>> :set -XOverloadedStrings+-- >>> import Control.Monad (void)+-- >>> import Data.Conduit+-- >>> import Data.Conduit.List (consume)+--+-- >>> runConduit $ parseLBS def "<a>content</a><b></b>" .| void (takeTree "a" ignoreAttrs) .| consume+-- [EventBeginDocument,EventBeginElement (Name {nameLocalName = "a", ...}) [],EventContent (ContentText "content"),EventEndElement (Name {nameLocalName = "a", ...})]+--+-- >>> runConduit $ parseLBS def "<a>content</a><b></b>" .| void (takeTree "b" ignoreAttrs) .| consume+-- [EventBeginDocument]+-- -- If next 'Event' isn't an element, nothing is consumed. --+-- >>> runConduit $ parseLBS def "text<a></a>" .| void (takeTree "a" ignoreAttrs) .| consume+-- [EventBeginDocument]+-- -- If an opening-tag is consumed but no matching closing-tag is found, an 'XmlException' is thrown. --+-- >>> runConduit $ parseLBS def "<a><b></b>" .| void (takeTree "a" ignoreAttrs) .| consume+-- *** Exception: InvalidEndElement (Name {nameLocalName = "a", nameNamespace = Nothing, namePrefix = Nothing}) Nothing+-- -- This function automatically ignores comments, instructions and whitespace. -- -- Returns @Just ()@ if an element was consumed, 'Nothing' otherwise.@@ -1134,14 +1137,19 @@ -- | Like 'takeTreeContent', without checking for tag name or attributes. ----- >>> runResourceT $ parseLBS def "text<a></a>" $$ takeAnyTreeContent .| consume--- Just [ EventContent (ContentText "text") ]+-- >>> :set -XOverloadedStrings+-- >>> import Control.Monad (void)+-- >>> import Data.Conduit ((.|), runConduit)+-- >>> import Data.Conduit.List (consume) ----- >>> runResourceT $ parseLBS def "</a><b></b>" $$ takeAnyTreeContent .| consume--- Just [ ]+-- >>> runConduit $ parseLBS def "text<a></a>" .| void takeAnyTreeContent .| consume+-- [EventBeginDocument,EventContent (ContentText "text")] ----- >>> runResourceT $ parseLBS def "<b><c></c></b></a>text" $$ takeAnyTreeContent .| consume--- Just [ EventBeginElement "b" [], EventBeginElement "c" [], EventEndElement "c", EventEndElement "b" ]+-- >>> runConduit $ parseLBS def "</a><b></b>" .| void takeAnyTreeContent .| consume+-- [EventBeginDocument]+--+-- >>> runConduit $ parseLBS def "<b><c></c></b></a>text" .| void takeAnyTreeContent .| consume+-- [EventBeginDocument,EventBeginElement (Name {nameLocalName = "b", ...}) [],EventBeginElement (Name {nameLocalName = "c", ...}) [],EventEndElement (Name {nameLocalName = "c", ...}),EventEndElement (Name {nameLocalName = "b", ...})] -- -- Since 1.5.0 takeAnyTreeContent :: MonadThrow m
+ test/doctest.hs view
@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["Text"]
− test/main.hs
@@ -1,955 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}--import Control.Exception (Exception, toException)-import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString.Char8 as S-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Typeable (Typeable)-import Data.XML.Types-import Test.Hspec-import Test.HUnit hiding (Test)-import qualified Text.XML as Res-import qualified Text.XML.Cursor as Cu-import Text.XML.Stream.Parse (def)-import qualified Text.XML.Stream.Parse as P-import qualified Text.XML.Unresolved as D--import Control.Monad-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Text.XML.Cursor (($.//), ($/), ($//), ($|),- (&.//), (&/), (&//))--import qualified Control.Monad.Trans.Resource as C-import Data.Conduit ((.|), runConduit, runConduitRes, ConduitT)-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import qualified Data.Map as Map-import Text.Blaze (toMarkup)-import Text.Blaze.Renderer.String (renderMarkup)--main :: IO ()-main = hspec $ do- describe "XML parsing and rendering" $ do- it "is idempotent to parse and render a document" documentParseRender- it "has valid parser combinators" combinators- context "has working choose function" testChoose- it "has working many function" testMany- it "has working many' function" testMany'- it "has working manyYield function" testManyYield- it "has working takeContent function" testTakeContent- it "has working takeTree function" testTakeTree- it "has working takeAnyTreeContent function" testTakeAnyTreeContent- it "has working orE" testOrE- it "is idempotent to parse and pretty render a document" documentParsePrettyRender- it "ignores the BOM" parseIgnoreBOM- it "strips duplicated attributes" stripDuplicateAttributes- it "displays comments" testRenderComments- it "conduit parser" testConduitParser- it "can omit the XML declaration" omitXMLDeclaration- context "correctly parses hexadecimal entities" hexEntityParsing- describe "XML Cursors" $ do- it "has correct parent" cursorParent- it "has correct ancestor" cursorAncestor- it "has correct orSelf" cursorOrSelf- it "has correct preceding" cursorPreceding- it "has correct following" cursorFollowing- it "has correct precedingSibling" cursorPrecedingSib- it "has correct followingSibling" cursorFollowingSib- it "has correct descendant" cursorDescendant- it "has correct check" cursorCheck- it "has correct check with lists" cursorPredicate- it "has correct checkNode" cursorCheckNode- it "has correct checkElement" cursorCheckElement- it "has correct checkName" cursorCheckName- it "has correct anyElement" cursorAnyElement- it "has correct element" cursorElement- it "has correct laxElement" cursorLaxElement- it "has correct content" cursorContent- it "has correct attribute" cursorAttribute- it "has correct laxAttribute" cursorLaxAttribute- it "has correct &* and $* operators" cursorDeep- it "has correct force" cursorForce- it "has correct forceM" cursorForceM- it "has correct hasAttribute" cursorHasAttribute- it "has correct attributeIs" cursorAttributeIs- describe "resolved" $ do- it "identifies unresolved entities" resolvedIdentifies- it "decodeHtmlEntities" testHtmlEntities- it "works for resolvable entities" resolvedAllGood- it "merges adjacent content nodes" resolvedMergeContent- it "understands inline entity declarations" resolvedInline- describe "pretty" $ do- it "works" casePretty- describe "top level namespaces" $ do- it "works" caseTopLevelNamespace- it "works with prefix" caseTopLevelNamespacePrefix- it "handles conflicts" caseTLNConflict- describe "blaze-html instances" $ do- it "works" caseBlazeHtml- describe "attribute reordering" $ do- it "works" caseAttrReorder- describe "ordering attributes explicitly" $ do- it "works" caseOrderAttrs- it "parsing CDATA" caseParseCdata- it "retains namespaces when asked" caseRetainNamespaces- it "handles iso-8859-1" caseIso8859_1- it "renders CDATA when asked" caseRenderCDATA- it "escapes CDATA closing tag in CDATA" caseEscapesCDATA--documentParseRender :: IO ()-documentParseRender =- mapM_ go docs- where- go x = x @=? D.parseLBS_ def (D.renderLBS def x)- docs =- [ Document (Prologue [] Nothing [])- (Element "foo" [] [])- []- , D.parseLBS_ def- "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo/>"- , D.parseLBS_ def- "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"- , D.parseLBS_ def- "<foo><![CDATA[this is some<CDATA content>]]></foo>"- , D.parseLBS_ def- "<foo bar='baz&bin'/>"- , D.parseLBS_ def- "<foo><?instr this is a processing instruction?></foo>"- , D.parseLBS_ def- "<foo><!-- this is a comment --></foo>"- ]--documentParsePrettyRender :: IO ()-documentParsePrettyRender =- L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc- where- doc = L.unlines- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo>"- , " <?bar bar?>"- , " text"- , " <?bin bin?>"- , "</foo>"- ]--combinators :: Assertion-combinators = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tag' "hello" (P.requireAttr "world") $ \world -> do- liftIO $ world @?= "true"- P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()- P.force "need child2" $ P.tagNoAttr "child2" $ return ()- P.force "need child3" $ P.tagNoAttr "child3" $ do- x <- P.contentMaybe- liftIO $ x @?= Just "combine <all> &content"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello world='true'>"- , "<?this should be ignored?>"- , "<child1 xmlns='mynamespace'/>"- , "<!-- this should be ignored -->"- , "<child2> </child2>"- , "<child3>combine <all> <![CDATA[&content]]></child3>\n"- , "</hello>"- ]--testChoose :: Spec-testChoose = do- it "can choose between elements"- testChooseEitherElem- it "can choose between elements and text, returning text"- testChooseElemOrTextIsText- it "can choose between elements and text, returning elements"- testChooseElemOrTextIsElem- it "can choose between text and elements, returning text"- testChooseTextOrElemIsText- it "can choose between text and elements, returning elements"- testChooseTextOrElemIsElem- it "can choose between text and elements, when the text is encoded"- testChooseElemOrTextIsEncoded- it "can choose between text and elements, when the text is encoded, NBSP"- testChooseElemOrTextIsEncodedNBSP- it "can choose between elements and text, when the text is whitespace"- testChooseElemOrTextIsWhiteSpace- it "can choose between text and elements, when the text is whitespace"- testChooseTextOrElemIsWhiteSpace- it "can choose between text and elements, when the whitespace is both literal and encoded"- testChooseElemOrTextIsChunkedText- it "can choose between text and elements, when the text is chunked the other way"- testChooseElemOrTextIsChunkedText2--testChooseElemOrTextIsText :: Assertion-testChooseElemOrTextIsText = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just " something "- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , " something "- , "</hello>"- ]--testChooseElemOrTextIsEncoded :: Assertion-testChooseElemOrTextIsEncoded = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just "\x20something\x20"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , " something "- , "</hello>"- ]--testChooseElemOrTextIsEncodedNBSP :: Assertion-testChooseElemOrTextIsEncodedNBSP = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just "\160something\160"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , " something "- , "</hello>"- ]---testChooseElemOrTextIsWhiteSpace :: Assertion-testChooseElemOrTextIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just "\x20\x20\x20"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello> </hello>"- ]--testChooseTextOrElemIsWhiteSpace :: Assertion-testChooseTextOrElemIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.contentMaybe- , P.tagNoAttr "failure" $ return "boom"- ]- liftIO $ x @?= Just "\x20\x20\x20"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello> </hello>"- ]--testChooseElemOrTextIsChunkedText :: Assertion-testChooseElemOrTextIsChunkedText = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just "\x20\x20\x20"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>   </hello>"- ]--testChooseElemOrTextIsChunkedText2 :: Assertion-testChooseElemOrTextIsChunkedText2 = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return "boom"- , P.contentMaybe- ]- liftIO $ x @?= Just "\x20\x20\x20"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>   </hello>"- ]--testChooseElemOrTextIsElem :: Assertion-testChooseElemOrTextIsElem = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "success" $ return "success"- , P.contentMaybe- ]- liftIO $ x @?= Just "success"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testChooseTextOrElemIsText :: Assertion-testChooseTextOrElemIsText = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.contentMaybe- , P.tagNoAttr "failure" $ return "boom"- ]- liftIO $ x @?= Just " something "- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , " something "- , "</hello>"- ]--testChooseTextOrElemIsElem :: Assertion-testChooseTextOrElemIsElem = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.contentMaybe- , P.tagNoAttr "success" $ return "success"- ]- liftIO $ x @?= Just "success"- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testChooseEitherElem :: Assertion-testChooseEitherElem = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return 1- , P.tagNoAttr "success" $ return 2- ]- liftIO $ x @?= Just (2 :: Int)- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testManyYield :: Assertion-testManyYield = do- -- Basically the same as testMany, but consume the streamed result- result <- runConduitRes $- P.parseLBS def input .| helloParser- .| CL.consume- length result @?= 5- where- helloParser = void $ P.tagNoAttr "hello" $ P.manyYield successParser- successParser = P.tagNoAttr "success" $ return ()- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "</hello>"- ]--testTakeContent :: Assertion-testTakeContent = do- result <- runConduitRes $ P.parseLBS def input .| rootParser- result @?= Just- [ EventContent (ContentText "Hello world !")- ]- where- rootParser = P.tagNoAttr "root" $ void (P.takeContent >> P.takeContent) .| CL.consume- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<root>"- , "Hello world !"- , "</root>"- ]--testTakeTree :: Assertion-testTakeTree = do- result <- runConduitRes $ P.parseLBS def input .| rootParser- result @?=- [ EventBeginDocument- , EventBeginDoctype "foo" Nothing- , EventEndDoctype- , EventBeginElement "a" []- , EventBeginElement "em" []- , EventContent (ContentText "Hello world !")- , EventEndElement "em"- , EventEndElement "a"- ]- where- rootParser = void (P.takeTree "a" P.ignoreAttrs) .| CL.consume- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<a>"- , "<em>Hello world !</em>"- , "</a>"- , "<b>"- , "</b>"- ]--testTakeAnyTreeContent :: Assertion-testTakeAnyTreeContent = do- result <- runConduitRes $ P.parseLBS def input .| rootParser- result @?= Just- [ EventBeginElement "b" []- , EventContent (ContentText "Hello ")- , EventBeginElement "em" []- , EventContent (ContentText "world")- , EventEndElement "em"- , EventContent (ContentText " !")- , EventEndElement "b"- ]- where- rootParser = P.tagNoAttr "root" $ (P.takeAnyTreeContent >> void P.ignoreAnyTreeContent) .| CL.consume- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<root>"- , "<b>Hello <em>world</em> !</b> Welcome !"- , "</root>"- ]---testMany :: Assertion-testMany = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.many $ P.tagNoAttr "success" $ return ()- liftIO $ length x @?= 5- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "</hello>"- ]--testMany' :: Assertion-testMany' = runConduitRes $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.many' $ P.tagNoAttr "success" $ return ()- liftIO $ length x @?= 5- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<foobar/>"- , "<success/>"- , "<foo><bar attr=\"1\">some content</bar></foo>"- , "<success/>"- , "</hello>"- ]--testOrE :: IO ()-testOrE = runConduitRes $ runConduit $ P.parseLBS def input .| do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.tagNoAttr "failure" (return 1) `P.orE`- P.tagNoAttr "success" (return 2)- y <- P.tag' "success" (P.requireAttr "failure") (const $ return 1) `P.orE`- P.tag' "success" (P.requireAttr "success") (const $ return 2)- liftIO $ x @?= Just (2 :: Int)- liftIO $ y @?= Just (2 :: Int)- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success success=\"0\"/>"- , "</hello>"- ]--testConduitParser :: Assertion-testConduitParser = do- x <- runConduitRes- $ P.parseLBS def input- .| (P.force "need hello" $ P.tagNoAttr "hello" f)- .| CL.consume- liftIO $ x @?= [1, 1, 1]- where- input = L.concat- [ "<?xml version='1.0'?>"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<item/>"- , "<item/>"- , "<item/>"- , "</hello>"- ]- f :: C.MonadThrow m => ConduitT Event Int m ()- f = do- ma <- P.tagNoAttr "item" (return 1)- maybe (return ()) (\a -> C.yield a >> f) ma--omitXMLDeclaration :: Assertion-omitXMLDeclaration = Res.renderLBS settings input @?= spec- where- settings = def { Res.rsXMLDeclaration = False }- input = Res.Document (Prologue [] Nothing [])- (Res.Element "foo" Map.empty [Res.NodeContent "bar"])- []- spec = "<foo>bar</foo>"--hexEntityParsing :: Spec-hexEntityParsing = do- it "rejects leading 0x" $- go "<foo>�xff;</foo>" @?= Nothing- it "rejects leading 0X" $- go "<foo>�Xff;</foo>" @?= Nothing- it "accepts lowercase hex digits" $- go "<foo>ÿ</foo>" @?= Just (spec "\xff")- it "accepts uppercase hex digits" $- go "<foo>ÿ</foo>" @?= Just (spec "\xff")- --Note: this must be rejected, because, according to the XML spec, a- --legal EntityRef's entity matches Name, which can't start with a- --hash.- it "rejects trailing junk" $- go "<foo>ÿhello;</foo>" @?= Nothing- --Some of these next tests are XML 1.0 specific (i.e., they would- --differ for XML 1.1), but approximately no-one uses XML 1.1.- it "rejects illegal character #x0" $- go "<foo>�</foo>" @?= Nothing- it "rejects illegal character #xFFFE" $- go "<foo></foo>" @?= Nothing- it "rejects illegal character #xFFFF" $- go "<foo></foo>" @?= Nothing- it "rejects illegal character #xD900" $- go "<foo>�</foo>" @?= Nothing- it "rejects illegal character #xC" $- go "<foo></foo>" @?= Nothing- it "rejects illegal character #x1F" $- go "<foo></foo>" @?= Nothing- it "accepts astral plane character" $- go "<foo>􀛿</foo>" @?= Just (spec "\x1006ff")- it "accepts custom character references" $- go' customSettings "<foo></foo>" @?= Just (spec "\xff")- where- spec content = Document (Prologue [] Nothing [])- (Element "foo" [] [NodeContent (ContentText content)])- []-- go = either (const Nothing) Just . D.parseLBS def- go' settings = either (const Nothing) Just . D.parseLBS settings- customSettings = def { P.psDecodeIllegalCharacters = customDecoder }- customDecoder 12 = Just '\xff'- customDecoder _ = Nothing--name :: [Cu.Cursor] -> [Text]-name [] = []-name (c:cs) = ($ name cs) $ case Cu.node c of- Res.NodeElement e -> ((Res.nameLocalName $ Res.elementName e) :)- _ -> id--cursor :: Cu.Cursor-cursor =- Cu.fromDocument $ Res.parseLBS_ def input- where- input = L.concat- [ "<foo attr=\"x\">"- , "<bar1/>"- , "<bar2>"- , "<baz1/>"- , "<baz2 attr=\"y\"/>"- , "<baz3>a</baz3>"- , "</bar2>"- , "<bar3>"- , "<bin1/>"- , "b"- , "<bin2/>"- , "<bin3/>"- , "</bar3>"- , "<Bar1 xmlns=\"http://example.com\" Attr=\"q\"/>"- , "</foo>"- ]--bar2, baz2, bar3, bin2 :: Cu.Cursor-bar2 = Cu.child cursor !! 1-baz2 = Cu.child bar2 !! 1--bar3 = Cu.child cursor !! 2-bin2 = Cu.child bar3 !! 1--cursorParent, cursorAncestor, cursorOrSelf, cursorPreceding, cursorFollowing,- cursorPrecedingSib, cursorFollowingSib, cursorDescendant, cursorCheck,- cursorPredicate, cursorCheckNode, cursorCheckElement, cursorCheckName,- cursorAnyElement, cursorElement, cursorLaxElement, cursorContent,- cursorAttribute, cursorLaxAttribute, cursorHasAttribute,- cursorAttributeIs, cursorDeep, cursorForce, cursorForceM,- resolvedIdentifies, resolvedAllGood, resolvedMergeContent,- testHtmlEntities- :: Assertion-cursorParent = name (Cu.parent bar2) @?= ["foo"]-cursorAncestor = name (Cu.ancestor baz2) @?= ["bar2", "foo"]-cursorOrSelf = name (Cu.orSelf Cu.ancestor baz2) @?= ["baz2", "bar2", "foo"]-cursorPreceding = do- name (Cu.preceding baz2) @?= ["baz1", "bar1"]- name (Cu.preceding bin2) @?= ["bin1", "baz3", "baz2", "baz1", "bar2", "bar1"]-cursorFollowing = do- name (Cu.following baz2) @?= ["baz3", "bar3", "bin1", "bin2", "bin3", "Bar1"]- name (Cu.following bar2) @?= ["bar3", "bin1", "bin2", "bin3", "Bar1"]-cursorPrecedingSib = name (Cu.precedingSibling baz2) @?= ["baz1"]-cursorFollowingSib = name (Cu.followingSibling baz2) @?= ["baz3"]-cursorDescendant = (name $ Cu.descendant cursor) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"-cursorCheck = null (cursor $.// Cu.check (const False)) @?= True-cursorPredicate = (name $ cursor $.// Cu.check Cu.descendant) @?= T.words "foo bar2 baz3 bar3"-cursorCheckNode = (name $ cursor $// Cu.checkNode f) @?= T.words "bar1 bar2 bar3"- where f (Res.NodeElement e) = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)- f _ = False-cursorCheckElement = (name $ cursor $// Cu.checkElement f) @?= T.words "bar1 bar2 bar3"- where f e = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)-cursorCheckName = (name $ cursor $// Cu.checkName f) @?= T.words "bar1 bar2 bar3"- where f n = "bar" `T.isPrefixOf` nameLocalName n-cursorAnyElement = (name $ cursor $// Cu.anyElement) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"-cursorElement = (name $ cursor $// Cu.element "bar1") @?= ["bar1"]-cursorLaxElement = (name $ cursor $// Cu.laxElement "bar1") @?= ["bar1", "Bar1"]-cursorContent = do- Cu.content cursor @?= []- (cursor $.// Cu.content) @?= ["a", "b"]-cursorAttribute = Cu.attribute "attr" cursor @?= ["x"]-cursorLaxAttribute = (cursor $.// Cu.laxAttribute "Attr") @?= ["x", "y", "q"]--cursorHasAttribute = (length $ cursor $.// Cu.hasAttribute "attr") @?= 2-cursorAttributeIs = (length $ cursor $.// Cu.attributeIs "attr" "y") @?= 1--cursorDeep = do- (Cu.element "foo" &/ Cu.element "bar2" &// Cu.attribute "attr") cursor @?= ["y"]- (return &.// Cu.attribute "attr") cursor @?= ["x", "y"]- (cursor $.// Cu.attribute "attr") @?= ["x", "y"]- (cursor $/ Cu.element "bar2" &// Cu.attribute "attr") @?= ["y"]- (cursor $/ Cu.element "bar2" &/ Cu.element "baz2" >=> Cu.attribute "attr") @?= ["y"]- null (cursor $| Cu.element "foo") @?= False-cursorForce = do- Cu.force DummyEx [] @?= (Nothing :: Maybe Integer)- Cu.force DummyEx [1] @?= Just (1 :: Int)- Cu.force DummyEx [1,2] @?= Just (1 :: Int)-cursorForceM = do- Cu.forceM DummyEx [] @?= (Nothing :: Maybe Integer)- Cu.forceM DummyEx [Just 1, Nothing] @?= Just (1 :: Int)- Cu.forceM DummyEx [Nothing, Just (1 :: Int)] @?= Nothing--data DummyEx = DummyEx- deriving (Show, Typeable)-instance Exception DummyEx--showEq :: (Show a, Show b) => Either a b -> Either a b -> Assertion-showEq x y = show x @=? show y--resolvedIdentifies =- Left (toException $ Res.UnresolvedEntityException $ Set.fromList ["foo", "bar", "baz"]) `showEq`- Res.parseLBS def- "<root attr='&bar;'>&foo; --- &baz; &foo;</root>"--testHtmlEntities =- Res.parseLBS_ def- { P.psDecodeEntities = P.decodeHtmlEntities- } xml1 @=? Res.parseLBS_ def xml2- where- xml1 = "<root> </root>"- xml2 = "<root> </root>"--resolvedAllGood =- D.parseLBS_ def xml @=?- Res.toXMLDocument (Res.parseLBS_ def xml)- where- xml = "<foo><bar/><baz/></foo>"--resolvedMergeContent =- Res.documentRoot (Res.parseLBS_ def xml) @=?- Res.Element "foo" Map.empty [Res.NodeContent "bar&baz"]- where- xml = "<foo>bar&baz</foo>"--parseIgnoreBOM :: Assertion-parseIgnoreBOM = do- either (const $ Left (1 :: Int)) Right (Res.parseText Res.def "\xfeef<foo/>") @?=- either (const $ Left (2 :: Int)) Right (Res.parseText Res.def "<foo/>")--stripDuplicateAttributes :: Assertion-stripDuplicateAttributes = do- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo bar=\"baz\"/>" @=?- D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [("bar", [ContentText "baz"]), ("bar", [ContentText "bin"])] []) [])- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo x:bar=\"baz\" xmlns:x=\"namespace\"/>" @=?- D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo"- [ ("x:bar", [ContentText "baz"])- , (Name "bar" (Just "namespace") (Just "x"), [ContentText "bin"])- ] []) [])--testRenderComments :: Assertion-testRenderComments =do- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo><!--comment--></foo>"- @=? D.renderLBS def (Document (Prologue [] Nothing [])- (Element "foo" [] [NodeComment "comment"]) [])--resolvedInline :: Assertion-resolvedInline = do- Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo>&bar;</foo>"- root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"]- Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>"- root2 @?= Res.Element "foo" (Map.singleton "bar" "baz") []--casePretty :: Assertion-casePretty = do- let pretty = S.unlines- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<!DOCTYPE foo>"- , "<foo bar=\"bar\" baz=\"baz\">"- , " <foo"- , " bar=\"bar\""- , " baz=\"baz\""- , " bin=\"bin\">"- , " Hello World"- , " </foo>"- , " <foo/>"- , " <?foo bar?>"- , " <!-- foo bar baz bin -->"- , " <bar>"- , " bar content"- , " </bar>"- , "</foo>"- ]- doctype = Res.Doctype "foo" Nothing- doc = Res.Document (Res.Prologue [] (Just doctype) []) root []- root = Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz")])- [ Res.NodeElement $ Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz"), ("bin", "bin")])- [ Res.NodeContent " Hello World\n\n"- , Res.NodeContent " "- ]- , Res.NodeElement $ Res.Element "foo" Map.empty []- , Res.NodeInstruction $ Res.Instruction "foo" "bar"- , Res.NodeComment "foo bar\n\r\nbaz \tbin "- , Res.NodeElement $ Res.Element "bar" Map.empty [Res.NodeContent "bar content"]- ]- pretty @=? S.concat (L.toChunks $ Res.renderLBS def { D.rsPretty = True } doc)--caseTopLevelNamespace :: Assertion-caseTopLevelNamespace = do- let lbs = S.concat- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo xmlns:bar=\"baz\">"- , "<subfoo bar:bin=\"\"/>"- , "</foo>"- ]- rs = def { D.rsNamespaces = [("bar", "baz")] }- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "foo" Map.empty- [ Res.NodeElement- $ Res.Element "subfoo" (Map.singleton "{baz}bin" "") []- ])- []- lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)--caseTopLevelNamespacePrefix :: Assertion-caseTopLevelNamespacePrefix = do- let lbs = S.concat- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo xmlns:bar=\"baz\">"- , "<subfoo bar:bin=\"\"/>"- , "</foo>"- ]- rs = def { D.rsNamespaces = [("bar", "baz")] }- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "foo" Map.empty- [ Res.NodeElement- $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) []- ])- []- lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)--caseTLNConflict :: Assertion-caseTLNConflict = do- let lbs = S.concat- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo xmlns:bar=\"something\" bar:x=\"y\">"- , "<subfoo xmlns:bar_=\"baz\" bar_:bin=\"\"/>"- , "</foo>"- ]- rs = def { D.rsNamespaces = [("bar", "baz")] }- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "foo" (Map.fromList [(Name "x" (Just "something") (Just "bar"), "y")])- [ Res.NodeElement- $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) []- ])- []- lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)--caseBlazeHtml :: Assertion-caseBlazeHtml =- expected @=? str- where- str = renderMarkup $ toMarkup $ Res.Document (Res.Prologue [] Nothing []) root []- root :: Res.Element- root = Res.Element "html" Map.empty- [ Res.NodeElement $ Res.Element "head" Map.empty- [ Res.NodeElement $ Res.Element "title" Map.empty [Res.NodeContent "Test"]- , Res.NodeElement $ Res.Element "script" Map.empty- [Res.NodeContent "if (5 < 6 || 8 > 9) alert('Hello World!');"]- , Res.NodeElement $ Res.Element "{http://www.snoyman.com/xml2html}ie-cond" (Map.singleton "cond" "lt IE 7")- [Res.NodeElement $ Res.Element "link" (Map.singleton "href" "ie6.css") []]- , Res.NodeElement $ Res.Element "style" Map.empty- [Res.NodeContent "body > h1 { color: red }"]- ]- , Res.NodeElement $ Res.Element "body" Map.empty- [ Res.NodeElement $ Res.Element "h1" Map.empty [Res.NodeContent "Hello World!"]- ]- ]- expected :: String- expected = concat- [ "<!DOCTYPE HTML>\n"- , "<html><head><title>Test</title><script>if (5 < 6 || 8 > 9) alert('Hello World!');</script>"- , "<!--[if lt IE 7]><link href=\"ie6.css\" /><![endif]-->"- , "<style>body > h1 { color: red }</style>"- , "</head>"- , "<body><h1>Hello World!</h1></body></html>"- ]--caseAttrReorder :: Assertion-caseAttrReorder = do- let lbs = S.concat- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo c=\"c\" b=\"b\" a=\"a\">"- , "<bar a=\"a\" b=\"b\" c=\"c\"/>"- , "</foo>"- ]- rs = def { Res.rsAttrOrder = \name' m ->- case name' of- "foo" -> reverse $ Map.toAscList m- _ -> Map.toAscList m- }- attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")]- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "foo" attrs- [ Res.NodeElement- $ Res.Element "bar" attrs []- ])- []- lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)--caseOrderAttrs :: Assertion-caseOrderAttrs = do- let lbs = S.concat- [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"- , "<foo c=\"c\" b=\"b\" a=\"a\">"- , "<bar a=\"a\" b=\"b\" c=\"c\"/>"- , "</foo>"- ]- rs = def { Res.rsAttrOrder = Res.orderAttrs- [("foo", ["c", "b"])]- }- attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")]- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "foo" attrs- [ Res.NodeElement- $ Res.Element "bar" attrs []- ])- []- lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)--caseParseCdata :: Assertion-caseParseCdata = do- let lbs = "<a><![CDATA[www.google.com]]></a>"- doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "a" Map.empty- [ Res.NodeContent "www.google.com"- ])- []- Res.parseLBS_ def lbs @?= doc--caseRetainNamespaces :: Assertion-caseRetainNamespaces = do- let lbs = "<foo xmlns:bar='baz'><bar:bin/><bin3 xmlns='bin4'></bin3></foo>"- doc = Res.parseLBS_ def { Res.psRetainNamespaces = True } lbs- doc `shouldBe` Res.Document- (Res.Prologue [] Nothing [])- (Res.Element- "foo"- (Map.singleton "xmlns:bar" "baz")- [ Res.NodeElement $ Res.Element- "{baz}bin"- Map.empty- []- , Res.NodeElement $ Res.Element- "{bin4}bin3"- (Map.singleton "xmlns" "bin4")- []- ])- []--caseIso8859_1 :: Assertion-caseIso8859_1 = do- let lbs = "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>\232</foo>"- doc = Res.parseLBS_ def lbs- doc `shouldBe` Res.Document- (Res.Prologue [] Nothing [])- (Res.Element- "foo"- Map.empty- [Res.NodeContent "\232"])- []--caseRenderCDATA :: Assertion-caseRenderCDATA = do- let doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "a" Map.empty- [ Res.NodeContent "www.google.com"- ])- []- withoutCDATA = Res.renderLBS def doc- withCDATA = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc- withCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[www.google.com]]></a>"- withoutCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a>www.google.com</a>"--caseEscapesCDATA :: Assertion-caseEscapesCDATA = do- let doc = Res.Document (Res.Prologue [] Nothing [])- (Res.Element "a" Map.empty- [ Res.NodeContent "]]>"- ])- []- result = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc- result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[]]]]><![CDATA[>]]></a>"
+ test/unit.hs view
@@ -0,0 +1,955 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Exception (Exception, toException)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Typeable (Typeable)+import Data.XML.Types+import Test.Hspec+import Test.HUnit hiding (Test)+import qualified Text.XML as Res+import qualified Text.XML.Cursor as Cu+import Text.XML.Stream.Parse (def)+import qualified Text.XML.Stream.Parse as P+import qualified Text.XML.Unresolved as D++import Control.Monad+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML.Cursor (($.//), ($/), ($//), ($|),+ (&.//), (&/), (&//))++import qualified Control.Monad.Trans.Resource as C+import Data.Conduit ((.|), runConduit, runConduitRes, ConduitT)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.Map as Map+import Text.Blaze (toMarkup)+import Text.Blaze.Renderer.String (renderMarkup)++main :: IO ()+main = hspec $ do+ describe "XML parsing and rendering" $ do+ it "is idempotent to parse and render a document" documentParseRender+ it "has valid parser combinators" combinators+ context "has working choose function" testChoose+ it "has working many function" testMany+ it "has working many' function" testMany'+ it "has working manyYield function" testManyYield+ it "has working takeContent function" testTakeContent+ it "has working takeTree function" testTakeTree+ it "has working takeAnyTreeContent function" testTakeAnyTreeContent+ it "has working orE" testOrE+ it "is idempotent to parse and pretty render a document" documentParsePrettyRender+ it "ignores the BOM" parseIgnoreBOM+ it "strips duplicated attributes" stripDuplicateAttributes+ it "displays comments" testRenderComments+ it "conduit parser" testConduitParser+ it "can omit the XML declaration" omitXMLDeclaration+ context "correctly parses hexadecimal entities" hexEntityParsing+ describe "XML Cursors" $ do+ it "has correct parent" cursorParent+ it "has correct ancestor" cursorAncestor+ it "has correct orSelf" cursorOrSelf+ it "has correct preceding" cursorPreceding+ it "has correct following" cursorFollowing+ it "has correct precedingSibling" cursorPrecedingSib+ it "has correct followingSibling" cursorFollowingSib+ it "has correct descendant" cursorDescendant+ it "has correct check" cursorCheck+ it "has correct check with lists" cursorPredicate+ it "has correct checkNode" cursorCheckNode+ it "has correct checkElement" cursorCheckElement+ it "has correct checkName" cursorCheckName+ it "has correct anyElement" cursorAnyElement+ it "has correct element" cursorElement+ it "has correct laxElement" cursorLaxElement+ it "has correct content" cursorContent+ it "has correct attribute" cursorAttribute+ it "has correct laxAttribute" cursorLaxAttribute+ it "has correct &* and $* operators" cursorDeep+ it "has correct force" cursorForce+ it "has correct forceM" cursorForceM+ it "has correct hasAttribute" cursorHasAttribute+ it "has correct attributeIs" cursorAttributeIs+ describe "resolved" $ do+ it "identifies unresolved entities" resolvedIdentifies+ it "decodeHtmlEntities" testHtmlEntities+ it "works for resolvable entities" resolvedAllGood+ it "merges adjacent content nodes" resolvedMergeContent+ it "understands inline entity declarations" resolvedInline+ describe "pretty" $ do+ it "works" casePretty+ describe "top level namespaces" $ do+ it "works" caseTopLevelNamespace+ it "works with prefix" caseTopLevelNamespacePrefix+ it "handles conflicts" caseTLNConflict+ describe "blaze-html instances" $ do+ it "works" caseBlazeHtml+ describe "attribute reordering" $ do+ it "works" caseAttrReorder+ describe "ordering attributes explicitly" $ do+ it "works" caseOrderAttrs+ it "parsing CDATA" caseParseCdata+ it "retains namespaces when asked" caseRetainNamespaces+ it "handles iso-8859-1" caseIso8859_1+ it "renders CDATA when asked" caseRenderCDATA+ it "escapes CDATA closing tag in CDATA" caseEscapesCDATA++documentParseRender :: IO ()+documentParseRender =+ mapM_ go docs+ where+ go x = x @=? D.parseLBS_ def (D.renderLBS def x)+ docs =+ [ Document (Prologue [] Nothing [])+ (Element "foo" [] [])+ []+ , D.parseLBS_ def+ "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo/>"+ , D.parseLBS_ def+ "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"+ , D.parseLBS_ def+ "<foo><![CDATA[this is some<CDATA content>]]></foo>"+ , D.parseLBS_ def+ "<foo bar='baz&bin'/>"+ , D.parseLBS_ def+ "<foo><?instr this is a processing instruction?></foo>"+ , D.parseLBS_ def+ "<foo><!-- this is a comment --></foo>"+ ]++documentParsePrettyRender :: IO ()+documentParsePrettyRender =+ L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc+ where+ doc = L.unlines+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo>"+ , " <?bar bar?>"+ , " text"+ , " <?bin bin?>"+ , "</foo>"+ ]++combinators :: Assertion+combinators = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tag' "hello" (P.requireAttr "world") $ \world -> do+ liftIO $ world @?= "true"+ P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()+ P.force "need child2" $ P.tagNoAttr "child2" $ return ()+ P.force "need child3" $ P.tagNoAttr "child3" $ do+ x <- P.contentMaybe+ liftIO $ x @?= Just "combine <all> &content"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello world='true'>"+ , "<?this should be ignored?>"+ , "<child1 xmlns='mynamespace'/>"+ , "<!-- this should be ignored -->"+ , "<child2> </child2>"+ , "<child3>combine <all> <![CDATA[&content]]></child3>\n"+ , "</hello>"+ ]++testChoose :: Spec+testChoose = do+ it "can choose between elements"+ testChooseEitherElem+ it "can choose between elements and text, returning text"+ testChooseElemOrTextIsText+ it "can choose between elements and text, returning elements"+ testChooseElemOrTextIsElem+ it "can choose between text and elements, returning text"+ testChooseTextOrElemIsText+ it "can choose between text and elements, returning elements"+ testChooseTextOrElemIsElem+ it "can choose between text and elements, when the text is encoded"+ testChooseElemOrTextIsEncoded+ it "can choose between text and elements, when the text is encoded, NBSP"+ testChooseElemOrTextIsEncodedNBSP+ it "can choose between elements and text, when the text is whitespace"+ testChooseElemOrTextIsWhiteSpace+ it "can choose between text and elements, when the text is whitespace"+ testChooseTextOrElemIsWhiteSpace+ it "can choose between text and elements, when the whitespace is both literal and encoded"+ testChooseElemOrTextIsChunkedText+ it "can choose between text and elements, when the text is chunked the other way"+ testChooseElemOrTextIsChunkedText2++testChooseElemOrTextIsText :: Assertion+testChooseElemOrTextIsText = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just " something "+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , " something "+ , "</hello>"+ ]++testChooseElemOrTextIsEncoded :: Assertion+testChooseElemOrTextIsEncoded = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "\x20something\x20"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , " something "+ , "</hello>"+ ]++testChooseElemOrTextIsEncodedNBSP :: Assertion+testChooseElemOrTextIsEncodedNBSP = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "\160something\160"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , " something "+ , "</hello>"+ ]+++testChooseElemOrTextIsWhiteSpace :: Assertion+testChooseElemOrTextIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "\x20\x20\x20"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello> </hello>"+ ]++testChooseTextOrElemIsWhiteSpace :: Assertion+testChooseTextOrElemIsWhiteSpace = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.contentMaybe+ , P.tagNoAttr "failure" $ return "boom"+ ]+ liftIO $ x @?= Just "\x20\x20\x20"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello> </hello>"+ ]++testChooseElemOrTextIsChunkedText :: Assertion+testChooseElemOrTextIsChunkedText = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "\x20\x20\x20"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>   </hello>"+ ]++testChooseElemOrTextIsChunkedText2 :: Assertion+testChooseElemOrTextIsChunkedText2 = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return "boom"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "\x20\x20\x20"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>   </hello>"+ ]++testChooseElemOrTextIsElem :: Assertion+testChooseElemOrTextIsElem = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "success" $ return "success"+ , P.contentMaybe+ ]+ liftIO $ x @?= Just "success"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]++testChooseTextOrElemIsText :: Assertion+testChooseTextOrElemIsText = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.contentMaybe+ , P.tagNoAttr "failure" $ return "boom"+ ]+ liftIO $ x @?= Just " something "+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , " something "+ , "</hello>"+ ]++testChooseTextOrElemIsElem :: Assertion+testChooseTextOrElemIsElem = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.contentMaybe+ , P.tagNoAttr "success" $ return "success"+ ]+ liftIO $ x @?= Just "success"+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]++testChooseEitherElem :: Assertion+testChooseEitherElem = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return 1+ , P.tagNoAttr "success" $ return 2+ ]+ liftIO $ x @?= Just (2 :: Int)+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]++testManyYield :: Assertion+testManyYield = do+ -- Basically the same as testMany, but consume the streamed result+ result <- runConduitRes $+ P.parseLBS def input .| helloParser+ .| CL.consume+ length result @?= 5+ where+ helloParser = void $ P.tagNoAttr "hello" $ P.manyYield successParser+ successParser = P.tagNoAttr "success" $ return ()+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "</hello>"+ ]++testTakeContent :: Assertion+testTakeContent = do+ result <- runConduitRes $ P.parseLBS def input .| rootParser+ result @?= Just+ [ EventContent (ContentText "Hello world !")+ ]+ where+ rootParser = P.tagNoAttr "root" $ void (P.takeContent >> P.takeContent) .| CL.consume+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<root>"+ , "Hello world !"+ , "</root>"+ ]++testTakeTree :: Assertion+testTakeTree = do+ result <- runConduitRes $ P.parseLBS def input .| rootParser+ result @?=+ [ EventBeginDocument+ , EventBeginDoctype "foo" Nothing+ , EventEndDoctype+ , EventBeginElement "a" []+ , EventBeginElement "em" []+ , EventContent (ContentText "Hello world !")+ , EventEndElement "em"+ , EventEndElement "a"+ ]+ where+ rootParser = void (P.takeTree "a" P.ignoreAttrs) .| CL.consume+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<a>"+ , "<em>Hello world !</em>"+ , "</a>"+ , "<b>"+ , "</b>"+ ]++testTakeAnyTreeContent :: Assertion+testTakeAnyTreeContent = do+ result <- runConduitRes $ P.parseLBS def input .| rootParser+ result @?= Just+ [ EventBeginElement "b" []+ , EventContent (ContentText "Hello ")+ , EventBeginElement "em" []+ , EventContent (ContentText "world")+ , EventEndElement "em"+ , EventContent (ContentText " !")+ , EventEndElement "b"+ ]+ where+ rootParser = P.tagNoAttr "root" $ (P.takeAnyTreeContent >> void P.ignoreAnyTreeContent) .| CL.consume+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<root>"+ , "<b>Hello <em>world</em> !</b> Welcome !"+ , "</root>"+ ]+++testMany :: Assertion+testMany = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.many $ P.tagNoAttr "success" $ return ()+ liftIO $ length x @?= 5+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "</hello>"+ ]++testMany' :: Assertion+testMany' = runConduitRes $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.many' $ P.tagNoAttr "success" $ return ()+ liftIO $ length x @?= 5+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<foobar/>"+ , "<success/>"+ , "<foo><bar attr=\"1\">some content</bar></foo>"+ , "<success/>"+ , "</hello>"+ ]++testOrE :: IO ()+testOrE = runConduitRes $ runConduit $ P.parseLBS def input .| do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.tagNoAttr "failure" (return 1) `P.orE`+ P.tagNoAttr "success" (return 2)+ y <- P.tag' "success" (P.requireAttr "failure") (const $ return 1) `P.orE`+ P.tag' "success" (P.requireAttr "success") (const $ return 2)+ liftIO $ x @?= Just (2 :: Int)+ liftIO $ y @?= Just (2 :: Int)+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success success=\"0\"/>"+ , "</hello>"+ ]++testConduitParser :: Assertion+testConduitParser = do+ x <- runConduitRes+ $ P.parseLBS def input+ .| (P.force "need hello" $ P.tagNoAttr "hello" f)+ .| CL.consume+ liftIO $ x @?= [1, 1, 1]+ where+ input = L.concat+ [ "<?xml version='1.0'?>"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<item/>"+ , "<item/>"+ , "<item/>"+ , "</hello>"+ ]+ f :: C.MonadThrow m => ConduitT Event Int m ()+ f = do+ ma <- P.tagNoAttr "item" (return 1)+ maybe (return ()) (\a -> C.yield a >> f) ma++omitXMLDeclaration :: Assertion+omitXMLDeclaration = Res.renderLBS settings input @?= spec+ where+ settings = def { Res.rsXMLDeclaration = False }+ input = Res.Document (Prologue [] Nothing [])+ (Res.Element "foo" Map.empty [Res.NodeContent "bar"])+ []+ spec = "<foo>bar</foo>"++hexEntityParsing :: Spec+hexEntityParsing = do+ it "rejects leading 0x" $+ go "<foo>�xff;</foo>" @?= Nothing+ it "rejects leading 0X" $+ go "<foo>�Xff;</foo>" @?= Nothing+ it "accepts lowercase hex digits" $+ go "<foo>ÿ</foo>" @?= Just (spec "\xff")+ it "accepts uppercase hex digits" $+ go "<foo>ÿ</foo>" @?= Just (spec "\xff")+ --Note: this must be rejected, because, according to the XML spec, a+ --legal EntityRef's entity matches Name, which can't start with a+ --hash.+ it "rejects trailing junk" $+ go "<foo>ÿhello;</foo>" @?= Nothing+ --Some of these next tests are XML 1.0 specific (i.e., they would+ --differ for XML 1.1), but approximately no-one uses XML 1.1.+ it "rejects illegal character #x0" $+ go "<foo>�</foo>" @?= Nothing+ it "rejects illegal character #xFFFE" $+ go "<foo></foo>" @?= Nothing+ it "rejects illegal character #xFFFF" $+ go "<foo></foo>" @?= Nothing+ it "rejects illegal character #xD900" $+ go "<foo>�</foo>" @?= Nothing+ it "rejects illegal character #xC" $+ go "<foo></foo>" @?= Nothing+ it "rejects illegal character #x1F" $+ go "<foo></foo>" @?= Nothing+ it "accepts astral plane character" $+ go "<foo>􀛿</foo>" @?= Just (spec "\x1006ff")+ it "accepts custom character references" $+ go' customSettings "<foo></foo>" @?= Just (spec "\xff")+ where+ spec content = Document (Prologue [] Nothing [])+ (Element "foo" [] [NodeContent (ContentText content)])+ []++ go = either (const Nothing) Just . D.parseLBS def+ go' settings = either (const Nothing) Just . D.parseLBS settings+ customSettings = def { P.psDecodeIllegalCharacters = customDecoder }+ customDecoder 12 = Just '\xff'+ customDecoder _ = Nothing++name :: [Cu.Cursor] -> [Text]+name [] = []+name (c:cs) = ($ name cs) $ case Cu.node c of+ Res.NodeElement e -> ((Res.nameLocalName $ Res.elementName e) :)+ _ -> id++cursor :: Cu.Cursor+cursor =+ Cu.fromDocument $ Res.parseLBS_ def input+ where+ input = L.concat+ [ "<foo attr=\"x\">"+ , "<bar1/>"+ , "<bar2>"+ , "<baz1/>"+ , "<baz2 attr=\"y\"/>"+ , "<baz3>a</baz3>"+ , "</bar2>"+ , "<bar3>"+ , "<bin1/>"+ , "b"+ , "<bin2/>"+ , "<bin3/>"+ , "</bar3>"+ , "<Bar1 xmlns=\"http://example.com\" Attr=\"q\"/>"+ , "</foo>"+ ]++bar2, baz2, bar3, bin2 :: Cu.Cursor+bar2 = Cu.child cursor !! 1+baz2 = Cu.child bar2 !! 1++bar3 = Cu.child cursor !! 2+bin2 = Cu.child bar3 !! 1++cursorParent, cursorAncestor, cursorOrSelf, cursorPreceding, cursorFollowing,+ cursorPrecedingSib, cursorFollowingSib, cursorDescendant, cursorCheck,+ cursorPredicate, cursorCheckNode, cursorCheckElement, cursorCheckName,+ cursorAnyElement, cursorElement, cursorLaxElement, cursorContent,+ cursorAttribute, cursorLaxAttribute, cursorHasAttribute,+ cursorAttributeIs, cursorDeep, cursorForce, cursorForceM,+ resolvedIdentifies, resolvedAllGood, resolvedMergeContent,+ testHtmlEntities+ :: Assertion+cursorParent = name (Cu.parent bar2) @?= ["foo"]+cursorAncestor = name (Cu.ancestor baz2) @?= ["bar2", "foo"]+cursorOrSelf = name (Cu.orSelf Cu.ancestor baz2) @?= ["baz2", "bar2", "foo"]+cursorPreceding = do+ name (Cu.preceding baz2) @?= ["baz1", "bar1"]+ name (Cu.preceding bin2) @?= ["bin1", "baz3", "baz2", "baz1", "bar2", "bar1"]+cursorFollowing = do+ name (Cu.following baz2) @?= ["baz3", "bar3", "bin1", "bin2", "bin3", "Bar1"]+ name (Cu.following bar2) @?= ["bar3", "bin1", "bin2", "bin3", "Bar1"]+cursorPrecedingSib = name (Cu.precedingSibling baz2) @?= ["baz1"]+cursorFollowingSib = name (Cu.followingSibling baz2) @?= ["baz3"]+cursorDescendant = (name $ Cu.descendant cursor) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"+cursorCheck = null (cursor $.// Cu.check (const False)) @?= True+cursorPredicate = (name $ cursor $.// Cu.check Cu.descendant) @?= T.words "foo bar2 baz3 bar3"+cursorCheckNode = (name $ cursor $// Cu.checkNode f) @?= T.words "bar1 bar2 bar3"+ where f (Res.NodeElement e) = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)+ f _ = False+cursorCheckElement = (name $ cursor $// Cu.checkElement f) @?= T.words "bar1 bar2 bar3"+ where f e = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)+cursorCheckName = (name $ cursor $// Cu.checkName f) @?= T.words "bar1 bar2 bar3"+ where f n = "bar" `T.isPrefixOf` nameLocalName n+cursorAnyElement = (name $ cursor $// Cu.anyElement) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"+cursorElement = (name $ cursor $// Cu.element "bar1") @?= ["bar1"]+cursorLaxElement = (name $ cursor $// Cu.laxElement "bar1") @?= ["bar1", "Bar1"]+cursorContent = do+ Cu.content cursor @?= []+ (cursor $.// Cu.content) @?= ["a", "b"]+cursorAttribute = Cu.attribute "attr" cursor @?= ["x"]+cursorLaxAttribute = (cursor $.// Cu.laxAttribute "Attr") @?= ["x", "y", "q"]++cursorHasAttribute = (length $ cursor $.// Cu.hasAttribute "attr") @?= 2+cursorAttributeIs = (length $ cursor $.// Cu.attributeIs "attr" "y") @?= 1++cursorDeep = do+ (Cu.element "foo" &/ Cu.element "bar2" &// Cu.attribute "attr") cursor @?= ["y"]+ (return &.// Cu.attribute "attr") cursor @?= ["x", "y"]+ (cursor $.// Cu.attribute "attr") @?= ["x", "y"]+ (cursor $/ Cu.element "bar2" &// Cu.attribute "attr") @?= ["y"]+ (cursor $/ Cu.element "bar2" &/ Cu.element "baz2" >=> Cu.attribute "attr") @?= ["y"]+ null (cursor $| Cu.element "foo") @?= False+cursorForce = do+ Cu.force DummyEx [] @?= (Nothing :: Maybe Integer)+ Cu.force DummyEx [1] @?= Just (1 :: Int)+ Cu.force DummyEx [1,2] @?= Just (1 :: Int)+cursorForceM = do+ Cu.forceM DummyEx [] @?= (Nothing :: Maybe Integer)+ Cu.forceM DummyEx [Just 1, Nothing] @?= Just (1 :: Int)+ Cu.forceM DummyEx [Nothing, Just (1 :: Int)] @?= Nothing++data DummyEx = DummyEx+ deriving (Show, Typeable)+instance Exception DummyEx++showEq :: (Show a, Show b) => Either a b -> Either a b -> Assertion+showEq x y = show x @=? show y++resolvedIdentifies =+ Left (toException $ Res.UnresolvedEntityException $ Set.fromList ["foo", "bar", "baz"]) `showEq`+ Res.parseLBS def+ "<root attr='&bar;'>&foo; --- &baz; &foo;</root>"++testHtmlEntities =+ Res.parseLBS_ def+ { P.psDecodeEntities = P.decodeHtmlEntities+ } xml1 @=? Res.parseLBS_ def xml2+ where+ xml1 = "<root> </root>"+ xml2 = "<root> </root>"++resolvedAllGood =+ D.parseLBS_ def xml @=?+ Res.toXMLDocument (Res.parseLBS_ def xml)+ where+ xml = "<foo><bar/><baz/></foo>"++resolvedMergeContent =+ Res.documentRoot (Res.parseLBS_ def xml) @=?+ Res.Element "foo" Map.empty [Res.NodeContent "bar&baz"]+ where+ xml = "<foo>bar&baz</foo>"++parseIgnoreBOM :: Assertion+parseIgnoreBOM = do+ either (const $ Left (1 :: Int)) Right (Res.parseText Res.def "\xfeef<foo/>") @?=+ either (const $ Left (2 :: Int)) Right (Res.parseText Res.def "<foo/>")++stripDuplicateAttributes :: Assertion+stripDuplicateAttributes = do+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo bar=\"baz\"/>" @=?+ D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [("bar", [ContentText "baz"]), ("bar", [ContentText "bin"])] []) [])+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo x:bar=\"baz\" xmlns:x=\"namespace\"/>" @=?+ D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo"+ [ ("x:bar", [ContentText "baz"])+ , (Name "bar" (Just "namespace") (Just "x"), [ContentText "bin"])+ ] []) [])++testRenderComments :: Assertion+testRenderComments =do+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo><!--comment--></foo>"+ @=? D.renderLBS def (Document (Prologue [] Nothing [])+ (Element "foo" [] [NodeComment "comment"]) [])++resolvedInline :: Assertion+resolvedInline = do+ Res.Document _ root _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo>&bar;</foo>"+ root @?= Res.Element "foo" Map.empty [Res.NodeContent "baz"]+ Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>"+ root2 @?= Res.Element "foo" (Map.singleton "bar" "baz") []++casePretty :: Assertion+casePretty = do+ let pretty = S.unlines+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<!DOCTYPE foo>"+ , "<foo bar=\"bar\" baz=\"baz\">"+ , " <foo"+ , " bar=\"bar\""+ , " baz=\"baz\""+ , " bin=\"bin\">"+ , " Hello World"+ , " </foo>"+ , " <foo/>"+ , " <?foo bar?>"+ , " <!-- foo bar baz bin -->"+ , " <bar>"+ , " bar content"+ , " </bar>"+ , "</foo>"+ ]+ doctype = Res.Doctype "foo" Nothing+ doc = Res.Document (Res.Prologue [] (Just doctype) []) root []+ root = Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz")])+ [ Res.NodeElement $ Res.Element "foo" (Map.fromList [("bar", "bar"), ("baz", "baz"), ("bin", "bin")])+ [ Res.NodeContent " Hello World\n\n"+ , Res.NodeContent " "+ ]+ , Res.NodeElement $ Res.Element "foo" Map.empty []+ , Res.NodeInstruction $ Res.Instruction "foo" "bar"+ , Res.NodeComment "foo bar\n\r\nbaz \tbin "+ , Res.NodeElement $ Res.Element "bar" Map.empty [Res.NodeContent "bar content"]+ ]+ pretty @=? S.concat (L.toChunks $ Res.renderLBS def { D.rsPretty = True } doc)++caseTopLevelNamespace :: Assertion+caseTopLevelNamespace = do+ let lbs = S.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo xmlns:bar=\"baz\">"+ , "<subfoo bar:bin=\"\"/>"+ , "</foo>"+ ]+ rs = def { D.rsNamespaces = [("bar", "baz")] }+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "foo" Map.empty+ [ Res.NodeElement+ $ Res.Element "subfoo" (Map.singleton "{baz}bin" "") []+ ])+ []+ lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)++caseTopLevelNamespacePrefix :: Assertion+caseTopLevelNamespacePrefix = do+ let lbs = S.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo xmlns:bar=\"baz\">"+ , "<subfoo bar:bin=\"\"/>"+ , "</foo>"+ ]+ rs = def { D.rsNamespaces = [("bar", "baz")] }+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "foo" Map.empty+ [ Res.NodeElement+ $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) []+ ])+ []+ lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)++caseTLNConflict :: Assertion+caseTLNConflict = do+ let lbs = S.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo xmlns:bar=\"something\" bar:x=\"y\">"+ , "<subfoo xmlns:bar_=\"baz\" bar_:bin=\"\"/>"+ , "</foo>"+ ]+ rs = def { D.rsNamespaces = [("bar", "baz")] }+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "foo" (Map.fromList [(Name "x" (Just "something") (Just "bar"), "y")])+ [ Res.NodeElement+ $ Res.Element "subfoo" (Map.fromList [(Name "bin" (Just "baz") (Just "bar"), "")]) []+ ])+ []+ lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)++caseBlazeHtml :: Assertion+caseBlazeHtml =+ expected @=? str+ where+ str = renderMarkup $ toMarkup $ Res.Document (Res.Prologue [] Nothing []) root []+ root :: Res.Element+ root = Res.Element "html" Map.empty+ [ Res.NodeElement $ Res.Element "head" Map.empty+ [ Res.NodeElement $ Res.Element "title" Map.empty [Res.NodeContent "Test"]+ , Res.NodeElement $ Res.Element "script" Map.empty+ [Res.NodeContent "if (5 < 6 || 8 > 9) alert('Hello World!');"]+ , Res.NodeElement $ Res.Element "{http://www.snoyman.com/xml2html}ie-cond" (Map.singleton "cond" "lt IE 7")+ [Res.NodeElement $ Res.Element "link" (Map.singleton "href" "ie6.css") []]+ , Res.NodeElement $ Res.Element "style" Map.empty+ [Res.NodeContent "body > h1 { color: red }"]+ ]+ , Res.NodeElement $ Res.Element "body" Map.empty+ [ Res.NodeElement $ Res.Element "h1" Map.empty [Res.NodeContent "Hello World!"]+ ]+ ]+ expected :: String+ expected = concat+ [ "<!DOCTYPE HTML>\n"+ , "<html><head><title>Test</title><script>if (5 < 6 || 8 > 9) alert('Hello World!');</script>"+ , "<!--[if lt IE 7]><link href=\"ie6.css\" /><![endif]-->"+ , "<style>body > h1 { color: red }</style>"+ , "</head>"+ , "<body><h1>Hello World!</h1></body></html>"+ ]++caseAttrReorder :: Assertion+caseAttrReorder = do+ let lbs = S.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo c=\"c\" b=\"b\" a=\"a\">"+ , "<bar a=\"a\" b=\"b\" c=\"c\"/>"+ , "</foo>"+ ]+ rs = def { Res.rsAttrOrder = \name' m ->+ case name' of+ "foo" -> reverse $ Map.toAscList m+ _ -> Map.toAscList m+ }+ attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")]+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "foo" attrs+ [ Res.NodeElement+ $ Res.Element "bar" attrs []+ ])+ []+ lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)++caseOrderAttrs :: Assertion+caseOrderAttrs = do+ let lbs = S.concat+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<foo c=\"c\" b=\"b\" a=\"a\">"+ , "<bar a=\"a\" b=\"b\" c=\"c\"/>"+ , "</foo>"+ ]+ rs = def { Res.rsAttrOrder = Res.orderAttrs+ [("foo", ["c", "b"])]+ }+ attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")]+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "foo" attrs+ [ Res.NodeElement+ $ Res.Element "bar" attrs []+ ])+ []+ lbs @=? S.concat (L.toChunks $ Res.renderLBS rs doc)++caseParseCdata :: Assertion+caseParseCdata = do+ let lbs = "<a><![CDATA[www.google.com]]></a>"+ doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "a" Map.empty+ [ Res.NodeContent "www.google.com"+ ])+ []+ Res.parseLBS_ def lbs @?= doc++caseRetainNamespaces :: Assertion+caseRetainNamespaces = do+ let lbs = "<foo xmlns:bar='baz'><bar:bin/><bin3 xmlns='bin4'></bin3></foo>"+ doc = Res.parseLBS_ def { Res.psRetainNamespaces = True } lbs+ doc `shouldBe` Res.Document+ (Res.Prologue [] Nothing [])+ (Res.Element+ "foo"+ (Map.singleton "xmlns:bar" "baz")+ [ Res.NodeElement $ Res.Element+ "{baz}bin"+ Map.empty+ []+ , Res.NodeElement $ Res.Element+ "{bin4}bin3"+ (Map.singleton "xmlns" "bin4")+ []+ ])+ []++caseIso8859_1 :: Assertion+caseIso8859_1 = do+ let lbs = "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>\232</foo>"+ doc = Res.parseLBS_ def lbs+ doc `shouldBe` Res.Document+ (Res.Prologue [] Nothing [])+ (Res.Element+ "foo"+ Map.empty+ [Res.NodeContent "\232"])+ []++caseRenderCDATA :: Assertion+caseRenderCDATA = do+ let doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "a" Map.empty+ [ Res.NodeContent "www.google.com"+ ])+ []+ withoutCDATA = Res.renderLBS def doc+ withCDATA = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc+ withCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[www.google.com]]></a>"+ withoutCDATA `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a>www.google.com</a>"++caseEscapesCDATA :: Assertion+caseEscapesCDATA = do+ let doc = Res.Document (Res.Prologue [] Nothing [])+ (Res.Element "a" Map.empty+ [ Res.NodeContent "]]>"+ ])+ []+ result = Res.renderLBS (def { Res.rsUseCDATA = const True }) doc+ result `shouldBe` "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a><![CDATA[]]]]><![CDATA[>]]></a>"
xml-conduit.cabal view
@@ -1,5 +1,5 @@ name: xml-conduit-version: 1.8.0+version: 1.8.0.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>@@ -11,8 +11,7 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://github.com/snoyberg/xml-extra-source-files: test/main.hs- README.md+extra-source-files: README.md ChangeLog.md library@@ -27,7 +26,6 @@ , attoparsec >= 0.10 , transformers >= 0.2 && < 0.6 , data-default-class- , monad-control >= 0.3 && < 1.1 , blaze-markup >= 0.5 , blaze-html >= 0.5 , deepseq >= 1.1.0.0@@ -40,9 +38,9 @@ other-modules: Text.XML.Stream.Token ghc-options: -Wall -test-suite test+test-suite unit type: exitcode-stdio-1.0- main-is: main.hs+ main-is: unit.hs hs-source-dirs: test build-depends: base , containers@@ -56,6 +54,13 @@ , conduit , blaze-markup , resourcet++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctest.hs+ hs-source-dirs: test+ build-depends: base+ , doctest >= 0.8 source-repository head type: git