Add support for reading and writing <kbd> elements

* Text.Pandoc.Shared: export `htmlSpanLikeElements` [API change]

This commit also introduces a mapping of HTML span like elements that
are internally represented as a Span with a single class, but that are
converted back to the original element by the html writer. As of now,
only the kbd element is handled this way. Ideally these elements should
be handled as plain AST values, but since that would be a breaking
change with a large impact, we revert to this stop-gap solution.

Fixes https://github.com/jgm/pandoc/issues/5796.

3 files changed, 54 insertions, 26 deletions

diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index bb4e3a913..a9a04c962 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -62,7 +62,8 @@ import Text.Pandoc.Options (
     extensionEnabled)
 import Text.Pandoc.Parsing hiding ((<|>))
 import Text.Pandoc.Shared (addMetaField, blocksToInlines', crFilter, escapeURI,
-    extractSpaces, onlySimpleTableCells, safeRead, underlineSpan)
+                           extractSpaces, htmlSpanLikeElements,
+                           onlySimpleTableCells, safeRead, underlineSpan)
 import Text.Pandoc.Walk
 import Text.Parsec.Error
 import Text.TeXMath (readMathML, writeTeX)
@@ -643,6 +644,7 @@ inline = choice
            , pStrong
            , pSuperscript
            , pSubscript
+           , pSpanLike
            , pSmall
            , pStrikeout
            , pUnderline
@@ -707,6 +709,12 @@ pSuperscript = pInlinesInTags "sup" B.superscript
 pSubscript :: PandocMonad m => TagParser m Inlines
 pSubscript = pInlinesInTags "sub" B.subscript
 
+pSpanLike :: PandocMonad m => TagParser m Inlines
+pSpanLike = Set.foldr
+  (\tag acc -> acc <|> pInlinesInTags tag (B.spanWith ("",[T.unpack tag],[])))
+  mzero
+  htmlSpanLikeElements
+
 pSmall :: PandocMonad m => TagParser m Inlines
 pSmall = pInlinesInTags "small" (B.spanWith ("",["small"],[]))
 
diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs
index bcaa48ea1..765bc0826 100644
--- a/src/Text/Pandoc/Shared.hs
+++ b/src/Text/Pandoc/Shared.hs
@@ -67,6 +67,7 @@ module Text.Pandoc.Shared (
                      makeMeta,
                      eastAsianLineBreakFilter,
                      underlineSpan,
+                     htmlSpanLikeElements,
                      splitSentences,
                      filterIpynbOutput,
                      -- * TagSoup HTML handling
@@ -694,6 +695,11 @@ eastAsianLineBreakFilter = bottomUp go
 underlineSpan :: Inlines -> Inlines
 underlineSpan = B.spanWith ("", ["underline"], [])
 
+-- | Set of HTML elements that are represented as Span with a class equal as
+-- the element tag itself.
+htmlSpanLikeElements :: Set.Set T.Text
+htmlSpanLikeElements = Set.fromList [T.pack "kbd"]
+
 -- | Returns the first sentence in a list of inlines, and the rest.
 breakSentence :: [Inline] -> ([Inline], [Inline])
 breakSentence [] = ([],[])
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index f573753b0..a1a617829 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE CPP                 #-}
+{-# LANGUAGE MultiWayIf          #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
-{-# LANGUAGE MultiWayIf          #-}
 {- |
    Module      : Text.Pandoc.Writers.HTML
    Copyright   : Copyright (C) 2006-2019 John MacFarlane
@@ -28,27 +28,28 @@ module Text.Pandoc.Writers.HTML (
   writeRevealJs,
   tagWithAttributes
   ) where
-import Prelude
 import Control.Monad.State.Strict
 import Data.Char (ord, toLower)
 import Data.List (intercalate, intersperse, isPrefixOf, partition)
+import Data.List.Split (splitWhen)
 import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
 import qualified Data.Set as Set
 import Data.String (fromString)
-import Data.List.Split (splitWhen)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
-import Text.DocTemplates (FromContext(lookupContext))
 import Network.HTTP (urlEncode)
 import Network.URI (URI (..), parseURIReference)
 import Numeric (showHex)
-import Text.Blaze.Internal (customLeaf, customParent, MarkupM(Empty))
+import Prelude
+import Text.Blaze.Internal (MarkupM (Empty), customLeaf, customParent)
+import Text.DocTemplates (FromContext (lookupContext))
 #if MIN_VERSION_blaze_markup(0,6,3)
 #else
 import Text.Blaze.Internal (preEscapedString, preEscapedText)
 #endif
 import Text.Blaze.Html hiding (contents)
+import Text.DocTemplates (Context (..))
 import Text.Pandoc.Definition
 import Text.Pandoc.Highlighting (formatHtmlBlock, formatHtmlInline, highlight,
                                  styleToCss)
@@ -57,7 +58,6 @@ import Text.Pandoc.Options
 import Text.Pandoc.Shared
 import Text.Pandoc.Slides
 import Text.Pandoc.Templates (renderTemplate)
-import Text.DocTemplates (Context(..))
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.Math
 import Text.Pandoc.Writers.Shared
@@ -412,7 +412,7 @@ tableOfContents opts sects = do
                 _ -> opts
   case toTableOfContents opts sects of
     bl@(BulletList (_:_)) -> Just <$> blockToHtml opts' bl
-    _ -> return Nothing
+    _                     -> return Nothing
 
 -- | Convert list of Note blocks to a footnote <div>.
 -- Assumes notes are sorted.
@@ -650,7 +650,7 @@ blockToHtml opts (Div (ident, "section":dclasses, dkvs)
       isSec (Div _ zs)                = any isSec zs
       isSec _                         = False
   let isPause (Para [Str ".",Space,Str ".",Space,Str "."]) = True
-      isPause _ = False
+      isPause _                                            = False
   let fragmentClass = case slideVariant of
                            RevealJsSlides -> "fragment"
                            _              -> "incremental"
@@ -907,9 +907,9 @@ tableRowToHtml :: PandocMonad m
 tableRowToHtml opts aligns rownum cols' = do
   let mkcell = if rownum == 0 then H.th else H.td
   let rowclass = case rownum of
-                      0 -> "header"
+                      0                  -> "header"
                       x | x `rem` 2 == 1 -> "odd"
-                      _ -> "even"
+                      _                  -> "even"
   cols'' <- zipWithM
             (\alignment item -> tableItemToHtml opts mkcell alignment item)
             aligns cols'
@@ -980,7 +980,7 @@ inlineToHtml :: PandocMonad m
 inlineToHtml opts inline = do
   html5 <- gets stHtml5
   case inline of
-    (Str str)        -> return $ strToHtml str
+    (Str str)      -> return $ strToHtml str
     Space          -> return $ strToHtml " "
     SoftBreak      -> return $ case writerWrapText opts of
                                      WrapNone     -> preEscapedString " "
@@ -989,22 +989,36 @@ inlineToHtml opts inline = do
     LineBreak      -> return $ do
                         if html5 then H5.br else H.br
                         strToHtml "\n"
-    (Span (id',classes,kvs) ils)
-                     -> inlineListToHtml opts ils >>=
-                           addAttrs opts attr' . H.span
-                        where attr' = (id',classes',kvs')
-                              classes' = filter (`notElem` ["csl-no-emph",
-                                              "csl-no-strong",
-                                              "csl-no-smallcaps"]) classes
-                              kvs' = if null styles
-                                        then kvs
-                                        else ("style", concat styles) : kvs
+
+    (Span (id',classes,kvs) ils) ->
+                        let spanLikeTag = case classes of
+                                [c] -> do
+                                  let c' = T.pack c
+                                  guard (c' `Set.member` htmlSpanLikeElements)
+                                  pure $ customParent (textTag c')
+                                _   -> Nothing
+                        in case spanLikeTag of
+                            Just tag -> tag <$> inlineListToHtml opts ils
+                            Nothing -> do
+                              h <- inlineListToHtml opts ils
+                              addAttrs opts (id',classes',kvs') (H.span h)
+                            where
                               styles = ["font-style:normal;"
-                                         | "csl-no-emph" `elem` classes]
+                                       | "csl-no-emph" `elem` classes]
                                     ++ ["font-weight:normal;"
-                                         | "csl-no-strong" `elem` classes]
+                                       | "csl-no-strong" `elem` classes]
                                     ++ ["font-variant:normal;"
-                                         | "csl-no-smallcaps" `elem` classes]
+                                       | "csl-no-smallcaps" `elem` classes]
+                              kvs' = if null styles
+                                        then kvs
+                                        else ("style", concat styles) : kvs
+                              classes' = [ c | c <- classes
+                                         , c `notElem` [ "csl-no-emph"
+                                                       , "csl-no-strong"
+                                                       , "csl-no-smallcaps"
+                                                       ]
+                                         ]
+
     (Emph lst)       -> inlineListToHtml opts lst >>= return . H.em
     (Strong lst)     -> inlineListToHtml opts lst >>= return . H.strong
     (Code attr str)  -> case hlCode of