path: root/src/Text/Pandoc/Writers/Docx/Table.hs

{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module      : Text.Pandoc.Writers.Docx.Table
Copyright   : Copyright (C) 2012-2024 John MacFarlane
License     : GNU GPL, version 2 or above
Maintainer  : John MacFarlane <[email protected]>

Conversion of table blocks to docx.
-}
module Text.Pandoc.Writers.Docx.Table
  ( tableToOpenXML
  , rowToOpenXML
  , OOXMLRow (..)
  , OOXMLCell (..)
  , RowType (..)
  ) where

import Control.Monad.State.Strict ( modify, gets )
import Control.Monad ( unless , zipWithM )
import Control.Monad.Except ( throwError )
import Data.Array ( elems, (!), assocs, indices )
import Data.Text (Text)
import Data.Maybe (catMaybes, fromMaybe)
import Text.Pandoc.Definition
    ( ColSpec,
      Caption(Caption),
      Format(Format),
      Attr,
      Block(Para, Plain),
      Inline(Str, Span, RawInline),
      Alignment(..),
      RowSpan(..),
      ColSpan(..),
      ColWidth(..) )
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Translations (translateTerm)
import Text.Pandoc.Writers.Docx.Types
    ( WS,
      WriterState(stNextTableNum, stInTable),
      WriterEnv(..),
      setFirstPara,
      pStyleM,
      withParaProp,
      withParaPropM )
import Control.Monad.Reader (asks)
import Text.Pandoc.Shared ( tshow, stringify )
import Text.Pandoc.Options (WriterOptions(..), isEnabled, CaptionPosition(..))
import Text.Pandoc.Extensions (Extension(Ext_native_numbering))
import Text.Pandoc.Error (PandocError(PandocSomeError))
import Text.Printf (printf)
import Text.Pandoc.Writers.GridTable
    ( rowArray,
      ColIndex,
      GridCell(..),
      Part(Part, partCellArray, partRowAttrs),
      RowIndex )
import Text.Pandoc.Writers.OOXML ( mknode )
import Text.Pandoc.XML.Light.Proc ( onlyElems )
import Text.Pandoc.XML.Light.Types
    ( Content(Elem), Element(elName), QName(qName) )
import qualified Data.Text as T
import qualified Text.Pandoc.Translations as Term
import qualified Text.Pandoc.Writers.GridTable as Grid

tableToOpenXML :: PandocMonad m
               => WriterOptions
               -> ([Block] -> WS m [Content])
               -> Grid.Table
               -> WS m [Content]
tableToOpenXML opts blocksToOpenXML gridTable = do
  setFirstPara
  let (Grid.Table (ident,_,tableAttr) caption colspecs _rowheads thead tbodies tfoot) =
        gridTable
  let (Caption _maybeShortCaption captionBlocks) = caption
  tablenum <- gets stNextTableNum
  unless (null captionBlocks) $
    modify $ \st -> st{ stNextTableNum = tablenum + 1 }
  let tableid = if T.null ident
                   then "table" <> tshow tablenum
                   else ident
  tablename <- translateTerm Term.Table
  let captionStr = stringify captionBlocks
  let aligns = map fst $ elems colspecs
  captionXml <- if null captionBlocks
                then return []
                else withParaPropM (pStyleM "Table Caption")
                     $ blocksToOpenXML
                     $ if isEnabled Ext_native_numbering opts
                          then addLabel tableid tablename tablenum captionBlocks
                          else captionBlocks
  -- We set "in table" after processing the caption, because we don't
  -- want the "Table Caption" style to be overwritten with "Compact".
  modify $ \s -> s { stInTable = True }
  head' <- cellGridToOpenXML blocksToOpenXML HeadRow aligns thead
  bodies <- mapM (cellGridToOpenXML blocksToOpenXML BodyRow aligns) tbodies
  foot' <- cellGridToOpenXML blocksToOpenXML FootRow aligns tfoot

  let hasHeader = not . null . indices . partRowAttrs $ thead
  let hasFooter = not . null . indices . partRowAttrs $ tfoot
  -- for compatibility with Word <= 2007, we include a val with a bitmask
  -- 0×0020  Apply first row conditional formatting
  -- 0×0040  Apply last row conditional formatting
  -- 0×0080  Apply first column conditional formatting
  -- 0×0100  Apply last column conditional formatting
  -- 0×0200  Do not apply row banding conditional formatting
  -- 0×0400  Do not apply column banding conditional formattin
  let tblLookVal = if hasHeader then (0x20 :: Int) else 0
  let (gridCols, tblWattr) = tableLayout (elems colspecs)
  listLevel <- asks envListLevel
  let tblStyle =  fromMaybe "Table" (lookup "custom-style" tableAttr)
  let indent = (listLevel + 1) * 720
  let hasWidths = not $ all ((== ColWidthDefault) . snd) colspecs
  let tbl = mknode "w:tbl" []
        ( mknode "w:tblPr" []
          ( [ mknode "w:tblStyle" [("w:val",tblStyle)] (),
              mknode "w:tblW" tblWattr () ] ++
            [ mknode "w:jc" [("w:val","left")] () | indent > 0 ] ++
            [ mknode "w:tblInd" [("w:w", tshow indent),("w:type","dxa")] ()
                | indent > 0 ] ++
            [ mknode "w:tblLayout" [("w:type", "fixed")] () | hasWidths ] ++
            [ mknode "w:tblLook" [("w:firstRow",if hasHeader then "1" else "0")
                                 ,("w:lastRow",if hasFooter then "1" else "0")
                                 ,("w:firstColumn","0")
                                 ,("w:lastColumn","0")
                                 ,("w:noHBand","0")
                                 ,("w:noVBand","0")
                                 ,("w:val", T.pack $ printf "%04x" tblLookVal)
                                 ] () ] ++
            [ mknode "w:tblCaption" [("w:val", captionStr)] ()
            | not (T.null captionStr) ]
          )
          : mknode "w:tblGrid" [] gridCols
          : head' ++ mconcat bodies ++ foot'
        )
  modify $ \s -> s { stInTable = False }
  return $
    case writerTableCaptionPosition opts of
      CaptionAbove -> captionXml ++ [Elem tbl]
      CaptionBelow -> Elem tbl : captionXml

addLabel :: Text -> Text -> Int -> [Block] -> [Block]
addLabel tableid tablename tablenum bs =
  case bs of
    (Para ils : rest)  -> Para (label : Str ": " : ils) : rest
    (Plain ils : rest) -> Plain (label : Str ": " : ils) : rest
    _ -> Para [label] : bs
 where
  label = Span (tableid,[],[])
            [Str (tablename <> "\160"),
             RawInline (Format "openxml")
               ("<w:fldSimple w:instr=\"SEQ Table"
               <> " \\* ARABIC \"><w:r><w:t>"
               <> tshow tablenum
               <> "</w:t></w:r></w:fldSimple>")]

-- | Parts of a table
data RowType = HeadRow | BodyRow | FootRow

alignmentToString :: Alignment -> Text
alignmentToString = \case
  AlignLeft    -> "left"
  AlignRight   -> "right"
  AlignCenter  -> "center"
  AlignDefault -> ""

tableLayout :: [ColSpec] -> ([Element], [(Text, Text)])
tableLayout specs =
  let
    textwidth = 7920  -- 5.5 in in twips       (1 twip == 1/20 pt)
    fullrow   = 5000  -- 100% specified in pct (1 pct  == 1/50th of a percent)
    ncols = length specs
    getWidth = \case
      ColWidth n -> n
      _          -> 0
    widths = map (getWidth . snd) specs
    rowwidth  = round (fullrow * sum widths) :: Int
    widthToTwips w = floor (textwidth * w)   :: Int
    mkGridCol w = mknode "w:gridCol" [("w:w", tshow (widthToTwips w))] ()
  in if all (== 0) widths
     then ( replicate ncols $ mkGridCol (1.0 / fromIntegral ncols)
          , [ ("w:type", "auto"), ("w:w", "0")])
     else ( map mkGridCol widths
          , [ ("w:type", "pct"), ("w:w", tshow rowwidth) ])

cellGridToOpenXML :: PandocMonad m
                  => ([Block] -> WS m [Content])
                  -> RowType
                  -> [Alignment]
                  -> Part
                  -> WS m [Element]
cellGridToOpenXML blocksToOpenXML rowType aligns part@(Part _ cellArray _) =
  if null (elems cellArray)
  then return mempty
  else partToRows rowType aligns part >>=
       fmap catMaybes . mapM (rowToOpenXML blocksToOpenXML)

data OOXMLCell
  = OOXMLCell Attr Alignment RowSpan ColSpan [Block]
  | OOXMLCellMerge ColSpan

data OOXMLRow = OOXMLRow RowType Attr [OOXMLCell]

partToRows :: PandocMonad m
           => RowType -> [Alignment] -> Part -> WS m [OOXMLRow]
partToRows rowType aligns part = do
  let toOOXMLCell :: PandocMonad m =>
        Alignment -> RowIndex -> ColIndex -> GridCell -> WS m [OOXMLCell]
      toOOXMLCell columnAlign ridx cidx = \case
        UnassignedCell ->
          throwError $ PandocSomeError "Encountered unassigned table cell"
        ContentCell attr align rowspan colspan blocks -> do
          -- Respect non-default, cell specific alignment.
          let align' = case align of
                AlignDefault -> columnAlign
                _            -> align
          return [OOXMLCell attr align' rowspan colspan blocks]
        ContinuationCell idx'@(ridx',cidx') | ridx /= ridx', cidx == cidx' -> do
          case (partCellArray part)!idx' of
            (ContentCell _ _ _ colspan _) -> return [OOXMLCellMerge colspan]
            x -> error $ "Content cell expected, got, " ++ show x ++
                         " at index " ++ show idx'
        _ -> return mempty
  let mkRow :: PandocMonad m => (RowIndex, Attr) -> WS m OOXMLRow
      mkRow (ridx, attr) = do
        cs <- zipWithM (\align -> uncurry $ toOOXMLCell align ridx)
                        aligns
                        (assocs . rowArray ridx $ partCellArray part)
        return $ OOXMLRow rowType attr . mconcat $ cs
  mapM mkRow $ assocs (partRowAttrs part)

rowToOpenXML :: PandocMonad m
             => ([Block] -> WS m [Content])
             -> OOXMLRow
             -> WS m (Maybe Element)
rowToOpenXML blocksToOpenXML (OOXMLRow rowType _attr cells)
  | null cells = return Nothing
  | otherwise = do
    xmlcells <- mapM (ooxmlCellToOpenXML blocksToOpenXML) cells
    let addTrPr = case rowType of
          HeadRow -> (mknode "w:trPr" []
                      [mknode "w:tblHeader" [("w:val", "on")] ()] :)
          BodyRow -> id
          FootRow -> id
    return $ Just $ mknode "w:tr" [] (addTrPr xmlcells)

ooxmlCellToOpenXML :: PandocMonad m
                   => ([Block] -> WS m [Content])
                   -> OOXMLCell
                   -> WS m Element
ooxmlCellToOpenXML blocksToOpenXML = \case
  OOXMLCellMerge (ColSpan colspan) -> do
    return $ mknode "w:tc" []
      [ mknode "w:tcPr" [] [ mknode "w:gridSpan" [("w:val", tshow colspan)] ()
                           , mknode "w:vMerge"   [("w:val", "continue")] () ]
      , mknode "w:p" [] [mknode "w:pPr" [] ()]]
  OOXMLCell _attr align rowspan (ColSpan colspan) contents -> do
    compactStyle <- pStyleM "Compact"
    es <- maybe id withParaProp (alignmentFor align) $ blocksToOpenXML contents
    -- Table cells require a <w:p> element, even an empty one!
    -- Not in the spec but in Word 2007, 2010. See #4953. And
    -- apparently the last element must be a <w:p>, see #6983.
    return . mknode "w:tc" [] $
      Elem
       (mknode "w:tcPr" [] ([ mknode "w:gridSpan" [("w:val", tshow colspan)] ()
                            | colspan > 1] ++
                            [ mknode "w:vMerge" [("w:val", "restart")] ()
                            | rowspan > RowSpan 1 ])) :
      if null contents
      then [Elem $ mknode "w:p" [] [mknode "w:pPr" [] [compactStyle]]]
      else case reverse (onlyElems es) of
             b:e:_ | qName (elName b) == "bookmarkEnd"  -- y tho?
                   , qName (elName e) == "p" -> es
             e:_   | qName (elName e) == "p" -> es
             _ -> es ++ [Elem $ mknode "w:p" [] ()]

alignmentFor :: Alignment -> Maybe Element
alignmentFor AlignDefault = Nothing
alignmentFor al = Just $ mknode "w:jc" [("w:val",alignmentToString al)] ()