content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TupleSections #-}
  {- |
     Module      : Text.Pandoc.Writers.JATS.Table
     Copyright   : © 2020-2024 Albert Krewinkel
     License     : GNU GPL, version 2 or above
  
     Maintainer  : Albert Krewinkel <albert+pandoc@tarleb.com>
     Stability   : alpha
     Portability : portable
  
  Conversion of 'Pandoc' tables to JATS XML.
  -}
  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.Pandoc.Shared (tshow)
  import Text.Pandoc.Writers.JATS.Types
  import Text.Pandoc.XML (escapeNCName, inTags, inTagsIndented, selfClosingTag)
  import qualified Data.Text as T
  import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
  
  tableToJATS :: PandocMonad m
              => WriterOptions
              -> Ann.Table
              -> JATS m (Doc Text)
  tableToJATS opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do
    let (Caption _maybeShortCaption captionBlocks) = caption
    -- Only paragraphs are allowed in captions, all other blocks must be
    -- wrapped in @<p>@ elements.
    let needsWrapping = \case
          Plain{} -> False
          Para{}  -> False
          _       -> True
    tbl <- captionlessTable opts attr colspecs thead tbodies tfoot
    captionDoc <- if null captionBlocks
                  then return empty
                  else do
                    blockToJATS <- asks jatsBlockWriter
                    inTagsIndented "caption" <$>
                      blockToJATS needsWrapping 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
      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
                 -> TableRow
                 -> JATS m (Doc Text)
  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", escapeNCName ident) :)) $
    filter ((`elem` knownAttribs) . fst) kvs
  
  tableCellToJats :: PandocMonad m
                  => WriterOptions
                  -> CellType
                  -> Alignment
                  -> Cell
                  -> JATS m (Doc Text)
  tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
    blockToJats   <- asks jatsBlockWriter
    inlinesToJats <- asks jatsInlinesWriter
    let fixBreak LineBreak = RawInline (Format "jats") "<break/>"
        fixBreak x         = x
    let cellContents = \case
          [Plain inlines] -> inlinesToJats opts
                               (map fixBreak inlines)
                               -- Note: <break/> is allowed only as a direct
                               -- child of <td>, so we don't use walk.
          blocks          -> blockToJats needsWrapInCell 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
  
  -- | Whether the JATS produced from this block should be wrapped in a
  -- @<p>@ element when put directly below a @<td>@ element.
  needsWrapInCell :: Block -> Bool
  needsWrapInCell = \case
    Plain{}          -> False  -- should be unwrapped anyway
    Para{}           -> False
    BulletList{}     -> False
    OrderedList{}    -> False
    DefinitionList{} -> False
    HorizontalRule   -> False
    CodeBlock{}      -> False
    RawBlock{}       -> False  -- responsibility of the user
    _                -> True
  