{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Readers.HTML.Table
   Copyright   : © 2006-2021 John MacFarlane,
                   2020-2021 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <albert@zeitkraut.de>
   Stability   : alpha
   Portability : portable

HTML table parser.
-}
module Text.Pandoc.Readers.HTML.Table (pTable) where

import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Text.HTML.TagSoup
import Text.Pandoc.Builder (Blocks)
import Text.Pandoc.CSS (cssAttributes)
import Text.Pandoc.Definition
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.Parsing
  ( eof, lookAhead, many, many1, manyTill, option, optional
  , optionMaybe, skipMany, try)
import Text.Pandoc.Readers.HTML.Parsing
import Text.Pandoc.Readers.HTML.Types (TagParser)
import Text.Pandoc.Shared (onlySimpleTableCells, safeRead)
import qualified Data.Text as T
import qualified Text.Pandoc.Builder as B

-- | Parses a @<col>@ element, returning the column's width. Defaults to
-- @'ColWidthDefault'@ if the width is not set or cannot be determined.
pCol :: PandocMonad m => TagParser m ColWidth
pCol :: TagParser m ColWidth
pCol = TagParser m ColWidth -> TagParser m ColWidth
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m ColWidth -> TagParser m ColWidth)
-> TagParser m ColWidth -> TagParser m ColWidth
forall a b. (a -> b) -> a -> b
$ do
  TagOpen Text
_ [Attribute Text]
attribs' <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"col" [])
  let attribs :: [Attribute Text]
attribs = [Attribute Text] -> [Attribute Text]
toStringAttr [Attribute Text]
attribs'
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (TagParser m (Tag Text)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ())
-> TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall a b. (a -> b) -> a -> b
$ (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> Tag Text -> Bool
matchTagClose Text
"col")
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  let width :: Double
width = case Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"width" [Attribute Text]
attribs of
                Maybe Text
Nothing -> case Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"style" [Attribute Text]
attribs of
                  Just (Text -> Text -> Maybe Text
T.stripPrefix Text
"width:" -> Just Text
xs) | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%') Text
xs ->
                    Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0.0 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Double
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead ((Char -> Bool) -> Text -> Text
T.filter
                      (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
" \t\r\n%'\";" :: [Char])) Text
xs)
                  Maybe Text
_ -> Double
0.0
                Just (Text -> Maybe (Text, Char)
T.unsnoc -> Just (Text
xs, Char
'%')) ->
                  Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0.0 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Double
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead Text
xs
                Maybe Text
_ -> Double
0.0
  if Double
width Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0.0
    then ColWidth -> TagParser m ColWidth
forall (m :: * -> *) a. Monad m => a -> m a
return (ColWidth -> TagParser m ColWidth)
-> ColWidth -> TagParser m ColWidth
forall a b. (a -> b) -> a -> b
$ Double -> ColWidth
ColWidth (Double -> ColWidth) -> Double -> ColWidth
forall a b. (a -> b) -> a -> b
$ Double
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100.0
    else ColWidth -> TagParser m ColWidth
forall (m :: * -> *) a. Monad m => a -> m a
return ColWidth
ColWidthDefault

pColgroup :: PandocMonad m => TagParser m [ColWidth]
pColgroup :: TagParser m [ColWidth]
pColgroup = TagParser m [ColWidth] -> TagParser m [ColWidth]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m [ColWidth] -> TagParser m [ColWidth])
-> TagParser m [ColWidth] -> TagParser m [ColWidth]
forall a b. (a -> b) -> a -> b
$ do
  (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"colgroup" [])
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ColWidth
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m [ColWidth]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ColWidth
forall (m :: * -> *). PandocMonad m => TagParser m ColWidth
pCol (Text -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => Text -> TagParser m ()
pCloses Text
"colgroup" ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) TagParser m [ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m [ColWidth]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank

data CellType
  = HeaderCell
  | BodyCell
  deriving CellType -> CellType -> Bool
(CellType -> CellType -> Bool)
-> (CellType -> CellType -> Bool) -> Eq CellType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CellType -> CellType -> Bool
$c/= :: CellType -> CellType -> Bool
== :: CellType -> CellType -> Bool
$c== :: CellType -> CellType -> Bool
Eq

pCell :: PandocMonad m
      => TagParser m Blocks
      -> CellType
      -> TagParser m (CellType, Cell)
pCell :: TagParser m Blocks -> CellType -> TagParser m (CellType, Cell)
pCell TagParser m Blocks
block CellType
celltype = TagParser m (CellType, Cell) -> TagParser m (CellType, Cell)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m (CellType, Cell) -> TagParser m (CellType, Cell))
-> TagParser m (CellType, Cell) -> TagParser m (CellType, Cell)
forall a b. (a -> b) -> a -> b
$ do
  let celltype' :: Text
celltype' = case CellType
celltype of
        CellType
HeaderCell -> Text
"th"
        CellType
BodyCell   -> Text
"td"
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TagOpen Text
_ [Attribute Text]
attribs <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text))
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
forall a b. (a -> b) -> a -> b
$ (Tag Text -> Bool)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
celltype' [])
  let cssAttribs :: [Attribute Text]
cssAttribs = [Attribute Text]
-> (Text -> [Attribute Text]) -> Maybe Text -> [Attribute Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Attribute Text]
cssAttributes (Maybe Text -> [Attribute Text]) -> Maybe Text -> [Attribute Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"style" [Attribute Text]
attribs
  let align :: Alignment
align = case Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"align" [Attribute Text]
attribs Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                   Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"text-align" [Attribute Text]
cssAttribs of
                Just Text
"left"   -> Alignment
AlignLeft
                Just Text
"right"  -> Alignment
AlignRight
                Just Text
"center" -> Alignment
AlignCenter
                Maybe Text
_             -> Alignment
AlignDefault
  let rowspan :: RowSpan
rowspan = Int -> RowSpan
RowSpan (Int -> RowSpan) -> (Maybe Int -> Int) -> Maybe Int -> RowSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> RowSpan) -> Maybe Int -> RowSpan
forall a b. (a -> b) -> a -> b
$
                Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Int) -> Maybe Text -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"rowspan" [Attribute Text]
attribs
  let colspan :: ColSpan
colspan = Int -> ColSpan
ColSpan (Int -> ColSpan) -> (Maybe Int -> Int) -> Maybe Int -> ColSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 (Maybe Int -> ColSpan) -> Maybe Int -> ColSpan
forall a b. (a -> b) -> a -> b
$
                Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe Int) -> Maybe Text -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [Attribute Text] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"colspan" [Attribute Text]
attribs
  Blocks
res <- Text -> TagParser m Blocks -> TagParser m Blocks
forall (m :: * -> *) a.
(PandocMonad m, Monoid a) =>
Text -> TagParser m a -> TagParser m a
pInTags Text
celltype' TagParser m Blocks
block
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  let handledAttribs :: [Text]
handledAttribs = [Text
"align", Text
"colspan", Text
"rowspan", Text
"text-align"]
      attribs' :: [Attribute Text]
attribs' = (Attribute Text -> [Attribute Text] -> [Attribute Text])
-> [Attribute Text] -> [Attribute Text] -> [Attribute Text]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Attribute Text -> [Attribute Text] -> [Attribute Text]
go [] [Attribute Text]
attribs
      go :: Attribute Text -> [Attribute Text] -> [Attribute Text]
go kv :: Attribute Text
kv@(Text
k, Text
_) [Attribute Text]
acc = case Text
k of
        Text
"style" -> case (Attribute Text -> Bool) -> [Attribute Text] -> [Attribute Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"text-align") (Text -> Bool)
-> (Attribute Text -> Text) -> Attribute Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute Text -> Text
forall a b. (a, b) -> a
fst) [Attribute Text]
cssAttribs of
                     [] -> [Attribute Text]
acc
                     [Attribute Text]
cs -> (Text
"style", [Attribute Text] -> Text
toStyleString [Attribute Text]
cs) Attribute Text -> [Attribute Text] -> [Attribute Text]
forall a. a -> [a] -> [a]
: [Attribute Text]
acc
        -- drop attrib if it's already handled
        Text
_ | Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
handledAttribs -> [Attribute Text]
acc
        Text
_ -> Attribute Text
kv Attribute Text -> [Attribute Text] -> [Attribute Text]
forall a. a -> [a] -> [a]
: [Attribute Text]
acc
  (CellType, Cell) -> TagParser m (CellType, Cell)
forall (m :: * -> *) a. Monad m => a -> m a
return (CellType
celltype, Attr -> Alignment -> RowSpan -> ColSpan -> Blocks -> Cell
B.cellWith ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs') Alignment
align RowSpan
rowspan ColSpan
colspan Blocks
res)

-- | Create a style attribute string from a list of CSS attributes
toStyleString :: [(Text, Text)] -> Text
toStyleString :: [Attribute Text] -> Text
toStyleString = Text -> [Text] -> Text
T.intercalate Text
"; " ([Text] -> Text)
-> ([Attribute Text] -> [Text]) -> [Attribute Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute Text -> Text) -> [Attribute Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Text
v) -> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v)

-- | Parses a normal table row; returns the row together with the number
-- of header cells at the beginning of the row.
pRow :: PandocMonad m
     => TagParser m Blocks
     -> TagParser m (RowHeadColumns, B.Row)
pRow :: TagParser m Blocks -> TagParser m (RowHeadColumns, Row)
pRow TagParser m Blocks
block = TagParser m (RowHeadColumns, Row)
-> TagParser m (RowHeadColumns, Row)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m (RowHeadColumns, Row)
 -> TagParser m (RowHeadColumns, Row))
-> TagParser m (RowHeadColumns, Row)
-> TagParser m (RowHeadColumns, Row)
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TagOpen Text
_ [Attribute Text]
attribs <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"tr" []) TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m (Tag Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [(CellType, Cell)]
cells <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(CellType, Cell)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (TagParser m Blocks
-> CellType
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> CellType -> TagParser m (CellType, Cell)
pCell TagParser m Blocks
block CellType
BodyCell ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TagParser m Blocks
-> CellType
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> CellType -> TagParser m (CellType, Cell)
pCell TagParser m Blocks
block CellType
HeaderCell)
  TagClose Text
_ <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> Tag Text -> Bool
matchTagClose Text
"tr")
  (RowHeadColumns, Row) -> TagParser m (RowHeadColumns, Row)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Int -> RowHeadColumns
RowHeadColumns (Int -> RowHeadColumns) -> Int -> RowHeadColumns
forall a b. (a -> b) -> a -> b
$ [(CellType, Cell)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((CellType, Cell) -> Bool)
-> [(CellType, Cell)] -> [(CellType, Cell)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((CellType -> CellType -> Bool
forall a. Eq a => a -> a -> Bool
== CellType
HeaderCell) (CellType -> Bool)
-> ((CellType, Cell) -> CellType) -> (CellType, Cell) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CellType, Cell) -> CellType
forall a b. (a, b) -> a
fst) [(CellType, Cell)]
cells)
         , Attr -> [Cell] -> Row
Row ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs) ([Cell] -> Row) -> [Cell] -> Row
forall a b. (a -> b) -> a -> b
$ ((CellType, Cell) -> Cell) -> [(CellType, Cell)] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
map (CellType, Cell) -> Cell
forall a b. (a, b) -> b
snd [(CellType, Cell)]
cells
         )

-- | Parses a header row, i.e., a row which containing nothing but
-- @<th>@ elements.
pHeaderRow :: PandocMonad m
           => TagParser m Blocks
           -> TagParser m B.Row
pHeaderRow :: TagParser m Blocks -> TagParser m Row
pHeaderRow TagParser m Blocks
block = TagParser m Row -> TagParser m Row
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m Row -> TagParser m Row)
-> TagParser m Row -> TagParser m Row
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  let pThs :: ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Cell]
pThs = ((CellType, Cell) -> Cell) -> [(CellType, Cell)] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
map (CellType, Cell) -> Cell
forall a b. (a, b) -> b
snd ([(CellType, Cell)] -> [Cell])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(CellType, Cell)]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Cell]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(CellType, Cell)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (TagParser m Blocks
-> CellType
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> CellType -> TagParser m (CellType, Cell)
pCell TagParser m Blocks
block CellType
HeaderCell)
  let mkRow :: ([Attribute Text], [Cell]) -> Row
mkRow ([Attribute Text]
attribs, [Cell]
cells) = Attr -> [Cell] -> Row
Row ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs) [Cell]
cells
  ([Attribute Text], [Cell]) -> Row
mkRow (([Attribute Text], [Cell]) -> Row)
-> ParsecT
     [Tag Text]
     HTMLState
     (ReaderT HTMLLocal m)
     ([Attribute Text], [Cell])
-> TagParser m Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TagOmission
-> Text
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Cell]
-> ParsecT
     [Tag Text]
     HTMLState
     (ReaderT HTMLLocal m)
     ([Attribute Text], [Cell])
forall (m :: * -> *) a.
PandocMonad m =>
TagOmission
-> Text -> TagParser m a -> TagParser m ([Attribute Text], a)
pInTagWithAttribs TagOmission
TagsRequired Text
"tr" ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Cell]
pThs

-- | Parses a table head. If there is no @thead@ element, this looks for
-- a row of @<th>@-only elements as the first line of the table.
pTableHead :: PandocMonad m
           => TagParser m Blocks
           -> TagParser m TableHead
pTableHead :: TagParser m Blocks -> TagParser m TableHead
pTableHead TagParser m Blocks
block = TagParser m TableHead -> TagParser m TableHead
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m TableHead -> TagParser m TableHead)
-> TagParser m TableHead -> TagParser m TableHead
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  let pRows :: ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
pRows = ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (TagParser m Blocks
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (RowHeadColumns, Row)
pRow TagParser m Blocks
block)
  let pThead :: TagParser m ([Attribute Text], [(RowHeadColumns, Row)])
pThead = TagOmission
-> Text
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
-> TagParser m ([Attribute Text], [(RowHeadColumns, Row)])
forall (m :: * -> *) a.
PandocMonad m =>
TagOmission
-> Text -> TagParser m a -> TagParser m ([Attribute Text], a)
pInTagWithAttribs TagOmission
ClosingTagOptional Text
"thead" ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
pRows
  TagParser m ([Attribute Text], [(RowHeadColumns, Row)])
-> ParsecT
     [Tag Text]
     HTMLState
     (ReaderT HTMLLocal m)
     (Maybe ([Attribute Text], [(RowHeadColumns, Row)]))
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe TagParser m ([Attribute Text], [(RowHeadColumns, Row)])
pThead ParsecT
  [Tag Text]
  HTMLState
  (ReaderT HTMLLocal m)
  (Maybe ([Attribute Text], [(RowHeadColumns, Row)]))
-> (Maybe ([Attribute Text], [(RowHeadColumns, Row)])
    -> TagParser m TableHead)
-> TagParser m TableHead
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ([Attribute Text]
attribs, [(RowHeadColumns, Row)]
rows) ->
      TableHead -> TagParser m TableHead
forall (m :: * -> *) a. Monad m => a -> m a
return (TableHead -> TagParser m TableHead)
-> TableHead -> TagParser m TableHead
forall a b. (a -> b) -> a -> b
$ Attr -> [Row] -> TableHead
TableHead ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs) ([Row] -> TableHead) -> [Row] -> TableHead
forall a b. (a -> b) -> a -> b
$ ((RowHeadColumns, Row) -> Row) -> [(RowHeadColumns, Row)] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
map (RowHeadColumns, Row) -> Row
forall a b. (a, b) -> b
snd [(RowHeadColumns, Row)]
rows
    Maybe ([Attribute Text], [(RowHeadColumns, Row)])
Nothing -> Maybe Row -> TableHead
mkTableHead (Maybe Row -> TableHead)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe Row)
-> TagParser m TableHead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe Row)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m Row
pHeaderRow TagParser m Blocks
block)
               where
                 mkTableHead :: Maybe Row -> TableHead
mkTableHead = Attr -> [Row] -> TableHead
TableHead Attr
nullAttr ([Row] -> TableHead)
-> (Maybe Row -> [Row]) -> Maybe Row -> TableHead
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
                   -- Use row as header only if it's non-empty
                   Just row :: Row
row@(Row Attr
_ (Cell
_:[Cell]
_)) -> [Row
row]
                   Maybe Row
_                      -> []

-- | Parses a table foot
pTableFoot :: PandocMonad m
           => TagParser m Blocks
           -> TagParser m TableFoot
pTableFoot :: TagParser m Blocks -> TagParser m TableFoot
pTableFoot TagParser m Blocks
block = TagParser m TableFoot -> TagParser m TableFoot
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m TableFoot -> TagParser m TableFoot)
-> TagParser m TableFoot -> TagParser m TableFoot
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TagOpen Text
_ [Attribute Text]
attribs <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"tfoot" []) TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m (Tag Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [Row]
rows <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Row]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (((RowHeadColumns, Row) -> Row)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RowHeadColumns, Row) -> Row
forall a b. (a, b) -> b
snd (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
forall a b. (a -> b) -> a -> b
$ TagParser m Blocks
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (RowHeadColumns, Row)
pRow TagParser m Blocks
block ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank)
  TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (TagParser m (Tag Text)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ())
-> TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall a b. (a -> b) -> a -> b
$ (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> Tag Text -> Bool
matchTagClose Text
"tfoot")
  TableFoot -> TagParser m TableFoot
forall (m :: * -> *) a. Monad m => a -> m a
return (TableFoot -> TagParser m TableFoot)
-> TableFoot -> TagParser m TableFoot
forall a b. (a -> b) -> a -> b
$ Attr -> [Row] -> TableFoot
TableFoot ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs) [Row]
rows

-- | Parses a table body
pTableBody :: PandocMonad m
           => TagParser m Blocks
           -> TagParser m TableBody
pTableBody :: TagParser m Blocks -> TagParser m TableBody
pTableBody TagParser m Blocks
block = TagParser m TableBody -> TagParser m TableBody
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m TableBody -> TagParser m TableBody)
-> TagParser m TableBody -> TagParser m TableBody
forall a b. (a -> b) -> a -> b
$ do
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [Attribute Text]
attribs <- [Attribute Text]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
 -> ParsecT
      [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
forall a b. (a -> b) -> a -> b
$ Tag Text -> [Attribute Text]
forall str. Tag str -> [Attribute str]
getAttribs (Tag Text -> [Attribute Text])
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tag Text -> Bool)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"tbody" [])
             ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Attribute Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [Row]
bodyheads <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Row]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m Row
pHeaderRow TagParser m Blocks
block)
  ([RowHeadColumns]
rowheads, [Row]
rows) <- [(RowHeadColumns, Row)] -> ([RowHeadColumns], [Row])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(RowHeadColumns, Row)] -> ([RowHeadColumns], [Row]))
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
-> ParsecT
     [Tag Text]
     HTMLState
     (ReaderT HTMLLocal m)
     ([RowHeadColumns], [Row])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [(RowHeadColumns, Row)]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (TagParser m Blocks
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (RowHeadColumns, Row)
pRow TagParser m Blocks
block ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank)
  ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ())
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall a b. (a -> b) -> a -> b
$ (Tag Text -> Bool)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> Tag Text -> Bool
matchTagClose Text
"tbody")
  TableBody -> TagParser m TableBody
forall (m :: * -> *) a. Monad m => a -> m a
return (TableBody -> TagParser m TableBody)
-> TableBody -> TagParser m TableBody
forall a b. (a -> b) -> a -> b
$ Attr -> RowHeadColumns -> [Row] -> [Row] -> TableBody
TableBody ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs) ((RowHeadColumns -> RowHeadColumns -> RowHeadColumns)
-> RowHeadColumns -> [RowHeadColumns] -> RowHeadColumns
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RowHeadColumns -> RowHeadColumns -> RowHeadColumns
forall a. Ord a => a -> a -> a
max RowHeadColumns
0 [RowHeadColumns]
rowheads) [Row]
bodyheads [Row]
rows
  where
    getAttribs :: Tag str -> [Attribute str]
getAttribs (TagOpen str
_ [Attribute str]
attribs) = [Attribute str]
attribs
    getAttribs Tag str
_ = []

-- | Parses a simple HTML table
pTable :: PandocMonad m
       => TagParser m Blocks -- ^ Caption and cell contents parser
       -> TagParser m Blocks
pTable :: TagParser m Blocks -> TagParser m Blocks
pTable TagParser m Blocks
block = TagParser m Blocks -> TagParser m Blocks
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (TagParser m Blocks -> TagParser m Blocks)
-> TagParser m Blocks -> TagParser m Blocks
forall a b. (a -> b) -> a -> b
$ do
  TagOpen Text
_ [Attribute Text]
attribs <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> [Attribute Text] -> Tag Text -> Bool
matchTagOpen Text
"table" [])  TagParser m (Tag Text)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m (Tag Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  Blocks
caption <- Blocks -> TagParser m Blocks -> TagParser m Blocks
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Blocks
forall a. Monoid a => a
mempty (TagParser m Blocks -> TagParser m Blocks)
-> TagParser m Blocks -> TagParser m Blocks
forall a b. (a -> b) -> a -> b
$ Text -> TagParser m Blocks -> TagParser m Blocks
forall (m :: * -> *) a.
(PandocMonad m, Monoid a) =>
Text -> TagParser m a -> TagParser m a
pInTags Text
"caption" TagParser m Blocks
block       TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m Blocks
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [ColWidth]
widths  <- (([[ColWidth]] -> [ColWidth]
forall a. Monoid a => [a] -> a
mconcat ([[ColWidth]] -> [ColWidth])
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [[ColWidth]]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [[ColWidth]]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall (m :: * -> *). PandocMonad m => TagParser m [ColWidth]
pColgroup) ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ColWidth
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ColWidth
forall (m :: * -> *). PandocMonad m => TagParser m ColWidth
pCol) ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TableHead
thead   <- TagParser m Blocks -> TagParser m TableHead
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableHead
pTableHead TagParser m Blocks
block               TagParser m TableHead
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> TagParser m TableHead
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  Maybe TableFoot
topfoot <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableFoot
pTableFoot TagParser m Blocks
block) ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  [TableBody]
tbodies <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [TableBody]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableBody
pTableBody TagParser m Blocks
block)        ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [TableBody]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [TableBody]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  Maybe TableFoot
botfoot <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableFoot
pTableFoot TagParser m Blocks
block) ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe TableFoot)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (m :: * -> *). PandocMonad m => TagParser m ()
pBlank
  TagClose Text
_ <- (Tag Text -> Bool) -> TagParser m (Tag Text)
forall (m :: * -> *).
PandocMonad m =>
(Tag Text -> Bool) -> TagParser m (Tag Text)
pSatisfy (Text -> Tag Text -> Bool
matchTagClose Text
"table")
  let tfoot :: TableFoot
tfoot = TableFoot -> Maybe TableFoot -> TableFoot
forall a. a -> Maybe a -> a
fromMaybe (Attr -> [Row] -> TableFoot
TableFoot Attr
nullAttr []) (Maybe TableFoot -> TableFoot) -> Maybe TableFoot -> TableFoot
forall a b. (a -> b) -> a -> b
$ Maybe TableFoot
topfoot Maybe TableFoot -> Maybe TableFoot -> Maybe TableFoot
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TableFoot
botfoot
  case [ColWidth]
-> TableHead
-> [TableBody]
-> TableFoot
-> Either [Char] ([ColSpec], TableHead, [TableBody], TableFoot)
normalize [ColWidth]
widths TableHead
thead [TableBody]
tbodies TableFoot
tfoot of
    Left [Char]
err -> [Char] -> TagParser m Blocks
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
    Right ([ColSpec]
colspecs, TableHead
thead', [TableBody]
tbodies', TableFoot
tfoot') -> Blocks -> TagParser m Blocks
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocks -> TagParser m Blocks) -> Blocks -> TagParser m Blocks
forall a b. (a -> b) -> a -> b
$
      Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Blocks
B.tableWith ([Attribute Text] -> Attr
toAttr [Attribute Text]
attribs)
                  (Blocks -> Caption
B.simpleCaption Blocks
caption)
                  [ColSpec]
colspecs
                  TableHead
thead'
                  [TableBody]
tbodies'
                  TableFoot
tfoot'
data TableType
  = SimpleTable
  | NormalTable

tableType :: [[Cell]] -> TableType
tableType :: [[Cell]] -> TableType
tableType [[Cell]]
cells =
  if [[[Block]]] -> Bool
onlySimpleTableCells ([[[Block]]] -> Bool) -> [[[Block]]] -> Bool
forall a b. (a -> b) -> a -> b
$ ([Cell] -> [[Block]]) -> [[Cell]] -> [[[Block]]]
forall a b. (a -> b) -> [a] -> [b]
map ((Cell -> [Block]) -> [Cell] -> [[Block]]
forall a b. (a -> b) -> [a] -> [b]
map Cell -> [Block]
cellContents) [[Cell]]
cells
  then TableType
SimpleTable
  else TableType
NormalTable
  where
    cellContents :: Cell -> [Block]
    cellContents :: Cell -> [Block]
cellContents (Cell Attr
_ Alignment
_ RowSpan
_ ColSpan
_ [Block]
bs) = [Block]
bs

normalize :: [ColWidth] -> TableHead -> [TableBody] -> TableFoot
          -> Either String ([ColSpec], TableHead, [TableBody], TableFoot)
normalize :: [ColWidth]
-> TableHead
-> [TableBody]
-> TableFoot
-> Either [Char] ([ColSpec], TableHead, [TableBody], TableFoot)
normalize [ColWidth]
widths TableHead
head' [TableBody]
bodies TableFoot
foot = do
  let rows :: [Row]
rows = TableHead -> [Row]
headRows TableHead
head' [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> (TableBody -> [Row]) -> [TableBody] -> [Row]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TableBody -> [Row]
bodyRows [TableBody]
bodies [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> TableFoot -> [Row]
footRows TableFoot
foot
  let cellWidth :: Cell -> Int
cellWidth (Cell Attr
_ Alignment
_ RowSpan
_ (ColSpan Int
cs) [Block]
_) = Int
cs
  let rowLength :: Row -> Int
rowLength = (Cell -> Int -> Int) -> Int -> [Cell] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Cell
cell Int
acc -> Cell -> Int
cellWidth Cell
cell Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
acc) Int
0 ([Cell] -> Int) -> (Row -> [Cell]) -> Row -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Row -> [Cell]
rowCells
  let ncols :: Int
ncols = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Row -> Int) -> [Row] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Row -> Int
rowLength [Row]
rows)
  let tblType :: TableType
tblType = [[Cell]] -> TableType
tableType ((Row -> [Cell]) -> [Row] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map Row -> [Cell]
rowCells [Row]
rows)
  -- fail on empty table
  if [Row] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Row]
rows
    then [Char]
-> Either [Char] ([ColSpec], TableHead, [TableBody], TableFoot)
forall a b. a -> Either a b
Left [Char]
"empty table"
    else ([ColSpec], TableHead, [TableBody], TableFoot)
-> Either [Char] ([ColSpec], TableHead, [TableBody], TableFoot)
forall a b. b -> Either a b
Right
         ( [Alignment] -> [ColWidth] -> [ColSpec]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [TableBody] -> [Alignment]
calculateAlignments Int
ncols [TableBody]
bodies)
               (Int -> TableType -> [ColWidth] -> [ColWidth]
normalizeColWidths Int
ncols TableType
tblType [ColWidth]
widths)
         , TableHead
head'
         , [TableBody]
bodies
         , TableFoot
foot
         )

normalizeColWidths :: Int -> TableType -> [ColWidth] -> [ColWidth]
normalizeColWidths :: Int -> TableType -> [ColWidth] -> [ColWidth]
normalizeColWidths Int
ncols TableType
tblType = \case
  [] -> case TableType
tblType of
          TableType
SimpleTable -> Int -> ColWidth -> [ColWidth]
forall a. Int -> a -> [a]
replicate Int
ncols ColWidth
ColWidthDefault
          TableType
NormalTable -> Int -> ColWidth -> [ColWidth]
forall a. Int -> a -> [a]
replicate Int
ncols (Double -> ColWidth
ColWidth (Double -> ColWidth) -> Double -> ColWidth
forall a b. (a -> b) -> a -> b
$ Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ncols)
  [ColWidth]
widths -> [ColWidth]
widths

calculateAlignments :: Int -> [TableBody] -> [Alignment]
calculateAlignments :: Int -> [TableBody] -> [Alignment]
calculateAlignments Int
cols [TableBody]
tbodies =
  case [[Cell]]
cells of
    [Cell]
cs:[[Cell]]
_ -> Int -> [Alignment] -> [Alignment]
forall a. Int -> [a] -> [a]
take Int
cols ([Alignment] -> [Alignment]) -> [Alignment] -> [Alignment]
forall a b. (a -> b) -> a -> b
$ (Cell -> [Alignment]) -> [Cell] -> [Alignment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cell -> [Alignment]
cellAligns [Cell]
cs [Alignment] -> [Alignment] -> [Alignment]
forall a. [a] -> [a] -> [a]
++ Alignment -> [Alignment]
forall a. a -> [a]
repeat Alignment
AlignDefault
    [[Cell]]
_    -> Int -> Alignment -> [Alignment]
forall a. Int -> a -> [a]
replicate Int
cols Alignment
AlignDefault
  where
    cells :: [[Cell]]
    cells :: [[Cell]]
cells = (TableBody -> [[Cell]]) -> [TableBody] -> [[Cell]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TableBody -> [[Cell]]
bodyRowCells [TableBody]
tbodies
    cellAligns :: Cell -> [Alignment]
    cellAligns :: Cell -> [Alignment]
cellAligns (Cell Attr
_ Alignment
align RowSpan
_ (ColSpan Int
cs) [Block]
_) = Int -> Alignment -> [Alignment]
forall a. Int -> a -> [a]
replicate Int
cs Alignment
align

bodyRowCells :: TableBody -> [[Cell]]
bodyRowCells :: TableBody -> [[Cell]]
bodyRowCells = (Row -> [Cell]) -> [Row] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map Row -> [Cell]
rowCells ([Row] -> [[Cell]])
-> (TableBody -> [Row]) -> TableBody -> [[Cell]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableBody -> [Row]
bodyRows

headRows :: TableHead -> [B.Row]
headRows :: TableHead -> [Row]
headRows (TableHead Attr
_ [Row]
rows) = [Row]
rows

bodyRows :: TableBody -> [B.Row]
bodyRows :: TableBody -> [Row]
bodyRows (TableBody Attr
_ RowHeadColumns
_ [Row]
headerRows [Row]
bodyRows') = [Row]
headerRows [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> [Row]
bodyRows'

footRows :: TableFoot -> [B.Row]
footRows :: TableFoot -> [Row]
footRows (TableFoot Attr
_ [Row]
rows) = [Row]
rows

rowCells :: B.Row -> [Cell]
rowCells :: Row -> [Cell]
rowCells (Row Attr
_ [Cell]
cells) = [Cell]
cells