@@ -1,4 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TupleSections #-}
3 Module : Text.Pandoc.Writers.JATS.Table
5 Module : Text.Pandoc.Writers.JATS.Table
4 Copyright : © 2020 Albert Krewinkel
6 Copyright : © 2020 Albert Krewinkel
@@ -14,69 +16,233 @@ module Text.Pandoc.Writers.JATS.Table
14 ( tableToJATS
16 ( tableToJATS
16import Control.Monad.Reader (asks)
18import Control.Monad.Reader (asks)
19+import Data.List.NonEmpty (NonEmpty ((:|)))
17import Data.Text (Text)
20import Data.Text (Text)
21+import Text.DocLayout (Doc, empty, vcat, ($$))
18import Text.Pandoc.Class.PandocMonad (PandocMonad)
22import Text.Pandoc.Class.PandocMonad (PandocMonad)
19import Text.Pandoc.Definition
23import Text.Pandoc.Definition
20import Text.Pandoc.Options (WriterOptions)
24import Text.Pandoc.Options (WriterOptions)
21−import Text.DocLayout (Doc, empty, vcat, ($$))
22import Text.Pandoc.Shared (tshow)
25import Text.Pandoc.Shared (tshow)
23import Text.Pandoc.Writers.JATS.Types
26import Text.Pandoc.Writers.JATS.Types
24−import Text.Pandoc.Writers.Shared (toLegacyTable)
25import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
27import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
26−
28+import qualified Data.Text as T
29+import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
28tableToJATS :: PandocMonad m
31tableToJATS :: PandocMonad m
29 => WriterOptions
32 => WriterOptions
30− -> Attr -> Caption -> [ColSpec] -> TableHead
33+ -> Ann.Table
31− -> [TableBody] -> TableFoot
32 -> JATS m (Doc Text)
34 -> JATS m (Doc Text)
33−tableToJATS opts _attr blkCapt specs th tb tf = do
35+tableToJATS opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do
34− blockToJATS <- asks jatsBlockWriter
36+ let (Caption _maybeShortCaption captionBlocks) = caption
35− let (caption, aligns, widths, headers, rows) =
37+ tbl <- captionlessTable opts attr colspecs thead tbodies tfoot
36− toLegacyTable blkCapt specs th tb tf
37− captionDoc <- if null caption
38+ captionDoc <- if null captionBlocks
38− then return mempty
39+ then return empty
41+ blockToJATS <- asks jatsBlockWriter
39− else inTagsIndented "caption" <$> blockToJATS opts (Para caption)
42+ inTagsIndented "caption" . vcat <$>
40− tbl <- captionlessTable aligns widths headers rows
43+ mapM (blockToJATS opts) captionBlocks
41 return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
44 return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
46+captionlessTable :: PandocMonad m
54+captionlessTable opts attr colspecs thead tbodies tfoot = do
55+ head' <- tableHeadToJats opts thead
56+ bodies <- mapM (tableBodyToJats opts) tbodies
57+ foot' <- tableFootToJats opts tfoot
58+ let validAttribs = [ "border", "cellpadding", "cellspacing", "content-type"
59+ , "frame", "rules", "specific-use", "style", "summary"
62+ let attribs = toAttribs attr validAttribs
63+ return $ inTags True "table" attribs $ vcat
64+ [ colSpecListToJATS colspecs
70+validTablePartAttribs :: [Text]
71+validTablePartAttribs =
72+ [ "align", "char", "charoff", "content-type", "style", "valign" ]
74+tableBodyToJats :: PandocMonad m
78+tableBodyToJats opts (Ann.TableBody attr _rowHeadCols inthead rows) = do
79+ let attribs = toAttribs attr validTablePartAttribs
80+ intermediateHead <- if null inthead
82+ else headerRowsToJats opts Thead inthead
83+ bodyRows <- bodyRowsToJats opts rows
84+ return $ inTags True "tbody" attribs $ intermediateHead $$ bodyRows
86+tableHeadToJats :: PandocMonad m
90+tableHeadToJats opts (Ann.TableHead attr rows) =
91+ tablePartToJats opts Thead attr rows
93+tableFootToJats :: PandocMonad m
97+tableFootToJats opts (Ann.TableFoot attr rows) =
98+ tablePartToJats opts Tfoot attr rows
100+tablePartToJats :: PandocMonad m
105+ -> JATS m (Doc Text)
106+tablePartToJats opts tblpart attr rows =
107+ if null rows || all isEmptyRow rows
110+ let tag' = case tblpart of
113+ Tbody -> "tbody" -- this would be unexpected
114+ let attribs = toAttribs attr validTablePartAttribs
115+ inTags True tag' attribs <$> headerRowsToJats opts tblpart rows
43− captionlessTable aligns widths headers rows = do
117+ isEmptyRow (Ann.HeaderRow _attr _rownum cells) = all isEmptyCell cells
118+ isEmptyCell (Ann.Cell _colspecs _colnum cell) =
119+ cell == Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) []
121+-- | The part of a table; header, footer, or body.
122+data TablePart = Thead | Tfoot | Tbody
125+data CellType = HeaderCell | BodyCell
127+data TableRow = TableRow TablePart Attr Ann.RowNumber Ann.RowHead Ann.RowBody
129+headerRowsToJats :: PandocMonad m
133+ -> JATS m (Doc Text)
134+headerRowsToJats opts tablepart =
135+ rowListToJats opts . map toTableRow
137+ toTableRow (Ann.HeaderRow attr rownum rowbody) =
138+ TableRow tablepart attr rownum [] rowbody
140+bodyRowsToJats :: PandocMonad m
143+ -> JATS m (Doc Text)
144+bodyRowsToJats opts =
145+ rowListToJats opts . zipWith toTableRow [1..]
147+ toTableRow rownum (Ann.BodyRow attr _rownum rowhead rowbody) =
148+ TableRow Tbody attr rownum rowhead rowbody
150+rowListToJats :: PandocMonad m
153+ -> JATS m (Doc Text)
154+rowListToJats opts = fmap vcat . mapM (tableRowToJats opts)
156+colSpecListToJATS :: [ColSpec] -> Doc Text
157+colSpecListToJATS colspecs =
158+ let hasDefaultWidth (_, ColWidthDefault) = True
159+ hasDefaultWidth _ = False
44− let percent w = tshow (truncate (100*w) :: Integer) <> "*"
161+ percent w = tshow (round (100*w) :: Integer) <> "%"
45− let coltags = vcat $ zipWith (\w al -> selfClosingTag "col"
162+
163+ col :: ColWidth -> Doc Text
164+ col = selfClosingTag "col" . \case
165+ ColWidthDefault -> mempty
46− ([("width", percent w) | w > 0] ++
166+ ColWidth w -> [("width", percent w)]
47− [("align", alignmentToText al)])) widths aligns
167+
48− thead <- if all null headers
168+ in if all hasDefaultWidth colspecs
49− then return empty
169+ then mempty
50− else inTagsIndented "thead" <$> tableRowToJATS opts True headers
170+ else inTags True "colgroup" [] $ vcat $ map (col . snd) colspecs
51− tbody <- inTagsIndented "tbody" . vcat <$>
171+
52− mapM (tableRowToJATS opts False) rows
53− return $ inTags True "table" [] $ coltags $$ thead $$ tbody
55−alignmentToText :: Alignment -> Text
56−alignmentToText alignment = case alignment of
58− AlignRight -> "right"
59− AlignCenter -> "center"
60− AlignDefault -> "left"
62−tableRowToJATS :: PandocMonad m
172+tableRowToJats :: PandocMonad m
63 => WriterOptions
173 => WriterOptions
64− -> Bool
174+ -> TableRow
66 -> JATS m (Doc Text)
175 -> JATS m (Doc Text)
67−tableRowToJATS opts isHeader cols =
176+tableRowToJats opts (TableRow tblpart attr _rownum rowhead rowbody) = do
68− inTagsIndented "tr" . vcat <$> mapM (tableItemToJATS opts isHeader) cols
177+ let validAttribs = [ "align", "char", "charoff", "content-type"
180+ let attr' = toAttribs attr validAttribs
181+ let celltype = case tblpart of
184+ headcells <- mapM (cellToJats opts HeaderCell) rowhead
185+ bodycells <- mapM (cellToJats opts celltype) rowbody
186+ return $ inTags True "tr" attr' $ mconcat
191+alignmentAttrib :: Alignment -> Maybe (Text, Text)
192+alignmentAttrib = fmap ("align",) . \case
193+ AlignLeft -> Just "left"
194+ AlignRight -> Just "right"
195+ AlignCenter -> Just "center"
196+ AlignDefault -> Nothing
198+colspanAttrib :: ColSpan -> Maybe (Text, Text)
199+colspanAttrib = \case
200+ ColSpan 1 -> Nothing
201+ ColSpan n -> Just ("colspan", tshow n)
203+rowspanAttrib :: RowSpan -> Maybe (Text, Text)
204+rowspanAttrib = \case
205+ RowSpan 1 -> Nothing
206+ RowSpan n -> Just ("rowspan", tshow n)
208+cellToJats :: PandocMonad m
212+ -> JATS m (Doc Text)
213+cellToJats opts celltype (Ann.Cell (colspec :| _) _colNum cell) =
214+ let align = fst colspec
215+ in tableCellToJats opts celltype align cell
217+toAttribs :: Attr -> [Text] -> [(Text, Text)]
218+toAttribs (ident, _classes, kvs) knownAttribs =
219+ (if T.null ident then id else (("id", ident) :)) $
220+ filter ((`elem` knownAttribs) . fst) kvs
70−tableItemToJATS :: PandocMonad m
222+tableCellToJats :: PandocMonad m
71 => WriterOptions
223 => WriterOptions
72− -> Bool
224+ -> CellType
73− -> [Block]
225+ -> Alignment
74 -> JATS m (Doc Text)
227 -> JATS m (Doc Text)
75−tableItemToJATS opts isHeader [Plain item] = do
228+tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
76− inlinesToJATS <- asks jatsInlinesWriter
229+ blockToJats <- asks jatsBlockWriter
77− inTags False (if isHeader then "th" else "td") [] <$>
230+ inlinesToJats <- asks jatsInlinesWriter
78− inlinesToJATS opts item
231+ let cellContents = \case
79−tableItemToJATS opts isHeader item = do
232+ [Plain inlines] -> inlinesToJats opts inlines
80− blockToJATS <- asks jatsBlockWriter
233+ blocks -> vcat <$> mapM (blockToJats opts) blocks
81− inTags False (if isHeader then "th" else "td") [] . vcat <$>
234+ let tag' = case ctype of
82− mapM (blockToJATS opts) item
235+ BodyCell -> "td"
237+ let align' = case align of
238+ AlignDefault -> colAlign
240+ let maybeCons = maybe id (:)
241+ let validAttribs = [ "abbr", "align", "axis", "char", "charoff"
242+ , "content-type", "headers", "scope", "style", "valign"
244+ let attribs = maybeCons (alignmentAttrib align')
245+ . maybeCons (rowspanAttrib rowspan)
246+ . maybeCons (colspanAttrib colspan)
247+ $ toAttribs attr validAttribs
248+ inTags False tag' attribs <$> cellContents item