{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{- |
   Module      : Text.Pandoc.Writers.JATS.Table
   Copyright   : © 2020-2021 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb@zeitkraut.de>
   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 :: WriterOptions -> Table -> JATS m (Doc Text)
tableToJATS WriterOptions
opts (Ann.Table Attr
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot) = do
  let (Caption Maybe ShortCaption
_maybeShortCaption [Block]
captionBlocks) = Caption
caption
  -- Only paragraphs are allowed in captions, all other blocks must be
  -- wrapped in @<p>@ elements.
  let needsWrapping :: Block -> Bool
needsWrapping = \case
        Plain{} -> Bool
False
        Para{}  -> Bool
False
        Block
_       -> Bool
True
  Doc Text
tbl <- WriterOptions
-> Attr
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> Attr
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> JATS m (Doc Text)
captionlessTable WriterOptions
opts Attr
attr [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot
  Doc Text
captionDoc <- if [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
captionBlocks
                then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
                else do
                  (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
blockToJATS <- (JATSEnv m
 -> (Block -> Bool)
 -> WriterOptions
 -> [Block]
 -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     ((Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m
-> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m
-> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
jatsBlockWriter
                  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"caption" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
blockToJATS Block -> Bool
needsWrapping WriterOptions
opts [Block]
captionBlocks
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"table-wrap" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
captionDoc Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
tbl

captionlessTable :: PandocMonad m
                 => WriterOptions
                 -> Attr
                 -> [ColSpec]
                 -> Ann.TableHead
                 -> [Ann.TableBody]
                 -> Ann.TableFoot
                 -> JATS m (Doc Text)
captionlessTable :: WriterOptions
-> Attr
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> JATS m (Doc Text)
captionlessTable WriterOptions
opts Attr
attr [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot = do
  Doc Text
head' <- WriterOptions -> TableHead -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TableHead -> JATS m (Doc Text)
tableHeadToJats WriterOptions
opts TableHead
thead
  [Doc Text]
bodies <- (TableBody -> JATS m (Doc Text))
-> [TableBody]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> TableBody -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TableBody -> JATS m (Doc Text)
tableBodyToJats WriterOptions
opts) [TableBody]
tbodies
  Doc Text
foot' <- WriterOptions -> TableFoot -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TableFoot -> JATS m (Doc Text)
tableFootToJats WriterOptions
opts TableFoot
tfoot
  let validAttribs :: [Text]
validAttribs = [ Text
"border", Text
"cellpadding", Text
"cellspacing", Text
"content-type"
                     , Text
"frame", Text
"rules", Text
"specific-use", Text
"style", Text
"summary"
                     , Text
"width"
                     ]
  let attribs :: [(Text, Text)]
attribs = Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validAttribs
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"table" [(Text, Text)]
attribs (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat
    [ [ColSpec] -> Doc Text
colSpecListToJATS [ColSpec]
colspecs
    , Doc Text
head'
    , Doc Text
foot'
    , [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
bodies
    ]

validTablePartAttribs :: [Text]
validTablePartAttribs :: [Text]
validTablePartAttribs =
  [ Text
"align", Text
"char", Text
"charoff", Text
"content-type", Text
"style", Text
"valign" ]

tableBodyToJats :: PandocMonad m
                => WriterOptions
                -> Ann.TableBody
                -> JATS m (Doc Text)
tableBodyToJats :: WriterOptions -> TableBody -> JATS m (Doc Text)
tableBodyToJats WriterOptions
opts (Ann.TableBody Attr
attr RowHeadColumns
_rowHeadCols [HeaderRow]
inthead [BodyRow]
rows) = do
  let attribs :: [(Text, Text)]
attribs = Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validTablePartAttribs
  Doc Text
intermediateHead <- if [HeaderRow] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HeaderRow]
inthead
                      then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Monoid a => a
mempty
                      else WriterOptions -> TablePart -> [HeaderRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TablePart -> [HeaderRow] -> JATS m (Doc Text)
headerRowsToJats WriterOptions
opts TablePart
Thead [HeaderRow]
inthead
  Doc Text
bodyRows <- WriterOptions -> [BodyRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [BodyRow] -> JATS m (Doc Text)
bodyRowsToJats WriterOptions
opts [BodyRow]
rows
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"tbody" [(Text, Text)]
attribs (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
intermediateHead Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
bodyRows

tableHeadToJats :: PandocMonad m
                => WriterOptions
                -> Ann.TableHead
                -> JATS m (Doc Text)
tableHeadToJats :: WriterOptions -> TableHead -> JATS m (Doc Text)
tableHeadToJats WriterOptions
opts (Ann.TableHead Attr
attr [HeaderRow]
rows) =
  WriterOptions
-> TablePart -> Attr -> [HeaderRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> TablePart -> Attr -> [HeaderRow] -> JATS m (Doc Text)
tablePartToJats WriterOptions
opts TablePart
Thead Attr
attr [HeaderRow]
rows

tableFootToJats :: PandocMonad m
                => WriterOptions
                -> Ann.TableFoot
                -> JATS m (Doc Text)
tableFootToJats :: WriterOptions -> TableFoot -> JATS m (Doc Text)
tableFootToJats WriterOptions
opts (Ann.TableFoot Attr
attr [HeaderRow]
rows) =
  WriterOptions
-> TablePart -> Attr -> [HeaderRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> TablePart -> Attr -> [HeaderRow] -> JATS m (Doc Text)
tablePartToJats WriterOptions
opts TablePart
Tfoot Attr
attr [HeaderRow]
rows

tablePartToJats :: PandocMonad m
                => WriterOptions
                -> TablePart
                -> Attr
                -> [Ann.HeaderRow]
                -> JATS m (Doc Text)
tablePartToJats :: WriterOptions
-> TablePart -> Attr -> [HeaderRow] -> JATS m (Doc Text)
tablePartToJats WriterOptions
opts TablePart
tblpart Attr
attr [HeaderRow]
rows =
  if [HeaderRow] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HeaderRow]
rows Bool -> Bool -> Bool
|| (HeaderRow -> Bool) -> [HeaderRow] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HeaderRow -> Bool
isEmptyRow [HeaderRow]
rows
  then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Monoid a => a
mempty
  else do
    let tag' :: Text
tag' = case TablePart
tblpart of
                 TablePart
Thead -> Text
"thead"
                 TablePart
Tfoot -> Text
"tfoot"
                 TablePart
Tbody -> Text
"tbody" -- this would be unexpected
    let attribs :: [(Text, Text)]
attribs = Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validTablePartAttribs
    Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
tag' [(Text, Text)]
attribs (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> TablePart -> [HeaderRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TablePart -> [HeaderRow] -> JATS m (Doc Text)
headerRowsToJats WriterOptions
opts TablePart
tblpart [HeaderRow]
rows
  where
    isEmptyRow :: HeaderRow -> Bool
isEmptyRow (Ann.HeaderRow Attr
_attr RowNumber
_rownum [Cell]
cells) = (Cell -> Bool) -> [Cell] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Cell -> Bool
isEmptyCell [Cell]
cells
    isEmptyCell :: Cell -> Bool
isEmptyCell (Ann.Cell NonEmpty ColSpec
_colspecs ColNumber
_colnum Cell
cell) =
      Cell
cell Cell -> Cell -> Bool
forall a. Eq a => a -> a -> Bool
== Attr -> Alignment -> RowSpan -> ColSpan -> [Block] -> Cell
Cell Attr
nullAttr Alignment
AlignDefault (Int -> RowSpan
RowSpan Int
1) (Int -> ColSpan
ColSpan Int
1) []

-- | The part of a table; header, footer, or body.
data TablePart = Thead | Tfoot | Tbody
  deriving (TablePart -> TablePart -> Bool
(TablePart -> TablePart -> Bool)
-> (TablePart -> TablePart -> Bool) -> Eq TablePart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TablePart -> TablePart -> Bool
$c/= :: TablePart -> TablePart -> Bool
== :: TablePart -> TablePart -> Bool
$c== :: TablePart -> TablePart -> Bool
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 :: WriterOptions -> TablePart -> [HeaderRow] -> JATS m (Doc Text)
headerRowsToJats WriterOptions
opts TablePart
tablepart =
  WriterOptions -> [TableRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [TableRow] -> JATS m (Doc Text)
rowListToJats WriterOptions
opts ([TableRow] -> JATS m (Doc Text))
-> ([HeaderRow] -> [TableRow]) -> [HeaderRow] -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderRow -> TableRow) -> [HeaderRow] -> [TableRow]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRow -> TableRow
toTableRow
  where
    toTableRow :: HeaderRow -> TableRow
toTableRow (Ann.HeaderRow Attr
attr RowNumber
rownum [Cell]
rowbody) =
      TablePart -> Attr -> RowNumber -> [Cell] -> [Cell] -> TableRow
TableRow TablePart
tablepart Attr
attr RowNumber
rownum [] [Cell]
rowbody

bodyRowsToJats :: PandocMonad m
               => WriterOptions
               -> [Ann.BodyRow]
               -> JATS m (Doc Text)
bodyRowsToJats :: WriterOptions -> [BodyRow] -> JATS m (Doc Text)
bodyRowsToJats WriterOptions
opts =
  WriterOptions -> [TableRow] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [TableRow] -> JATS m (Doc Text)
rowListToJats WriterOptions
opts ([TableRow] -> JATS m (Doc Text))
-> ([BodyRow] -> [TableRow]) -> [BodyRow] -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RowNumber -> BodyRow -> TableRow)
-> [RowNumber] -> [BodyRow] -> [TableRow]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RowNumber -> BodyRow -> TableRow
toTableRow [RowNumber
1..]
  where
    toTableRow :: RowNumber -> BodyRow -> TableRow
toTableRow RowNumber
rownum (Ann.BodyRow Attr
attr RowNumber
_rownum [Cell]
rowhead [Cell]
rowbody) =
      TablePart -> Attr -> RowNumber -> [Cell] -> [Cell] -> TableRow
TableRow TablePart
Tbody Attr
attr RowNumber
rownum [Cell]
rowhead [Cell]
rowbody

rowListToJats :: PandocMonad m
              => WriterOptions
              -> [TableRow]
              -> JATS m (Doc Text)
rowListToJats :: WriterOptions -> [TableRow] -> JATS m (Doc Text)
rowListToJats WriterOptions
opts = ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat (StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
 -> JATS m (Doc Text))
-> ([TableRow]
    -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text])
-> [TableRow]
-> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TableRow -> JATS m (Doc Text))
-> [TableRow]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> TableRow -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> TableRow -> JATS m (Doc Text)
tableRowToJats WriterOptions
opts)

colSpecListToJATS :: [ColSpec] -> Doc Text
colSpecListToJATS :: [ColSpec] -> Doc Text
colSpecListToJATS [ColSpec]
colspecs =
  let hasDefaultWidth :: (a, ColWidth) -> Bool
hasDefaultWidth (a
_, ColWidth
ColWidthDefault) = Bool
True
      hasDefaultWidth (a, ColWidth)
_                    = Bool
False

      percent :: a -> Text
percent a
w = Integer -> Text
forall a. Show a => a -> Text
tshow (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (a
100a -> a -> a
forall a. Num a => a -> a -> a
*a
w) :: Integer) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%"

      col :: ColWidth -> Doc Text
      col :: ColWidth -> Doc Text
col = Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"col" ([(Text, Text)] -> Doc Text)
-> (ColWidth -> [(Text, Text)]) -> ColWidth -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        ColWidth
ColWidthDefault -> [(Text, Text)]
forall a. Monoid a => a
mempty
        ColWidth Double
w -> [(Text
"width", Double -> Text
forall a. RealFrac a => a -> Text
percent Double
w)]

   in if (ColSpec -> Bool) -> [ColSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ColSpec -> Bool
forall a. (a, ColWidth) -> Bool
hasDefaultWidth [ColSpec]
colspecs
      then Doc Text
forall a. Monoid a => a
mempty
      else Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"colgroup" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$ (ColSpec -> Doc Text) -> [ColSpec] -> [Doc Text]
forall a b. (a -> b) -> [a] -> [b]
map (ColWidth -> Doc Text
col (ColWidth -> Doc Text)
-> (ColSpec -> ColWidth) -> ColSpec -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColSpec -> ColWidth
forall a b. (a, b) -> b
snd) [ColSpec]
colspecs

tableRowToJats :: PandocMonad m
               => WriterOptions
               -> TableRow
               -> JATS m (Doc Text)
tableRowToJats :: WriterOptions -> TableRow -> JATS m (Doc Text)
tableRowToJats WriterOptions
opts (TableRow TablePart
tblpart Attr
attr RowNumber
_rownum [Cell]
rowhead [Cell]
rowbody) = do
  let validAttribs :: [Text]
validAttribs = [ Text
"align", Text
"char", Text
"charoff", Text
"content-type"
                     , Text
"style", Text
"valign"
                     ]
  let attr' :: [(Text, Text)]
attr' = Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validAttribs
  let celltype :: CellType
celltype = case TablePart
tblpart of
                   TablePart
Thead -> CellType
HeaderCell
                   TablePart
_     -> CellType
BodyCell
  [Doc Text]
headcells <- (Cell -> JATS m (Doc Text))
-> [Cell] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> CellType -> Cell -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> CellType -> Cell -> JATS m (Doc Text)
cellToJats WriterOptions
opts CellType
HeaderCell) [Cell]
rowhead
  [Doc Text]
bodycells <- (Cell -> JATS m (Doc Text))
-> [Cell] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> CellType -> Cell -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> CellType -> Cell -> JATS m (Doc Text)
cellToJats WriterOptions
opts CellType
celltype) [Cell]
rowbody
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"tr" [(Text, Text)]
attr' (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat
    [ [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
headcells
    , [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
bodycells
    ]

alignmentAttrib :: Alignment -> Maybe (Text, Text)
alignmentAttrib :: Alignment -> Maybe (Text, Text)
alignmentAttrib = (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"align",) (Maybe Text -> Maybe (Text, Text))
-> (Alignment -> Maybe Text) -> Alignment -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  Alignment
AlignLeft    -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"left"
  Alignment
AlignRight   -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"right"
  Alignment
AlignCenter  -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"center"
  Alignment
AlignDefault -> Maybe Text
forall a. Maybe a
Nothing

colspanAttrib :: ColSpan -> Maybe (Text, Text)
colspanAttrib :: ColSpan -> Maybe (Text, Text)
colspanAttrib = \case
  ColSpan Int
1 -> Maybe (Text, Text)
forall a. Maybe a
Nothing
  ColSpan Int
n -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"colspan", Int -> Text
forall a. Show a => a -> Text
tshow Int
n)

rowspanAttrib :: RowSpan -> Maybe (Text, Text)
rowspanAttrib :: RowSpan -> Maybe (Text, Text)
rowspanAttrib = \case
  RowSpan Int
1 -> Maybe (Text, Text)
forall a. Maybe a
Nothing
  RowSpan Int
n -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"rowspan", Int -> Text
forall a. Show a => a -> Text
tshow Int
n)

cellToJats :: PandocMonad m
           => WriterOptions
           -> CellType
           -> Ann.Cell
           -> JATS m (Doc Text)
cellToJats :: WriterOptions -> CellType -> Cell -> JATS m (Doc Text)
cellToJats WriterOptions
opts CellType
celltype (Ann.Cell (ColSpec
colspec :| [ColSpec]
_) ColNumber
_colNum Cell
cell) =
  let align :: Alignment
align = ColSpec -> Alignment
forall a b. (a, b) -> a
fst ColSpec
colspec
  in WriterOptions -> CellType -> Alignment -> Cell -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> CellType -> Alignment -> Cell -> JATS m (Doc Text)
tableCellToJats WriterOptions
opts CellType
celltype Alignment
align Cell
cell

toAttribs :: Attr -> [Text] -> [(Text, Text)]
toAttribs :: Attr -> [Text] -> [(Text, Text)]
toAttribs (Text
ident, [Text]
_classes, [(Text, Text)]
kvs) [Text]
knownAttribs =
  (if Text -> Bool
T.null Text
ident then [(Text, Text)] -> [(Text, Text)]
forall a. a -> a
id else ((Text
"id", Text -> Text
escapeNCName Text
ident) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:)) ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
  ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
knownAttribs) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
kvs

tableCellToJats :: PandocMonad m
                => WriterOptions
                -> CellType
                -> Alignment
                -> Cell
                -> JATS m (Doc Text)
tableCellToJats :: WriterOptions -> CellType -> Alignment -> Cell -> JATS m (Doc Text)
tableCellToJats WriterOptions
opts CellType
ctype Alignment
colAlign (Cell Attr
attr Alignment
align RowSpan
rowspan ColSpan
colspan [Block]
item) = do
  (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
blockToJats   <- (JATSEnv m
 -> (Block -> Bool)
 -> WriterOptions
 -> [Block]
 -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     ((Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m
-> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m
-> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
jatsBlockWriter
  WriterOptions -> ShortCaption -> JATS m (Doc Text)
inlinesToJats <- (JATSEnv m -> WriterOptions -> ShortCaption -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     (WriterOptions -> ShortCaption -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> WriterOptions -> ShortCaption -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m -> WriterOptions -> ShortCaption -> JATS m (Doc Text)
jatsInlinesWriter
  let cellContents :: [Block] -> JATS m (Doc Text)
cellContents = \case
        [Plain ShortCaption
inlines] -> WriterOptions -> ShortCaption -> JATS m (Doc Text)
inlinesToJats WriterOptions
opts ShortCaption
inlines
        [Block]
blocks          -> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
blockToJats Block -> Bool
needsWrapInCell WriterOptions
opts [Block]
blocks
  let tag' :: Text
tag' = case CellType
ctype of
        CellType
BodyCell   -> Text
"td"
        CellType
HeaderCell -> Text
"th"
  let align' :: Alignment
align' = case Alignment
align of
        Alignment
AlignDefault -> Alignment
colAlign
        Alignment
_            -> Alignment
align
  let maybeCons :: Maybe a -> [a] -> [a]
maybeCons = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a] -> [a]
forall a. a -> a
id (:)
  let validAttribs :: [Text]
validAttribs = [ Text
"abbr", Text
"align", Text
"axis", Text
"char", Text
"charoff"
                     , Text
"content-type", Text
"headers", Text
"scope", Text
"style", Text
"valign"
                     ]
  let attribs :: [(Text, Text)]
attribs = Maybe (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. Maybe a -> [a] -> [a]
maybeCons (Alignment -> Maybe (Text, Text)
alignmentAttrib Alignment
align')
              ([(Text, Text)] -> [(Text, Text)])
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. Maybe a -> [a] -> [a]
maybeCons (RowSpan -> Maybe (Text, Text)
rowspanAttrib RowSpan
rowspan)
              ([(Text, Text)] -> [(Text, Text)])
-> ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)]
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. Maybe a -> [a] -> [a]
maybeCons (ColSpan -> Maybe (Text, Text)
colspanAttrib ColSpan
colspan)
              ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validAttribs
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
tag' [(Text, Text)]
attribs (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> JATS m (Doc Text)
cellContents [Block]
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 :: Block -> Bool
needsWrapInCell = \case
  Plain{}          -> Bool
False  -- should be unwrapped anyway
  Para{}           -> Bool
False
  BulletList{}     -> Bool
False
  OrderedList{}    -> Bool
False
  DefinitionList{} -> Bool
False
  Block
HorizontalRule   -> Bool
False
  CodeBlock{}      -> Bool
False
  RawBlock{}       -> Bool
False  -- responsibility of the user
  Block
_                -> Bool
True