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 "@&" =?> "@&"
- , "haskell" =: codeWith ("",["haskell"],[]) ">>="
- =?> ">>="
- , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
- =?> ">>="
- ]
- , testGroup "images"
- [ "alt with formatting" =:
- image "/url" "title" ("my " <> emph "image")
- =?> ""
- ]
- , testGroup "blocks"
- [ "definition list with empty
foo bar
examples" - ] - , testGroup "sample" - [ "sample should be rendered correctly" =: - plain (codeWith ("",["sample"],[]) "Answer is 42") =?> - "Answer is 42" - ] - , testGroup "variable" - [ "variable should be rendered correctly" =: - plain (codeWith ("",["variable"],[]) "result") =?> - "result" - ] - , testGroup "sample with style" - [ "samp should wrap highlighted code" =: - codeWith ("",["sample","haskell"],[]) ">>=" - =?> ("
" ++
- ">>=")
- ]
- , testGroup "variable with style"
- [ "var should wrap highlighted code" =:
- codeWith ("",["haskell","variable"],[]) ">>="
- =?> ("" ++
- ">>=")
- ]
- ]
- where
- tQ :: (ToString a, ToPandoc a)
- => String -> (a, String) -> TestTree
- tQ = test htmlQTags
+tests =
+ [ testGroup "inline code"
+ [ "basic" =: code "@&" =?> "@&"
+ , "haskell" =: codeWith ("",["haskell"],[]) ">>="
+ =?> ">>="
+ , "nolanguage" =: codeWith ("",["nolanguage"],[]) ">>="
+ =?> ">>="
+ ]
+ , testGroup "images"
+ [ "alt with formatting" =:
+ image "/url" "title" ("my " <> emph "image")
+ =?> "foo bar
examples" + ] + , testGroup "sample" + [ "sample should be rendered correctly" =: + plain (codeWith ("",["sample"],[]) "Answer is 42") =?> + "Answer is 42" + ] + , testGroup "variable" + [ "variable should be rendered correctly" =: + plain (codeWith ("",["variable"],[]) "result") =?> + "result" + ] + , testGroup "sample with style" + [ "samp should wrap highlighted code" =: + codeWith ("",["sample","haskell"],[]) ">>=" + =?> ("
" ++
+ ">>=")
+ ]
+ , testGroup "variable with style"
+ [ "var should wrap highlighted code" =:
+ codeWith ("",["haskell","variable"],[]) ">>="
+ =?> ("" ++
+ ">>=")
+ ]
+ ]
+ where
+ tQ :: (ToString a, ToPandoc a)
+ => String -> (a, String) -> TestTree
+ tQ = test htmlQTags