diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/HTML.hs | 16 | ||||
| -rw-r--r-- | test/Tests/Writers/HTML.hs | 109 |
2 files changed, 71 insertions, 54 deletions
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 332de1545..f7a387927 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -882,7 +882,7 @@ blockToHtml opts (BlockQuote blocks) = do else do contents <- blockListToHtml opts blocks return $ H.blockquote $ nl opts >> contents >> nl opts -blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do +blockToHtml opts (Header level (ident,classes,kvs) lst) = do contents <- inlineListToHtml opts lst let secnum = fromMaybe mempty $ lookup "number" kvs let contents' = if writerNumberSections opts && not (T.null secnum) @@ -890,7 +890,13 @@ blockToHtml opts (Header level attr@(_,classes,kvs) lst) = do then (H.span ! A.class_ "header-section-number" $ toHtml secnum) >> strToHtml " " >> contents else contents - addAttrs opts attr + html5 <- gets stHtml5 + let kvs' = if html5 + then kvs + else [ (k, v) | (k, v) <- kvs + , k `elem` (["lang", "dir", "title", "style" + , "align"] ++ intrinsicEventsHTML4)] + addAttrs opts (ident,classes,kvs') $ case level of 1 -> H.h1 contents' 2 -> H.h2 contents' @@ -1526,6 +1532,12 @@ allowsMathEnvironments MathML = True allowsMathEnvironments (WebTeX _) = True allowsMathEnvironments _ = False +-- | List of intrinsic event attributes allowed on all elements in HTML4. +intrinsicEventsHTML4 :: [Text] +intrinsicEventsHTML4 = + [ "onclick", "ondblclick", "onmousedown", "onmouseup", "onmouseover" + , "onmouseout", "onmouseout", "onkeypress", "onkeydown", "onkeyup"] + isRawHtml :: PandocMonad m => Format -> StateT WriterState m Bool isRawHtml f = do html5 <- gets stHtml5 diff --git a/test/Tests/Writers/HTML.hs b/test/Tests/Writers/HTML.hs index 328801e31..404f6da98 100644 --- a/test/Tests/Writers/HTML.hs +++ b/test/Tests/Writers/HTML.hs @@ -34,55 +34,60 @@ infix 4 =: (=:) = test html tests :: [TestTree] -tests = [ testGroup "inline code" - [ "basic" =: code "@&" =?> "<code>@&</code>" - , "haskell" =: codeWith ("",["haskell"],[]) ">>=" - =?> "<code class=\"sourceCode haskell\"><span class=\"op\">>>=</span></code>" - , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>=" - =?> "<code class=\"nolanguage\">>>=</code>" - ] - , testGroup "images" - [ "alt with formatting" =: - image "/url" "title" ("my " <> emph "image") - =?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />" - ] - , testGroup "blocks" - [ "definition list with empty <dt>" =: - definitionList [(mempty, [para $ text "foo bar"])] - =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>" - ] - , testGroup "quotes" - [ "quote with cite attribute (without q-tags)" =: - doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples")) - =?> "“<span cite=\"http://example.org\">examples</span>”" - , tQ "quote with cite attribute (with q-tags)" $ - doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples")) - =?> "<q cite=\"http://example.org\">examples</q>" - ] - , testGroup "sample" - [ "sample should be rendered correctly" =: - plain (codeWith ("",["sample"],[]) "Answer is 42") =?> - "<samp>Answer is 42</samp>" - ] - , testGroup "variable" - [ "variable should be rendered correctly" =: - plain (codeWith ("",["variable"],[]) "result") =?> - "<var>result</var>" - ] - , testGroup "sample with style" - [ "samp should wrap highlighted code" =: - codeWith ("",["sample","haskell"],[]) ">>=" - =?> ("<samp><code class=\"sourceCode haskell\">" ++ - "<span class=\"op\">>>=</span></code></samp>") - ] - , testGroup "variable with style" - [ "var should wrap highlighted code" =: - codeWith ("",["haskell","variable"],[]) ">>=" - =?> ("<var><code class=\"sourceCode haskell\">" ++ - "<span class=\"op\">>>=</span></code></var>") - ] - ] - where - tQ :: (ToString a, ToPandoc a) - => String -> (a, String) -> TestTree - tQ = test htmlQTags +tests = + [ testGroup "inline code" + [ "basic" =: code "@&" =?> "<code>@&</code>" + , "haskell" =: codeWith ("",["haskell"],[]) ">>=" + =?> "<code class=\"sourceCode haskell\"><span class=\"op\">>>=</span></code>" + , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>=" + =?> "<code class=\"nolanguage\">>>=</code>" + ] + , testGroup "images" + [ "alt with formatting" =: + image "/url" "title" ("my " <> emph "image") + =?> "<img src=\"/url\" title=\"title\" alt=\"my image\" />" + ] + , testGroup "blocks" + [ "definition list with empty <dt>" =: + definitionList [(mempty, [para $ text "foo bar"])] + =?> "<dl><dt></dt><dd><p>foo bar</p></dd></dl>" + , "heading with disallowed attributes" =: + headerWith ("", [], [("invalid","1"), ("lang", "en")]) 1 "test" + =?> + "<h1 lang=\"en\">test</h1>" + ] + , testGroup "quotes" + [ "quote with cite attribute (without q-tags)" =: + doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples")) + =?> "“<span cite=\"http://example.org\">examples</span>”" + , tQ "quote with cite attribute (with q-tags)" $ + doubleQuoted (spanWith ("", [], [("cite", "http://example.org")]) (str "examples")) + =?> "<q cite=\"http://example.org\">examples</q>" + ] + , testGroup "sample" + [ "sample should be rendered correctly" =: + plain (codeWith ("",["sample"],[]) "Answer is 42") =?> + "<samp>Answer is 42</samp>" + ] + , testGroup "variable" + [ "variable should be rendered correctly" =: + plain (codeWith ("",["variable"],[]) "result") =?> + "<var>result</var>" + ] + , testGroup "sample with style" + [ "samp should wrap highlighted code" =: + codeWith ("",["sample","haskell"],[]) ">>=" + =?> ("<samp><code class=\"sourceCode haskell\">" ++ + "<span class=\"op\">>>=</span></code></samp>") + ] + , testGroup "variable with style" + [ "var should wrap highlighted code" =: + codeWith ("",["haskell","variable"],[]) ">>=" + =?> ("<var><code class=\"sourceCode haskell\">" ++ + "<span class=\"op\">>>=</span></code></var>") + ] + ] + where + tQ :: (ToString a, ToPandoc a) + => String -> (a, String) -> TestTree + tQ = test htmlQTags |