diff --git a/src/Text/XmlHtml.hs b/src/Text/XmlHtml.hs --- a/src/Text/XmlHtml.hs +++ b/src/Text/XmlHtml.hs @@ -57,8 +57,9 @@ -- * Rendering render, - XML.renderXmlFragment, - HTML.renderHtmlFragment + XMLR.renderXmlFragment, + HTML.renderHtmlFragment, + renderDocType ) where ------------------------------------------------------------------------------ @@ -69,7 +70,7 @@ import Text.XmlHtml.TextParser import qualified Text.XmlHtml.XML.Parse as XML -import qualified Text.XmlHtml.XML.Render as XML +import qualified Text.XmlHtml.XML.Render as XMLR import qualified Text.XmlHtml.HTML.Parse as HTML import qualified Text.XmlHtml.HTML.Render as HTML @@ -101,6 +102,10 @@ ------------------------------------------------------------------------------ -- | Renders a 'Document'. render :: Document -> Builder -render (XmlDocument e dt ns) = XML.render e dt ns +render (XmlDocument e dt ns) = XMLR.render e dt ns render (HtmlDocument e dt ns) = HTML.render e dt ns + + +renderDocType :: Encoding -> Maybe DocType -> Builder +renderDocType = XMLR.docTypeDecl diff --git a/src/Text/XmlHtml/HTML/Meta.hs b/src/Text/XmlHtml/HTML/Meta.hs --- a/src/Text/XmlHtml/HTML/Meta.hs +++ b/src/Text/XmlHtml/HTML/Meta.hs @@ -4,6 +4,7 @@ module Text.XmlHtml.HTML.Meta ( voidTags , rawTextTags + , isRawText , endOmittableLast , endOmittableNext , predefinedRefs @@ -30,12 +31,36 @@ ] ------------------------------------------------------------------------------ --- | Elements that XmlHtml treats as raw text. Raw text elements are not --- allowed to have any other tags in them. This is necessary to support the --- Javascript less than operator inside a script tag, for example. +-- | Elements that XmlHtml treats as raw text by default. Raw text elements +-- are not allowed to have any other tags in them. This is necessary to +-- support the Javascript less than operator inside a script tag, for example. +-- +-- The library uses the 'isRawText' function everywhere instead of checking +-- this set directly because that gives us an escape hatch to avoid the +-- default behavior if necessary. {-# NOINLINE rawTextTags #-} rawTextTags :: HashSet Text rawTextTags = S.fromList [ "script", "style" ] + +------------------------------------------------------------------------------ +-- | Determine whether a tag should be treated as raw text. Raw text elements +-- are not allowed to have any other tags in them. This is necessary to +-- support the Javascript less than operator inside a script tag, for example. +-- +-- If a tag is in the 'rawTextTags' set, this function allows you to override +-- that behavior by adding the @xmlhtmlNotRaw@ attribute. Conversely, if a +-- tag is not in the 'rawTextTags' set, this function allows you to override +-- that by adding the @xmlhtmlRaw@ attribute to the tag. +-- +-- This is the function that is actually used in the parser and renderer. +-- 'rawTextTags' is not used any more, but is still provided for backwards +-- compatibility and to let you see which tags are treated as raw by default. +{-# NOINLINE isRawText #-} +isRawText :: Text -> [(Text, Text)] -> Bool +isRawText tag as = + if tag `S.member` rawTextTags + then ("xmlhtmlNotRaw", "") `notElem` as + else ("xmlhtmlRaw", "") `elem` as ------------------------------------------------------------------------------ -- | List of elements with omittable end tags. diff --git a/src/Text/XmlHtml/HTML/Parse.hs b/src/Text/XmlHtml/HTML/Parse.hs --- a/src/Text/XmlHtml/HTML/Parse.hs +++ b/src/Text/XmlHtml/HTML/Parse.hs @@ -158,7 +158,7 @@ else nonEmptyElem where nonEmptyElem - | tbase `S.member` rawTextTags = do + | isRawText tbase a = do c <- XML.cdata "<" $ P.try (endTag t) return (Element t a [c], Matched) | tbase `S.member` endOmittableLast = tagContents optional 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 @@ -98,7 +98,7 @@ `mappend` fromText e " />" | tb `S.member` voidTags = error $ T.unpack t ++ " must be empty" - | tb `S.member` rawTextTags, + | isRawText tb a, all isTextNode c, let s = T.concat (map nodeText c), not ("" - | tb `S.member` rawTextTags, + | isRawText tb a, [ TextNode _ ] <- c = error $ T.unpack t ++ " cannot contain text looking like its end tag" - | tb `S.member` rawTextTags = + | isRawText tb a = error $ T.unpack t ++ " cannot contain child elements or comments" | otherwise = fromText e "<" diff --git a/test/suite/Text/XmlHtml/Tests.hs b/test/suite/Text/XmlHtml/Tests.hs --- a/test/suite/Text/XmlHtml/Tests.hs +++ b/test/suite/Text/XmlHtml/Tests.hs @@ -64,7 +64,7 @@ testIt "emptyElement " emptyElement, testIt "emptyElement2 " emptyElement2, testIt "elemWithText " elemWithText, - testIt "xmlDecl " xmlDecl, + testIt "xmlDeclXML " xmlDeclXML, testIt "procInst " procInst, testIt "badDoctype1 " badDoctype1, testIt "badDoctype2 " badDoctype2, @@ -181,8 +181,8 @@ elemWithText = parseXML "" "text" == Right (XmlDocument UTF8 Nothing [Element "myElement" [] [TextNode "text"]]) -xmlDecl :: Bool -xmlDecl = parseXML "" "" +xmlDeclXML :: Bool +xmlDeclXML = parseXML "" "" == Right (XmlDocument UTF8 Nothing []) procInst :: Bool @@ -408,8 +408,8 @@ == Right (HtmlDocument UTF8 Nothing [Element "img" [] []]) rawTextElem :: Bool -rawTextElem = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "script" [] [ +rawTextElem = parseHTML "" "" + == Right (HtmlDocument UTF8 Nothing [Element "script" [("type", "text/javascript")] [ TextNode "Thistest&"] ]) diff --git a/test/xmlhtml-testsuite.cabal b/test/xmlhtml-testsuite.cabal --- a/test/xmlhtml-testsuite.cabal +++ b/test/xmlhtml-testsuite.cabal @@ -9,14 +9,14 @@ build-depends: HUnit == 1.2.*, - directory >= 1.0 && <1.2, + directory >= 1.0 && <1.3, QuickCheck >= 2.3.0.2, base == 4.*, blaze-builder >= 0.2 && <0.4, - blaze-html >= 0.5 && <0.6, + blaze-html >= 0.5 && <0.7, blaze-markup >= 0.5 && <0.6, - bytestring == 0.9.*, - containers >= 0.3 && <0.5, + bytestring >= 0.9 && <0.11, + containers >= 0.3 && <0.6, parsec >= 3.1.2 && <3.2, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, @@ -24,5 +24,5 @@ text >= 0.11 && <0.12, unordered-containers >= 0.1.4 && <0.3 - ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded + ghc-options: -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind diff --git a/xmlhtml.cabal b/xmlhtml.cabal --- a/xmlhtml.cabal +++ b/xmlhtml.cabal @@ -1,5 +1,5 @@ Name: xmlhtml -Version: 0.2.1 +Version: 0.2.2 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