xmlhtml 0.2.4 → 0.2.5
raw patch · 13 files changed
+542/−401 lines, 13 filesdep +bytestring-builderdep +hspecdep −test-frameworkdep −test-framework-hunitdep ~blaze-htmldep ~blaze-markup
Dependencies added: bytestring-builder, hspec
Dependencies removed: test-framework, test-framework-hunit
Dependency ranges changed: blaze-html, blaze-markup
Files
- CHANGELOG.md +8/−0
- src/Text/Blaze/Renderer/XmlHtml.hs +5/−5
- src/Text/XmlHtml.hs +12/−2
- src/Text/XmlHtml/Common.hs +47/−3
- src/Text/XmlHtml/HTML/Render.hs +68/−46
- src/Text/XmlHtml/XML/Render.hs +54/−41
- test/src/TestSuite.hs +16/−3
- test/src/Text/XmlHtml/CursorTests.hs +13/−15
- test/src/Text/XmlHtml/DocumentTests.hs +62/−49
- test/src/Text/XmlHtml/OASISTest.hs +34/−27
- test/src/Text/XmlHtml/TestCommon.hs +3/−4
- test/src/Text/XmlHtml/Tests.hs +213/−201
- xmlhtml.cabal +7/−5
+ CHANGELOG.md view
@@ -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+
src/Text/Blaze/Renderer/XmlHtml.hs view
@@ -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 #-}
src/Text/XmlHtml.hs view
@@ -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
src/Text/XmlHtml/Common.hs view
@@ -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 <div example="">+ -- '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
src/Text/XmlHtml/HTML/Render.hs view
@@ -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 "<!--"- `mappend` fromText e t- `mappend` 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 "<!--"+ `mappend` fromText e t+ `mappend` 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 ("</" `T.append` t `T.isInfixOf` s) = fromText e "<" `mappend` fromText e t- `mappend` (mconcat $ map (attribute e tb) a)+ `mappend` (mconcat $ map (attribute opts e tb) a) `mappend` fromText e ">" `mappend` fromText e s `mappend` fromText e "</"@@ -123,33 +135,43 @@ | otherwise = fromText e "<" `mappend` fromText e t- `mappend` (mconcat $ map (attribute e tb) a)+ `mappend` (mconcat $ map (attribute opts e tb) a) `mappend` fromText e ">"- `mappend` (mconcat $ map (node e) c)+ `mappend` (mconcat $ map (node opts e) c) `mappend` fromText e "</" `mappend` fromText e t `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)
src/Text/XmlHtml/XML/Render.hs view
@@ -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 "<!--"- `mappend` fromText e t- `mappend` 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 "<!--"+ `mappend` fromText e t+ `mappend` 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 "</" `mappend` fromText e t `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 -> ("\"", "'" , """)
test/src/TestSuite.hs view
@@ -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
test/src/Text/XmlHtml/CursorTests.hs view
@@ -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
test/src/Text/XmlHtml/DocumentTests.hs view
@@ -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 = "<p div=\"tester\"></p>" -- Element "p" [("div","tester")] []+ tmpl2 = "<p div=\"tes'er\"></p>"+ tmpl3 = "<p div='tes\"er'></p>"+ rndr =+ fmap (B.toLazyByteString . renderWithOptions+ (defaultRenderOptions { roAttributeSurround = SurroundDoubleQuote}))+ . parseHTML "test"+ assertEqual "plain attr" (rndr tmpl1) (Right "<p div=\"tester\"></p>")+ assertEqual "plain attr" (rndr tmpl2) (Right "<p div=\"tes'er\"></p>")+ assertEqual "plain attr" (rndr tmpl3) (Right "<p div='tes\"er'></p>")
test/src/Text/XmlHtml/OASISTest.hs view
@@ -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-
test/src/Text/XmlHtml/TestCommon.hs view
@@ -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.
test/src/Text/XmlHtml/Tests.hs view
@@ -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 "" "<!dOcTyPe html SyStEm 'foo'>"@@ -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` "<!DOCTYPE html SYSTEM \"test\'ing\">\n"+ == utf8Decl `B.append` "<!DOCTYPE html SYSTEM \"test'ing\">\n" doubleQuoteInSysID :: Bool doubleQuoteInSysID = toByteString (render (XmlDocument UTF8 (Just (DocType "html" (System "test\"ing") NoInternalSubset)) []))- == utf8Decl `B.append` "<!DOCTYPE html SYSTEM \'test\"ing\'>\n"+ == utf8Decl `B.append` "<!DOCTYPE html SYSTEM 'test\"ing'>\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` "<foo bar=\"test\'ing\"/>"+ == utf8Decl `B.append` "<foo bar=\"test'ing\"/>" doubleQuoteInAttr :: Bool doubleQuoteInAttr = toByteString (render (XmlDocument UTF8 Nothing [ Element "foo" [("bar", "test\"ing")] [] ]))- == utf8Decl `B.append` "<foo bar=\'test\"ing\'/>"+ == utf8Decl `B.append` "<foo bar='test\"ing'/>" bothQuotesInAttr :: Bool bothQuotesInAttr = toByteString (render (XmlDocument UTF8 Nothing [- Element "foo" [("bar", "test\'\"ing")] []+ Element "foo" [("bar", "test'\"ing")] [] ]))- == utf8Decl `B.append` "<foo bar=\"test\'"ing\"/>"+ == utf8Decl `B.append` "<foo bar='test'\"ing'/>" 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)) []))- == "<!DOCTYPE html SYSTEM \"test\'ing\">\n"+ == "<!DOCTYPE html SYSTEM \"test'ing\">\n" hDoubleQuoteInSysID :: Bool hDoubleQuoteInSysID = toByteString (render (HtmlDocument UTF8 (Just (DocType "html" (System "test\"ing") NoInternalSubset)) []))- == "<!DOCTYPE html SYSTEM \'test\"ing\'>\n"+ == "<!DOCTYPE html SYSTEM 'test\"ing'>\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")] [] ]))- == "<foo bar=\"test\'ing\"></foo>"+ == "<foo bar=\"test'ing\"></foo>" hDoubleQuoteInAttr :: Bool hDoubleQuoteInAttr = toByteString (render (HtmlDocument UTF8 Nothing [ Element "foo" [("bar", "test\"ing")] [] ]))- == "<foo bar=\'test\"ing\'></foo>"+ == "<foo bar='test\"ing'></foo>" hBothQuotesInAttr :: Bool hBothQuotesInAttr = toByteString (render (HtmlDocument UTF8 Nothing [- Element "foo" [("bar", "test\'\"ing")] []+ Element "foo" [("bar", "test'\"ing")] [] ]))- == "<foo bar=\"test\'"ing\"></foo>"+ == "<foo bar='test'\"ing'></foo>" ------------------------------------------------------------------------------ -- 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")] [] ]))- == "<img src=\'foo\' />"+ == "<img src='foo' />" renderHTMLVoid2 :: Bool renderHTMLVoid2 = isBottom $@@ -806,7 +782,7 @@ TextNode "<testing>/&+</foo>" ] ]))- == "<script type=\'text/javascript\'><testing>/&+</foo></script>"+ == "<script type='text/javascript'><testing>/&+</foo></script>" renderHTMLRawMult :: Bool renderHTMLRawMult =@@ -816,7 +792,7 @@ TextNode "bar" ] ]))- == "<script type=\'text/javascript\'>foobar</script>"+ == "<script type='text/javascript'>foobar</script>" renderHTMLRaw2 :: Bool renderHTMLRaw2 = isBottom $@@ -855,32 +831,32 @@ toByteString (render (HtmlDocument UTF8 Nothing [ Element "a" [("href", "")] [] ]))- == "<a href=\"\"></a>"+ == "<a href=''></a>" renderHTMLAmpAttr1 :: Bool renderHTMLAmpAttr1 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a & b")] [] ]))- == "<body foo=\'a & b\'></body>"+ == "<body foo='a & b'></body>" renderHTMLAmpAttr2 :: Bool renderHTMLAmpAttr2 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a & b")] [] ]))- == "<body foo=\'a &amp; b\'></body>"+ == "<body foo='a &amp; b'></body>" renderHTMLAmpAttr3 :: Bool renderHTMLAmpAttr3 = toByteString (render (HtmlDocument UTF8 Nothing [ Element "body" [("foo", "a e b")] [] ]))- == "<body foo=\'a &#x65; b\'></body>"+ == "<body foo='a &#x65; b'></body>" renderHTMLQVoid :: Bool renderHTMLQVoid = toByteString (render (HtmlDocument UTF8 Nothing [ Element "foo:img" [("src", "foo")] [] ]))- == "<foo:img src=\'foo\' />"+ == "<foo:img src='foo' />" renderHTMLQVoid2 :: Bool renderHTMLQVoid2 = isBottom $@@ -895,7 +871,7 @@ TextNode "<testing>/&+</foo>" ] ]))- == "<foo:script type=\'text/javascript\'><testing>/&+</foo></foo:script>"+ == "<foo:script type='text/javascript'><testing>/&+</foo></foo:script>" renderHTMLQRawMult :: Bool renderHTMLQRawMult =@@ -905,7 +881,7 @@ TextNode "bar" ] ]))- == "<foo:script type=\'text/javascript\'>foobar</foo:script>"+ == "<foo:script type='text/javascript'>foobar</foo:script>" 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))+ "<div single=''' double='\"' both=''\"'></div>"++doubleAlways :: Assertion+doubleAlways =+ assertEqual "doubleAlways"+ (renderToByteString (RenderOptions SurroundDoubleQuote+ AttrResolveByEscape+ Nothing))+ "<div single=\"'\" double=\""\" both=\"'"\"></div>"++singleAvoidEscaping :: Assertion+singleAvoidEscaping =+ assertEqual "singleAvoidEscaping"+ (renderToByteString (RenderOptions SurroundSingleQuote+ AttrResolveAvoidEscape+ Nothing))+ "<div single=\"'\" double='\"' both=''\"'></div>"++doubleAvoidEscaping :: Assertion+doubleAvoidEscaping =+ assertEqual "doubleAvoidEscaping"+ (renderToByteString (RenderOptions SurroundDoubleQuote+ AttrResolveAvoidEscape+ Nothing))+ "<div single=\"'\" double='\"' both=\"'"\"></div>"++ ------------------------------------------------------------------------------ -- 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")---
xmlhtml.cabal view
@@ -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