@@ -1,6 +1,6 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE LambdaCase #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ViewPatterns #-}
3+{-# LANGUAGE ViewPatterns #-}
44{- |
55 Module : Text.Pandoc.Readers.HTML.Table
66 Copyright : © 2006-2020 John MacFarlane,
@@ -60,13 +60,21 @@ pColgroup = try $ do
6060 skipMany pBlank
6161 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank
6262
63+data CellType
64+ = HeaderCell
65+ | BodyCell
66+ deriving Eq
67+
6368pCell :: PandocMonad m
6469 => TagParser m Blocks
65− -> Text
66− -> TagParser m [Cell]
70+ -> CellType
71+ -> TagParser m (CellType, Cell)
6772pCell block celltype = try $ do
73+ let celltype' = case celltype of
74+ HeaderCell -> "th"
75+ BodyCell -> "td"
6876 skipMany pBlank
69− TagOpen _ attribs <- lookAhead $ pSatisfy (matchTagOpen celltype [])
77+ TagOpen _ attribs <- lookAhead $ pSatisfy (matchTagOpen celltype' [])
7078 let cssAttribs = maybe [] cssAttributes $ lookup "style" attribs
7179 let align = case lookup "align" attribs <|>
7280 lookup "text-align" cssAttribs of
@@ -78,7 +86,7 @@ pCell block celltype = try $ do
7886 safeRead =<< lookup "rowspan" attribs
7987 let colspan = ColSpan . fromMaybe 1 $
8088 safeRead =<< lookup "colspan" attribs
81− res <- pInTags celltype block
89+ res <- pInTags celltype' block
8290 skipMany pBlank
8391 let handledAttribs = ["align", "colspan", "rowspan", "text-align"]
8492 attribs' = foldr go [] attribs
@@ -89,48 +97,55 @@ pCell block celltype = try $ do
8997 -- drop attrib if it's already handled
9098 _ | k `elem` handledAttribs -> acc
9199 _ -> kv : acc
92− return [B.cellWith (toAttr attribs') align rowspan colspan res]
100+ return (celltype, B.cellWith (toAttr attribs') align rowspan colspan res)
93101
94102-- | Create a style attribute string from a list of CSS attributes
95103toStyleString :: [(Text, Text)] -> Text
96104toStyleString = T.intercalate "; " . map (\(k, v) -> k <> ": " <> v)
97105
98−data RowType
99− = HeaderCells
100− | AllCells
101−
102−-- | Parses a table row
106+-- | Parses a normal table row; returns the row together with the number
107+-- of header cells at the beginning of the row.
103108pRow :: PandocMonad m
104109 => TagParser m Blocks
105− -> RowType
106− -> TagParser m [B.Row]
107−pRow block rowType = try $ do
110+ -> TagParser m (RowHeadColumns, B.Row)
111+pRow block = try $ do
108112 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
113+ TagOpen _ attribs <- pSatisfy (matchTagOpen "tr" []) <* skipMany pBlank
114+ cells <- many (pCell block BodyCell <|> pCell block HeaderCell)
115+ TagClose _ <- pSatisfy (matchTagClose "tr")
116+ return ( RowHeadColumns $ length (takeWhile ((== HeaderCell) . fst) cells)
117+ , Row (toAttr attribs) $ map snd cells
118+ )
119+
120+-- | Parses a header row, i.e., a row which containing nothing but
121+-- @<th>@ elements.
122+pHeaderRow :: PandocMonad m
123+ => TagParser m Blocks
124+ -> TagParser m B.Row
125+pHeaderRow block = try $ do
126+ skipMany pBlank
127+ let pThs = map snd <$> many (pCell block HeaderCell)
128+ let mkRow (attribs, cells) = Row (toAttr attribs) cells
129+ mkRow <$> pInTagWithAttribs TagsRequired "tr" pThs
130+
131+-- | Parses a table head. If there is no @thead@ element, this looks for
132+-- a row of @<th>@-only elements as the first line of the table.
120133pTableHead :: PandocMonad m
121134 => TagParser m Blocks
122135 -> TagParser m TableHead
123136pTableHead block = try $ do
124137 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]
138+ let pRows = many (pRow block)
139+ let pThead = pInTagWithAttribs ClosingTagOptional "thead" pRows
140+ optionMaybe pThead >>= \case
141+ Just (attribs, rows) ->
142+ return $ TableHead (toAttr attribs) $ map snd rows
143+ Nothing -> mkTableHead <$> optionMaybe (pHeaderRow block)
144+ where
145+ mkTableHead = TableHead nullAttr . \case
146+ -- Use row as header only if it's non-empty
147+ Just row@(Row _ (_:_)) -> [row]
148+ _ -> []
134149
135150-- | Parses a table foot
136151pTableFoot :: PandocMonad m
@@ -139,7 +154,7 @@ pTableFoot :: PandocMonad m
139154pTableFoot block = try $ do
140155 skipMany pBlank
141156 TagOpen _ attribs <- pSatisfy (matchTagOpen "tfoot" []) <* skipMany pBlank
142− rows <- mconcat <$> many (pRow block AllCells <* skipMany pBlank)
157+ rows <- many (fmap snd $ pRow block <* skipMany pBlank)
143158 optional $ pSatisfy (matchTagClose "tfoot")
144159 return $ TableFoot (toAttr attribs) rows
145160
@@ -147,12 +162,17 @@ pTableFoot block = try $ do
147162pTableBody :: PandocMonad m
148163 => TagParser m Blocks
149164 -> TagParser m TableBody
150−pTableBody block = do
165+pTableBody block = try $ do
151166 skipMany pBlank
152− (attribs, rows) <- pInTagWithAttribs TagsOmittable "tbody"
153− (mconcat <$> many1 (pRow block AllCells))
154− return $ TableBody (toAttr attribs) 0 [] rows
155−
167+ attribs <- option [] $ getAttribs <$> pSatisfy (matchTagOpen "tbody" [])
168+ <* skipMany pBlank
169+ bodyheads <- many (pHeaderRow block)
170+ (rowheads, rows) <- unzip <$> many1 (pRow block <* skipMany pBlank)
171+ optional $ pSatisfy (matchTagClose "tbody")
172+ return $ TableBody (toAttr attribs) (foldr max 0 rowheads) bodyheads rows
173+ where
174+ getAttribs (TagOpen _ attribs) = attribs
175+ getAttribs _ = []
156176
157177-- | Parses a simple HTML table
158178pTable :: PandocMonad m