JATS writer: support advanced table features

2 files changed, 217 insertions, 50 deletions

diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs
index 0ddb70c83..7058a4557 100644
--- a/src/Text/Pandoc/Writers/JATS.hs
+++ b/src/Text/Pandoc/Writers/JATS.hs
@@ -46,6 +46,7 @@ import Text.Pandoc.Writers.Math
 import Text.Pandoc.Writers.Shared
 import Text.Pandoc.XML
 import Text.TeXMath
+import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
 import qualified Text.XML.Light as Xml
 
 -- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange
@@ -349,8 +350,8 @@ blockToJATS _ b@(RawBlock f str)
       report $ BlockNotRendered b
       return empty
 blockToJATS _ HorizontalRule = return empty -- not semantic
-blockToJATS opts (Table attr blkCapt specs th tb tf) =
-  tableToJATS opts attr blkCapt specs th tb tf
+blockToJATS opts (Table attr caption colspecs thead tbody tfoot) =
+  tableToJATS opts (Ann.toTable attr caption colspecs thead tbody tfoot)
 
 -- | Convert a list of inline elements to JATS.
 inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text)
diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
index dd7678f63..a4d42832d 100644
--- a/src/Text/Pandoc/Writers/JATS/Table.hs
+++ b/src/Text/Pandoc/Writers/JATS/Table.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 {- |
    Module      : Text.Pandoc.Writers.JATS.Table
    Copyright   : © 2020 Albert Krewinkel
@@ -14,69 +16,233 @@ module Text.Pandoc.Writers.JATS.Table
   ( tableToJATS
   ) where
 import Control.Monad.Reader (asks)
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Text (Text)
+import Text.DocLayout (Doc, empty, vcat, ($$))
 import Text.Pandoc.Class.PandocMonad (PandocMonad)
 import Text.Pandoc.Definition
 import Text.Pandoc.Options (WriterOptions)
-import Text.DocLayout (Doc, empty, vcat, ($$))
 import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.JATS.Types
-import Text.Pandoc.Writers.Shared (toLegacyTable)
 import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
-
+import qualified Data.Text as T
+import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
 
 tableToJATS :: PandocMonad m
             => WriterOptions
-            -> Attr -> Caption -> [ColSpec] -> TableHead
-            -> [TableBody] -> TableFoot
+            -> Ann.Table
             -> JATS m (Doc Text)
-tableToJATS opts _attr blkCapt specs th tb tf = do
-  blockToJATS <- asks jatsBlockWriter
-  let (caption, aligns, widths, headers, rows) =
-        toLegacyTable blkCapt specs th tb tf
-  captionDoc <- if null caption
-                then return mempty
-                else inTagsIndented "caption" <$> blockToJATS opts (Para caption)
-  tbl <- captionlessTable aligns widths headers rows
+tableToJATS opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do
+  let (Caption _maybeShortCaption captionBlocks) = caption
+  tbl <- captionlessTable opts attr colspecs thead tbodies tfoot
+  captionDoc <- if null captionBlocks
+                then return empty
+                else do
+                  blockToJATS <- asks jatsBlockWriter
+                  inTagsIndented "caption" . vcat <$>
+                    mapM (blockToJATS opts) captionBlocks
   return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
+
+captionlessTable :: PandocMonad m
+                 => WriterOptions
+                 -> Attr
+                 -> [ColSpec]
+                 -> Ann.TableHead
+                 -> [Ann.TableBody]
+                 -> Ann.TableFoot
+                 -> JATS m (Doc Text)
+captionlessTable opts attr colspecs thead tbodies tfoot = do
+  head' <- tableHeadToJats opts thead
+  bodies <- mapM (tableBodyToJats opts) tbodies
+  foot' <- tableFootToJats opts tfoot
+  let validAttribs = [ "border", "cellpadding", "cellspacing", "content-type"
+                     , "frame", "rules", "specific-use", "style", "summary"
+                     , "width"
+                     ]
+  let attribs = toAttribs attr validAttribs
+  return $ inTags True "table" attribs $ vcat
+    [ colSpecListToJATS colspecs
+    , head'
+    , foot'
+    , vcat bodies
+    ]
+
+validTablePartAttribs :: [Text]
+validTablePartAttribs =
+  [ "align", "char", "charoff", "content-type", "style", "valign" ]
+
+tableBodyToJats :: PandocMonad m
+                => WriterOptions
+                -> Ann.TableBody
+                -> JATS m (Doc Text)
+tableBodyToJats opts (Ann.TableBody attr _rowHeadCols inthead rows) = do
+  let attribs = toAttribs attr validTablePartAttribs
+  intermediateHead <- if null inthead
+                      then return mempty
+                      else headerRowsToJats opts Thead inthead
+  bodyRows <- bodyRowsToJats opts rows
+  return $ inTags True "tbody" attribs $ intermediateHead $$ bodyRows
+
+tableHeadToJats :: PandocMonad m
+                => WriterOptions
+                -> Ann.TableHead
+                -> JATS m (Doc Text)
+tableHeadToJats opts (Ann.TableHead attr rows) =
+  tablePartToJats opts Thead attr rows
+
+tableFootToJats :: PandocMonad m
+                => WriterOptions
+                -> Ann.TableFoot
+                -> JATS m (Doc Text)
+tableFootToJats opts (Ann.TableFoot attr rows) =
+  tablePartToJats opts Tfoot attr rows
+
+tablePartToJats :: PandocMonad m
+                => WriterOptions
+                -> TablePart
+                -> Attr
+                -> [Ann.HeaderRow]
+                -> JATS m (Doc Text)
+tablePartToJats opts tblpart attr rows =
+  if null rows || all isEmptyRow rows
+  then return mempty
+  else do
+    let tag' = case tblpart of
+                 Thead -> "thead"
+                 Tfoot -> "tfoot"
+                 Tbody -> "tbody" -- this would be unexpected
+    let attribs = toAttribs attr validTablePartAttribs
+    inTags True tag' attribs <$> headerRowsToJats opts tblpart rows
   where
-    captionlessTable aligns widths headers rows = do
-      let percent w = tshow (truncate (100*w) :: Integer) <> "*"
-      let coltags = vcat $ zipWith (\w al -> selfClosingTag "col"
-                           ([("width", percent w) | w > 0] ++
-                            [("align", alignmentToText al)])) widths aligns
-      thead <- if all null headers
-                  then return empty
-                  else inTagsIndented "thead" <$> tableRowToJATS opts True headers
-      tbody <- inTagsIndented "tbody" . vcat <$>
-                    mapM (tableRowToJATS opts False) rows
-      return $ inTags True "table" [] $ coltags $$ thead $$ tbody
-
-alignmentToText :: Alignment -> Text
-alignmentToText alignment = case alignment of
-                                 AlignLeft    -> "left"
-                                 AlignRight   -> "right"
-                                 AlignCenter  -> "center"
-                                 AlignDefault -> "left"
-
-tableRowToJATS :: PandocMonad m
+    isEmptyRow (Ann.HeaderRow _attr _rownum cells) = all isEmptyCell cells
+    isEmptyCell (Ann.Cell _colspecs _colnum cell) =
+      cell == Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) []
+
+-- | The part of a table; header, footer, or body.
+data TablePart = Thead | Tfoot | Tbody
+  deriving (Eq)
+
+data CellType = HeaderCell | BodyCell
+
+data TableRow = TableRow TablePart Attr Ann.RowNumber Ann.RowHead Ann.RowBody
+
+headerRowsToJats :: PandocMonad m
+                 => WriterOptions
+                 -> TablePart
+                 -> [Ann.HeaderRow]
+                 -> JATS m (Doc Text)
+headerRowsToJats opts tablepart =
+  rowListToJats opts . map toTableRow
+  where
+    toTableRow (Ann.HeaderRow attr rownum rowbody) =
+      TableRow tablepart attr rownum [] rowbody
+
+bodyRowsToJats :: PandocMonad m
+               => WriterOptions
+               -> [Ann.BodyRow]
+               -> JATS m (Doc Text)
+bodyRowsToJats opts =
+  rowListToJats opts . zipWith toTableRow [1..]
+  where
+    toTableRow rownum (Ann.BodyRow attr _rownum rowhead rowbody) =
+      TableRow Tbody attr rownum rowhead rowbody
+
+rowListToJats :: PandocMonad m
+              => WriterOptions
+              -> [TableRow]
+              -> JATS m (Doc Text)
+rowListToJats opts = fmap vcat . mapM (tableRowToJats opts)
+
+colSpecListToJATS :: [ColSpec] -> Doc Text
+colSpecListToJATS colspecs =
+  let hasDefaultWidth (_, ColWidthDefault) = True
+      hasDefaultWidth _                    = False
+
+      percent w = tshow (round (100*w) :: Integer) <> "%"
+
+      col :: ColWidth -> Doc Text
+      col = selfClosingTag "col" . \case
+        ColWidthDefault -> mempty
+        ColWidth w -> [("width", percent w)]
+
+   in if all hasDefaultWidth colspecs
+      then mempty
+      else inTags True "colgroup" [] $ vcat $ map (col . snd) colspecs
+
+tableRowToJats :: PandocMonad m
                => WriterOptions
-               -> Bool
-               -> [[Block]]
+               -> TableRow
                -> JATS m (Doc Text)
-tableRowToJATS opts isHeader cols =
-  inTagsIndented "tr" . vcat <$> mapM (tableItemToJATS opts isHeader) cols
+tableRowToJats opts (TableRow tblpart attr _rownum rowhead rowbody) = do
+  let validAttribs = [ "align", "char", "charoff", "content-type"
+                     , "style", "valign"
+                     ]
+  let attr' = toAttribs attr validAttribs
+  let celltype = case tblpart of
+                   Thead -> HeaderCell
+                   _     -> BodyCell
+  headcells <- mapM (cellToJats opts HeaderCell) rowhead
+  bodycells <- mapM (cellToJats opts celltype) rowbody
+  return $ inTags True "tr" attr' $ mconcat
+    [ vcat headcells
+    , vcat bodycells
+    ]
+
+alignmentAttrib :: Alignment -> Maybe (Text, Text)
+alignmentAttrib = fmap ("align",) . \case
+  AlignLeft    -> Just "left"
+  AlignRight   -> Just "right"
+  AlignCenter  -> Just "center"
+  AlignDefault -> Nothing
+
+colspanAttrib :: ColSpan -> Maybe (Text, Text)
+colspanAttrib = \case
+  ColSpan 1 -> Nothing
+  ColSpan n -> Just ("colspan", tshow n)
+
+rowspanAttrib :: RowSpan -> Maybe (Text, Text)
+rowspanAttrib = \case
+  RowSpan 1 -> Nothing
+  RowSpan n -> Just ("rowspan", tshow n)
+
+cellToJats :: PandocMonad m
+           => WriterOptions
+           -> CellType
+           -> Ann.Cell
+           -> JATS m (Doc Text)
+cellToJats opts celltype (Ann.Cell (colspec :| _) _colNum cell) =
+  let align = fst colspec
+  in tableCellToJats opts celltype align cell
+
+toAttribs :: Attr -> [Text] -> [(Text, Text)]
+toAttribs (ident, _classes, kvs) knownAttribs =
+  (if T.null ident then id else (("id", ident) :)) $
+  filter ((`elem` knownAttribs) . fst) kvs
 
-tableItemToJATS :: PandocMonad m
+tableCellToJats :: PandocMonad m
                 => WriterOptions
-                -> Bool
-                -> [Block]
+                -> CellType
+                -> Alignment
+                -> Cell
                 -> JATS m (Doc Text)
-tableItemToJATS opts isHeader [Plain item] = do
-  inlinesToJATS <- asks jatsInlinesWriter
-  inTags False (if isHeader then "th" else "td") [] <$>
-    inlinesToJATS opts item
-tableItemToJATS opts isHeader item = do
-  blockToJATS <- asks jatsBlockWriter
-  inTags False (if isHeader then "th" else "td") [] . vcat <$>
-    mapM (blockToJATS opts) item
+tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
+  blockToJats   <- asks jatsBlockWriter
+  inlinesToJats <- asks jatsInlinesWriter
+  let cellContents = \case
+        [Plain inlines] -> inlinesToJats opts inlines
+        blocks          -> vcat <$> mapM (blockToJats opts) blocks
+  let tag' = case ctype of
+        BodyCell   -> "td"
+        HeaderCell -> "th"
+  let align' = case align of
+        AlignDefault -> colAlign
+        _            -> align
+  let maybeCons = maybe id (:)
+  let validAttribs = [ "abbr", "align", "axis", "char", "charoff"
+                     , "content-type", "headers", "scope", "style", "valign"
+                     ]
+  let attribs = maybeCons (alignmentAttrib align')
+              . maybeCons (rowspanAttrib rowspan)
+              . maybeCons (colspanAttrib colspan)
+              $ toAttribs attr validAttribs
+  inTags False tag' attribs <$> cellContents item