[API change] Add functions htmlAddStyle, htmlAlignmentToString and htmlAttrs to Writers/Shared.hs

The functions htmlAddStyle and htmlAlignmentToString are moved from Writers/HTML.hs, where they were called 'addStyle' and 'alignmentToString' respectively.
The function htmlAttrs is split off from tagWithAttrs in Writers/Shared.hs. It creates a representation of an Attr object, as one would see in a tagWithAttrs (but without the tag)

2 files changed, 42 insertions, 31 deletions

diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index 3356e39fa..019660dce 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -48,7 +48,6 @@ import Text.DocLayout (render, literal, Doc)
 import Text.Blaze.Internal (MarkupM (Empty), customLeaf, customParent)
 import Text.DocTemplates (FromContext (lookupContext), Context (..))
 import Text.Blaze.Html hiding (contents)
-import Text.Pandoc.CSS (cssAttributes)
 import Text.Pandoc.Definition
 import Text.Pandoc.Highlighting (formatHtmlBlock, formatHtml4Block,
                  formatHtmlInline, highlight, styleToCss)
@@ -1268,13 +1267,6 @@ tableRowToHtml opts (TableRow tblpart attr rownum rowhead rowbody) = do
     rowHtml
     nl
 
-alignmentToString :: Alignment -> Maybe Text
-alignmentToString = \case
-  AlignLeft    -> Just "left"
-  AlignRight   -> Just "right"
-  AlignCenter  -> Just "center"
-  AlignDefault -> Nothing
-
 colspanAttrib :: ColSpan -> Attribute
 colspanAttrib = \case
   ColSpan 1 -> mempty
@@ -1310,12 +1302,12 @@ tableCellToHtml opts ctype colAlign (Cell attr align rowspan colspan item) = do
   let align' = case align of
         AlignDefault -> colAlign
         _            -> align
-  let kvs' = case alignmentToString align' of
+  let kvs' = case htmlAlignmentToString align' of
                Nothing ->
                  kvs
                Just alignStr ->
                  if html5
-                 then addStyle ("text-align", alignStr) kvs
+                 then htmlAddStyle ("text-align", alignStr) kvs
                  else case break ((== "align") . fst) kvs of
                    (_, []) -> ("align", alignStr) : kvs
                    (xs, _:rest) -> xs ++ ("align", alignStr) : rest
@@ -1328,23 +1320,6 @@ tableCellToHtml opts ctype colAlign (Cell attr align rowspan colspan item) = do
     tag' ! attribs $ contents
     nl
 
--- | Adds a key-value pair to the @style@ attribute.
-addStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
-addStyle (key, value) kvs =
-  let cssToStyle = T.intercalate " " . map (\(k, v) -> k <> ": " <> v <> ";")
-  in case break ((== "style") . fst) kvs of
-    (_, []) ->
-      -- no style attribute yet, add new one
-      ("style", cssToStyle [(key, value)]) : kvs
-    (xs, (_,cssStyles):rest) ->
-      -- modify the style attribute
-      xs ++ ("style", cssToStyle modifiedCssStyles) : rest
-      where
-        modifiedCssStyles =
-          case break ((== key) . fst) $ cssAttributes cssStyles of
-            (cssAttribs, []) -> (key, value) : cssAttribs
-            (pre, _:post)    -> pre ++ (key, value) : post
-
 toListItems :: [Html] -> [Html]
 toListItems items = map toListItem items ++ [nl]
 
diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs
index d56efe398..1af0f7e9f 100644
--- a/src/Text/Pandoc/Writers/Shared.hs
+++ b/src/Text/Pandoc/Writers/Shared.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 {- |
    Module      : Text.Pandoc.Writers.Shared
    Copyright   : Copyright (C) 2013-2022 John MacFarlane
@@ -23,6 +24,9 @@ module Text.Pandoc.Writers.Shared (
                      , defField
                      , getLang
                      , tagWithAttrs
+                     , htmlAddStyle
+                     , htmlAlignmentToString
+                     , htmlAttrs
                      , isDisplayMath
                      , fixDisplayMath
                      , unsmartify
@@ -53,6 +57,7 @@ import qualified Data.Map as M
 import qualified Data.Text as T
 import Data.Text (Text)
 import qualified Text.Pandoc.Builder as Builder
+import Text.Pandoc.CSS (cssAttributes)
 import Text.Pandoc.Definition
 import Text.Pandoc.Options
 import Text.DocLayout
@@ -168,9 +173,12 @@ getLang opts meta =
 
 -- | Produce an HTML tag with the given pandoc attributes.
 tagWithAttrs :: HasChars a => Text -> Attr -> Doc a
-tagWithAttrs tag (ident,classes,kvs) = hsep
-  ["<" <> text (T.unpack tag)
-  ,if T.null ident
+tagWithAttrs tag attr = "<" <> text (T.unpack tag) <> (htmlAttrs attr) <> ">"
+
+-- | Produce HTML for the given pandoc attributes, to be used in HTML tags
+htmlAttrs :: HasChars a => Attr -> Doc a
+htmlAttrs (ident, classes, kvs) = addSpaceIfNotEmpty (hsep [
+  if T.null ident
       then empty
       else "id=" <> doubleQuotes (text $ T.unpack ident)
   ,if null classes
@@ -178,7 +186,35 @@ tagWithAttrs tag (ident,classes,kvs) = hsep
       else "class=" <> doubleQuotes (text $ T.unpack (T.unwords classes))
   ,hsep (map (\(k,v) -> text (T.unpack k) <> "=" <>
                 doubleQuotes (text $ T.unpack (escapeStringForXML v))) kvs)
-  ] <> ">"
+  ])
+
+addSpaceIfNotEmpty :: HasChars a => Doc a -> Doc a
+addSpaceIfNotEmpty f = if isEmpty f then f else " " <> f
+
+-- | Adds a key-value pair to the @style@ attribute.
+htmlAddStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
+htmlAddStyle (key, value) kvs =
+  let cssToStyle = T.intercalate " " . map (\(k, v) -> k <> ": " <> v <> ";")
+  in case break ((== "style") . fst) kvs of
+    (_, []) ->
+      -- no style attribute yet, add new one
+      ("style", cssToStyle [(key, value)]) : kvs
+    (xs, (_,cssStyles):rest) ->
+      -- modify the style attribute
+      xs ++ ("style", cssToStyle modifiedCssStyles) : rest
+      where
+        modifiedCssStyles =
+          case break ((== key) . fst) $ cssAttributes cssStyles of
+            (cssAttribs, []) -> (key, value) : cssAttribs
+            (pre, _:post)    -> pre ++ (key, value) : post
+
+-- | Get the html representation of an alignment key
+htmlAlignmentToString :: Alignment -> Maybe Text
+htmlAlignmentToString = \case
+  AlignLeft    -> Just "left"
+  AlignRight   -> Just "right"
+  AlignCenter  -> Just "center"
+  AlignDefault -> Nothing
 
 -- | Returns 'True' iff the argument is an inline 'Math' element of type
 -- 'DisplayMath'.