@@ -1,3 +1,4 @@
1+{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE ViewPatterns #-}
34{- |
@@ -12,17 +13,19 @@
1213
1314HTML table parser.
1415-}
15−module Text.Pandoc.Readers.HTML.Table (pTable') where
16+module Text.Pandoc.Readers.HTML.Table (pTable) where
1617
17−import Control.Monad (guard)
18+import Control.Applicative ((<|>))
1819import Data.Maybe (fromMaybe)
1920import Data.Text (Text)
2021import Text.HTML.TagSoup
2122import Text.Pandoc.Builder (Blocks)
23+import Text.Pandoc.CSS (cssAttributes)
2224import Text.Pandoc.Definition
2325import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
2426import Text.Pandoc.Parsing
25− ( (<|>), eof, many, many1, manyTill, option, optional, skipMany, try)
27+ ( eof, lookAhead, many, many1, manyTill, option, optional
28+ , optionMaybe, skipMany, try)
2629import Text.Pandoc.Readers.HTML.Parsing
2730import Text.Pandoc.Readers.HTML.Types (TagParser)
2831import Text.Pandoc.Shared (onlySimpleTableCells, safeRead)
@@ -57,58 +60,183 @@ pColgroup = try $ do
5760 skipMany pBlank
5861 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank
5962
60−-- | Parses a simple HTML table
61−pTable' :: PandocMonad m
62− => TagParser m Blocks -- ^ Caption parser
63− -> (Text -> TagParser m [Cell]) -- ^ Table cell parser
64− -> TagParser m Blocks
65−pTable' block pCell = try $ do
66− TagOpen _ attribs' <- pSatisfy (matchTagOpen "table" [])
67− let attribs = toAttr attribs'
63+pCell :: PandocMonad m
64+ => TagParser m Blocks
65+ -> Text
66+ -> TagParser m [Cell]
67+pCell block celltype = try $ do
68+ skipMany pBlank
69+ TagOpen _ attribs <- lookAhead $ pSatisfy (matchTagOpen celltype [])
70+ let cssAttribs = maybe [] cssAttributes $ lookup "style" attribs
71+ let align = case lookup "align" attribs <|>
72+ lookup "text-align" cssAttribs of
73+ Just "left" -> AlignLeft
74+ Just "right" -> AlignRight
75+ Just "center" -> AlignCenter
76+ _ -> AlignDefault
77+ let rowspan = RowSpan . fromMaybe 1 $
78+ safeRead =<< lookup "rowspan" attribs
79+ let colspan = ColSpan . fromMaybe 1 $
80+ safeRead =<< lookup "colspan" attribs
81+ res <- pInTags celltype block
82+ skipMany pBlank
83+ let handledAttribs = ["align", "colspan", "rowspan", "text-align"]
84+ attribs' = foldr go [] attribs
85+ go kv@(k, _) acc = case k of
86+ "style" -> case filter ((/= "text-align") . fst) cssAttribs of
87+ [] -> acc
88+ cs -> ("style", toStyleString cs) : acc
89+ -- drop attrib if it's already handled
90+ _ | k `elem` handledAttribs -> acc
91+ _ -> kv : acc
92+ return [B.cellWith (toAttr attribs') align rowspan colspan res]
93+
94+-- | Create a style attribute string from a list of CSS attributes
95+toStyleString :: [(Text, Text)] -> Text
96+toStyleString = T.intercalate "; " . map (\(k, v) -> k <> ": " <> v)
97+
98+data RowType
99+ = HeaderCells
100+ | AllCells
101+
102+-- | Parses a table row
103+pRow :: PandocMonad m
104+ => TagParser m Blocks
105+ -> RowType
106+ -> TagParser m [B.Row]
107+pRow block rowType = try $ do
108+ skipMany pBlank
109+ case rowType of
110+ HeaderCells -> do
111+ maybeCells <- optionMaybe (pInTags "tr" (pCell block "th"))
112+ return $ case maybeCells of
113+ Nothing -> []
114+ Just cells -> [Row nullAttr cells]
115+ AllCells -> do
116+ cells <- pInTags "tr" (pCell block "td" <|> pCell block "th")
117+ return [Row nullAttr cells]
118+
119+-- | Parses a table head
120+pTableHead :: PandocMonad m
121+ => TagParser m Blocks
122+ -> TagParser m TableHead
123+pTableHead block = try $ do
124+ skipMany pBlank
125+ (attribs, rows) <- pInTagWithAttribs ClosingTagOptional "thead"
126+ (option [] $ pRow block AllCells)
127+ <|> pInTagWithAttribs TagsOmittable "thead"
128+ (pRow block HeaderCells)
129+ let cells = concatMap (\(Row _ cs) -> cs) rows
130+ if null cells
131+ then TableHead nullAttr <$>
132+ pInTag TagsOmittable "tbody" (pRow block HeaderCells)
133+ else return $ TableHead (toAttr attribs) [Row nullAttr cells]
134+
135+-- | Parses a table foot
136+pTableFoot :: PandocMonad m
137+ => TagParser m Blocks
138+ -> TagParser m TableFoot
139+pTableFoot block = try $ do
140+ skipMany pBlank
141+ TagOpen _ attribs <- pSatisfy (matchTagOpen "tfoot" []) <* skipMany pBlank
142+ rows <- mconcat <$> many (pRow block AllCells <* skipMany pBlank)
143+ optional $ pSatisfy (matchTagClose "tfoot")
144+ return $ TableFoot (toAttr attribs) rows
145+
146+-- | Parses a table body
147+pTableBody :: PandocMonad m
148+ => TagParser m Blocks
149+ -> TagParser m TableBody
150+pTableBody block = do
68151 skipMany pBlank
69− caption <- option mempty $ pInTags "caption" block <* skipMany pBlank
70− widths' <- (mconcat <$> many1 pColgroup) <|> many pCol
71− let pTh = option [] $ pInTags "tr" (pCell "th")
72− pTr = try $ skipMany pBlank
73− *> pInTags "tr" (pCell "td" <|> pCell "th")
74− pTBody = pInTag TagsOmittable "tbody" $ many1 pTr
75− head'' <- pInTag ClosingTagOptional "thead" (option [] pTr)
76− <|> pInTag TagsOmittable "thead" pTh
77− head' <- pInTag TagsOmittable "tbody"
78− (if null head'' then pTh else return head'')
79− topfoot <- option [] $ pInTag TagsRequired "tfoot" $ many pTr
80− rowsLs <- many pTBody
81− bottomfoot <- option [] $ pInTag ClosingTagOptional "tfoot" $ many pTr
152+ (attribs, rows) <- pInTagWithAttribs TagsOmittable "tbody"
153+ (mconcat <$> many1 (pRow block AllCells))
154+ return $ TableBody (toAttr attribs) 0 [] rows
155+
156+
157+-- | Parses a simple HTML table
158+pTable :: PandocMonad m
159+ => TagParser m Blocks -- ^ Caption and cell contents parser
160+ -> TagParser m Blocks
161+pTable block = try $ do
162+ TagOpen _ attribs <- pSatisfy (matchTagOpen "table" []) <* skipMany pBlank
163+ caption <- option mempty $ pInTags "caption" block <* skipMany pBlank
164+ widths <- ((mconcat <$> many1 pColgroup) <|> many pCol) <* skipMany pBlank
165+ thead <- pTableHead block <* skipMany pBlank
166+ topfoot <- optionMaybe (pTableFoot block) <* skipMany pBlank
167+ tbodies <- many (pTableBody block) <* skipMany pBlank
168+ botfoot <- optionMaybe (pTableFoot block) <* skipMany pBlank
82169 TagClose _ <- pSatisfy (matchTagClose "table")
83− let rows = concat rowsLs <> topfoot <> bottomfoot
84− rows''' = map (map cellContents) rows
170+ let tfoot = fromMaybe (TableFoot nullAttr []) $ topfoot <|> botfoot
171+ case normalize widths thead tbodies tfoot of
172+ Left err -> fail err
173+ Right (colspecs, thead', tbodies', tfoot') -> return $
174+ B.tableWith (toAttr attribs)
175+ (B.simpleCaption caption)
176+ colspecs
177+ thead'
178+ tbodies'
179+ tfoot'
180+data TableType
181+ = SimpleTable
182+ | NormalTable
183+
184+tableType :: [[Cell]] -> TableType
185+tableType cells =
186+ if onlySimpleTableCells $ map (map cellContents) cells
187+ then SimpleTable
188+ else NormalTable
189+ where
190+ cellContents :: Cell -> [Block]
191+ cellContents (Cell _ _ _ _ bs) = bs
192+
193+normalize :: [ColWidth] -> TableHead -> [TableBody] -> TableFoot
194+ -> Either String ([ColSpec], TableHead, [TableBody], TableFoot)
195+normalize widths head' bodies foot = do
196+ let rows = headRows head' <> concatMap bodyRows bodies <> footRows foot
197+ let rowLength = length . rowCells
198+ let ncols = maximum (map rowLength rows)
199+ let tblType = tableType (map rowCells rows)
85200 -- fail on empty table
86− guard $ not $ null head' && null rows'''
87− let isSimple = onlySimpleTableCells $
88− map cellContents head' : rows'''
89− let cols = if null head'
90− then maximum (map length rows''')
91− else length head'
92− let aligns = case rows of
93− (cs:_) -> take cols $
94− concatMap cellAligns cs ++ repeat AlignDefault
95− _ -> replicate cols AlignDefault
96− let widths = if null widths'
97− then if isSimple
98− then replicate cols ColWidthDefault
99− else replicate cols (ColWidth (1.0 / fromIntegral cols))
100− else widths'
101− let toRow = Row nullAttr
102− toHeaderRow l = [toRow l | not (null l)]
103− return $ B.tableWith attribs
104− (B.simpleCaption caption)
105− (zip aligns widths)
106− (TableHead nullAttr $ toHeaderRow head')
107− [TableBody nullAttr 0 [] $ map toRow rows]
108− (TableFoot nullAttr [])
109−
110−cellContents :: Cell -> [Block]
111−cellContents (Cell _ _ _ _ bs) = bs
112−
113−cellAligns :: Cell -> [Alignment]
114−cellAligns (Cell _ align _ (ColSpan cs) _) = replicate cs align
201+ if null rows
202+ then Left "empty table"
203+ else Right
204+ ( zip (calculateAlignments ncols bodies)
205+ (normalizeColWidths ncols tblType widths)
206+ , head'
207+ , bodies
208+ , foot
209+ )
210+
211+normalizeColWidths :: Int -> TableType -> [ColWidth] -> [ColWidth]
212+normalizeColWidths ncols tblType = \case
213+ [] -> case tblType of
214+ SimpleTable -> replicate ncols ColWidthDefault
215+ NormalTable -> replicate ncols (ColWidth $ 1 / fromIntegral ncols)
216+ widths -> widths
217+
218+calculateAlignments :: Int -> [TableBody] -> [Alignment]
219+calculateAlignments cols tbodies =
220+ case cells of
221+ cs:_ -> take cols $ concatMap cellAligns cs ++ repeat AlignDefault
222+ _ -> replicate cols AlignDefault
223+ where
224+ cells :: [[Cell]]
225+ cells = concatMap bodyRowCells tbodies
226+ cellAligns :: Cell -> [Alignment]
227+ cellAligns (Cell _ align _ (ColSpan cs) _) = replicate cs align
228+
229+bodyRowCells :: TableBody -> [[Cell]]
230+bodyRowCells = map rowCells . bodyRows
231+
232+headRows :: TableHead -> [B.Row]
233+headRows (TableHead _ rows) = rows
234+
235+bodyRows :: TableBody -> [B.Row]
236+bodyRows (TableBody _ _ headerRows bodyRows') = headerRows <> bodyRows'
237+
238+footRows :: TableFoot -> [B.Row]
239+footRows (TableFoot _ rows) = rows
240+
241+rowCells :: B.Row -> [Cell]
242+rowCells (Row _ cells) = cells