@@ -1,4 +1,6 @@
1+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TupleSections #-}
24{- |
35 Module : Text.Pandoc.Writers.JATS.Table
46 Copyright : © 2020 Albert Krewinkel
@@ -14,69 +16,233 @@ module Text.Pandoc.Writers.JATS.Table
1416 ( tableToJATS
1517 ) where
1618import Control.Monad.Reader (asks)
19+import Data.List.NonEmpty (NonEmpty ((:|)))
1720import Data.Text (Text)
21+import Text.DocLayout (Doc, empty, vcat, ($$))
1822import Text.Pandoc.Class.PandocMonad (PandocMonad)
1923import Text.Pandoc.Definition
2024import Text.Pandoc.Options (WriterOptions)
21−import Text.DocLayout (Doc, empty, vcat, ($$))
2225import Text.Pandoc.Shared (tshow)
2326import Text.Pandoc.Writers.JATS.Types
24−import Text.Pandoc.Writers.Shared (toLegacyTable)
2527import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
26−
28+import qualified Data.Text as T
29+import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
2730
2831tableToJATS :: PandocMonad m
2932 => WriterOptions
30− -> Attr -> Caption -> [ColSpec] -> TableHead
31− -> [TableBody] -> TableFoot
33+ -> Ann.Table
3234 -> JATS m (Doc Text)
33−tableToJATS opts _attr blkCapt specs th tb tf = do
34− blockToJATS <- asks jatsBlockWriter
35− let (caption, aligns, widths, headers, rows) =
36− toLegacyTable blkCapt specs th tb tf
37− captionDoc <- if null caption
38− then return mempty
39− else inTagsIndented "caption" <$> blockToJATS opts (Para caption)
40− tbl <- captionlessTable aligns widths headers rows
35+tableToJATS opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do
36+ let (Caption _maybeShortCaption captionBlocks) = caption
37+ tbl <- captionlessTable opts attr colspecs thead tbodies tfoot
38+ captionDoc <- if null captionBlocks
39+ then return empty
40+ else do
41+ blockToJATS <- asks jatsBlockWriter
42+ inTagsIndented "caption" . vcat <$>
43+ mapM (blockToJATS opts) captionBlocks
4144 return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
45+
46+captionlessTable :: PandocMonad m
47+ => WriterOptions
48+ -> Attr
49+ -> [ColSpec]
50+ -> Ann.TableHead
51+ -> [Ann.TableBody]
52+ -> Ann.TableFoot
53+ -> JATS m (Doc Text)
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"
60+ , "width"
61+ ]
62+ let attribs = toAttribs attr validAttribs
63+ return $ inTags True "table" attribs $ vcat
64+ [ colSpecListToJATS colspecs
65+ , head'
66+ , foot'
67+ , vcat bodies
68+ ]
69+
70+validTablePartAttribs :: [Text]
71+validTablePartAttribs =
72+ [ "align", "char", "charoff", "content-type", "style", "valign" ]
73+
74+tableBodyToJats :: PandocMonad m
75+ => WriterOptions
76+ -> Ann.TableBody
77+ -> JATS m (Doc Text)
78+tableBodyToJats opts (Ann.TableBody attr _rowHeadCols inthead rows) = do
79+ let attribs = toAttribs attr validTablePartAttribs
80+ intermediateHead <- if null inthead
81+ then return mempty
82+ else headerRowsToJats opts Thead inthead
83+ bodyRows <- bodyRowsToJats opts rows
84+ return $ inTags True "tbody" attribs $ intermediateHead $$ bodyRows
85+
86+tableHeadToJats :: PandocMonad m
87+ => WriterOptions
88+ -> Ann.TableHead
89+ -> JATS m (Doc Text)
90+tableHeadToJats opts (Ann.TableHead attr rows) =
91+ tablePartToJats opts Thead attr rows
92+
93+tableFootToJats :: PandocMonad m
94+ => WriterOptions
95+ -> Ann.TableFoot
96+ -> JATS m (Doc Text)
97+tableFootToJats opts (Ann.TableFoot attr rows) =
98+ tablePartToJats opts Tfoot attr rows
99+
100+tablePartToJats :: PandocMonad m
101+ => WriterOptions
102+ -> TablePart
103+ -> Attr
104+ -> [Ann.HeaderRow]
105+ -> JATS m (Doc Text)
106+tablePartToJats opts tblpart attr rows =
107+ if null rows || all isEmptyRow rows
108+ then return mempty
109+ else do
110+ let tag' = case tblpart of
111+ Thead -> "thead"
112+ Tfoot -> "tfoot"
113+ Tbody -> "tbody" -- this would be unexpected
114+ let attribs = toAttribs attr validTablePartAttribs
115+ inTags True tag' attribs <$> headerRowsToJats opts tblpart rows
42116 where
43− captionlessTable aligns widths headers rows = do
44− let percent w = tshow (truncate (100*w) :: Integer) <> "*"
45− let coltags = vcat $ zipWith (\w al -> selfClosingTag "col"
46− ([("width", percent w) | w > 0] ++
47− [("align", alignmentToText al)])) widths aligns
48− thead <- if all null headers
49− then return empty
50− else inTagsIndented "thead" <$> tableRowToJATS opts True headers
51− tbody <- inTagsIndented "tbody" . vcat <$>
52− mapM (tableRowToJATS opts False) rows
53− return $ inTags True "table" [] $ coltags $$ thead $$ tbody
54−
55−alignmentToText :: Alignment -> Text
56−alignmentToText alignment = case alignment of
57− AlignLeft -> "left"
58− AlignRight -> "right"
59− AlignCenter -> "center"
60− AlignDefault -> "left"
61−
62−tableRowToJATS :: PandocMonad m
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) []
120+
121+-- | The part of a table; header, footer, or body.
122+data TablePart = Thead | Tfoot | Tbody
123+ deriving (Eq)
124+
125+data CellType = HeaderCell | BodyCell
126+
127+data TableRow = TableRow TablePart Attr Ann.RowNumber Ann.RowHead Ann.RowBody
128+
129+headerRowsToJats :: PandocMonad m
130+ => WriterOptions
131+ -> TablePart
132+ -> [Ann.HeaderRow]
133+ -> JATS m (Doc Text)
134+headerRowsToJats opts tablepart =
135+ rowListToJats opts . map toTableRow
136+ where
137+ toTableRow (Ann.HeaderRow attr rownum rowbody) =
138+ TableRow tablepart attr rownum [] rowbody
139+
140+bodyRowsToJats :: PandocMonad m
141+ => WriterOptions
142+ -> [Ann.BodyRow]
143+ -> JATS m (Doc Text)
144+bodyRowsToJats opts =
145+ rowListToJats opts . zipWith toTableRow [1..]
146+ where
147+ toTableRow rownum (Ann.BodyRow attr _rownum rowhead rowbody) =
148+ TableRow Tbody attr rownum rowhead rowbody
149+
150+rowListToJats :: PandocMonad m
151+ => WriterOptions
152+ -> [TableRow]
153+ -> JATS m (Doc Text)
154+rowListToJats opts = fmap vcat . mapM (tableRowToJats opts)
155+
156+colSpecListToJATS :: [ColSpec] -> Doc Text
157+colSpecListToJATS colspecs =
158+ let hasDefaultWidth (_, ColWidthDefault) = True
159+ hasDefaultWidth _ = False
160+
161+ percent w = tshow (round (100*w) :: Integer) <> "%"
162+
163+ col :: ColWidth -> Doc Text
164+ col = selfClosingTag "col" . \case
165+ ColWidthDefault -> mempty
166+ ColWidth w -> [("width", percent w)]
167+
168+ in if all hasDefaultWidth colspecs
169+ then mempty
170+ else inTags True "colgroup" [] $ vcat $ map (col . snd) colspecs
171+
172+tableRowToJats :: PandocMonad m
63173 => WriterOptions
64− -> Bool
65− -> [[Block]]
174+ -> TableRow
66175 -> JATS m (Doc Text)
67−tableRowToJATS opts isHeader cols =
68− inTagsIndented "tr" . vcat <$> mapM (tableItemToJATS opts isHeader) cols
176+tableRowToJats opts (TableRow tblpart attr _rownum rowhead rowbody) = do
177+ let validAttribs = [ "align", "char", "charoff", "content-type"
178+ , "style", "valign"
179+ ]
180+ let attr' = toAttribs attr validAttribs
181+ let celltype = case tblpart of
182+ Thead -> HeaderCell
183+ _ -> BodyCell
184+ headcells <- mapM (cellToJats opts HeaderCell) rowhead
185+ bodycells <- mapM (cellToJats opts celltype) rowbody
186+ return $ inTags True "tr" attr' $ mconcat
187+ [ vcat headcells
188+ , vcat bodycells
189+ ]
190+
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
197+
198+colspanAttrib :: ColSpan -> Maybe (Text, Text)
199+colspanAttrib = \case
200+ ColSpan 1 -> Nothing
201+ ColSpan n -> Just ("colspan", tshow n)
202+
203+rowspanAttrib :: RowSpan -> Maybe (Text, Text)
204+rowspanAttrib = \case
205+ RowSpan 1 -> Nothing
206+ RowSpan n -> Just ("rowspan", tshow n)
207+
208+cellToJats :: PandocMonad m
209+ => WriterOptions
210+ -> CellType
211+ -> Ann.Cell
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
216+
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
69221
70−tableItemToJATS :: PandocMonad m
222+tableCellToJats :: PandocMonad m
71223 => WriterOptions
72− -> Bool
73− -> [Block]
224+ -> CellType
225+ -> Alignment
226+ -> Cell
74227 -> JATS m (Doc Text)
75−tableItemToJATS opts isHeader [Plain item] = do
76− inlinesToJATS <- asks jatsInlinesWriter
77− inTags False (if isHeader then "th" else "td") [] <$>
78− inlinesToJATS opts item
79−tableItemToJATS opts isHeader item = do
80− blockToJATS <- asks jatsBlockWriter
81− inTags False (if isHeader then "th" else "td") [] . vcat <$>
82− mapM (blockToJATS opts) item
228+tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
229+ blockToJats <- asks jatsBlockWriter
230+ inlinesToJats <- asks jatsInlinesWriter
231+ let cellContents = \case
232+ [Plain inlines] -> inlinesToJats opts inlines
233+ blocks -> vcat <$> mapM (blockToJats opts) blocks
234+ let tag' = case ctype of
235+ BodyCell -> "td"
236+ HeaderCell -> "th"
237+ let align' = case align of
238+ AlignDefault -> colAlign
239+ _ -> align
240+ let maybeCons = maybe id (:)
241+ let validAttribs = [ "abbr", "align", "axis", "char", "charoff"
242+ , "content-type", "headers", "scope", "style", "valign"
243+ ]
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