07919e1 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

HTML reader: improve support for table headers, footer, attributes

07919e1Albert Krewinkel6 years ago

src/Text/Pandoc/CSS.hs+21−16

compare with master

unifiedsplit

@@ -11,41 +11,46 @@ Portability : portable

12Tools for working with CSS.

13-}

14−module Text.Pandoc.CSS ( pickStyleAttrProps

14+module Text.Pandoc.CSS

15+ ( cssAttributes

16+ , pickStyleAttrProps

15− , pickStylesToKVs

17+ , pickStylesToKVs

16− )

18+ )

17where

19where

19−import qualified Data.Text as T

20import Data.Maybe (mapMaybe, listToMaybe)

21import Data.Maybe (mapMaybe, listToMaybe)

22+import Data.Text (Text, pack)

21import Text.Pandoc.Shared (trim)

23import Text.Pandoc.Shared (trim)

22import Text.Parsec

24import Text.Parsec

23import Text.Parsec.Text

25import Text.Parsec.Text

25−ruleParser :: Parser (T.Text, T.Text)

27+ruleParser :: Parser (Text, Text)

26ruleParser = do

28ruleParser = do

27 p <- many1 (noneOf ":") <* char ':'

29 p <- many1 (noneOf ":") <* char ':'

28 v <- many1 (noneOf ":;") <* optional (char ';') <* spaces

30 v <- many1 (noneOf ":;") <* optional (char ';') <* spaces

29− return (trim $ T.pack p, trim $ T.pack v)

31+ return (trim $ pack p, trim $ pack v)

31−styleAttrParser :: Parser [(T.Text, T.Text)]

33+styleAttrParser :: Parser [(Text, Text)]

32styleAttrParser = many1 ruleParser

34styleAttrParser = many1 ruleParser

34−eitherToMaybe :: Either a b -> Maybe b

36+-- | Parses a style string, returning the CSS attributes.

35−eitherToMaybe (Right x) = Just x

37+-- Returns an empty list on failure.

36−eitherToMaybe _ = Nothing

38+cssAttributes :: Text -> [(Text, Text)]

39+cssAttributes styleString =

40+ -- Use Data.Either.fromRight once GHC 8.0 is no longer supported

41+ case parse styleAttrParser "" styleString of

42+ Left _ -> []

43+ Right x -> x

38-- | takes a list of keys/properties and a CSS string and

45-- | takes a list of keys/properties and a CSS string and

39-- returns the corresponding key-value-pairs.

46-- returns the corresponding key-value-pairs.

40−pickStylesToKVs :: [T.Text] -> T.Text -> [(T.Text, T.Text)]

47+pickStylesToKVs :: [Text] -> Text -> [(Text, Text)]

41pickStylesToKVs props styleAttr =

48pickStylesToKVs props styleAttr =

42− case parse styleAttrParser "" styleAttr of

43− Left _ -> []

44− Right styles -> filter (\s -> fst s `elem` props) styles

49+ filter (\s -> fst s `elem` props) $ cssAttributes styleAttr

46-- | takes a list of key/property synonyms and a CSS string and maybe

51-- | takes a list of key/property synonyms and a CSS string and maybe

47-- returns the value of the first match (in order of the supplied list)

52-- returns the value of the first match (in order of the supplied list)

48−pickStyleAttrProps :: [T.Text] -> T.Text -> Maybe T.Text

53+pickStyleAttrProps :: [Text] -> Text -> Maybe Text

49pickStyleAttrProps lookupProps styleAttr = do

54pickStyleAttrProps lookupProps styleAttr = do

50− styles <- eitherToMaybe $ parse styleAttrParser "" styleAttr

55+ styles <- either (const Nothing) Just $ parse styleAttrParser "" styleAttr

51 listToMaybe $ mapMaybe (`lookup` styles) lookupProps

56 listToMaybe $ mapMaybe (`lookup` styles) lookupProps

src/Text/Pandoc/Readers/HTML.hs+4−36

@@ -26,7 +26,7 @@ module Text.Pandoc.Readers.HTML ( readHtml

27import Control.Applicative ((<|>))

28import Control.Arrow (first)

29−import Control.Monad (guard, mplus, msum, mzero, unless, void)

29+import Control.Monad (guard, msum, mzero, unless, void)

30import Control.Monad.Except (throwError)

31import Control.Monad.Reader (ask, asks, lift, local, runReaderT)

32import Data.ByteString.Base64 (encode)

@@ -50,7 +50,7 @@ import Text.Pandoc.CSS (pickStyleAttrProps)

50import qualified Text.Pandoc.UTF8 as UTF8

51import Text.Pandoc.Definition

52import Text.Pandoc.Readers.HTML.Parsing

53−import Text.Pandoc.Readers.HTML.Table (pTable')

53+import Text.Pandoc.Readers.HTML.Table (pTable)

54import Text.Pandoc.Readers.HTML.TagCategories

55import Text.Pandoc.Readers.HTML.Types

56import Text.Pandoc.Readers.LaTeX (rawLaTeXInline)

@@ -63,8 +63,7 @@ import Text.Pandoc.Options (

63 extensionEnabled)

64import Text.Pandoc.Parsing hiding ((<|>))

65import Text.Pandoc.Shared (addMetaField, blocksToInlines', crFilter, escapeURI,

66− extractSpaces, htmlSpanLikeElements, elemText, splitTextBy,

66+ extractSpaces, htmlSpanLikeElements, safeRead, tshow)

67− safeRead, tshow)

68import Text.Pandoc.Walk

67import Text.Pandoc.Walk

69import Text.Parsec.Error

68import Text.Parsec.Error

70import Text.TeXMath (readMathML, writeTeX)

69import Text.TeXMath (readMathML, writeTeX)

@@ -159,7 +158,7 @@ block = do

159 , pCodeBlock

158 , pCodeBlock

160 , pList

159 , pList

161 , pHrule

160 , pHrule

162− , pTable

161+ , pTable block

163 , pHtml

162 , pHtml

164 , pHead

163 , pHead

165 , pBody

164 , pBody

@@ -464,31 +463,6 @@ pHrule = do

464 pSelfClosing (=="hr") (const True)

463 pSelfClosing (=="hr") (const True)

465 return B.horizontalRule

464 return B.horizontalRule

466

465

467−pTable :: PandocMonad m => TagParser m Blocks

468−pTable = pTable' block pCell

469−

470−pCell :: PandocMonad m => Text -> TagParser m [Cell]

471−pCell celltype = try $ do

472− skipMany pBlank

473− tag <- lookAhead $ pSatisfy (\t -> t ~== TagOpen celltype [])

474− let extractAlign' [] = ""

475− extractAlign' ("text-align":x:_) = x

476− extractAlign' (_:xs) = extractAlign' xs

477− let extractAlign = extractAlign' . splitTextBy (`elemText` " \t;:")

478− let align = case maybeFromAttrib "align" tag `mplus`

479− (extractAlign <$> maybeFromAttrib "style" tag) of

480− Just "left" -> AlignLeft

481− Just "right" -> AlignRight

482− Just "center" -> AlignCenter

483− _ -> AlignDefault

484− let rowspan = RowSpan . fromMaybe 1 $

485− safeRead =<< maybeFromAttrib "rowspan" tag

486− let colspan = ColSpan . fromMaybe 1 $

487− safeRead =<< maybeFromAttrib "colspan" tag

488− res <- pInTags celltype block

489− skipMany pBlank

490− return [B.cell align rowspan colspan res]

491−

492pBlockQuote :: PandocMonad m => TagParser m Blocks

466pBlockQuote :: PandocMonad m => TagParser m Blocks

493pBlockQuote = do

467pBlockQuote = do

494 contents <- pInTags "blockquote" block

468 contents <- pInTags "blockquote" block

@@ -653,12 +627,6 @@ pLineBreak = do

653 pSelfClosing (=="br") (const True)

627 pSelfClosing (=="br") (const True)

654 return B.linebreak

628 return B.linebreak

655

629

656−-- Unlike fromAttrib from tagsoup, this distinguishes

657−-- between a missing attribute and an attribute with empty content.

658−maybeFromAttrib :: Text -> Tag Text -> Maybe Text

659−maybeFromAttrib name (TagOpen _ attrs) = lookup name attrs

660−maybeFromAttrib _ _ = Nothing

661−

662pLink :: PandocMonad m => TagParser m Inlines

630pLink :: PandocMonad m => TagParser m Inlines

663pLink = try $ do

631pLink = try $ do

664 tag <- pSatisfy $ tagOpenLit "a" (const True)

632 tag <- pSatisfy $ tagOpenLit "a" (const True)

src/Text/Pandoc/Readers/HTML/Parsing.hs+36−11

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{- |

3{- |

3 Module : Text.Pandoc.Readers.HTML.Parsing

4 Module : Text.Pandoc.Readers.HTML.Parsing

@@ -15,6 +16,7 @@ module Text.Pandoc.Readers.HTML.Parsing

15 , pInTags

16 , pInTags

16 , pInTags'

17 , pInTags'

17 , pInTag

18 , pInTag

19+ , pInTagWithAttribs

18 , pAny

20 , pAny

19 , pCloses

21 , pCloses

20 , pSatisfy

22 , pSatisfy

@@ -22,6 +24,7 @@ module Text.Pandoc.Readers.HTML.Parsing

22 , matchTagClose

24 , matchTagClose

23 , matchTagOpen

25 , matchTagOpen

24 , isSpace

26 , isSpace

27+ , maybeFromAttrib

25 , toAttr

28 , toAttr

26 , toStringAttr

29 , toStringAttr

27 )

30 )

@@ -31,11 +34,11 @@ import Control.Monad (guard, void, mzero)

31import Data.Maybe (fromMaybe)

34import Data.Maybe (fromMaybe)

32import Data.Text (Text)

35import Data.Text (Text)

33import Text.HTML.TagSoup

36import Text.HTML.TagSoup

34− ( Tag (..), (~==), isTagText, isTagPosition, isTagOpen, isTagClose )

37+ ( Attribute, Tag (..), isTagText, isTagPosition, isTagOpen, isTagClose, (~==) )

35import Text.Pandoc.Class.PandocMonad (PandocMonad (..))

38import Text.Pandoc.Class.PandocMonad (PandocMonad (..))

36import Text.Pandoc.Definition (Attr)

39import Text.Pandoc.Definition (Attr)

37import Text.Pandoc.Parsing

40import Text.Pandoc.Parsing

38− ( (<|>), eof, getPosition, lookAhead, manyTill, newPos, optional

41+ ( (<|>), eof, getPosition, lookAhead, manyTill, newPos, option, optional

39 , skipMany, setPosition, token, try)

42 , skipMany, setPosition, token, try)

40import Text.Pandoc.Readers.HTML.TagCategories

43import Text.Pandoc.Readers.HTML.TagCategories

41import Text.Pandoc.Readers.HTML.Types

44import Text.Pandoc.Readers.HTML.Types

@@ -60,25 +63,41 @@ pInTags' :: (PandocMonad m, Monoid a)

60 -> TagParser m a

63 -> TagParser m a

61 -> TagParser m a

64 -> TagParser m a

62pInTags' tagtype tagtest parser = try $ do

65pInTags' tagtype tagtest parser = try $ do

63− pSatisfy (\t -> t ~== TagOpen tagtype [] && tagtest t)

66+ pSatisfy $ \t -> matchTagOpen tagtype [] t && tagtest t

64 mconcat <$> manyTill parser (pCloses tagtype <|> eof)

67 mconcat <$> manyTill parser (pCloses tagtype <|> eof)

69+pInTag :: PandocMonad m

70+ => TagOmission -- ^ Whether some tags can be omitted

71+ -> Text -- ^ @tagtype@ Tag name

72+ -> TagParser m a -- ^ @p@ Content parser

73+ -> TagParser m a

74+pInTag tagOmission tagtype = fmap snd . pInTagWithAttribs tagOmission tagtype

75+

76+-- | Returns the contents of a tag together with its attributes; parses

66−-- parses p, preceded by an opening tag (optional if tagsOptional)

77+-- @p@, preceded by an opening tag (optional if TagsOmittable) and

67−-- and followed by a closing tag (optional if tagsOptional)

78+-- followed by a closing tag (optional unless TagsRequired).

68−pInTag :: PandocMonad m => TagOmission -> Text -> TagParser m a -> TagParser m a

79+pInTagWithAttribs :: PandocMonad m

80+ => TagOmission -- ^ Whether some tags can be omitted

81+ -> Text -- ^ @tagtype@ Tag name

82+ -> TagParser m a -- ^ @p@ Content parser

83+ -> TagParser m ([Attribute Text], a)

69−pInTag tagOmission tagtype p = try $ do

84+pInTagWithAttribs tagOmission tagtype p = try $ do

70− skipMany pBlank

71 let openingOptional = tagOmission == TagsOmittable

85 let openingOptional = tagOmission == TagsOmittable

72 let closingOptional = tagOmission /= TagsRequired

86 let closingOptional = tagOmission /= TagsRequired

87+ skipMany pBlank

73− (if openingOptional then optional else void) $

88+ attribs <- (if openingOptional then option [] else id)

74− pSatisfy (matchTagOpen tagtype [])

89+ (getAttribs <$> pSatisfy (matchTagOpen tagtype []))

75 skipMany pBlank

90 skipMany pBlank

76 x <- p

91 x <- p

77 skipMany pBlank

92 skipMany pBlank

78 (if closingOptional then optional else void) $

93 (if closingOptional then optional else void) $

79 pSatisfy (matchTagClose tagtype)

94 pSatisfy (matchTagClose tagtype)

80 skipMany pBlank

95 skipMany pBlank

81− return x

96+ return (attribs, x)

97+ where

98+ getAttribs = \case

99+ TagOpen _ attribs -> attribs

100+ _ -> []

101

83pCloses :: PandocMonad m => Text -> TagParser m ()

102pCloses :: PandocMonad m => Text -> TagParser m ()

84pCloses tagtype = try $ do

103pCloses tagtype = try $ do

@@ -183,6 +202,12 @@ toStringAttr = map go

183 -> (x',y)

202 -> (x',y)

184 _ -> (x,y)

203 _ -> (x,y)

185

204

205+-- Unlike fromAttrib from tagsoup, this distinguishes

206+-- between a missing attribute and an attribute with empty content.

207+maybeFromAttrib :: Text -> Tag Text -> Maybe Text

208+maybeFromAttrib name (TagOpen _ attrs) = lookup name attrs

209+maybeFromAttrib _ _ = Nothing

210+

186mkAttr :: [(Text, Text)] -> Attr

211mkAttr :: [(Text, Text)] -> Attr

187mkAttr attr = (attribsId, attribsClasses, attribsKV)

212mkAttr attr = (attribsId, attribsClasses, attribsKV)

188 where attribsId = fromMaybe "" $ lookup "id" attr

213 where attribsId = fromMaybe "" $ lookup "id" attr

src/Text/Pandoc/Readers/HTML/Table.hs+183−55

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE ViewPatterns #-}

3{-# LANGUAGE ViewPatterns #-}

3{- |

4{- |

@@ -12,17 +13,19 @@

13HTML table parser.

14HTML table parser.

14-}

15-}

15−module Text.Pandoc.Readers.HTML.Table (pTable') where

16+module Text.Pandoc.Readers.HTML.Table (pTable) where

17−import Control.Monad (guard)

18+import Control.Applicative ((<|>))

18import Data.Maybe (fromMaybe)

19import Data.Maybe (fromMaybe)

19import Data.Text (Text)

20import Data.Text (Text)

20import Text.HTML.TagSoup

21import Text.HTML.TagSoup

21import Text.Pandoc.Builder (Blocks)

22import Text.Pandoc.Builder (Blocks)

23+import Text.Pandoc.CSS (cssAttributes)

22import Text.Pandoc.Definition

24import Text.Pandoc.Definition

23import Text.Pandoc.Class.PandocMonad (PandocMonad (..))

25import Text.Pandoc.Class.PandocMonad (PandocMonad (..))

24import Text.Pandoc.Parsing

26import Text.Pandoc.Parsing

25− ( (<|>), eof, many, many1, manyTill, option, optional, skipMany, try)

27+ ( eof, lookAhead, many, many1, manyTill, option, optional

28+ , optionMaybe, skipMany, try)

26import Text.Pandoc.Readers.HTML.Parsing

29import Text.Pandoc.Readers.HTML.Parsing

27import Text.Pandoc.Readers.HTML.Types (TagParser)

30import Text.Pandoc.Readers.HTML.Types (TagParser)

28import Text.Pandoc.Shared (onlySimpleTableCells, safeRead)

31import Text.Pandoc.Shared (onlySimpleTableCells, safeRead)

@@ -57,58 +60,183 @@ pColgroup = try $ do

57 skipMany pBlank

60 skipMany pBlank

58 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank

61 manyTill pCol (pCloses "colgroup" <|> eof) <* skipMany pBlank

60−-- | Parses a simple HTML table

61−pTable' :: PandocMonad m

63+pCell :: PandocMonad m

62− => TagParser m Blocks -- ^ Caption parser

64+ => TagParser m Blocks

65+ -> Text

63− -> (Text -> TagParser m [Cell]) -- ^ Table cell parser

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

64− -> TagParser m Blocks

138+ -> TagParser m TableFoot

65−pTable' block pCell = try $ do

139+pTableFoot block = try $ do

140+ skipMany pBlank

66− TagOpen _ attribs' <- pSatisfy (matchTagOpen "table" [])

141+ TagOpen _ attribs <- pSatisfy (matchTagOpen "tfoot" []) <* skipMany pBlank

142+ rows <- mconcat <$> many (pRow block AllCells <* skipMany pBlank)

143+ optional $ pSatisfy (matchTagClose "tfoot")

67− let attribs = toAttr attribs'

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

68 skipMany pBlank

151 skipMany pBlank

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

69− caption <- option mempty $ pInTags "caption" block <* skipMany pBlank

163+ caption <- option mempty $ pInTags "caption" block <* skipMany pBlank

70− widths' <- (mconcat <$> many1 pColgroup) <|> many pCol

164+ widths <- ((mconcat <$> many1 pColgroup) <|> many pCol) <* skipMany pBlank

71− let pTh = option [] $ pInTags "tr" (pCell "th")

165+ thead <- pTableHead block <* skipMany pBlank

72− pTr = try $ skipMany pBlank

166+ topfoot <- optionMaybe (pTableFoot block) <* skipMany pBlank

73− *> pInTags "tr" (pCell "td" <|> pCell "th")

167+ tbodies <- many (pTableBody block) <* skipMany pBlank

74− pTBody = pInTag TagsOmittable "tbody" $ many1 pTr

168+ botfoot <- optionMaybe (pTableFoot block) <* skipMany pBlank

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

82 TagClose _ <- pSatisfy (matchTagClose "table")

169 TagClose _ <- pSatisfy (matchTagClose "table")

83− let rows = concat rowsLs <> topfoot <> bottomfoot

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 =

84− rows''' = map (map cellContents) rows

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)

85 -- fail on empty table

200 -- fail on empty table

86− guard $ not $ null head' && null rows'''

201+ if null rows

87− let isSimple = onlySimpleTableCells $

202+ then Left "empty table"

88− map cellContents head' : rows'''

203+ else Right

89− let cols = if null head'

204+ ( zip (calculateAlignments ncols bodies)

90− then maximum (map length rows''')

205+ (normalizeColWidths ncols tblType widths)

91− else length head'

206+ , head'

92− let aligns = case rows of

207+ , bodies

93− (cs:_) -> take cols $

208+ , foot

94− concatMap cellAligns cs ++ repeat AlignDefault

209+ )

95− _ -> replicate cols AlignDefault

210+

96− let widths = if null widths'

211+normalizeColWidths :: Int -> TableType -> [ColWidth] -> [ColWidth]

97− then if isSimple

212+normalizeColWidths ncols tblType = \case

213+ [] -> case tblType of

98− then replicate cols ColWidthDefault

214+ SimpleTable -> replicate ncols ColWidthDefault

99− else replicate cols (ColWidth (1.0 / fromIntegral cols))

215+ NormalTable -> replicate ncols (ColWidth $ 1 / fromIntegral ncols)

100− else widths'

216+ widths -> widths

101− let toRow = Row nullAttr

217+

102− toHeaderRow l = [toRow l | not (null l)]

218+calculateAlignments :: Int -> [TableBody] -> [Alignment]

103− return $ B.tableWith attribs

219+calculateAlignments cols tbodies =

104− (B.simpleCaption caption)

220+ case cells of

105− (zip aligns widths)

221+ cs:_ -> take cols $ concatMap cellAligns cs ++ repeat AlignDefault

106− (TableHead nullAttr $ toHeaderRow head')

222+ _ -> replicate cols AlignDefault

107− [TableBody nullAttr 0 [] $ map toRow rows]

223+ where

108− (TableFoot nullAttr [])

224+ cells :: [[Cell]]

109−

225+ cells = concatMap bodyRowCells tbodies

110−cellContents :: Cell -> [Block]

111−cellContents (Cell _ _ _ _ bs) = bs

112−

113−cellAligns :: Cell -> [Alignment]

226+ cellAligns :: Cell -> [Alignment]

114−cellAligns (Cell _ align _ (ColSpan cs) _) = replicate cs align

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

test/html-reader.native+24−22

@@ -448,16 +448,15 @@ Pandoc (Meta {unMeta = fromList [("generator",MetaInlines [Str "pandoc"]),("titl

448 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

449 [Plain [Str "2"]]

450 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

451− [Plain [Str "3"]]]

451+ [Plain [Str "3"]]]])]

452− ,Row ("",[],[])

453− [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

454− [Plain [Str "4"]]

455− ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

456− [Plain [Str "5"]]

457− ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

458− [Plain [Str "6"]]]])]

459 (TableFoot ("",[],[])

452 (TableFoot ("",[],[])

460− [])

453+ [Row ("",[],[])

454+ [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

455+ [Plain [Str "4"]]

456+ ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

457+ [Plain [Str "5"]]

458+ ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

459+ [Plain [Str "6"]]]])

461,HorizontalRule

460,HorizontalRule

462,Table ("",[],[]) (Caption Nothing

461,Table ("",[],[]) (Caption Nothing

463 [])

462 [])

@@ -576,8 +575,10 @@ Pandoc (Meta {unMeta = fromList [("generator",MetaInlines [Str "pandoc"]),("titl

576 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

575 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

577 [Plain [Str "2"]]

576 [Plain [Str "2"]]

578 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

577 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

579− [Plain [Str "3"]]]

578+ [Plain [Str "3"]]]])

579+ ,(TableBody ("",[],[]) (RowHeadColumns 0)

580+ []

580− ,Row ("",[],[])

581+ [Row ("",[],[])

581 [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

582 [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

582 [Plain [Str "4"]]

583 [Plain [Str "4"]]

583 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

584 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

@@ -608,8 +609,10 @@ Pandoc (Meta {unMeta = fromList [("generator",MetaInlines [Str "pandoc"]),("titl

608 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

609 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

609 [Para [Str "2"]]

610 [Para [Str "2"]]

610 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

611 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

611− [Plain [Str "3"]]]

612+ [Plain [Str "3"]]]])

613+ ,(TableBody ("",[],[]) (RowHeadColumns 0)

614+ []

612− ,Row ("",[],[])

615+ [Row ("",[],[])

613 [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

616 [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

614 [Plain [Str "4"]]

617 [Plain [Str "4"]]

615 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

618 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

@@ -712,15 +715,14 @@ Pandoc (Meta {unMeta = fromList [("generator",MetaInlines [Str "pandoc"]),("titl

712 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

715 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

713 [Plain [Str "2"]]

716 [Plain [Str "2"]]

714 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

717 ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

715− [Plain [Str "3"]]]

718+ [Plain [Str "3"]]]])]

716− ,Row ("",[],[])

717− [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

718− [Plain [Str "4"]]

719− ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

720− [Plain [Str "5"]]

721− ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

722− [Plain [Str "6"]]]])]

723 (TableFoot ("",[],[])

719 (TableFoot ("",[],[])

724− [])

720+ [Row ("",[],[])

721+ [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

722+ [Plain [Str "4"]]

723+ ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

724+ [Plain [Str "5"]]

725+ ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)

726+ [Plain [Str "6"]]]])

725,Header 2 ("empty-tables",[],[]) [Str "Empty",Space,Str "Tables"]

727,Header 2 ("empty-tables",[],[]) [Str "Empty",Space,Str "Tables"]

726,Para [Str "This",Space,Str "section",Space,Str "should",Space,Str "be",Space,Str "empty."]]

728,Para [Str "This",Space,Str "section",Space,Str "should",Space,Str "be",Space,Str "empty."]]