diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# 0.2.5 + +* Add renderWithOptions and the ability to control how attributes are + surrounded with quotes. +* Update to latest version of blaze-html and blaze-markup. Required bumping + the lower bound because the blaze changes were not backwards compatible. +* Switch from test-framework to hspec + diff --git a/src/Text/Blaze/Renderer/XmlHtml.hs b/src/Text/Blaze/Renderer/XmlHtml.hs --- a/src/Text/Blaze/Renderer/XmlHtml.hs +++ b/src/Text/Blaze/Renderer/XmlHtml.hs @@ -58,22 +58,22 @@ (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/src/Text/XmlHtml.hs b/src/Text/XmlHtml.hs --- a/src/Text/XmlHtml.hs +++ b/src/Text/XmlHtml.hs @@ -32,6 +32,9 @@ ExternalID(..), InternalSubset(..), Encoding(..), + RenderOptions(..), + AttrSurround(..), + AttrResolveInternalQuotes(..), -- * Manipulating documents isTextNode, @@ -57,8 +60,12 @@ -- * Rendering render, + renderWithOptions, + defaultRenderOptions, XMLR.renderXmlFragment, + XMLR.renderXmlFragmentWithOptions, HTML.renderHtmlFragment, + HTML.renderHtmlFragmentWithOptions, renderDocType ) where @@ -101,9 +108,12 @@ ------------------------------------------------------------------------------ -- | 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 --- a/src/Text/XmlHtml/Common.hs +++ b/src/Text/XmlHtml/Common.hs @@ -4,19 +4,24 @@ 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 import Data.Maybe 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) +import Text.XmlHtml.HTML.Meta (reversePredefinedRefs, + explicitAttributes) ------------------------------------------------------------------------------ @@ -51,6 +56,37 @@ ------------------------------------------------------------------------------ +-- | Rendering options +data RenderOptions = RenderOptions { + 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 + + , 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 + { roAttributeSurround = SurroundSingleQuote + , roAttributeResolveInternal = AttrResolveAvoidEscape + , roExplicitEmptyAttrs = Just explicitAttributes + } + +------------------------------------------------------------------------------ -- | Determines whether the node is text or not. isTextNode :: Node -> Bool isTextNode (TextNode _) = True @@ -261,3 +297,11 @@ 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 --- a/src/Text/XmlHtml/HTML/Render.hs +++ b/src/Text/XmlHtml/HTML/Render.hs @@ -6,6 +6,8 @@ import Blaze.ByteString.Builder import Control.Applicative +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import Data.Maybe import qualified Text.Parsec as P import Text.XmlHtml.Common @@ -17,8 +19,6 @@ 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 @@ -26,24 +26,36 @@ ------------------------------------------------------------------------------ -- | 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. +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 _ [] = mempty -renderHtmlFragment e (n:ns) = - firstNode e n `mappend` (mconcat $ map (node e) ns) +renderHtmlFragment = renderHtmlFragmentWithOptions defaultRenderOptions ------------------------------------------------------------------------------ @@ -67,39 +79,39 @@ ------------------------------------------------------------------------------ -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 tb) a) + `mappend` (mconcat $ map (attribute opts e tb) a) `mappend` fromText e " />" | tb `S.member` voidTags = error $ T.unpack t ++ " must be empty" @@ -109,7 +121,7 @@ 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, Text) -> Builder -attribute e tb (n,v) - | v == "" && not explicit = +attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder +attribute opts e tb (n,v) + | v == "" && not explicit = fromText e " " `mappend` fromText e n - | v /= "" && not ("\'" `T.isInfixOf` v) = + | roAttributeResolveInternal opts == AttrResolveAvoidEscape + && surround `T.isInfixOf` v + && not (alternative `T.isInfixOf` v) = fromText e " " `mappend` fromText e n - `mappend` fromText e "=\'" + `mappend` fromText e ('=' `T.cons` alternative) `mappend` escaped "&" e v - `mappend` fromText e "\'" - | otherwise = + `mappend` fromText e alternative + | 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 + `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 -> ("\"", "'" , """) + nbase = T.toLower $ snd $ T.breakOnEnd ":" n + 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 --- a/src/Text/XmlHtml/XML/Render.hs +++ b/src/Text/XmlHtml/XML/Render.hs @@ -18,26 +18,31 @@ ------------------------------------------------------------------------------ -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 @@ ------------------------------------------------------------------------------ -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,39 @@ ------------------------------------------------------------------------------ -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) + | 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 ent) (escaped "<&" e v) + `mappend` fromText e surround + where + (surround, alternative, ent) = case roAttributeSurround opts of + SurroundSingleQuote -> ("'" , "\"", "'") + SurroundDoubleQuote -> ("\"", "'" , """) diff --git a/test/src/TestSuite.hs b/test/src/TestSuite.hs --- 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 --- 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 @@ -- 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 --- a/test/src/Text/XmlHtml/DocumentTests.hs +++ b/test/src/Text/XmlHtml/DocumentTests.hs @@ -2,9 +2,9 @@ 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 @@ -14,64 +14,65 @@ -- 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, + 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 "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, + == 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 + it "renderDoubleQuoteAttrs " $ useDoubleQuoteAttrs compareExternalIDs :: Bool compareExternalIDs = Public "foo" "bar" /= System "bar" @@ -272,3 +273,15 @@ descElemTagOther = descendantElementTag "b" n == Nothing where n = TextNode "" +useDoubleQuoteAttrs :: Assertion +useDoubleQuoteAttrs = do + let tmpl1 = "

" -- Element "p" [("div","tester")] [] + tmpl2 = "

" + tmpl3 = "

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

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

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

") diff --git a/test/src/Text/XmlHtml/OASISTest.hs b/test/src/Text/XmlHtml/OASISTest.hs --- a/test/src/Text/XmlHtml/OASISTest.hs +++ b/test/src/Text/XmlHtml/OASISTest.hs @@ -2,15 +2,18 @@ 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 -import Test.Framework.Providers.HUnit +import Test.Hspec import Test.HUnit hiding (Test, Node) import Text.XmlHtml @@ -32,27 +35,32 @@ -- 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). -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" - ] +-- 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 :: 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 oasisP name = do tests <- getOASIS ".xml" name @@ -150,7 +158,7 @@ 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 +185,6 @@ 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/TestCommon.hs b/test/src/Text/XmlHtml/TestCommon.hs --- a/test/src/Text/XmlHtml/TestCommon.hs +++ b/test/src/Text/XmlHtml/TestCommon.hs @@ -4,14 +4,13 @@ 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 --- a/test/src/Text/XmlHtml/Tests.hs +++ b/test/src/Text/XmlHtml/Tests.hs @@ -1,78 +1,55 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -module Text.XmlHtml.Tests (tests) where +module Text.XmlHtml.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 +import Test.Hspec import Test.HUnit hiding (Test, Node) 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 -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 @@ -253,28 +230,27 @@ -- 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 "" "" @@ -353,43 +329,42 @@ -- HTML Quirks Parsing Tests ------------------------------------------------- ------------------------------------------------------------------------------ -htmlParsingQuirkTests :: [Test] -htmlParsingQuirkTests = [ - testIt "voidElem " voidElem, - testIt "caseInsDoctype1 " caseInsDoctype1, - testIt "caseInsDoctype2 " caseInsDoctype2, - testIt "voidEmptyElem " voidEmptyElem, - testIt "rawTextElem " rawTextElem, - testIt "endTagCase " endTagCase, - testIt "hexEntityCap " hexEntityCap, - testIt "laxAttrName " laxAttrName, - testCase "badAttrName " badAttrName, - testIt "emptyAttr " emptyAttr, - testIt "emptyAttr2 " emptyAttr2, - testIt "unquotedAttr " unquotedAttr, - testIt "laxAttrVal " laxAttrVal, - testIt "ampersandInText " ampersandInText, - testIt "omitOptionalEnds " omitOptionalEnds, - testIt "omitEndHEAD " omitEndHEAD, - testIt "omitEndLI " omitEndLI, - testIt "omitEndDT " omitEndDT, - testIt "omitEndDD " omitEndDD, - testIt "omitEndP " omitEndP, - testIt "omitEndRT " omitEndRT, - testIt "omitEndRP " omitEndRP, - testIt "omitEndOPTGRP " omitEndOPTGRP, - testIt "omitEndOPTION " omitEndOPTION, - testIt "omitEndCOLGRP " omitEndCOLGRP, - testIt "omitEndTHEAD " omitEndTHEAD, - testIt "omitEndTBODY " omitEndTBODY, - testIt "omitEndTFOOT " omitEndTFOOT, - testIt "omitEndTR " omitEndTR, - testIt "omitEndTD " omitEndTD, - testIt "omitEndTH " omitEndTH, - testIt "testNewRefs " testNewRefs, - testIt "errorImplicitClose " errorImplicitClose, +htmlParsingQuirkTests :: Spec +htmlParsingQuirkTests = do + testIt "voidElem " voidElem + testIt "caseInsDoctype1 " caseInsDoctype1 + testIt "caseInsDoctype2 " caseInsDoctype2 + testIt "voidEmptyElem " voidEmptyElem + testIt "rawTextElem " rawTextElem + testIt "endTagCase " endTagCase + testIt "hexEntityCap " hexEntityCap + testIt "laxAttrName " laxAttrName + it "badAttrName " badAttrName + testIt "emptyAttr " emptyAttr + testIt "emptyAttr2 " emptyAttr2 + testIt "unquotedAttr " unquotedAttr + testIt "laxAttrVal " laxAttrVal + testIt "ampersandInText " ampersandInText + testIt "omitOptionalEnds " omitOptionalEnds + testIt "omitEndHEAD " omitEndHEAD + testIt "omitEndLI " omitEndLI + testIt "omitEndDT " omitEndDT + testIt "omitEndDD " omitEndDD + testIt "omitEndP " omitEndP + testIt "omitEndRT " omitEndRT + testIt "omitEndRP " omitEndRP + testIt "omitEndOPTGRP " omitEndOPTGRP + testIt "omitEndOPTION " omitEndOPTION + testIt "omitEndCOLGRP " omitEndCOLGRP + testIt "omitEndTHEAD " omitEndTHEAD + testIt "omitEndTBODY " omitEndTBODY + testIt "omitEndTFOOT " omitEndTFOOT + testIt "omitEndTR " omitEndTR + testIt "omitEndTD " omitEndTD + testIt "omitEndTH " omitEndTH + testIt "testNewRefs " testNewRefs + testIt "errorImplicitClose " errorImplicitClose testIt "weirdScriptThing " weirdScriptThing - ] caseInsDoctype1 :: Bool caseInsDoctype1 = parseHTML "" "" @@ -548,24 +523,23 @@ -- XML Rendering Tests ------------------------------------------------------- ------------------------------------------------------------------------------ -xmlRenderingTests :: [Test] -xmlRenderingTests = [ - testIt "renderByteOrderMark " renderByteOrderMark, - testIt "renderByteOrderMarkLE " renderByteOrderMarkLE, - testIt "singleQuoteInSysID " singleQuoteInSysID, - testIt "doubleQuoteInSysID " doubleQuoteInSysID, - testIt "bothQuotesInSysID " bothQuotesInSysID, - testIt "doubleQuoteInPubID " doubleQuoteInPubID, - testIt "doubleDashInComment " doubleDashInComment, - testIt "trailingDashInComment " trailingDashInComment, - testIt "renderEmptyText " renderEmptyText, - testIt "singleQuoteInAttr " singleQuoteInAttr, - testIt "doubleQuoteInAttr " doubleQuoteInAttr, - testIt "bothQuotesInAttr " bothQuotesInAttr, - testIt "ndashEscapesInLatin " ndashEscapesInLatin, - testIt "smileyEscapesInLatin " smileyEscapesInLatin, +xmlRenderingTests :: Spec +xmlRenderingTests = do + testIt "renderByteOrderMark " renderByteOrderMark + testIt "renderByteOrderMarkLE " renderByteOrderMarkLE + testIt "singleQuoteInSysID " singleQuoteInSysID + testIt "doubleQuoteInSysID " doubleQuoteInSysID + testIt "bothQuotesInSysID " bothQuotesInSysID + testIt "doubleQuoteInPubID " doubleQuoteInPubID + testIt "doubleDashInComment " doubleDashInComment + testIt "trailingDashInComment " trailingDashInComment + testIt "renderEmptyText " renderEmptyText + testIt "singleQuoteInAttr " singleQuoteInAttr + testIt "doubleQuoteInAttr " doubleQuoteInAttr + testIt "bothQuotesInAttr " bothQuotesInAttr + testIt "ndashEscapesInLatin " ndashEscapesInLatin + testIt "smileyEscapesInLatin " smileyEscapesInLatin testIt "numericalEscapes " numericalEscapes - ] renderByteOrderMark :: Bool renderByteOrderMark = @@ -584,21 +558,21 @@ 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 +603,23 @@ 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 = @@ -672,20 +646,19 @@ -- HTML Repeats of XML Rendering Tests --------------------------------------- ------------------------------------------------------------------------------ -htmlXMLRenderingTests :: [Test] -htmlXMLRenderingTests = [ - testIt "hRenderByteOrderMark " hRenderByteOrderMark, - testIt "hSingleQuoteInSysID " hSingleQuoteInSysID, - testIt "hDoubleQuoteInSysID " hDoubleQuoteInSysID, - testIt "hBothQuotesInSysID " hBothQuotesInSysID, - testIt "hDoubleQuoteInPubID " hDoubleQuoteInPubID, - testIt "hDoubleDashInComment " hDoubleDashInComment, - testIt "hTrailingDashInComment " hTrailingDashInComment, - testIt "hRenderEmptyText " hRenderEmptyText, - testIt "hSingleQuoteInAttr " hSingleQuoteInAttr, - testIt "hDoubleQuoteInAttr " hDoubleQuoteInAttr, +htmlXMLRenderingTests :: Spec +htmlXMLRenderingTests = do + testIt "hRenderByteOrderMark " hRenderByteOrderMark + testIt "hSingleQuoteInSysID " hSingleQuoteInSysID + testIt "hDoubleQuoteInSysID " hDoubleQuoteInSysID + testIt "hBothQuotesInSysID " hBothQuotesInSysID + testIt "hDoubleQuoteInPubID " hDoubleQuoteInPubID + testIt "hDoubleDashInComment " hDoubleDashInComment + testIt "hTrailingDashInComment " hTrailingDashInComment + testIt "hRenderEmptyText " hRenderEmptyText + testIt "hSingleQuoteInAttr " hSingleQuoteInAttr + testIt "hDoubleQuoteInAttr " hDoubleQuoteInAttr testIt "hBothQuotesInAttr " hBothQuotesInAttr - ] hRenderByteOrderMark :: Bool hRenderByteOrderMark = @@ -695,21 +668,21 @@ 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,58 +713,61 @@ 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")] [] ])) - == "" + == "" ------------------------------------------------------------------------------ -- HTML Quirks Rendering Tests ----------------------------------------------- ------------------------------------------------------------------------------ -htmlRenderingQuirkTests :: [Test] -htmlRenderingQuirkTests = [ - testIt "renderHTMLVoid " renderHTMLVoid, - testIt "renderHTMLVoid2 " renderHTMLVoid2, - testIt "renderHTMLRaw " renderHTMLRaw, - testIt "renderHTMLRawMult " renderHTMLRawMult, - testIt "renderHTMLRaw2 " renderHTMLRaw2, - testIt "renderHTMLRaw3 " renderHTMLRaw3, - testIt "renderHTMLRaw4 " renderHTMLRaw4, - testIt "renderHTMLEmptyAttr " renderHTMLEmptyAttr, - testIt "renderHTMLEmptyAttr2 " renderHTMLEmptyAttr2, - testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1, - testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2, - testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3, - testIt "renderHTMLQVoid " renderHTMLQVoid, - testIt "renderHTMLQVoid2 " renderHTMLQVoid2, - testIt "renderHTMLQRaw " renderHTMLQRaw, - testIt "renderHTMLQRawMult " renderHTMLQRawMult, - testIt "renderHTMLQRaw2 " renderHTMLQRaw2, - testIt "renderHTMLQRaw3 " renderHTMLQRaw3, +htmlRenderingQuirkTests :: Spec +htmlRenderingQuirkTests = do + testIt "renderHTMLVoid " renderHTMLVoid + testIt "renderHTMLVoid2 " renderHTMLVoid2 + testIt "renderHTMLRaw " renderHTMLRaw + testIt "renderHTMLRawMult " renderHTMLRawMult + testIt "renderHTMLRaw2 " renderHTMLRaw2 + testIt "renderHTMLRaw3 " renderHTMLRaw3 + testIt "renderHTMLRaw4 " renderHTMLRaw4 + testIt "renderHTMLEmptyAttr " renderHTMLEmptyAttr + testIt "renderHTMLEmptyAttr2 " renderHTMLEmptyAttr2 + testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1 + testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2 + testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3 + testIt "renderHTMLQVoid " renderHTMLQVoid + testIt "renderHTMLQVoid2 " renderHTMLQVoid2 + testIt "renderHTMLQRaw " renderHTMLQRaw + testIt "renderHTMLQRawMult " renderHTMLQRawMult + testIt "renderHTMLQRaw2 " renderHTMLQRaw2 + testIt "renderHTMLQRaw3 " renderHTMLQRaw3 testIt "renderHTMLQRaw4 " renderHTMLQRaw4 - ] + it "singleAlways " singleAlways + it "doubleAlways " doubleAlways + it "singleAvoidEscaping " singleAvoidEscaping + it "doubleAvoidEscaping " doubleAvoidEscaping renderHTMLVoid :: Bool renderHTMLVoid = toByteString (render (HtmlDocument UTF8 Nothing [ Element "img" [("src", "foo")] [] ])) - == "" + == "" renderHTMLVoid2 :: Bool renderHTMLVoid2 = isBottom $ @@ -806,7 +782,7 @@ TextNode "/&+" ] ])) - == "" + == "" renderHTMLRawMult :: Bool renderHTMLRawMult = @@ -816,7 +792,7 @@ TextNode "bar" ] ])) - == "" + == "" renderHTMLRaw2 :: Bool renderHTMLRaw2 = isBottom $ @@ -855,32 +831,32 @@ 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 +871,7 @@ TextNode "/&+" ] ])) - == "/&+" + == "/&+" renderHTMLQRawMult :: Bool renderHTMLQRawMult = @@ -905,7 +881,7 @@ TextNode "bar" ] ])) - == "foobar" + == "foobar" renderHTMLQRaw2 :: Bool renderHTMLQRaw2 = isBottom $ @@ -932,22 +908,61 @@ ] ])) +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 ---------------------------- ------------------------------------------------------------------------------ -blazeRenderTests :: [Test] -blazeRenderTests = [ - testIt "blazeTestString " blazeTestString, - testIt "blazeTestText " blazeTestText, - testIt "blazeTestBS " blazeTestBS, - testIt "blazeTestPre " blazeTestPre, - testIt "blazeTestExternal " blazeTestExternal, - testIt "blazeTestCustom " blazeTestCustom, - testIt "blazeTestMulti " blazeTestMulti, +blazeRenderTests :: Spec +blazeRenderTests = do + testIt "blazeTestString " blazeTestString + testIt "blazeTestText " blazeTestText + testIt "blazeTestBS " blazeTestBS + testIt "blazeTestPre " blazeTestPre + testIt "blazeTestExternal " blazeTestExternal + testIt "blazeTestCustom " blazeTestCustom + testIt "blazeTestMulti " blazeTestMulti testIt "blazeTestEmpty " blazeTestEmpty - ] blazeTestIsString :: (IsString t1, IsString t) => (t -> AttributeValue) -> (t1 -> Html) -> Bool @@ -997,6 +1012,3 @@ selectCustom :: Html selectCustom = H.select ! H.customAttribute "dojoType" "select" $ (mappend "foo " "bar") - - - diff --git a/xmlhtml.cabal b/xmlhtml.cabal --- 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 @@ -37,6 +37,7 @@ extra/logo.gif, haddock.sh, README.md, + CHANGELOG.md, test/src/TestSuite.hs test/src/Text/XmlHtml/CursorTests.hs, test/src/Text/XmlHtml/DocumentTests.hs, @@ -821,9 +822,10 @@ 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.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, parsec >= 3.1.2 && < 3.2, text >= 0.11 && < 1.3, @@ -852,9 +854,9 @@ 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, + hspec >= 2.4 && <2.5, text, xmlhtml