{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
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 opts :: WriterOptions
opts (Ann.Table attr :: Attr
attr caption :: Caption
caption colspecs :: [ColSpec]
colspecs thead :: TableHead
thead tbodies :: [TableBody]
tbodies tfoot :: TableFoot
tfoot) = do
let (Caption _maybeShortCaption :: Maybe ShortCaption
_maybeShortCaption captionBlocks :: [Block]
captionBlocks) = Caption
caption
let needsWrapping :: Block -> Bool
needsWrapping = \case
Plain{} -> Bool
False
Para{} -> Bool
False
_ -> 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 "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 "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 opts :: WriterOptions
opts attr :: Attr
attr colspecs :: [ColSpec]
colspecs thead :: TableHead
thead tbodies :: [TableBody]
tbodies tfoot :: 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 = [ "border", "cellpadding", "cellspacing", "content-type"
, "frame", "rules", "specific-use", "style", "summary"
, "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 "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 =
[ "align", "char", "charoff", "content-type", "style", "valign" ]
tableBodyToJats :: PandocMonad m
=> WriterOptions
-> Ann.TableBody
-> JATS m (Doc Text)
tableBodyToJats :: WriterOptions -> TableBody -> JATS m (Doc Text)
tableBodyToJats opts :: WriterOptions
opts (Ann.TableBody attr :: Attr
attr _rowHeadCols :: RowHeadColumns
_rowHeadCols inthead :: [HeaderRow]
inthead rows :: [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 "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 opts :: WriterOptions
opts (Ann.TableHead attr :: Attr
attr rows :: [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)
opts :: WriterOptions
opts (Ann.TableFoot attr :: Attr
attr rows :: [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 opts :: WriterOptions
opts tblpart :: TablePart
tblpart attr :: Attr
attr rows :: [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
Thead -> "thead"
Tfoot -> "tfoot"
Tbody -> "tbody"
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
_attr _rownum :: RowNumber
_rownum cells :: [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 _colspecs :: NonEmpty ColSpec
_colspecs _colnum :: ColNumber
_colnum cell :: 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 1) (Int -> ColSpan
ColSpan 1) []
data TablePart = Thead | | 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 = | BodyCell
data TableRow = TableRow TablePart Attr Ann.RowNumber Ann.RowHead Ann.RowBody
headerRowsToJats :: PandocMonad m
=> WriterOptions
-> TablePart
-> [Ann.HeaderRow]
-> JATS m (Doc Text)
opts :: WriterOptions
opts tablepart :: 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
attr rownum :: RowNumber
rownum rowbody :: [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 opts :: 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 [1..]
where
toTableRow :: RowNumber -> BodyRow -> TableRow
toTableRow rownum :: RowNumber
rownum (Ann.BodyRow attr :: Attr
attr _rownum :: RowNumber
_rownum rowhead :: [Cell]
rowhead rowbody :: [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 opts :: 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 colspecs :: [ColSpec]
colspecs =
let hasDefaultWidth :: (a, ColWidth) -> Bool
hasDefaultWidth (_, ColWidthDefault) = Bool
True
hasDefaultWidth _ = Bool
False
percent :: a -> Text
percent w :: a
w = Integer -> Text
forall a. Show a => a -> Text
tshow (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (100a -> a -> a
forall a. Num a => a -> a -> a
*a
w) :: Integer) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "%"
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 "col" ([(Text, Text)] -> Doc Text)
-> (ColWidth -> [(Text, Text)]) -> ColWidth -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
ColWidthDefault -> [(Text, Text)]
forall a. Monoid a => a
mempty
ColWidth w :: Double
w -> [("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 "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 opts :: WriterOptions
opts (TableRow tblpart :: TablePart
tblpart attr :: Attr
attr _rownum :: RowNumber
_rownum rowhead :: [Cell]
rowhead rowbody :: [Cell]
rowbody) = do
let validAttribs :: [Text]
validAttribs = [ "align", "char", "charoff", "content-type"
, "style", "valign"
]
let attr' :: [(Text, Text)]
attr' = Attr -> [Text] -> [(Text, Text)]
toAttribs Attr
attr [Text]
validAttribs
let celltype :: CellType
celltype = case TablePart
tblpart of
Thead -> CellType
HeaderCell
_ -> 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 "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 ("align",) (Maybe Text -> Maybe (Text, Text))
-> (Alignment -> Maybe Text) -> Alignment -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
AlignLeft -> Text -> Maybe Text
forall a. a -> Maybe a
Just "left"
AlignRight -> Text -> Maybe Text
forall a. a -> Maybe a
Just "right"
AlignCenter -> Text -> Maybe Text
forall a. a -> Maybe a
Just "center"
AlignDefault -> Maybe Text
forall a. Maybe a
Nothing
colspanAttrib :: ColSpan -> Maybe (Text, Text)
colspanAttrib :: ColSpan -> Maybe (Text, Text)
colspanAttrib = \case
ColSpan 1 -> Maybe (Text, Text)
forall a. Maybe a
Nothing
ColSpan n :: Int
n -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ("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 1 -> Maybe (Text, Text)
forall a. Maybe a
Nothing
RowSpan n :: Int
n -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just ("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 opts :: WriterOptions
opts celltype :: CellType
celltype (Ann.Cell (colspec :: ColSpec
colspec :| _) _colNum :: ColNumber
_colNum cell :: 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 (ident :: Text
ident, _classes :: [Text]
_classes, kvs :: [(Text, Text)]
kvs) knownAttribs :: [Text]
knownAttribs =
(if Text -> Bool
T.null Text
ident then [(Text, Text)] -> [(Text, Text)]
forall a. a -> a
id else (("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 opts :: WriterOptions
opts ctype :: CellType
ctype colAlign :: Alignment
colAlign (Cell attr :: Attr
attr align :: Alignment
align rowspan :: RowSpan
rowspan colspan :: ColSpan
colspan item :: [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 inlines :: ShortCaption
inlines] -> WriterOptions -> ShortCaption -> JATS m (Doc Text)
inlinesToJats WriterOptions
opts ShortCaption
inlines
blocks :: [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
BodyCell -> "td"
HeaderCell -> "th"
let align' :: Alignment
align' = case Alignment
align of
AlignDefault -> Alignment
colAlign
_ -> 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 = [ "abbr", "align", "axis", "char", "charoff"
, "content-type", "headers", "scope", "style", "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
needsWrapInCell :: Block -> Bool
needsWrapInCell :: Block -> Bool
needsWrapInCell = \case
Plain{} -> Bool
False
Para{} -> Bool
False
BulletList{} -> Bool
False
OrderedList{} -> Bool
False
DefinitionList{} -> Bool
False
HorizontalRule -> Bool
False
CodeBlock{} -> Bool
False
RawBlock{} -> Bool
False
_ -> Bool
True