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 @@ -23,9 +23,6 @@ rawTextTags :: Set Text rawTextTags = S.fromAscList [ "script", "style" ] -rcdataTags :: Set Text -rcdataTags = S.fromAscList [ "textarea", "title" ] - ------------------------------------------------------------------------------ -- | Tags which can be implicitly ended in case they are the last element in -- their parent. This list actually includes all of the elements that have 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 @@ -47,37 +47,33 @@ with neither markup nor references, except that they end at the first syntactically valid matching end tag. - 3. HTML RCDATA tags (textarea and title) are parsed as text and references - but no other markup, except that they end at the first syntactically - valid matching end tag. - - 4. End tags need only match their corresponding start tags in a case + 3. End tags need only match their corresponding start tags in a case insensitive comparison. In case they are different, the start tag is used for the element tag name. - 5. Hexadecimal char references may use &#X...; (capital X) -- DONE + 4. Hexadecimal char references may use &#X...; (capital X) -- DONE - 6. Attribute names are allowed to consist of any text except for control + 5. Attribute names are allowed to consist of any text except for control characters, space, '\"', '\'', '>', '/', or '='. - 7. Empty attribute syntax is allowed (an attribute not followed by an eq). + 6. Empty attribute syntax is allowed (an attribute not followed by an eq). In this case, the attribute value is considered to be the empty string. - 8. Quoted attribute syntax is relaxed to allow any character except for + 7. Quoted attribute syntax is relaxed to allow any character except for the matching quote. References are allowed. - 9. Attribute values may be unquoted. In this case, the attribute value + 8. Attribute values may be unquoted. In this case, the attribute value may not contain space, single or double quotes, '=', '<', '>', or '`', and may not be the empty string. It can still contain references. - 10. There are many more character references available. + 9. There are many more character references available. - 11. Only "ambiguous" ampersands are prohibited in character data. This + 10. Only "ambiguous" ampersands are prohibited in character data. This means ampersands that parse like character or entity references. - 12. Omittable end tags are inserted automatically. + 11. Omittable end tags are inserted automatically. - 13. DOCTYPE tags matched with case insensitive keywords. + 12. DOCTYPE tags matched with case insensitive keywords. -} @@ -136,17 +132,6 @@ ------------------------------------------------------------------------------ --- | Reads text and references, up until the passed-in parser succeeds. --- (Generally, the passed in parser should be an end tag parser for the --- RCDATA element.) -rcdata :: [Char] -> Parser a -> Parser Node -rcdata cs end = TextNode <$> T.concat <$> P.manyTill part end - where part = takeWhile1 (not . (`elem` cs)) - <|> reference - <|> T.singleton <$> P.anyChar - - ------------------------------------------------------------------------------- -- | When parsing an element, three things can happen (besides failure): -- -- (1) The end tag matches the start tag. This is a Matched. @@ -162,51 +147,50 @@ -- element being parsed. data ElemResult = Matched | ImplicitLast Text - | ImplicitNext Text [(Text, Text)] Bool + | ImplicitNext Text Text [(Text, Text)] Bool ------------------------------------------------------------------------------ -finishElement :: Text -> [(Text, Text)] -> Bool -> Parser (Node, ElemResult) -finishElement t a b = do +finishElement :: Text -> Text -> [(Text, Text)] -> Bool + -> Parser (Node, ElemResult) +finishElement t tbase a b = do if b then return (Element t a [], Matched) else nonEmptyElem where nonEmptyElem - | T.map toLower t `S.member` rawTextTags = do + | tbase `S.member` rawTextTags = do c <- XML.cdata "<" $ P.try (endTag t) return (Element t a [c], Matched) - | T.map toLower t `S.member` rcdataTags = do - c <- rcdata "&<" $ P.try (endTag t) - return (Element t a [c], Matched) - | T.map toLower t `S.member` endOmittableLast = tagContents optional + | tbase `S.member` endOmittableLast = tagContents optional | otherwise = tagContents (fmap Just) tagContents modifier = do - (c,r1) <- content (Just t) + (c,r1) <- content (Just tbase) case r1 of Matched -> do r2 <- modifier (endTag t) case r2 of Nothing -> return (Element t a c, Matched) Just rr -> return (Element t a c, rr) - ImplicitLast tag | T.map toLower tag == T.map toLower t -> do + ImplicitLast tag | T.toCaseFold tag == T.toCaseFold t -> do return (Element t a c, Matched) end -> do return (Element t a c, end) ------------------------------------------------------------------------------ -emptyOrStartTag :: Parser (Text, [(Text, Text)], Bool) +emptyOrStartTag :: Parser (Text, Text, [(Text, Text)], Bool) emptyOrStartTag = do t <- P.try $ P.char '<' *> XML.name + let tbase = T.toLower $ snd $ T.breakOnEnd ":" t a <- many $ P.try $ do XML.whiteSpace attribute when (hasDups a) $ fail "Duplicate attribute names in element" _ <- optional XML.whiteSpace e <- fmap isJust $ optional (P.char '/') - let e' = e || (T.map toLower t `S.member` voidTags) + let e' = e || (tbase `S.member` voidTags) _ <- P.char '>' - return (t, a, e') + return (t, tbase, a, e') where hasDups a = length (nub (map fst a)) < length a @@ -268,9 +252,10 @@ endTag s = do _ <- text " found inside <" ++ T.unpack s ++ "> tag" @@ -306,17 +291,17 @@ return (n, end) doElement = do - (t,a,b) <- emptyOrStartTag - handle t a b + (t,tb, a,b) <- emptyOrStartTag + handle t tb a b - handle t a b = do - if breaksTag t parent - then return ([Nothing], ImplicitNext t a b) + handle t tb a b = do + if breaksTag tb parent + then return ([Nothing], ImplicitNext t tb a b) else do - (n,end) <- finishElement t a b + (n,end) <- finishElement t tb a b case end of - ImplicitNext t' a' b' -> do - (ns,end') <- handle t' a' b' + ImplicitNext t' tb' a' b' -> do + (ns,end') <- handle t' tb' a' b' return (Just n : ns, end') _ -> return ([Just n], end) 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 @@ -60,7 +60,9 @@ | otherwise = fromText e "" -node e (Element t a c) = element e t a c +node e (Element t a c) = + let tbase = T.toLower $ snd $ T.breakOnEnd ":" t + in element e t tbase a c ------------------------------------------------------------------------------ @@ -78,16 +80,16 @@ ------------------------------------------------------------------------------ -- XXX: Should do something to avoid concatting large CDATA sections before -- writing them to the output. -element :: Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder -element e t a c - | t `S.member` voidTags && null c = +element :: Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder +element e t tb a c + | tb `S.member` voidTags && null c = fromText e "<" `mappend` fromText e t `mappend` (mconcat $ map (attribute e) a) `mappend` fromText e " />" - | t `S.member` voidTags = + | tb `S.member` voidTags = error $ T.unpack t ++ " must be empty" - | t `S.member` rawTextTags, + | tb `S.member` rawTextTags, all isTextNode c, let s = T.concat (map nodeText c), not ("" - | t `S.member` rawTextTags, + | tb `S.member` rawTextTags, [ TextNode _ ] <- c = error $ T.unpack t ++ " cannot contain text looking like its end tag" - | t `S.member` rawTextTags = - error $ T.unpack t ++ " cannot contain child elements or comments" - | t `S.member` rcdataTags, - all isTextNode c = - fromText e "<" - `mappend` fromText e t - `mappend` (mconcat $ map (attribute e) a) - `mappend` fromText e ">" - `mappend` mconcat (map (escaped "<&" e . nodeText) c) - `mappend` fromText e "" - | t `S.member` rcdataTags = + | tb `S.member` rawTextTags = 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 @@ -358,7 +358,6 @@ testIt "caseInsDoctype2 " caseInsDoctype2, testIt "voidEmptyElem " voidEmptyElem, testIt "rawTextElem " rawTextElem, - testIt "rcdataElem " rcdataElem, testIt "endTagCase " endTagCase, testIt "hexEntityCap " hexEntityCap, testIt "laxAttrName " laxAttrName, @@ -409,12 +408,6 @@ TextNode "Thistest&"] ]) -rcdataElem :: Bool -rcdataElem = parseHTML "" "" - == Right (HtmlDocument UTF8 Nothing [Element "textarea" [] [ - TextNode "This'\"a]]>test&"] - ]) - endTagCase :: Bool endTagCase = parseHTML "" "" == Right (HtmlDocument UTF8 Nothing [Element "testing" [] []]) @@ -735,12 +728,16 @@ testIt "renderHTMLRaw2 " renderHTMLRaw2, testIt "renderHTMLRaw3 " renderHTMLRaw3, testIt "renderHTMLRaw4 " renderHTMLRaw4, - testIt "renderHTMLRcdata " renderHTMLRcdata, - testIt "renderHTMLRcdataMult " renderHTMLRcdataMult, - testIt "renderHTMLRcdata2 " renderHTMLRcdata2, testIt "renderHTMLAmpAttr1 " renderHTMLAmpAttr1, testIt "renderHTMLAmpAttr2 " renderHTMLAmpAttr2, - testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3 + testIt "renderHTMLAmpAttr3 " renderHTMLAmpAttr3, + testIt "renderHTMLQVoid " renderHTMLQVoid, + testIt "renderHTMLQVoid2 " renderHTMLQVoid2, + testIt "renderHTMLQRaw " renderHTMLQRaw, + testIt "renderHTMLQRawMult " renderHTMLQRawMult, + testIt "renderHTMLQRaw2 " renderHTMLQRaw2, + testIt "renderHTMLQRaw3 " renderHTMLQRaw3, + testIt "renderHTMLQRaw4 " renderHTMLQRaw4 ] renderHTMLVoid :: Bool @@ -800,33 +797,6 @@ ] ])) -renderHTMLRcdata :: Bool -renderHTMLRcdata = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "title" [("foo", "bar")] [ - TextNode "/&+" - ] - ])) - == "<testing>/&+</&quot;>" - -renderHTMLRcdataMult :: Bool -renderHTMLRcdataMult = - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "title" [] [ - TextNode "foo", - TextNode "bar" - ] - ])) - == "foobar" - -renderHTMLRcdata2 :: Bool -renderHTMLRcdata2 = isBottom $ - toByteString (render (HtmlDocument UTF8 Nothing [ - Element "title" [] [ - Comment "foo" - ] - ])) - renderHTMLAmpAttr1 :: Bool renderHTMLAmpAttr1 = toByteString (render (HtmlDocument UTF8 Nothing [ @@ -844,6 +814,63 @@ 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 $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:img" [] [TextNode "foo"] + ])) + +renderHTMLQRaw :: Bool +renderHTMLQRaw = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "/&+" + ] + ])) + == "/&+" + +renderHTMLQRawMult :: Bool +renderHTMLQRawMult = + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "foo", + TextNode "bar" + ] + ])) + == "foobar" + +renderHTMLQRaw2 :: Bool +renderHTMLQRaw2 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) + +renderHTMLQRaw3 :: Bool +renderHTMLQRaw3 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + Comment "foo" + ] + ])) + +renderHTMLQRaw4 :: Bool +renderHTMLQRaw4 = isBottom $ + toByteString (render (HtmlDocument UTF8 Nothing [ + Element "foo:script" [("type", "text/javascript")] [ + TextNode "" + ] + ])) ------------------------------------------------------------------------------ diff --git a/test/xmlhtml-testsuite.cabal b/test/xmlhtml-testsuite.cabal --- a/test/xmlhtml-testsuite.cabal +++ b/test/xmlhtml-testsuite.cabal @@ -1,5 +1,5 @@ name: xmlhtml-testsuite -version: 0.1.1 +version: 0.1.3 build-type: Simple cabal-version: >= 1.6 @@ -13,14 +13,14 @@ QuickCheck >= 2.3.0.2, base == 4.*, blaze-builder == 0.2.*, - blaze-html == 0.3.*, + blaze-html >= 0.3.2 && < 0.5, bytestring == 0.9.*, containers >= 0.3 && <0.5, parsec >= 3.0 && < 3.2, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && <0.3, test-framework-quickcheck2 >= 0.2.6 && < 0.3, - text >= 0.10 && < 0.12 + text >= 0.11 && < 0.12 ghc-options: -O2 -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.1.2 +Version: 0.1.3 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 wo that