{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.Docx.Table Copyright : Copyright (C) 2012-2021 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Conversion of table blocks to docx. -} module Text.Pandoc.Writers.Docx.Table ( tableToOpenXML ) where import Control.Monad.State.Strict import Data.Array import Data.Text (Text) import Text.Pandoc.Definition import Text.Pandoc.Class.PandocMonad (PandocMonad, translateTerm) import Text.Pandoc.Writers.Docx.Types import Text.Pandoc.Shared import Text.Printf (printf) import Text.Pandoc.Writers.GridTable hiding (Table) import Text.Pandoc.Writers.OOXML import Text.Pandoc.XML.Light as XML hiding (Attr) import qualified Data.Text as T import qualified Text.Pandoc.Translations as Term import qualified Text.Pandoc.Writers.GridTable as Grid tableToOpenXML :: PandocMonad m => ([Block] -> WS m [Content]) -> Grid.Table -> WS m [Content] tableToOpenXML blocksToOpenXML gridTable = do setFirstPara let (Grid.Table (ident,_,_) 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 $ addLabel tableid tablename tablenum 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) let tbl = mknode "w:tbl" [] ( mknode "w:tblPr" [] ( mknode "w:tblStyle" [("w:val","Table")] () : mknode "w:tblW" tblWattr () : 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 $ captionXml ++ [Elem tbl] addLabel :: Text -> Text -> Int -> [Block] -> [Block] addLabel tableid tablename tablenum bs = case bs of (Para ils : rest) -> Para (label : Space : ils) : rest (Plain ils : rest) -> Plain (label : Space : ils) : rest _ -> Para [label] : bs where label = Span (tableid,[],[]) [Str (tablename <> "\160"), RawInline (Format "openxml") (" " \\* ARABIC \">" <> tshow tablenum <> ""), Str ":"] -- | Parts of a table data RowType = HeadRow | BodyRow | FootRow alignmentToString :: Alignment -> Text alignmentToString = \case AlignLeft -> "left" AlignRight -> "right" AlignCenter -> "center" AlignDefault -> "left" 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 mapM (rowToOpenXML blocksToOpenXML) $ partToRows rowType aligns part data OOXMLCell = OOXMLCell Attr Alignment RowSpan ColSpan [Block] | OOXMLCellMerge ColSpan data OOXMLRow = OOXMLRow RowType Attr [OOXMLCell] partToRows :: RowType -> [Alignment] -> Part -> [OOXMLRow] partToRows rowType aligns part = let toOOXMLCell :: Alignment -> RowIndex -> ColIndex -> GridCell -> [OOXMLCell] toOOXMLCell columnAlign ridx cidx = \case ContentCell attr align rowspan colspan blocks -> -- Respect non-default, cell specific alignment. let align' = case align of AlignDefault -> columnAlign _ -> align in [OOXMLCell attr align' rowspan colspan blocks] ContinuationCell idx'@(ridx',cidx') | ridx /= ridx', cidx == cidx' -> case (partCellArray part)!idx' of (ContentCell _ _ _ colspan _) -> [OOXMLCellMerge colspan] x -> error $ "Content cell expected, got, " ++ show x ++ " at index " ++ show idx' _ -> mempty mkRow :: (RowIndex, Attr) -> OOXMLRow mkRow (ridx, attr) = OOXMLRow rowType attr . mconcat . zipWith (\align -> uncurry $ toOOXMLCell align ridx) aligns . assocs . rowArray ridx $ partCellArray part in map mkRow $ assocs (partRowAttrs part) rowToOpenXML :: PandocMonad m => ([Block] -> WS m [Content]) -> OOXMLRow -> WS m Element rowToOpenXML blocksToOpenXML (OOXMLRow rowType _attr cells) = do xmlcells <- mapM (ooxmlCellToOpenXML blocksToOpenXML) cells let addTrPr = case rowType of HeadRow -> (mknode "w:trPr" [] [mknode "w:tblHeader" [("w:val", "true")] ()] :) BodyRow -> id FootRow -> id return $ 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 <- withParaProp (alignmentFor align) $ blocksToOpenXML contents -- Table cells require a element, even an empty one! -- Not in the spec but in Word 2007, 2010. See #4953. And -- apparently the last element must be a , 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 -> Element alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()