41237fc · typeable/pandoc

git.iko.soy/typeable/pandoc

HTML reader: extract table parsing into separate module

commit41237fcc0ed890795f065c0a7f204fa5597defee authorAlbert Krewinkel <albert@zeitkraut.de> dateMon 23 Nov 2020, 12:32 (6 years ago) parent2f11026

4 files changed+141−95

compare with master

unifiedsplit

pandoc.cabal+1 src/Text/Pandoc/Readers/HTML.hs+3−95 src/Text/Pandoc/Readers/HTML/Parsing.hs+26 src/Text/Pandoc/Readers/HTML/Table.hs+111

pandoc.cabal+1

@@ -600,6 +600,7 @@ library

600600 Text.Pandoc.Readers.Docx.Util,

601601 Text.Pandoc.Readers.Docx.Fields,

602602 Text.Pandoc.Readers.HTML.Parsing,

603+ Text.Pandoc.Readers.HTML.Table,

603604 Text.Pandoc.Readers.HTML.TagCategories,

604605 Text.Pandoc.Readers.HTML.Types,

605606 Text.Pandoc.Readers.LaTeX.Parsing,

src/Text/Pandoc/Readers/HTML.hs+3−95

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

5050import qualified Text.Pandoc.UTF8 as UTF8

5151import Text.Pandoc.Definition

5252import Text.Pandoc.Readers.HTML.Parsing

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

5354import Text.Pandoc.Readers.HTML.TagCategories

5455import Text.Pandoc.Readers.HTML.Types

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

56−import Text.Pandoc.XML (html5Attributes, html4Attributes, rdfaAttributes)

5757import Text.Pandoc.Error

5858import Text.Pandoc.Logging

5959import Text.Pandoc.Options (

@@ -64,7 +64,7 @@ import Text.Pandoc.Options (

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

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

6666 extractSpaces, htmlSpanLikeElements, elemText, splitTextBy,

67− onlySimpleTableCells, safeRead, tshow)

67+ safeRead, tshow)

6868import Text.Pandoc.Walk

6969import Text.Parsec.Error

7070import Text.TeXMath (readMathML, writeTeX)

@@ -474,79 +474,7 @@ pHrule = do

474474 return B.horizontalRule

475475

476476pTable :: PandocMonad m => TagParser m Blocks

477−pTable = try $ do

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

479− let attribs = toAttr attribs'

480− skipMany pBlank

481− caption <- option mempty $ pInTags "caption" inline <* skipMany pBlank

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

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

484− pTr = try $ skipMany pBlank >>

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

486− pTBody = pInTag True "tbody" $ many1 pTr

487− head'' <- pInTag False "thead" (option [] pTr) <|> pInTag True "thead" pTh

488− head' <- map snd <$>

489− pInTag True "tbody"

490− (if null head'' then pTh else return head'')

491− topfoot <- option [] $ pInTag False "tfoot" $ many pTr

492− rowsLs <- many pTBody

493− bottomfoot <- option [] $ pInTag False "tfoot" $ many pTr

494− TagClose _ <- pSatisfy (matchTagClose "table")

495− let rows'' = concat rowsLs <> topfoot <> bottomfoot

496− let rows''' = map (map snd) rows''

497− -- fail on empty table

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

499− let isSimple = onlySimpleTableCells $ fmap B.toList <$> head':rows'''

500− let cols = if null head'

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

502− else length head'

503− -- add empty cells to short rows

504− let addEmpties r = case cols - length r of

505− n | n > 0 -> r <> replicate n mempty

506− | otherwise -> r

507− let rows = map addEmpties rows'''

508− let aligns = case rows'' of

509− (cs:_) -> take cols $ map fst cs ++ repeat AlignDefault

510− _ -> replicate cols AlignDefault

511− let widths = if null widths'

512− then if isSimple

513− then replicate cols ColWidthDefault

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

515− else widths'

516− let toRow = Row nullAttr . map B.simpleCell

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

518− return $ B.tableWith attribs

519− (B.simpleCaption $ B.plain caption)

520− (zip aligns widths)

521− (TableHead nullAttr $ toHeaderRow head')

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

523− (TableFoot nullAttr [])

524−

525−pCol :: PandocMonad m => TagParser m ColWidth

526−pCol = try $ do

527− TagOpen _ attribs' <- pSatisfy (matchTagOpen "col" [])

528− let attribs = toStringAttr attribs'

529− skipMany pBlank

530− optional $ pSatisfy (matchTagClose "col")

531− skipMany pBlank

532− let width = case lookup "width" attribs of

533− Nothing -> case lookup "style" attribs of

534− Just (T.stripPrefix "width:" -> Just xs) | T.any (== '%') xs ->

535− fromMaybe 0.0 $ safeRead (T.filter

536− (`notElem` (" \t\r\n%'\";" :: [Char])) xs)

537− _ -> 0.0

538− Just (T.unsnoc -> Just (xs, '%')) ->

539− fromMaybe 0.0 $ safeRead xs

540− _ -> 0.0

541− if width > 0.0

542− then return $ ColWidth $ width / 100.0

543− else return ColWidthDefault

544−

545−pColgroup :: PandocMonad m => TagParser m [ColWidth]

546−pColgroup = try $ do

547− pSatisfy (matchTagOpen "colgroup" [])

548− skipMany pBlank

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

477+pTable = pTable' inline pCell

550478

551479noColOrRowSpans :: Tag Text -> Bool

552480noColOrRowSpans t = isNullOrOne "colspan" && isNullOrOne "rowspan"

@@ -847,16 +775,6 @@ pRawHtmlInline = do

847775mathMLToTeXMath :: Text -> Either Text Text

848776mathMLToTeXMath s = writeTeX <$> readMathML s

849777

850−toStringAttr :: [(Text, Text)] -> [(Text, Text)]

851−toStringAttr = map go

852− where

853− go (x,y) =

854− case T.stripPrefix "data-" x of

855− Just x' | x' `Set.notMember` (html5Attributes <>

856− html4Attributes <> rdfaAttributes)

857− -> (x',y)

858− _ -> (x,y)

859−

860778pScriptMath :: PandocMonad m => TagParser m Inlines

861779pScriptMath = try $ do

862780 TagOpen _ attr' <- pSatisfy $ tagOpen (=="script") (const True)

@@ -1151,16 +1069,6 @@ htmlTag f = try $ do

11511069 handleTag tagname

11521070 _ -> mzero

11531071

1154−mkAttr :: [(Text, Text)] -> Attr

1155−mkAttr attr = (attribsId, attribsClasses, attribsKV)

1156− where attribsId = fromMaybe "" $ lookup "id" attr

1157− attribsClasses = T.words (fromMaybe "" $ lookup "class" attr) <> epubTypes

1158− attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr

1159− epubTypes = T.words $ fromMaybe "" $ lookup "epub:type" attr

1160−

1161−toAttr :: [(Text, Text)] -> Attr

1162−toAttr = mkAttr . toStringAttr

1163−

11641072-- Strip namespace prefixes

11651073stripPrefixes :: [Tag Text] -> [Tag Text]

11661074stripPrefixes = map stripPrefix

src/Text/Pandoc/Readers/HTML/Parsing.hs+26

@@ -21,19 +21,25 @@ module Text.Pandoc.Readers.HTML.Parsing

2121 , matchTagClose

2222 , matchTagOpen

2323 , isSpace

24+ , toAttr

25+ , toStringAttr

2426 )

2527where

2628

2729import Control.Monad (guard, void, mzero)

30+import Data.Maybe (fromMaybe)

2831import Data.Text (Text)

2932import Text.HTML.TagSoup

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

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

35+import Text.Pandoc.Definition (Attr)

3136import Text.Pandoc.Parsing

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

3338 , skipMany, setPosition, token, try)

3439import Text.Pandoc.Readers.HTML.TagCategories

3540import Text.Pandoc.Readers.HTML.Types

3641import Text.Pandoc.Shared (tshow)

42+import Text.Pandoc.XML (html5Attributes, html4Attributes, rdfaAttributes)

3743import qualified Data.Set as Set

3844import qualified Data.Text as T

3945

@@ -154,3 +160,23 @@ t1 `closes` t2 |

154160 t2 `Set.notMember` blockTags &&

155161 t2 `Set.notMember` eitherBlockOrInline = True

156162_ `closes` _ = False

163+

164+toStringAttr :: [(Text, Text)] -> [(Text, Text)]

165+toStringAttr = map go

166+ where

167+ go (x,y) =

168+ case T.stripPrefix "data-" x of

169+ Just x' | x' `Set.notMember` (html5Attributes <>

170+ html4Attributes <> rdfaAttributes)

171+ -> (x',y)

172+ _ -> (x,y)

173+

174+mkAttr :: [(Text, Text)] -> Attr

175+mkAttr attr = (attribsId, attribsClasses, attribsKV)

176+ where attribsId = fromMaybe "" $ lookup "id" attr

177+ attribsClasses = T.words (fromMaybe "" $ lookup "class" attr) <> epubTypes

178+ attribsKV = filter (\(k,_) -> k /= "class" && k /= "id") attr

179+ epubTypes = T.words $ fromMaybe "" $ lookup "epub:type" attr

180+

181+toAttr :: [(Text, Text)] -> Attr

182+toAttr = mkAttr . toStringAttr

src/Text/Pandoc/Readers/HTML/Table.hsnew file+111

@@ -0,0 +1,111 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE ViewPatterns #-}

3+{- |

4+ Module : Text.Pandoc.Readers.HTML.Table

6+ 2020 Albert Krewinkel

7+ License : GNU GPL, version 2 or above

9+ Maintainer : Albert Krewinkel <albert@zeitkraut.de>

10+ Stability : alpha

11+ Portability : portable

12+

13+HTML table parser.

14+-}

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

16+

17+import Control.Monad (guard)

18+import Data.Maybe (fromMaybe)

19+import Data.Text (Text)

20+import Text.HTML.TagSoup

21+import Text.Pandoc.Builder (Blocks, Inlines)

22+import Text.Pandoc.Definition

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

24+import Text.Pandoc.Parsing

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

26+import Text.Pandoc.Readers.HTML.Parsing

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

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

29+import qualified Data.Text as T

30+import qualified Text.Pandoc.Builder as B

31+

32+-- | Parses a @<col>@ element, returning the column's width. Defaults to

33+-- @'ColWidthDefault'@ if the width is not set or cannot be determined.

34+pCol :: PandocMonad m => TagParser m ColWidth

35+pCol = try $ do

36+ TagOpen _ attribs' <- pSatisfy (matchTagOpen "col" [])

37+ let attribs = toStringAttr attribs'

38+ skipMany pBlank

39+ optional $ pSatisfy (matchTagClose "col")

40+ skipMany pBlank

41+ let width = case lookup "width" attribs of

42+ Nothing -> case lookup "style" attribs of

43+ Just (T.stripPrefix "width:" -> Just xs) | T.any (== '%') xs ->

44+ fromMaybe 0.0 $ safeRead (T.filter

45+ (`notElem` (" \t\r\n%'\";" :: [Char])) xs)

46+ _ -> 0.0

47+ Just (T.unsnoc -> Just (xs, '%')) ->

48+ fromMaybe 0.0 $ safeRead xs

49+ _ -> 0.0

50+ if width > 0.0

51+ then return $ ColWidth $ width / 100.0

52+ else return ColWidthDefault

53+

54+pColgroup :: PandocMonad m => TagParser m [ColWidth]

55+pColgroup = try $ do

56+ pSatisfy (matchTagOpen "colgroup" [])

57+ skipMany pBlank

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

59+

60+-- | Parses a simple HTML table

61+pTable' :: PandocMonad m

62+ => TagParser m Inlines -- ^ Caption parser

63+ -> (Text -> TagParser m [(Alignment, Blocks)]) -- ^ Table cell parser

64+ -> TagParser m Blocks

65+pTable' inline pCell = try $ do

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

67+ let attribs = toAttr attribs'

68+ skipMany pBlank

69+ caption <- option mempty $ pInTags "caption" inline <* 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 True "tbody" $ many1 pTr

75+ head'' <- pInTag False "thead" (option [] pTr) <|> pInTag True "thead" pTh

76+ head' <- map snd <$>

77+ pInTag True "tbody"

78+ (if null head'' then pTh else return head'')

79+ topfoot <- option [] $ pInTag False "tfoot" $ many pTr

80+ rowsLs <- many pTBody

81+ bottomfoot <- option [] $ pInTag False "tfoot" $ many pTr

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

83+ let rows'' = concat rowsLs <> topfoot <> bottomfoot

84+ let rows''' = map (map snd) rows''

85+ -- fail on empty table

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

87+ let isSimple = onlySimpleTableCells $ fmap B.toList <$> head':rows'''

88+ let cols = if null head'

89+ then maximum (map length rows''')

90+ else length head'

91+ -- add empty cells to short rows

92+ let addEmpties r = case cols - length r of

93+ n | n > 0 -> r <> replicate n mempty

94+ | otherwise -> r

95+ let rows = map addEmpties rows'''

96+ let aligns = case rows'' of

97+ (cs:_) -> take cols $ map fst cs ++ repeat AlignDefault

98+ _ -> replicate cols AlignDefault

99+ let widths = if null widths'

100+ then if isSimple

101+ then replicate cols ColWidthDefault

102+ else replicate cols (ColWidth (1.0 / fromIntegral cols))

103+ else widths'

104+ let toRow = Row nullAttr . map B.simpleCell

105+ toHeaderRow l = [toRow l | not (null l)]

106+ return $ B.tableWith attribs

107+ (B.simpleCaption $ B.plain caption)

108+ (zip aligns widths)

109+ (TableHead nullAttr $ toHeaderRow head')

110+ [TableBody nullAttr 0 [] $ map toRow rows]

111+ (TableFoot nullAttr [])