From bf4a1c91fe6c2bd79c7c7597699d0a516a65c939 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Wed, 3 May 2017 16:30:36 -0600 Subject: [PATCH 01/59] Bump HUnit --- xmlhtml.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xmlhtml.cabal b/xmlhtml.cabal index 04384c1..55b86d6 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -846,7 +846,7 @@ Test-suite testsuite main-is: TestSuite.hs build-depends: - HUnit >= 1.2 && <1.6, + HUnit >= 1.2 && <1.7, base, blaze-builder, blaze-html, From 7b1ca6c81182ce4daf42111172bdf8ceffe111da Mon Sep 17 00:00:00 2001 From: Chris Smith Date: Fri, 19 May 2017 00:57:52 -0700 Subject: [PATCH 02/59] Always render anchor href attributes with explicit values. This is an exception to the normal rule that empty attributes use the abbreviated value-less syntax. The two forms are semantically equivalent, but some browsers prefer one or the other in different situations. --- src/Text/XmlHtml/HTML/Meta.hs | 11 +++++++++++ src/Text/XmlHtml/HTML/Render.hs | 22 +++++++++++++--------- test/src/Text/XmlHtml/Tests.hs | 16 ++++++++++++++++ 3 files changed, 40 insertions(+), 9 deletions(-) diff --git a/src/Text/XmlHtml/HTML/Meta.hs b/src/Text/XmlHtml/HTML/Meta.hs index 452d3c9..f624bb6 100644 --- a/src/Text/XmlHtml/HTML/Meta.hs +++ b/src/Text/XmlHtml/HTML/Meta.hs @@ -8,6 +8,7 @@ module Text.XmlHtml.HTML.Meta , isRawText , endOmittableLast , endOmittableNext + , explicitAttributes , predefinedRefs , reversePredefinedRefs ) where @@ -113,6 +114,16 @@ endOmittableNext = M.fromList [ ("tr", S.fromList ["tr"]) ] +------------------------------------------------------------------------------ +-- | Tags and attributes which should always be rendered with an explicit +-- value, even when the value is empty. This is required by some web browsers +-- for tags that are typically non-empty. +{-# NOINLINE explicitAttributes #-} +explicitAttributes :: HashMap Text (HashSet Text) +explicitAttributes = M.fromList [ + ("a", S.fromList ["href"]) + ] + ------------------------------------------------------------------------------ -- | Predefined character entity references as defined by the HTML5 spec. {-# NOINLINE predefinedRefs #-} diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index cd517b8..d4a238e 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -18,6 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M #if !MIN_VERSION_base(4,8,0) import Data.Monoid @@ -98,7 +99,7 @@ element e t tb a c | tb `S.member` voidTags && null c = fromText e "<" `mappend` fromText e t - `mappend` (mconcat $ map (attribute e) a) + `mappend` (mconcat $ map (attribute e tb) a) `mappend` fromText e " />" | tb `S.member` voidTags = error $ T.unpack t ++ " must be empty" @@ -108,7 +109,7 @@ element e t tb a c not ("" `mappend` fromText e s `mappend` fromText e "" `mappend` (mconcat $ map (node e) c) `mappend` fromText e " (Text, Text) -> Builder -attribute e (n,v) - | v == "" = +attribute :: Encoding -> Text -> (Text, Text) -> Builder +attribute e tb (n,v) + | v == "" && not explicit = fromText e " " `mappend` fromText e n - | not ("\'" `T.isInfixOf` v) = + | v /= "" && not ("\'" `T.isInfixOf` v) = fromText e " " `mappend` fromText e n `mappend` fromText e "=\'" `mappend` escaped "&" e v `mappend` fromText e "\'" - | otherwise = + | otherwise = fromText e " " `mappend` fromText e n `mappend` fromText e "=\"" `mappend` escaped "&\"" e v `mappend` fromText e "\"" - + where nbase = T.toLower $ snd $ T.breakOnEnd ":" n + explicit = case M.lookup tb explicitAttributes of + Nothing -> False + Just ns -> nbase `S.member` ns diff --git a/test/src/Text/XmlHtml/Tests.hs b/test/src/Text/XmlHtml/Tests.hs index e91e1da..32f018b 100644 --- a/test/src/Text/XmlHtml/Tests.hs +++ b/test/src/Text/XmlHtml/Tests.hs @@ -772,6 +772,8 @@ htmlRenderingQuirkTests = [ testIt "renderHTMLRaw2 " renderHTMLRaw2, testIt "renderHTMLRaw3 " renderHTMLRaw3, testIt "renderHTMLRaw4 " renderHTMLRaw4, + testIt "renderHTMLEmptyAttr " renderHTMLEmptyAttr, + testIt "renderHTMLEmptyAttr2 " renderHTMLEmptyAttr2, testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1, testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2, testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3, @@ -841,6 +843,20 @@ renderHTMLRaw4 = isBottom $ ] ])) +renderHTMLEmptyAttr :: Bool +renderHTMLEmptyAttr = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "input" [("checked", "")] [] + ])) + == "" + +renderHTMLEmptyAttr2 :: Bool +renderHTMLEmptyAttr2 = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "a" [("href", "")] [] + ])) + == "" + renderHTMLAmpAttr1 :: Bool renderHTMLAmpAttr1 = toByteString (render (HtmlDocument UTF8 Nothing [ From f9de07f779eb5289227aafe2df93ff3d251319c2 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 21 Jun 2017 15:21:35 -0400 Subject: [PATCH 03/59] Add RenderingOptions for setting the attribute value surround char --- src/Text/XmlHtml.hs | 10 +++- src/Text/XmlHtml/Common.hs | 13 +++++ src/Text/XmlHtml/HTML/Render.hs | 79 +++++++++++++++------------- src/Text/XmlHtml/XML/Render.hs | 92 ++++++++++++++++++--------------- 4 files changed, 114 insertions(+), 80 deletions(-) diff --git a/src/Text/XmlHtml.hs b/src/Text/XmlHtml.hs index 3db6deb..3633711 100644 --- a/src/Text/XmlHtml.hs +++ b/src/Text/XmlHtml.hs @@ -32,6 +32,8 @@ module Text.XmlHtml ( ExternalID(..), InternalSubset(..), Encoding(..), + RenderOptions(..), + AttributeSurround(..), -- * Manipulating documents isTextNode, @@ -57,6 +59,7 @@ module Text.XmlHtml ( -- * Rendering render, + renderWithOptions, XMLR.renderXmlFragment, HTML.renderHtmlFragment, renderDocType @@ -101,9 +104,12 @@ parseHTML = parse HTML.docFragment ------------------------------------------------------------------------------ -- | Renders a 'Document'. +renderWithOptions :: RenderOptions -> Document -> Builder +renderWithOptions opts (XmlDocument e dt ns) = XMLR.renderWithOptions opts e dt ns +renderWithOptions opts (HtmlDocument e dt ns) = HTML.renderWithOptions opts e dt ns + render :: Document -> Builder -render (XmlDocument e dt ns) = XMLR.render e dt ns -render (HtmlDocument e dt ns) = HTML.render e dt ns +render doc = renderWithOptions defaultRenderOptions doc renderDocType :: Encoding -> Maybe DocType -> Builder diff --git a/src/Text/XmlHtml/Common.hs b/src/Text/XmlHtml/Common.hs index acdad42..8416a97 100644 --- a/src/Text/XmlHtml/Common.hs +++ b/src/Text/XmlHtml/Common.hs @@ -50,6 +50,19 @@ data Node = TextNode !Text deriving (Eq, Show) +------------------------------------------------------------------------------ +-- | Rendering options. Attritube values may be surrounded by single quotes +-- (default), or by double quotes +data RenderOptions = RenderOptions { + attributeSurround :: AttributeSurround + } + +data AttributeSurround = SurroundDoubleQuote | SurroundSingleQuote + deriving (Eq, Ord, Show) + +defaultRenderOptions :: RenderOptions +defaultRenderOptions = RenderOptions SurroundSingleQuote + ------------------------------------------------------------------------------ -- | Determines whether the node is text or not. isTextNode :: Node -> Bool diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index cd517b8..41b3a61 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -25,24 +25,26 @@ import Data.Monoid ------------------------------------------------------------------------------ -- | And, the rendering code. -render :: Encoding -> Maybe DocType -> [Node] -> Builder -render e dt ns = byteOrder +renderWithOptions :: RenderOptions -> Encoding -> Maybe DocType -> [Node] -> Builder +renderWithOptions opts e dt ns = byteOrder `mappend` docTypeDecl e dt `mappend` nodes where byteOrder | isUTF16 e = fromText e "\xFEFF" -- byte order mark | otherwise = mempty nodes | null ns = mempty - | otherwise = firstNode e (head ns) - `mappend` (mconcat $ map (node e) (tail ns)) + | otherwise = firstNode opts e (head ns) + `mappend` (mconcat $ map (node opts e) (tail ns)) +render :: Encoding -> Maybe DocType -> [Node] -> Builder +render = renderWithOptions defaultRenderOptions ------------------------------------------------------------------------------ -- | Function for rendering HTML nodes without the overhead of creating a -- Document structure. -renderHtmlFragment :: Encoding -> [Node] -> Builder -renderHtmlFragment _ [] = mempty -renderHtmlFragment e (n:ns) = - firstNode e n `mappend` (mconcat $ map (node e) ns) +renderHtmlFragment :: RenderOptions -> Encoding -> [Node] -> Builder +renderHtmlFragment _ _ [] = mempty +renderHtmlFragment opts e (n:ns) = + firstNode opts e n `mappend` (mconcat $ map (node opts e) ns) ------------------------------------------------------------------------------ @@ -66,39 +68,39 @@ escaped bad e t = ------------------------------------------------------------------------------ -node :: Encoding -> Node -> Builder -node e (TextNode t) = escaped "<>&" e t -node e (Comment t) | "--" `T.isInfixOf` t = error "Invalid comment" - | "-" `T.isSuffixOf` t = error "Invalid comment" - | otherwise = fromText e "" -node e (Element t a c) = +node :: RenderOptions -> Encoding -> Node -> Builder +node _ e (TextNode t) = escaped "<>&" e t +node _ e (Comment t) | "--" `T.isInfixOf` t = error "Invalid comment" + | "-" `T.isSuffixOf` t = error "Invalid comment" + | otherwise = fromText e "" +node opts e (Element t a c) = let tbase = T.toLower $ snd $ T.breakOnEnd ":" t - in element e t tbase a c + in element opts e t tbase a c ------------------------------------------------------------------------------ -- | Process the first node differently to encode leading whitespace. This -- lets us be sure that @parseHTML@ is a left inverse to @render@. -firstNode :: Encoding -> Node -> Builder -firstNode e (Comment t) = node e (Comment t) -firstNode e (Element t a c) = node e (Element t a c) -firstNode _ (TextNode "") = mempty -firstNode e (TextNode t) = let (c,t') = fromJust $ T.uncons t - in escaped "<>& \t\r" e (T.singleton c) - `mappend` node e (TextNode t') +firstNode :: RenderOptions -> Encoding -> Node -> Builder +firstNode opts e (Comment t) = node opts e (Comment t) +firstNode opts e (Element t a c) = node opts e (Element t a c) +firstNode _ _ (TextNode "") = mempty +firstNode opts e (TextNode t) = let (c,t') = fromJust $ T.uncons t + in escaped "<>& \t\r" e (T.singleton c) + `mappend` node opts e (TextNode t') ------------------------------------------------------------------------------ -- XXX: Should do something to avoid concatting large CDATA sections before -- writing them to the output. -element :: Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder -element e t tb a c +element :: RenderOptions -> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder +element opts e t tb a c | tb `S.member` voidTags && null c = fromText e "<" `mappend` fromText e t - `mappend` (mconcat $ map (attribute e) a) + `mappend` (mconcat $ map (attribute opts e) a) `mappend` fromText e " />" | tb `S.member` voidTags = error $ T.unpack t ++ " must be empty" @@ -108,7 +110,7 @@ element e t tb a c not ("" `mappend` fromText e s `mappend` fromText e "" - `mappend` (mconcat $ map (node e) c) + `mappend` (mconcat $ map (node opts e) c) `mappend` fromText e "" ------------------------------------------------------------------------------ -attribute :: Encoding -> (Text, Text) -> Builder -attribute e (n,v) +attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder +attribute opts e (n,v) | v == "" = fromText e " " `mappend` fromText e n - | not ("\'" `T.isInfixOf` v) = + | not (preferredSurround `T.isInfixOf` v) = fromText e " " `mappend` fromText e n - `mappend` fromText e "=\'" + `mappend` fromText e ('=' `T.cons` preferredSurround) `mappend` escaped "&" e v - `mappend` fromText e "\'" + `mappend` fromText e preferredSurround | otherwise = fromText e " " `mappend` fromText e n - `mappend` fromText e "=\"" + `mappend` fromText e ('=' `T.cons` otherSurround) `mappend` escaped "&\"" e v - `mappend` fromText e "\"" + `mappend` fromText e otherSurround + where (preferredSurround, otherSurround) = case attributeSurround opts of + SurroundDoubleQuote -> ("\"", "\'") + SurroundSingleQuote -> ("\'", "\"") diff --git a/src/Text/XmlHtml/XML/Render.hs b/src/Text/XmlHtml/XML/Render.hs index 6f9c2e7..e74fb72 100644 --- a/src/Text/XmlHtml/XML/Render.hs +++ b/src/Text/XmlHtml/XML/Render.hs @@ -18,26 +18,31 @@ import Data.Monoid ------------------------------------------------------------------------------ -render :: Encoding -> Maybe DocType -> [Node] -> Builder -render e dt ns = byteOrder +renderWithOptions :: RenderOptions -> Encoding -> Maybe DocType -> [Node] -> Builder +renderWithOptions opts e dt ns = byteOrder `mappend` xmlDecl e `mappend` docTypeDecl e dt `mappend` nodes where byteOrder | isUTF16 e = fromText e "\xFEFF" -- byte order mark | otherwise = mempty nodes | null ns = mempty - | otherwise = firstNode e (head ns) - `mappend` (mconcat $ map (node e) (tail ns)) + | otherwise = firstNode opts e (head ns) + `mappend` (mconcat $ map (node opts e) (tail ns)) + +render :: Encoding -> Maybe DocType -> [Node] -> Builder +render = renderWithOptions defaultRenderOptions ------------------------------------------------------------------------------ -- | Function for rendering XML nodes without the overhead of creating a -- Document structure. -renderXmlFragment :: Encoding -> [Node] -> Builder -renderXmlFragment _ [] = mempty -renderXmlFragment e (n:ns) = - firstNode e n `mappend` (mconcat $ map (node e) ns) +renderXmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder +renderXmlFragmentWithOptions _ _ [] = mempty +renderXmlFragmentWithOptions opts e (n:ns) = + firstNode opts e n `mappend` (mconcat $ map (node opts e) ns) +renderXmlFragment :: Encoding -> [Node] -> Builder +renderXmlFragment = renderXmlFragmentWithOptions defaultRenderOptions ------------------------------------------------------------------------------ xmlDecl :: Encoding -> Builder @@ -93,26 +98,26 @@ pubID e sid | not ("\"" `T.isInfixOf` sid) = fromText e "\"" ------------------------------------------------------------------------------ -node :: Encoding -> Node -> Builder -node e (TextNode t) = escaped "<>&" e t -node e (Comment t) | "--" `T.isInfixOf` t = error "Invalid comment" - | "-" `T.isSuffixOf` t = error "Invalid comment" - | otherwise = fromText e "" -node e (Element t a c) = element e t a c +node :: RenderOptions -> Encoding -> Node -> Builder +node _ e (TextNode t) = escaped "<>&" e t +node _ e (Comment t) | "--" `T.isInfixOf` t = error "Invalid comment" + | "-" `T.isSuffixOf` t = error "Invalid comment" + | otherwise = fromText e "" +node opts e (Element t a c) = element opts e t a c ------------------------------------------------------------------------------ -- | Process the first node differently to encode leading whitespace. This -- lets us be sure that @parseXML@ is a left inverse to @render@. -firstNode :: Encoding -> Node -> Builder -firstNode e (Comment t) = node e (Comment t) -firstNode e (Element t a c) = node e (Element t a c) -firstNode _ (TextNode "") = mempty -firstNode e (TextNode t) = let (c,t') = fromJust $ T.uncons t - in escaped "<>& \t\r" e (T.singleton c) - `mappend` node e (TextNode t') +firstNode :: RenderOptions -> Encoding -> Node -> Builder +firstNode opts e (Comment t) = node opts e (Comment t) +firstNode opts e (Element t a c) = node opts e (Element t a c) +firstNode _ _ (TextNode "") = mempty +firstNode opts e (TextNode t) = let (c,t') = fromJust $ T.uncons t + in escaped "<>& \t\r" e (T.singleton c) + `mappend` node opts e (TextNode t') ------------------------------------------------------------------------------ @@ -137,31 +142,36 @@ entity e c = fromText e "&#" ------------------------------------------------------------------------------ -element :: Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder -element e t a [] = fromText e "<" +element :: RenderOptions -> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder +element opts e t a [] = fromText e "<" `mappend` fromText e t - `mappend` (mconcat $ map (attribute e) a) + `mappend` (mconcat $ map (attribute opts e) a) `mappend` fromText e "/>" -element e t a c = fromText e "<" +element opts e t a c = fromText e "<" `mappend` fromText e t - `mappend` (mconcat $ map (attribute e) a) + `mappend` (mconcat $ map (attribute opts e) a) `mappend` fromText e ">" - `mappend` (mconcat $ map (node e) c) + `mappend` (mconcat $ map (node opts e) c) `mappend` fromText e "" ------------------------------------------------------------------------------ -attribute :: Encoding -> (Text, Text) -> Builder -attribute e (n,v) | not ("\'" `T.isInfixOf` v) = fromText e " " - `mappend` fromText e n - `mappend` fromText e "=\'" - `mappend` escaped "<&" e v - `mappend` fromText e "\'" - | otherwise = fromText e " " - `mappend` fromText e n - `mappend` fromText e "=\"" - `mappend` escaped "<&\"" e v - `mappend` fromText e "\"" - +attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder +attribute opts e (n,v) + | not (preferredSurround `T.isInfixOf` v) = + fromText e " " + `mappend` fromText e n + `mappend` fromText e (T.cons '=' preferredSurround) + `mappend` escaped "<&" e v + `mappend` fromText e preferredSurround + | otherwise = + fromText e " " + `mappend` fromText e n + `mappend` fromText e (T.cons '=' otherSurround) + `mappend` escaped "<&\"" e v + `mappend` fromText e otherSurround + where (preferredSurround, otherSurround) = case attributeSurround opts of + SurroundDoubleQuote -> ("\"", "\'") + SurroundSingleQuote -> ("\'", "\"") From f377b2056cf0687ac7699fd902973462555cdb6a Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 21 Jun 2017 18:12:22 -0400 Subject: [PATCH 04/59] old ghc compat --- xmlhtml.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/xmlhtml.cabal b/xmlhtml.cabal index 55b86d6..1da4989 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -852,6 +852,7 @@ Test-suite testsuite blaze-html, blaze-markup, bytestring, + bytestring-builder, directory >= 1.0 && <1.4, test-framework >= 0.8.0.3 && <0.9, test-framework-hunit >= 0.3 && <0.4, From e0d4115a142424656e52f5402019c1e6e265c393 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Thu, 22 Jun 2017 08:07:46 -0400 Subject: [PATCH 05/59] Bump minor version number --- xmlhtml.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xmlhtml.cabal b/xmlhtml.cabal index 1da4989..e6395a3 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -1,5 +1,5 @@ Name: xmlhtml -Version: 0.2.4 +Version: 0.2.5 Synopsis: XML parser and renderer with HTML 5 quirks mode Description: Contains renderers and parsers for both XML and HTML 5 document fragments, which share data structures so that From 9c81d684e6fa3a99201eb6976d2077497085c1b9 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 28 Jun 2017 11:32:20 -0400 Subject: [PATCH 06/59] Fix API breakage around renderFragment --- src/Text/XmlHtml.hs | 2 ++ src/Text/XmlHtml/HTML/Render.hs | 16 +++++++++++++--- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Text/XmlHtml.hs b/src/Text/XmlHtml.hs index f56ac56..9453825 100644 --- a/src/Text/XmlHtml.hs +++ b/src/Text/XmlHtml.hs @@ -62,7 +62,9 @@ module Text.XmlHtml ( renderWithOptions, defaultRenderOptions, XMLR.renderXmlFragment, + XMLR.renderXmlFragmentWithOptions, HTML.renderHtmlFragment, + HTML.renderHtmlFragmentWithOptions, renderDocType ) where diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index 66c0952..d4483ce 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -36,18 +36,28 @@ renderWithOptions opts e dt ns = byteOrder | otherwise = firstNode opts e (head ns) `mappend` (mconcat $ map (node opts e) (tail ns)) + +------------------------------------------------------------------------------ render :: Encoding -> Maybe DocType -> [Node] -> Builder render = renderWithOptions defaultRenderOptions + ------------------------------------------------------------------------------ -- | Function for rendering HTML nodes without the overhead of creating a -- Document structure. -renderHtmlFragment :: RenderOptions -> Encoding -> [Node] -> Builder -renderHtmlFragment _ _ [] = mempty -renderHtmlFragment opts e (n:ns) = +renderHtmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder +renderHtmlFragmentWithOptions _ _ [] = mempty +renderHtmlFragmentWithOptions opts e (n:ns) = firstNode opts e n `mappend` (mconcat $ map (node opts e) ns) +------------------------------------------------------------------------------ +-- | Function for rendering HTML nodes without the overhead of creating a +-- Document structure, using default rendering options +renderHtmlFragment :: Encoding -> [Node] -> Builder +renderHtmlFragment = renderHtmlFragmentWithOptions defaultRenderOptions + + ------------------------------------------------------------------------------ -- | HTML allows & so long as it is not "ambiguous" (i.e., looks like an -- entity). So we have a special case for that. From 485378f1644ea75dc4380f7a5a43be6ad7607d94 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Wed, 28 Jun 2017 13:45:20 -0400 Subject: [PATCH 07/59] Always use the attr quotes specified by user, escaping internal quotes --- src/Text/XmlHtml/HTML/Render.hs | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index d4483ce..240062d 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -6,7 +6,11 @@ module Text.XmlHtml.HTML.Render where import Blaze.ByteString.Builder import Control.Applicative +import qualified Data.ByteString.Builder as B import Data.Maybe +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Lazy as TL import qualified Text.Parsec as P import Text.XmlHtml.Common import Text.XmlHtml.TextParser @@ -142,31 +146,31 @@ element opts e t tb a c `mappend` fromText e t `mappend` fromText e ">" - ------------------------------------------------------------------------------ attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder attribute opts e tb (n,v) | v == "" && not explicit = fromText e " " `mappend` fromText e n - | v /= "" && not (preferredSurround `T.isInfixOf` v) = - fromText e " " - `mappend` fromText e n - `mappend` fromText e ('=' `T.cons` preferredSurround) - `mappend` escaped "&" e v - `mappend` fromText e preferredSurround - | otherwise = + | otherwise = fromText e " " `mappend` fromText e n - `mappend` fromText e ('=' `T.cons` otherSurround) - `mappend` escaped "&\"" e v - `mappend` fromText e otherSurround + `mappend` fromText e ('=' `T.cons` surround) + `mappend` bmap (T.replace surround escapeTo) (escaped "&" e v) + `mappend` fromText e surround where - (preferredSurround, otherSurround) = case attributeSurround opts of - SurroundDoubleQuote -> ("\"", "\'") - SurroundSingleQuote -> ("\'", "\"") + (surround, escapeTo) = case attributeSurround opts of + SurroundDoubleQuote -> ("\"", """) + SurroundSingleQuote -> ("'", "'") nbase = T.toLower $ snd $ T.breakOnEnd ":" n + bmap :: (T.Text -> T.Text) -> B.Builder -> B.Builder + bmap f = B.byteString + . T.encodeUtf8 + . f + . TL.toStrict + . TL.decodeUtf8 + . B.toLazyByteString explicit = case M.lookup tb explicitAttributes of Nothing -> False Just ns -> nbase `S.member` ns From ea06c4200a7d8218e8742d9815ea5eaf43de53d5 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Thu, 6 Jul 2017 11:16:25 -0400 Subject: [PATCH 08/59] Fix and improve quoting options and fix travis build (#32) --- src/Text/XmlHtml.hs | 3 +- src/Text/XmlHtml/Common.hs | 45 +++++++--- src/Text/XmlHtml/HTML/Render.hs | 45 +++++----- src/Text/XmlHtml/XML/Render.hs | 23 +++--- test/src/Text/XmlHtml/DocumentTests.hs | 4 +- test/src/Text/XmlHtml/OASISTest.hs | 21 +++-- test/src/Text/XmlHtml/Tests.hs | 110 +++++++++++++++++-------- xmlhtml.cabal | 1 + 8 files changed, 166 insertions(+), 86 deletions(-) diff --git a/src/Text/XmlHtml.hs b/src/Text/XmlHtml.hs index 9453825..50fbd4f 100644 --- a/src/Text/XmlHtml.hs +++ b/src/Text/XmlHtml.hs @@ -33,7 +33,8 @@ module Text.XmlHtml ( InternalSubset(..), Encoding(..), RenderOptions(..), - AttributeSurround(..), + AttrSurround(..), + AttrResolveInternalQuotes(..), -- * Manipulating documents isTextNode, diff --git a/src/Text/XmlHtml/Common.hs b/src/Text/XmlHtml/Common.hs index b2bfd0d..5a06ab8 100644 --- a/src/Text/XmlHtml/Common.hs +++ b/src/Text/XmlHtml/Common.hs @@ -4,7 +4,10 @@ module Text.XmlHtml.Common where +import Data.ByteString (ByteString) import Blaze.ByteString.Builder +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Builder as B import Data.Char (isAscii, isLatin1) import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S @@ -14,9 +17,9 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS import Text.XmlHtml.HTML.Meta (reversePredefinedRefs, explicitAttributes) @@ -53,20 +56,34 @@ data Node = TextNode !Text ------------------------------------------------------------------------------ --- | Rendering options. Attritube values may be surrounded by single quotes --- (default), or by double quotes +-- | Rendering options data RenderOptions = RenderOptions { - attributeSurround :: AttributeSurround - , explicitEmptyAttributes :: M.HashMap Text (S.HashSet Text) - } + roAttributeSurround :: AttrSurround + -- ^ Single or double-quotes used around attribute values + + , roAttributeResolveInternal :: AttrResolveInternalQuotes + -- ^ Quotes inside attribute values that conflict with the surround + -- are escaped, or the outer quotes are changed to avoid conflicting + -- with the internal ones -data AttributeSurround = SurroundDoubleQuote | SurroundSingleQuote + , roExplicitEmptyAttrs :: Maybe (M.HashMap Text (S.HashSet Text)) + -- ^ Attributes in the whitelist with empty values are + -- rendered as
+ -- 'Nothing' applies this rule to all attributes with empty values + + } deriving (Eq, Show) + +data AttrSurround = SurroundDoubleQuote | SurroundSingleQuote + deriving (Eq, Ord, Show) + +data AttrResolveInternalQuotes = AttrResolveByEscape | AttrResolveAvoidEscape deriving (Eq, Ord, Show) defaultRenderOptions :: RenderOptions defaultRenderOptions = RenderOptions - { attributeSurround = SurroundSingleQuote - , explicitEmptyAttributes = explicitAttributes + { roAttributeSurround = SurroundSingleQuote + , roAttributeResolveInternal = AttrResolveAvoidEscape + , roExplicitEmptyAttrs = Just explicitAttributes } ------------------------------------------------------------------------------ @@ -280,3 +297,11 @@ isUTF16 e = e == UTF16BE || e == UTF16LE fromText :: Encoding -> Text -> Builder fromText e t = fromByteString (encoder e t) + +bmap :: (Text -> Text) -> B.Builder -> B.Builder +bmap f = B.byteString + . T.encodeUtf8 + . f + . TL.toStrict + . TL.decodeUtf8 + . B.toLazyByteString diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index 240062d..cbf1b52 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -6,11 +6,9 @@ module Text.XmlHtml.HTML.Render where import Blaze.ByteString.Builder import Control.Applicative -import qualified Data.ByteString.Builder as B +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import Data.Maybe -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy as TL import qualified Text.Parsec as P import Text.XmlHtml.Common import Text.XmlHtml.TextParser @@ -21,8 +19,6 @@ import Text.XmlHtml.XML.Render (docTypeDecl, entity) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as M #if !MIN_VERSION_base(4,8,0) import Data.Monoid @@ -149,28 +145,33 @@ element opts e t tb a c ------------------------------------------------------------------------------ attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder attribute opts e tb (n,v) - | v == "" && not explicit = + | v == "" && not explicit = fromText e " " `mappend` fromText e n + | roAttributeResolveInternal opts == AttrResolveAvoidEscape + && surround `T.isInfixOf` v + && not (alternative `T.isInfixOf` v) = + fromText e " " + `mappend` fromText e n + `mappend` fromText e ('=' `T.cons` alternative) + `mappend` escaped "&" e v + `mappend` fromText e alternative | otherwise = fromText e " " `mappend` fromText e n `mappend` fromText e ('=' `T.cons` surround) - `mappend` bmap (T.replace surround escapeTo) (escaped "&" e v) + `mappend` bmap (T.replace surround ent) (escaped "&" e v) `mappend` fromText e surround where - (surround, escapeTo) = case attributeSurround opts of - SurroundDoubleQuote -> ("\"", """) - SurroundSingleQuote -> ("'", "'") - + (surround, alternative, ent) = case roAttributeSurround opts of + SurroundSingleQuote -> ("'" , "\"", "'") + SurroundDoubleQuote -> ("\"", "'" , """) nbase = T.toLower $ snd $ T.breakOnEnd ":" n - bmap :: (T.Text -> T.Text) -> B.Builder -> B.Builder - bmap f = B.byteString - . T.encodeUtf8 - . f - . TL.toStrict - . TL.decodeUtf8 - . B.toLazyByteString - explicit = case M.lookup tb explicitAttributes of - Nothing -> False - Just ns -> nbase `S.member` ns + explicit = maybe + True + -- ^ Nothing 'explicitEmptyAttributes' means: attach '=""' to all + -- empty attributes + (maybe False (S.member nbase) . M.lookup tb) + -- ^ (Just m) means: attach '=""' only when tag and attr name + -- are in the explicit-empty-attrs map 'm' + (roExplicitEmptyAttrs opts) diff --git a/src/Text/XmlHtml/XML/Render.hs b/src/Text/XmlHtml/XML/Render.hs index e74fb72..b76ff3d 100644 --- a/src/Text/XmlHtml/XML/Render.hs +++ b/src/Text/XmlHtml/XML/Render.hs @@ -160,18 +160,21 @@ element opts e t a c = fromText e "<" ------------------------------------------------------------------------------ attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder attribute opts e (n,v) - | not (preferredSurround `T.isInfixOf` v) = + | roAttributeResolveInternal opts == AttrResolveAvoidEscape + && surround `T.isInfixOf` v + && not (alternative `T.isInfixOf` v) = fromText e " " `mappend` fromText e n - `mappend` fromText e (T.cons '=' preferredSurround) + `mappend` fromText e (T.cons '=' alternative) `mappend` escaped "<&" e v - `mappend` fromText e preferredSurround - | otherwise = + `mappend` fromText e alternative + | otherwise = fromText e " " `mappend` fromText e n - `mappend` fromText e (T.cons '=' otherSurround) - `mappend` escaped "<&\"" e v - `mappend` fromText e otherSurround - where (preferredSurround, otherSurround) = case attributeSurround opts of - SurroundDoubleQuote -> ("\"", "\'") - SurroundSingleQuote -> ("\'", "\"") + `mappend` fromText e (T.cons '=' surround) + `mappend` bmap (T.replace surround ent) (escaped "<&" e v) + `mappend` fromText e surround + where + (surround, alternative, ent) = case roAttributeSurround opts of + SurroundSingleQuote -> ("'" , "\"", "'") + SurroundDoubleQuote -> ("\"", "'" , """) diff --git a/test/src/Text/XmlHtml/DocumentTests.hs b/test/src/Text/XmlHtml/DocumentTests.hs index 9e4fa49..0c99973 100644 --- a/test/src/Text/XmlHtml/DocumentTests.hs +++ b/test/src/Text/XmlHtml/DocumentTests.hs @@ -282,8 +282,8 @@ useDoubleQuoteAttrs = do tmpl3 = "

" rndr = fmap (B.toLazyByteString . renderWithOptions - (defaultRenderOptions { attributeSurround = SurroundDoubleQuote})) + (defaultRenderOptions { roAttributeSurround = SurroundDoubleQuote})) . parseHTML "test" assertEqual "plain attr" (rndr tmpl1) (Right "

") assertEqual "plain attr" (rndr tmpl2) (Right "

") - assertEqual "plain attr" (rndr tmpl3) (Right "

") + assertEqual "plain attr" (rndr tmpl3) (Right "

") diff --git a/test/src/Text/XmlHtml/OASISTest.hs b/test/src/Text/XmlHtml/OASISTest.hs index 74af50f..f1deca5 100644 --- a/test/src/Text/XmlHtml/OASISTest.hs +++ b/test/src/Text/XmlHtml/OASISTest.hs @@ -2,11 +2,15 @@ module Text.XmlHtml.OASISTest (testsOASIS) where -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Monad +import Control.Applicative ((<*>)) +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (forM_) +import Data.Functor ((<$>)) +import Data.Traversable (forM) import qualified Data.ByteString as B import Data.Maybe +import Data.Monoid (mconcat) import qualified Data.Text as T import System.Directory import Test.Framework @@ -32,6 +36,12 @@ import Text.XmlHtml -- For tests that should succeed as XML but not HTML, or vice versa, files -- can be named /filename/@.xml.correct@, and so on (all 4 combinations). + +-- We need this as long as we support bytestring versions +-- that don't export BSL.toStrict (ghc-7.4 and older) +toStrict' :: BSL.ByteString -> B.ByteString +toStrict' = mconcat . BSL.toChunks + testsOASIS :: [Test] testsOASIS = [ testCase "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml", @@ -150,7 +160,7 @@ oasisRerender :: String -> Assertion oasisRerender name = do src <- B.readFile name let Right d = parseXML "" src - let src2 = toByteString (render d) + let src2 = toStrict' . toLazyByteString $ render d let Right d2 = parseXML "" src2 assertEqual ("rerender " ++ name) d d2 @@ -177,7 +187,6 @@ hOasisRerender :: String -> Assertion hOasisRerender name = do src <- B.readFile name let Right d = parseHTML "" src - let src2 = toByteString (render d) + let src2 = toStrict' . toLazyByteString $ render d let Right d2 = parseHTML "" src2 assertEqual ("rerender " ++ name) d d2 - diff --git a/test/src/Text/XmlHtml/Tests.hs b/test/src/Text/XmlHtml/Tests.hs index 32f018b..85b589e 100644 --- a/test/src/Text/XmlHtml/Tests.hs +++ b/test/src/Text/XmlHtml/Tests.hs @@ -6,9 +6,9 @@ module Text.XmlHtml.Tests (tests) where import Blaze.ByteString.Builder import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Monoid +import Data.Monoid (mappend, mempty) import Data.String -import Data.Text () -- for string instance +import Data.Text (Text) import qualified Data.Text.Encoding as T import Test.Framework import Test.Framework.Providers.HUnit @@ -17,7 +17,6 @@ import Text.Blaze import Text.Blaze.Html import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A -import qualified Text.Blaze.Internal as H import Text.Blaze.Renderer.XmlHtml import Text.XmlHtml import Text.XmlHtml.CursorTests @@ -584,21 +583,21 @@ utf8Decl = T.encodeUtf8 "\n" singleQuoteInSysID :: Bool singleQuoteInSysID = toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (System "test\'ing") NoInternalSubset)) + (Just (DocType "html" (System "test'ing") NoInternalSubset)) [])) - == utf8Decl `B.append` "\n" + == utf8Decl `B.append` "\n" doubleQuoteInSysID :: Bool doubleQuoteInSysID = toByteString (render (XmlDocument UTF8 (Just (DocType "html" (System "test\"ing") NoInternalSubset)) [])) - == utf8Decl `B.append` "\n" + == utf8Decl `B.append` "\n" bothQuotesInSysID :: Bool bothQuotesInSysID = isBottom $ toByteString (render (XmlDocument UTF8 - (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) + (Just (DocType "html" (System "test\"'ing") NoInternalSubset)) [])) doubleQuoteInPubID :: Bool @@ -629,23 +628,23 @@ renderEmptyText = singleQuoteInAttr :: Bool singleQuoteInAttr = toByteString (render (XmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'ing")] [] + Element "foo" [("bar", "test'ing")] [] ])) - == utf8Decl `B.append` "" + == utf8Decl `B.append` "" doubleQuoteInAttr :: Bool doubleQuoteInAttr = toByteString (render (XmlDocument UTF8 Nothing [ Element "foo" [("bar", "test\"ing")] [] ])) - == utf8Decl `B.append` "" + == utf8Decl `B.append` "" bothQuotesInAttr :: Bool bothQuotesInAttr = toByteString (render (XmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'\"ing")] [] + Element "foo" [("bar", "test'\"ing")] [] ])) - == utf8Decl `B.append` "" + == utf8Decl `B.append` "" ndashEscapesInLatin :: Bool ndashEscapesInLatin = @@ -695,21 +694,21 @@ hRenderByteOrderMark = hSingleQuoteInSysID :: Bool hSingleQuoteInSysID = toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (System "test\'ing") NoInternalSubset)) + (Just (DocType "html" (System "test'ing") NoInternalSubset)) [])) - == "\n" + == "\n" hDoubleQuoteInSysID :: Bool hDoubleQuoteInSysID = toByteString (render (HtmlDocument UTF8 (Just (DocType "html" (System "test\"ing") NoInternalSubset)) [])) - == "\n" + == "\n" hBothQuotesInSysID :: Bool hBothQuotesInSysID = isBottom $ toByteString (render (HtmlDocument UTF8 - (Just (DocType "html" (System "test\"\'ing") NoInternalSubset)) + (Just (DocType "html" (System "test\"'ing") NoInternalSubset)) [])) hDoubleQuoteInPubID :: Bool @@ -740,23 +739,23 @@ hRenderEmptyText = hSingleQuoteInAttr :: Bool hSingleQuoteInAttr = toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'ing")] [] + Element "foo" [("bar", "test'ing")] [] ])) - == "" + == "" hDoubleQuoteInAttr :: Bool hDoubleQuoteInAttr = toByteString (render (HtmlDocument UTF8 Nothing [ Element "foo" [("bar", "test\"ing")] [] ])) - == "" + == "" hBothQuotesInAttr :: Bool hBothQuotesInAttr = toByteString (render (HtmlDocument UTF8 Nothing [ - Element "foo" [("bar", "test\'\"ing")] [] + Element "foo" [("bar", "test'\"ing")] [] ])) - == "" + == "" ------------------------------------------------------------------------------ @@ -783,7 +782,11 @@ htmlRenderingQuirkTests = [ testIt "renderHTMLQRawMult " renderHTMLQRawMult, testIt "renderHTMLQRaw2 " renderHTMLQRaw2, testIt "renderHTMLQRaw3 " renderHTMLQRaw3, - testIt "renderHTMLQRaw4 " renderHTMLQRaw4 + testIt "renderHTMLQRaw4 " renderHTMLQRaw4, + testCase "singleAlways " singleAlways, + testCase "doubleAlways " doubleAlways, + testCase "singleAvoidEscaping " singleAvoidEscaping, + testCase "doubleAvoidEscaping " doubleAvoidEscaping ] renderHTMLVoid :: Bool @@ -791,7 +794,7 @@ renderHTMLVoid = toByteString (render (HtmlDocument UTF8 Nothing [ Element "img" [("src", "foo")] [] ])) - == "" + == "" renderHTMLVoid2 :: Bool renderHTMLVoid2 = isBottom $ @@ -806,7 +809,7 @@ renderHTMLRaw = TextNode "/&+" ] ])) - == "" + == "" renderHTMLRawMult :: Bool renderHTMLRawMult = @@ -816,7 +819,7 @@ renderHTMLRawMult = TextNode "bar" ] ])) - == "" + == "" renderHTMLRaw2 :: Bool renderHTMLRaw2 = isBottom $ @@ -855,32 +858,32 @@ renderHTMLEmptyAttr2 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "a" [("href", "")] [] ])) - == "" + == "" renderHTMLAmpAttr1 :: Bool renderHTMLAmpAttr1 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a & b")] [] ])) - == "" + == "" renderHTMLAmpAttr2 :: Bool renderHTMLAmpAttr2 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a & b")] [] ])) - == "" + == "" renderHTMLAmpAttr3 :: Bool renderHTMLAmpAttr3 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a e b")] [] ])) - == "" + == "" renderHTMLQVoid :: Bool renderHTMLQVoid = toByteString (render (HtmlDocument UTF8 Nothing [ Element "foo:img" [("src", "foo")] [] ])) - == "" + == "" renderHTMLQVoid2 :: Bool renderHTMLQVoid2 = isBottom $ @@ -895,7 +898,7 @@ renderHTMLQRaw = TextNode "/&+" ] ])) - == "/&+" + == "/&+" renderHTMLQRawMult :: Bool renderHTMLQRawMult = @@ -905,7 +908,7 @@ renderHTMLQRawMult = TextNode "bar" ] ])) - == "foobar" + == "foobar" renderHTMLQRaw2 :: Bool renderHTMLQRaw2 = isBottom $ @@ -932,6 +935,46 @@ renderHTMLQRaw4 = isBottom $ ] ])) +renderToByteString :: RenderOptions -> ByteString +renderToByteString opts = toByteString (renderWithOptions opts document) + where + attrs :: [(Text, Text)] + attrs = [("single", "'"), ("double", "\""), ("both", "'\"")] + document :: Document + document = HtmlDocument UTF8 Nothing [Element "div" attrs []] + +singleAlways :: Assertion +singleAlways = + assertEqual "singleAlways" + (renderToByteString (RenderOptions SurroundSingleQuote + AttrResolveByEscape + Nothing)) + "
" + +doubleAlways :: Assertion +doubleAlways = + assertEqual "doubleAlways" + (renderToByteString (RenderOptions SurroundDoubleQuote + AttrResolveByEscape + Nothing)) + "
" + +singleAvoidEscaping :: Assertion +singleAvoidEscaping = + assertEqual "singleAvoidEscaping" + (renderToByteString (RenderOptions SurroundSingleQuote + AttrResolveAvoidEscape + Nothing)) + "
" + +doubleAvoidEscaping :: Assertion +doubleAvoidEscaping = + assertEqual "doubleAvoidEscaping" + (renderToByteString (RenderOptions SurroundDoubleQuote + AttrResolveAvoidEscape + Nothing)) + "
" + ------------------------------------------------------------------------------ -- Tests of rendering from the blaze-html package ---------------------------- @@ -997,6 +1040,3 @@ blazeTestEmpty = renderHtmlNodes mempty == [] selectCustom :: Html selectCustom = H.select ! H.customAttribute "dojoType" "select" $ (mappend "foo " "bar") - - - diff --git a/xmlhtml.cabal b/xmlhtml.cabal index e6395a3..91e3f9b 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -824,6 +824,7 @@ Library blaze-html >= 0.5 && < 0.9, blaze-markup >= 0.5 && < 0.8, bytestring >= 0.9 && < 0.11, + bytestring-builder >= 0.10.4.0.2 && < 0.11, containers >= 0.3 && < 0.6, parsec >= 3.1.2 && < 3.2, text >= 0.11 && < 1.3, From 2d87523a02cfb8676ed2737a3e20c6afa087e38a Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Thu, 6 Jul 2017 11:38:37 -0400 Subject: [PATCH 09/59] Fix haddock parse error --- src/Text/XmlHtml/HTML/Render.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Text/XmlHtml/HTML/Render.hs b/src/Text/XmlHtml/HTML/Render.hs index cbf1b52..ce29680 100644 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -169,9 +169,9 @@ attribute opts e tb (n,v) nbase = T.toLower $ snd $ T.breakOnEnd ":" n explicit = maybe True - -- ^ Nothing 'explicitEmptyAttributes' means: attach '=""' to all + -- Nothing 'explicitEmptyAttributes' means: attach '=""' to all -- empty attributes (maybe False (S.member nbase) . M.lookup tb) - -- ^ (Just m) means: attach '=""' only when tag and attr name + -- (Just m) means: attach '=""' only when tag and attr name -- are in the explicit-empty-attrs map 'm' (roExplicitEmptyAttrs opts) From f82109d17e57f60bac8b7423e2c895a154444d92 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Fri, 28 Jul 2017 11:12:16 -0400 Subject: [PATCH 10/59] Bump blaze-html and blaze-markup --- xmlhtml.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/xmlhtml.cabal b/xmlhtml.cabal index 91e3f9b..b99843a 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -821,8 +821,8 @@ Library Build-depends: base >= 4 && < 5, blaze-builder >= 0.2 && < 0.5, - blaze-html >= 0.5 && < 0.9, - blaze-markup >= 0.5 && < 0.8, + blaze-html >= 0.5 && < 0.10, + blaze-markup >= 0.5 && < 0.9, bytestring >= 0.9 && < 0.11, bytestring-builder >= 0.10.4.0.2 && < 0.11, containers >= 0.3 && < 0.6, From ae604e520fb5315b900abfd6cd8cf9fbb773e1f7 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Mon, 14 Aug 2017 09:09:10 -0400 Subject: [PATCH 11/59] Use newest version of blaze-html and blaze-markup --- src/Text/Blaze/Renderer/XmlHtml.hs | 10 +++++----- xmlhtml.cabal | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Text/Blaze/Renderer/XmlHtml.hs b/src/Text/Blaze/Renderer/XmlHtml.hs index acec408..93d21a3 100644 --- a/src/Text/Blaze/Renderer/XmlHtml.hs +++ b/src/Text/Blaze/Renderer/XmlHtml.hs @@ -58,22 +58,22 @@ renderNodes = go [] (Element (getText tag) attrs (go [] content []) :) go attrs (CustomParent tag content) = (Element (fromChoiceStringText tag) attrs (go [] content []) :) - go attrs (Leaf tag _ _) = + go attrs (Leaf tag _ _ _) = (Element (getText tag) attrs [] :) - go attrs (CustomLeaf tag _) = + go attrs (CustomLeaf tag _ _) = (Element (fromChoiceStringText tag) attrs [] :) go attrs (AddAttribute key _ value content) = go ((getText key, fromChoiceStringText value) : attrs) content go attrs (AddCustomAttribute key value content) = go ((fromChoiceStringText key, fromChoiceStringText value) : attrs) content - go _ (Content content) = fromChoiceString content + go _ (Content content _) = fromChoiceString content #if MIN_VERSION_blaze_markup(0,6,3) - go _ (TBI.Comment comment) = + go _ (TBI.Comment comment _) = (X.Comment (fromChoiceStringText comment) :) #endif go attrs (Append h1 h2) = go attrs h1 . go attrs h2 - go _ Empty = id + go _ (Empty _) = id {-# NOINLINE go #-} {-# INLINE renderNodes #-} diff --git a/xmlhtml.cabal b/xmlhtml.cabal index b99843a..7509fff 100644 --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -821,8 +821,8 @@ Library Build-depends: base >= 4 && < 5, blaze-builder >= 0.2 && < 0.5, - blaze-html >= 0.5 && < 0.10, - blaze-markup >= 0.5 && < 0.9, + blaze-html >= 0.9 && < 0.10, + blaze-markup >= 0.8 && < 0.9, bytestring >= 0.9 && < 0.11, bytestring-builder >= 0.10.4.0.2 && < 0.11, containers >= 0.3 && < 0.6, From 854ce10f2ee19d39a08ba9ed1bf3c8725b717f57 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Mon, 14 Aug 2017 10:24:43 -0400 Subject: [PATCH 12/59] Switch from test-framework to hspec --- test/src/TestSuite.hs | 19 +- test/src/Text/XmlHtml/CursorTests.hs | 28 +-- test/src/Text/XmlHtml/DocumentTests.hs | 102 ++++---- test/src/Text/XmlHtml/OASISTest.hs | 40 ++-- test/src/Text/XmlHtml/TestCommon.hs | 7 +- test/src/Text/XmlHtml/Tests.hs | 316 +++++++++++-------------- xmlhtml.cabal | 3 +- 7 files changed, 246 insertions(+), 269 deletions(-) diff --git a/test/src/TestSuite.hs b/test/src/TestSuite.hs index 1b41963..3bc7480 100644 --- a/test/src/TestSuite.hs +++ b/test/src/TestSuite.hs @@ -2,8 +2,21 @@ module Main where -import Test.Framework (defaultMain) -import Text.XmlHtml.Tests (tests) +import Test.Hspec +import Text.XmlHtml.CursorTests +import Text.XmlHtml.DocumentTests +import Text.XmlHtml.OASISTest +import Text.XmlHtml.Tests main :: IO () -main = defaultMain tests +main = hspec $ do + describe "xmlParsingTests" xmlParsingTests + describe "htmlXMLParsingTests" htmlXMLParsingTests + describe "htmlParsingQuirkTests" htmlParsingQuirkTests + describe "xmlRenderingTests" xmlRenderingTests + describe "htmlXMLRenderingTests" htmlXMLRenderingTests + describe "htmlRenderingQuirkTests" htmlRenderingQuirkTests + describe "documentTests" documentTests + describe "cursorTests" cursorTests + describe "blazeRenderTests" blazeRenderTests + describe "testsOASIS" testsOASIS diff --git a/test/src/Text/XmlHtml/CursorTests.hs b/test/src/Text/XmlHtml/CursorTests.hs index 489665b..a45aed3 100644 --- a/test/src/Text/XmlHtml/CursorTests.hs +++ b/test/src/Text/XmlHtml/CursorTests.hs @@ -3,8 +3,7 @@ module Text.XmlHtml.CursorTests (cursorTests) where import Data.Maybe -import Test.Framework -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Test, Node) import Text.XmlHtml import Text.XmlHtml.Cursor @@ -14,19 +13,18 @@ import Text.XmlHtml.TestCommon -- Tests of navigating with the Cursor type ---------------------------------- ------------------------------------------------------------------------------ -cursorTests :: [Test] -cursorTests = [ - testIt "fromNodeAndCurrent " $ fromNodeAndCurrent, - testIt "fromNodesAndSiblings " $ fromNodesAndSiblings, - testIt "leftSiblings " $ leftSiblings, - testIt "emptyFromNodes " $ emptyFromNodes, - testIt "cursorNEQ " $ cursorNEQ, - testCase "cursorNavigation " $ cursorNavigation, - testCase "cursorSearch " $ cursorSearch, - testCase "cursorMutation " $ cursorMutation, - testCase "cursorInsertion " $ cursorInsertion, - testCase "cursorDeletion " $ cursorDeletion - ] +cursorTests :: Spec +cursorTests = do + testIt "fromNodeAndCurrent " $ fromNodeAndCurrent + testIt "fromNodesAndSiblings " $ fromNodesAndSiblings + testIt "leftSiblings " $ leftSiblings + testIt "emptyFromNodes " $ emptyFromNodes + testIt "cursorNEQ " $ cursorNEQ + it "cursorNavigation " $ cursorNavigation + it "cursorSearch " $ cursorSearch + it "cursorMutation " $ cursorMutation + it "cursorInsertion " $ cursorInsertion + it "cursorDeletion " $ cursorDeletion fromNodeAndCurrent :: Bool fromNodeAndCurrent = all (\n -> n == current (fromNode n)) ns diff --git a/test/src/Text/XmlHtml/DocumentTests.hs b/test/src/Text/XmlHtml/DocumentTests.hs index 0c99973..31cbb88 100644 --- a/test/src/Text/XmlHtml/DocumentTests.hs +++ b/test/src/Text/XmlHtml/DocumentTests.hs @@ -4,8 +4,7 @@ module Text.XmlHtml.DocumentTests (documentTests) where import qualified Data.ByteString.Builder as B import Data.Text () -- for string instance -import Test.Framework -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Node, Test) import Text.XmlHtml import Text.XmlHtml.TestCommon @@ -15,66 +14,65 @@ import Text.XmlHtml.TestCommon -- Tests of manipulating the Node tree and Document -------------------------- ------------------------------------------------------------------------------ -documentTests :: [Test] -documentTests = [ +documentTests :: Spec +documentTests = do -- Exercise the (/=) operators; (==) is done plenty of places. - testIt "compareExternalIDs " $ compareExternalIDs, - testIt "compareInternalSubs " $ compareInternalSubs, - testIt "compareDoctypes " $ compareDoctypes, - testIt "compareNodes " $ compareNodes, - testIt "compareDocuments " $ compareDocuments, - testIt "compareEncodings " $ compareEncodings, + testIt "compareExternalIDs " $ compareExternalIDs + testIt "compareInternalSubs " $ compareInternalSubs + testIt "compareDoctypes " $ compareDoctypes + testIt "compareNodes " $ compareNodes + testIt "compareDocuments " $ compareDocuments + testIt "compareEncodings " $ compareEncodings -- Silly tests just to exercise the Show instances on types. - testCase "exerciseShows " $ exerciseShows, + it "exerciseShows " $ exerciseShows -- Exercise the accessors for Document and Node - testCase "docNodeAccessors " $ docNodeAccessors, - - testIt "isTextNodeYes " $ isTextNode someTextNode, - testIt "isTextNodeNo " $ not $ isTextNode someComment, - testIt "isTextNodeNo2 " $ not $ isTextNode someElement, - testIt "isCommentYes " $ isComment someComment, - testIt "isCommentNo " $ not $ isComment someTextNode, - testIt "isCommentNo2 " $ not $ isComment someElement, - testIt "isElementYes " $ isElement someElement, - testIt "isElementNo " $ not $ isElement someTextNode, - testIt "isElementNo2 " $ not $ isElement someComment, - testIt "tagNameElement " $ tagName someElement == Just "baz", - testIt "tagNameText " $ tagName someTextNode == Nothing, - testIt "tagNameComment " $ tagName someComment == Nothing, + it "docNodeAccessors " $ docNodeAccessors + + testIt "isTextNodeYes " $ isTextNode someTextNode + testIt "isTextNodeNo " $ not $ isTextNode someComment + testIt "isTextNodeNo2 " $ not $ isTextNode someElement + testIt "isCommentYes " $ isComment someComment + testIt "isCommentNo " $ not $ isComment someTextNode + testIt "isCommentNo2 " $ not $ isComment someElement + testIt "isElementYes " $ isElement someElement + testIt "isElementNo " $ not $ isElement someTextNode + testIt "isElementNo2 " $ not $ isElement someComment + testIt "tagNameElement " $ tagName someElement == Just "baz" + testIt "tagNameText " $ tagName someTextNode == Nothing + testIt "tagNameComment " $ tagName someComment == Nothing testIt "getAttributePresent " $ getAttribute "fiz" someElement - == Just "buzz", + == Just "buzz" testIt "getAttributeMissing " $ getAttribute "baz" someElement - == Nothing, + == Nothing testIt "getAttributeWrongType " $ getAttribute "fix" someTextNode - == Nothing, - testIt "hasAttributePresent " $ hasAttribute "fiz" someElement, - testIt "hasAttributeMissing " $ not $ hasAttribute "baz" someElement, - testIt "hasAttributeWrongType " $ not $ hasAttribute "fix" someTextNode, - testIt "setAttributeNew " $ setAttributeNew, - testIt "setAttributeReplace " $ setAttributeReplace, - testIt "setAttributeWrongType " $ setAttributeWrongType, - testIt "nestedNodeText " $ nestedNodeText, - testIt "childNodesElem " $ childNodesElem, - testIt "childNodesOther " $ childNodesOther, - testIt "childElemsTest " $ childElemsTest, - testIt "childElemsTagTest " $ childElemsTagTest, - testIt "childElemTagExists " $ childElemTagExists, - testIt "childElemTagNotExists " $ childElemTagNotExists, - testIt "childElemTagOther " $ childElemTagOther, - testIt "descNodesElem " $ descNodesElem, - testIt "descNodesOther " $ descNodesOther, - testIt "descElemsTest " $ descElemsTest, - testIt "descElemsTagTest " $ descElemsTagTest, - testIt "descElemTagExists " $ descElemTagExists, - testIt "descElemTagDFS " $ descElemTagDFS, - testIt "descElemTagNotExists " $ descElemTagNotExists, - testIt "descElemTagOther " $ descElemTagOther, + == Nothing + testIt "hasAttributePresent " $ hasAttribute "fiz" someElement + testIt "hasAttributeMissing " $ not $ hasAttribute "baz" someElement + testIt "hasAttributeWrongType " $ not $ hasAttribute "fix" someTextNode + testIt "setAttributeNew " $ setAttributeNew + testIt "setAttributeReplace " $ setAttributeReplace + testIt "setAttributeWrongType " $ setAttributeWrongType + testIt "nestedNodeText " $ nestedNodeText + testIt "childNodesElem " $ childNodesElem + testIt "childNodesOther " $ childNodesOther + testIt "childElemsTest " $ childElemsTest + testIt "childElemsTagTest " $ childElemsTagTest + testIt "childElemTagExists " $ childElemTagExists + testIt "childElemTagNotExists " $ childElemTagNotExists + testIt "childElemTagOther " $ childElemTagOther + testIt "descNodesElem " $ descNodesElem + testIt "descNodesOther " $ descNodesOther + testIt "descElemsTest " $ descElemsTest + testIt "descElemsTagTest " $ descElemsTagTest + testIt "descElemTagExists " $ descElemTagExists + testIt "descElemTagDFS " $ descElemTagDFS + testIt "descElemTagNotExists " $ descElemTagNotExists + testIt "descElemTagOther " $ descElemTagOther -- Exercise render options - testCase "renderDoubleQuoteAttrs " $ useDoubleQuoteAttrs - ] + it "renderDoubleQuoteAttrs " $ useDoubleQuoteAttrs compareExternalIDs :: Bool compareExternalIDs = Public "foo" "bar" /= System "bar" diff --git a/test/src/Text/XmlHtml/OASISTest.hs b/test/src/Text/XmlHtml/OASISTest.hs index f1deca5..9adaceb 100644 --- a/test/src/Text/XmlHtml/OASISTest.hs +++ b/test/src/Text/XmlHtml/OASISTest.hs @@ -13,8 +13,7 @@ import Data.Maybe import Data.Monoid (mconcat) import qualified Data.Text as T import System.Directory -import Test.Framework -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Test, Node) import Text.XmlHtml @@ -42,25 +41,24 @@ import Text.XmlHtml toStrict' :: BSL.ByteString -> B.ByteString toStrict' = mconcat . BSL.toChunks -testsOASIS :: [Test] -testsOASIS = [ - testCase "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/ibm-invalid " $ oasisP "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/ibm-valid " $ oasisP "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/oasis " $ oasisP "oasis/oasis.xml", - testCase "xmlhtml/r-ibm-not-wf " $ oasisR "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/r-ibm-invalid " $ oasisR "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/r-ibm-valid " $ oasisR "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/r-oasis " $ oasisR "oasis/oasis.xml", - testCase "xmlhtml/h-ibm-not-wf " $ oasisHP "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/h-ibm-invalid " $ oasisHP "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/h-ibm-valid " $ oasisHP "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/h-oasis " $ oasisHP "oasis/oasis.xml", - testCase "xmlhtml/hr-ibm-not-wf " $ oasisHR "ibm/ibm_oasis_not-wf.xml", - testCase "xmlhtml/hr-ibm-invalid " $ oasisHR "ibm/ibm_oasis_invalid.xml", - testCase "xmlhtml/hr-ibm-valid " $ oasisHR "ibm/ibm_oasis_valid.xml", - testCase "xmlhtml/hr-oasis " $ oasisHR "oasis/oasis.xml" - ] +testsOASIS :: Spec +testsOASIS = do + it "xmlhtml/ibm-not-wf " $ oasisP "ibm/ibm_oasis_not-wf.xml" + it "xmlhtml/ibm-invalid " $ oasisP "ibm/ibm_oasis_invalid.xml" + it "xmlhtml/ibm-valid " $ oasisP "ibm/ibm_oasis_valid.xml" + it "xmlhtml/oasis " $ oasisP "oasis/oasis.xml" + it "xmlhtml/r-ibm-not-wf " $ oasisR "ibm/ibm_oasis_not-wf.xml" + it "xmlhtml/r-ibm-invalid " $ oasisR "ibm/ibm_oasis_invalid.xml" + it "xmlhtml/r-ibm-valid " $ oasisR "ibm/ibm_oasis_valid.xml" + it "xmlhtml/r-oasis " $ oasisR "oasis/oasis.xml" + it "xmlhtml/h-ibm-not-wf " $ oasisHP "ibm/ibm_oasis_not-wf.xml" + it "xmlhtml/h-ibm-invalid " $ oasisHP "ibm/ibm_oasis_invalid.xml" + it "xmlhtml/h-ibm-valid " $ oasisHP "ibm/ibm_oasis_valid.xml" + it "xmlhtml/h-oasis " $ oasisHP "oasis/oasis.xml" + it "xmlhtml/hr-ibm-not-wf " $ oasisHR "ibm/ibm_oasis_not-wf.xml" + it "xmlhtml/hr-ibm-invalid " $ oasisHR "ibm/ibm_oasis_invalid.xml" + it "xmlhtml/hr-ibm-valid " $ oasisHR "ibm/ibm_oasis_valid.xml" + it "xmlhtml/hr-oasis " $ oasisHR "oasis/oasis.xml" oasisP :: String -> Assertion diff --git a/test/src/Text/XmlHtml/TestCommon.hs b/test/src/Text/XmlHtml/TestCommon.hs index 016b9c6..b468a34 100644 --- a/test/src/Text/XmlHtml/TestCommon.hs +++ b/test/src/Text/XmlHtml/TestCommon.hs @@ -4,14 +4,13 @@ module Text.XmlHtml.TestCommon where import Control.Exception as E import System.IO.Unsafe -import Test.Framework -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Test, Node) ------------------------------------------------------------------------------ -- | Tests a simple Bool property. -testIt :: TestName -> Bool -> Test -testIt name b = testCase name $ assertBool name b +testIt :: String -> Bool -> Spec +testIt name b = it name $ assertBool name b ------------------------------------------------------------------------------ -- Code adapted from ChasingBottoms. diff --git a/test/src/Text/XmlHtml/Tests.hs b/test/src/Text/XmlHtml/Tests.hs index 85b589e..641429f 100644 --- a/test/src/Text/XmlHtml/Tests.hs +++ b/test/src/Text/XmlHtml/Tests.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -module Text.XmlHtml.Tests (tests) where +module Text.XmlHtml.Tests where import Blaze.ByteString.Builder import Data.ByteString (ByteString) @@ -10,8 +10,7 @@ import Data.Monoid (mappend, mempty) import Data.String import Data.Text (Text) import qualified Data.Text.Encoding as T -import Test.Framework -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Test, Node) import Text.Blaze import Text.Blaze.Html @@ -19,59 +18,38 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import Text.Blaze.Renderer.XmlHtml import Text.XmlHtml -import Text.XmlHtml.CursorTests -import Text.XmlHtml.DocumentTests import Text.XmlHtml.TestCommon -import Text.XmlHtml.OASISTest - - ------------------------------------------------------------------------------- --- The master list of tests to run. ------------------------------------------ ------------------------------------------------------------------------------- - -tests :: [Test] -tests = xmlParsingTests - ++ htmlXMLParsingTests - ++ htmlParsingQuirkTests - ++ xmlRenderingTests - ++ htmlXMLRenderingTests - ++ htmlRenderingQuirkTests - ++ documentTests - ++ cursorTests - ++ blazeRenderTests - ++ testsOASIS ------------------------------------------------------------------------------ -- XML Parsing Tests --------------------------------------------------------- ------------------------------------------------------------------------------ -xmlParsingTests :: [Test] -xmlParsingTests = [ - testCase "byteOrderMark " byteOrderMark, - testIt "emptyDocument " emptyDocument, - testIt "publicDocType " publicDocType, - testIt "systemDocType " systemDocType, - testIt "emptyDocType " emptyDocType, - testCase "dtdInternalScan " dtdInternalScan, - testIt "textOnly " textOnly, - testIt "textWithRefs " textWithRefs, - testIt "untermRef " untermRef, - testIt "textWithCDATA " textWithCDATA, - testIt "cdataOnly " cdataOnly, - testIt "commentOnly " commentOnly, - testIt "emptyElement " emptyElement, - testIt "emptyElement2 " emptyElement2, - testIt "elemWithText " elemWithText, - testIt "xmlDeclXML " xmlDeclXML, - testIt "procInst " procInst, - testIt "badDoctype1 " badDoctype1, - testIt "badDoctype2 " badDoctype2, - testIt "badDoctype3 " badDoctype3, - testIt "badDoctype4 " badDoctype4, - testIt "badDoctype5 " badDoctype5, - testCase "tagNames " tagNames - ] +xmlParsingTests :: Spec +xmlParsingTests = do + it "byteOrderMark " byteOrderMark + testIt "emptyDocument " emptyDocument + testIt "publicDocType " publicDocType + testIt "systemDocType " systemDocType + testIt "emptyDocType " emptyDocType + it "dtdInternalScan " dtdInternalScan + testIt "textOnly " textOnly + testIt "textWithRefs " textWithRefs + testIt "untermRef " untermRef + testIt "textWithCDATA " textWithCDATA + testIt "cdataOnly " cdataOnly + testIt "commentOnly " commentOnly + testIt "emptyElement " emptyElement + testIt "emptyElement2 " emptyElement2 + testIt "elemWithText " elemWithText + testIt "xmlDeclXML " xmlDeclXML + testIt "procInst " procInst + testIt "badDoctype1 " badDoctype1 + testIt "badDoctype2 " badDoctype2 + testIt "badDoctype3 " badDoctype3 + testIt "badDoctype4 " badDoctype4 + testIt "badDoctype5 " badDoctype5 + it "tagNames " tagNames byteOrderMark :: Assertion byteOrderMark = do @@ -252,28 +230,27 @@ tagNames = do -- HTML Repetitions of XML Parsing Tests ------------------------------------- ------------------------------------------------------------------------------ -htmlXMLParsingTests :: [Test] -htmlXMLParsingTests = [ - testIt "emptyDocumentHTML " emptyDocumentHTML, - testIt "publicDocTypeHTML " publicDocTypeHTML, - testIt "systemDocTypeHTML " systemDocTypeHTML, - testIt "emptyDocTypeHTML " emptyDocTypeHTML, - testIt "textOnlyHTML " textOnlyHTML, - testIt "textWithRefsHTML " textWithRefsHTML, - testIt "textWithCDataHTML " textWithCDataHTML, - testIt "cdataOnlyHTML " cdataOnlyHTML, - testIt "commentOnlyHTML " commentOnlyHTML, - testIt "emptyElementHTML " emptyElementHTML, - testIt "emptyElement2HTML " emptyElement2HTML, - testIt "elemWithTextHTML " elemWithTextHTML, - testIt "xmlDeclHTML " xmlDeclHTML, - testIt "procInstHTML " procInstHTML, - testIt "badDoctype1HTML " badDoctype1HTML, - testIt "badDoctype2HTML " badDoctype2HTML, - testIt "badDoctype3HTML " badDoctype3HTML, - testIt "badDoctype4HTML " badDoctype4HTML, +htmlXMLParsingTests :: Spec +htmlXMLParsingTests = do + testIt "emptyDocumentHTML " emptyDocumentHTML + testIt "publicDocTypeHTML " publicDocTypeHTML + testIt "systemDocTypeHTML " systemDocTypeHTML + testIt "emptyDocTypeHTML " emptyDocTypeHTML + testIt "textOnlyHTML " textOnlyHTML + testIt "textWithRefsHTML " textWithRefsHTML + testIt "textWithCDataHTML " textWithCDataHTML + testIt "cdataOnlyHTML " cdataOnlyHTML + testIt "commentOnlyHTML " commentOnlyHTML + testIt "emptyElementHTML " emptyElementHTML + testIt "emptyElement2HTML " emptyElement2HTML + testIt "elemWithTextHTML " elemWithTextHTML + testIt "xmlDeclHTML " xmlDeclHTML + testIt "procInstHTML " procInstHTML + testIt "badDoctype1HTML " badDoctype1HTML + testIt "badDoctype2HTML " badDoctype2HTML + testIt "badDoctype3HTML " badDoctype3HTML + testIt "badDoctype4HTML " badDoctype4HTML testIt "badDoctype5HTML " badDoctype5HTML - ] emptyDocumentHTML :: Bool emptyDocumentHTML = parseHTML "" "" @@ -352,43 +329,42 @@ badDoctype5HTML = isLeft $ parseHTML "" ("" @@ -547,24 +523,23 @@ weirdScriptThing = parseHTML "" "