From 9423b4b7d91b38540388d0183d49cc413538edb9 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Thu, 10 Sep 2020 18:47:40 +0200
Subject: Support colspans and rowspans in HTML tables (#6644)
* HTML writer: add support for row headers, colspans, rowspans
* Add planet table tests
See #6312
---
src/Text/Pandoc/Writers/HTML.hs | 252 +++++++++++++++++++++++++++++-----------
1 file changed, 187 insertions(+), 65 deletions(-)
(limited to 'src')
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index ab8e8ef93..eaf13b7da 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -30,6 +32,7 @@ module Text.Pandoc.Writers.HTML (
import Control.Monad.State.Strict
import Data.Char (ord)
import Data.List (intercalate, intersperse, partition, delete, (\\))
+import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
@@ -53,6 +56,7 @@ import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Walk
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
+import Text.Pandoc.Writers.Tables
import Text.Pandoc.XML (escapeStringForXML, fromEntities, toEntities,
html5Attributes, html4Attributes, rdfaAttributes)
import qualified Text.Blaze.XHtml5 as H5
@@ -899,39 +903,33 @@ blockToHtml opts (DefinitionList lst) = do
return $ mconcat $ nl opts : term' : nl opts :
intersperse (nl opts) defs') lst
defList opts contents
-blockToHtml opts (Table attr blkCapt specs thead tbody tfoot) = do
- let (capt, aligns, widths, headers, rows') = toLegacyTable blkCapt specs thead tbody tfoot
- captionDoc <- if null capt
- then return mempty
- else do
- cs <- inlineListToHtml opts capt
- return $ H.caption cs >> nl opts
- html5 <- gets stHtml5
- let percent w = show (truncate (100*w) :: Integer) <> "%"
- let coltags = if all (== 0.0) widths
- then mempty
- else do
- H.colgroup $ do
- nl opts
- mapM_ (\w -> do
- if html5
- then H.col ! A.style (toValue $ "width: " <>
- percent w)
- else H.col ! A.width (toValue $ percent w)
- nl opts) widths
- nl opts
- head' <- if all null headers
- then return mempty
- else do
- contents <- tableRowToHtml opts aligns 0 headers
- return $ H.thead (nl opts >> contents) >> nl opts
- body' <- liftM (\x -> H.tbody (nl opts >> mconcat x)) $
- zipWithM (tableRowToHtml opts aligns) [1..] rows'
+blockToHtml opts (Table attr caption colspecs thead tbody tfoot) =
+ tableToHtml opts (toAnnTable attr caption colspecs thead tbody tfoot)
+
+tableToHtml :: PandocMonad m
+ => WriterOptions
+ -> AnnTable
+ -> StateT WriterState m Html
+tableToHtml opts (AnnTable attr caption colspecs thead tbodies _tfoot) = do
+ captionDoc <- case caption of
+ Caption _ [] -> return mempty
+ Caption _ longCapt -> do
+ cs <- blockListToHtml opts longCapt
+ return $ do
+ H.caption cs
+ nl opts
+ coltags <- colSpecListToHtml opts colspecs
+ head' <- tableHeadToHtml opts thead
+ body' <- mconcat <$> mapM (tableBodyToHtml opts) tbodies
let (ident,classes,kvs) = attr
-- When widths of columns are < 100%, we need to set width for the whole
-- table, or some browsers give us skinny columns with lots of space
-- between:
- let totalWidth = sum widths
+ -- let totalWidth = sum widths
+ let colWidth = \case
+ ColWidth d -> d
+ ColWidthDefault -> 0
+ let totalWidth = sum . map (colWidth . snd) $ colspecs
let attr' = case lookup "style" kvs of
Nothing | totalWidth < 1 && totalWidth > 0
-> (ident,classes, ("style","width:" <>
@@ -939,56 +937,180 @@ blockToHtml opts (Table attr blkCapt specs thead tbody tfoot) = do
<> "%;"):kvs)
_ -> attr
addAttrs opts attr' $ H.table $
- nl opts >> captionDoc >> coltags >> head' >> body' >> nl opts
+ nl opts *> captionDoc *> coltags *> head' *> body' *> nl opts
+
+tableBodyToHtml :: PandocMonad m
+ => WriterOptions
+ -> AnnTableBody
+ -> StateT WriterState m Html
+tableBodyToHtml opts (AnnTableBody _attr _rowHeadCols _intm rows) =
+ H.tbody <$> bodyRowsToHtml opts rows
+
+tableHeadToHtml :: PandocMonad m
+ => WriterOptions
+ -> AnnTableHead
+ -> StateT WriterState m Html
+tableHeadToHtml opts (AnnTableHead attr rows) =
+ if null rows || all isEmptyRow rows
+ then return mempty
+ else do
+ contents <- headerRowsToHtml opts rows
+ headElement <- addAttrs opts attr $ H.thead contents
+ return $ do
+ headElement
+ nl opts
+ where
+ isEmptyRow (AnnHeaderRow _attr _rownum cells) = all isEmptyCell cells
+ isEmptyCell (AnnCell _colspecs _colnum cell) =
+ cell == Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) []
+
+
+data RowType = HeaderRow | FooterRow | BodyRow
+ deriving (Eq)
+
+data CellType = HeaderCell | BodyCell
+
+data TableRow = TableRow RowType Attr RowNumber AnnRowHead AnnRowBody
+
+headerRowsToHtml :: PandocMonad m
+ => WriterOptions
+ -> [AnnHeaderRow]
+ -> StateT WriterState m Html
+headerRowsToHtml opts =
+ rowListToHtml opts . map toTableRow
+ where
+ toTableRow (AnnHeaderRow attr rownum rowbody) =
+ TableRow HeaderRow attr rownum [] rowbody
+
+bodyRowsToHtml :: PandocMonad m
+ => WriterOptions
+ -> [AnnBodyRow]
+ -> StateT WriterState m Html
+bodyRowsToHtml opts =
+ rowListToHtml opts . zipWith toTableRow [1..]
+ where
+ toTableRow rownum (AnnBodyRow attr _rownum rowhead rowbody) =
+ TableRow BodyRow attr rownum rowhead rowbody
+
+
+rowListToHtml :: PandocMonad m
+ => WriterOptions
+ -> [TableRow]
+ -> StateT WriterState m Html
+rowListToHtml opts rows =
+ (\x -> (nl opts *> mconcat x)) <$>
+ mapM (tableRowToHtml opts) rows
+
+colSpecListToHtml :: PandocMonad m
+ => WriterOptions
+ -> [ColSpec]
+ -> StateT WriterState m Html
+colSpecListToHtml opts colspecs = do
+ html5 <- gets stHtml5
+ let hasDefaultWidth (_, ColWidthDefault) = True
+ hasDefaultWidth _ = False
+
+ let percent w = show (truncate (100*w) :: Integer) <> "%"
+
+ let col :: ColWidth -> Html
+ col cw = do
+ H.col ! case cw of
+ ColWidthDefault -> mempty
+ ColWidth w -> if html5
+ then A.style (toValue $ "width: " <> percent w)
+ else A.width (toValue $ percent w)
+ nl opts
+
+ return $
+ if all hasDefaultWidth colspecs
+ then mempty
+ else do
+ H.colgroup $ do
+ nl opts
+ mapM_ (col . snd) colspecs
+ nl opts
tableRowToHtml :: PandocMonad m
=> WriterOptions
- -> [Alignment]
- -> Int
- -> [[Block]]
+ -> TableRow
-> StateT WriterState m Html
-tableRowToHtml opts aligns rownum cols' = do
- let mkcell = if rownum == 0 then H.th else H.td
- let rowclass = case rownum of
- 0 -> "header"
- x | x `rem` 2 == 1 -> "odd"
- _ -> "even"
- cols'' <- zipWithM
- (\alignment item -> tableItemToHtml opts mkcell alignment item)
- aligns cols'
- return $ (H.tr ! A.class_ rowclass $ nl opts >> mconcat cols'')
- >> nl opts
-
-alignmentToString :: Alignment -> [Char]
-alignmentToString alignment = case alignment of
- AlignLeft -> "left"
- AlignRight -> "right"
- AlignCenter -> "center"
- AlignDefault -> ""
-
-tableItemToHtml :: PandocMonad m
+tableRowToHtml opts (TableRow rowtype _attr rownum rowhead rowbody) = do
+ let rowclass = A.class_ $ case rownum of
+ RowNumber x | x `rem` 2 == 1 -> "odd"
+ _ | rowtype /= HeaderRow -> "even"
+ _ -> "header"
+ let celltype = case rowtype of
+ HeaderRow -> HeaderCell
+ _ -> BodyCell
+ head' <- mapM (cellToHtml opts HeaderCell) rowhead
+ body <- mapM (cellToHtml opts celltype) rowbody
+ return $ do
+ H.tr ! rowclass $ nl opts *> mconcat (head' <> body)
+ nl opts
+
+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
+ ColSpan n -> A.colspan (toValue n)
+
+rowspanAttrib :: RowSpan -> Attribute
+rowspanAttrib = \case
+ RowSpan 1 -> mempty
+ RowSpan n -> A.rowspan (toValue n)
+
+cellToHtml :: PandocMonad m
+ => WriterOptions
+ -> CellType
+ -> AnnCell
+ -> StateT WriterState m Html
+cellToHtml opts celltype (AnnCell (colspec :| _) _colNum cell) =
+ let align = fst colspec
+ in tableCellToHtml opts celltype align cell
+
+tableCellToHtml :: PandocMonad m
=> WriterOptions
- -> (Html -> Html)
+ -> CellType
-> Alignment
- -> [Block]
+ -> Cell
-> StateT WriterState m Html
-tableItemToHtml opts tag' align' item = do
+tableCellToHtml opts ctype colAlign (Cell attr align rowspan colspan item) = do
contents <- blockListToHtml opts item
html5 <- gets stHtml5
- let alignStr = alignmentToString align'
- let attribs = if html5
- then A.style (toValue $ "text-align: " <> alignStr <> ";")
- else A.align (toValue alignStr)
- let tag'' = if null alignStr
- then tag'
- else tag' ! attribs
- return $ tag'' contents >> nl opts
+ let tag' = case ctype of
+ BodyCell -> H.td
+ HeaderCell -> H.th
+ let align' = case align of
+ AlignDefault -> colAlign
+ _ -> align
+ let alignAttribs = case alignmentToString align' of
+ Nothing ->
+ mempty
+ Just alignStr ->
+ if html5
+ then A.style (toValue $ "text-align: " <> alignStr <> ";")
+ else A.align (toValue alignStr)
+ otherAttribs <- attrsToHtml opts attr
+ let attribs = mconcat
+ $ alignAttribs
+ : colspanAttrib colspan
+ : rowspanAttrib rowspan
+ : otherAttribs
+ return $ do
+ tag' ! attribs $ contents
+ nl opts
toListItems :: WriterOptions -> [Html] -> [Html]
toListItems opts items = map (toListItem opts) items ++ [nl opts]
toListItem :: WriterOptions -> Html -> Html
-toListItem opts item = nl opts >> H.li item
+toListItem opts item = nl opts *> H.li item
blockListToHtml :: PandocMonad m
=> WriterOptions -> [Block] -> StateT WriterState m Html
--
cgit v1.2.3