{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Readers.HTML.Table
   Copyright   : © 2006-2023 John MacFarlane,
                   2020-2023 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, isJust)
import Data.Either (lefts, rights)
import Data.List.NonEmpty (nonEmpty)
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
import Control.Monad (guard)

-- | Parses a @<col>@ element, returning the column's width.
-- An Either value is used:  Left i means a "relative length" with
-- integral value i (see https://www.w3.org/TR/html4/types.html#h-6.6);
-- Right w means a regular width.  Defaults to @'Right ColWidthDefault'@
-- if the width is not set or cannot be determined.
pCol :: PandocMonad m => TagParser m (Either Int ColWidth)
pCol :: forall (m :: * -> *).
PandocMonad m =>
TagParser m (Either Int ColWidth)
pCol = ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
 -> ParsecT
      [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth))
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int 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
  Either Int ColWidth
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Int ColWidth
 -> ParsecT
      [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth))
-> Either Int ColWidth
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
forall a b. (a -> b) -> a -> b
$ 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 ->
                    Either Int ColWidth
-> (Double -> Either Int ColWidth)
-> Maybe Double
-> Either Int ColWidth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right ColWidth
ColWidthDefault) (ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right (ColWidth -> Either Int ColWidth)
-> (Double -> ColWidth) -> Double -> Either Int ColWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ColWidth
ColWidth (Double -> ColWidth) -> (Double -> Double) -> Double -> ColWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100.0))
                      (Maybe Double -> Either Int ColWidth)
-> Maybe Double -> Either Int ColWidth
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 -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
" \t\r\n%'\";" :: [Char])) Text
xs)
                  Maybe Text
_ -> ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right ColWidth
ColWidthDefault
                Just (Text -> Maybe (Text, Char)
T.unsnoc -> Just (Text
xs, Char
'*')) ->
                  Either Int ColWidth
-> (Int -> Either Int ColWidth) -> Maybe Int -> Either Int ColWidth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Either Int ColWidth
forall a b. a -> Either a b
Left Int
1) Int -> Either Int ColWidth
forall a b. a -> Either a b
Left (Maybe Int -> Either Int ColWidth)
-> Maybe Int -> Either Int ColWidth
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead Text
xs
                Just (Text -> Maybe (Text, Char)
T.unsnoc -> Just (Text
xs, Char
'%')) ->
                  Either Int ColWidth
-> (Double -> Either Int ColWidth)
-> Maybe Double
-> Either Int ColWidth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right ColWidth
ColWidthDefault)
                        (ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right (ColWidth -> Either Int ColWidth)
-> (Double -> ColWidth) -> Double -> Either Int ColWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ColWidth
ColWidth (Double -> ColWidth) -> (Double -> Double) -> Double -> ColWidth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
100.0)) (Maybe Double -> Either Int ColWidth)
-> Maybe Double -> Either Int ColWidth
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
_ -> ColWidth -> Either Int ColWidth
forall a b. b -> Either a b
Right ColWidth
ColWidthDefault

pColgroup :: PandocMonad m => TagParser m [Either Int ColWidth]
pColgroup :: forall (m :: * -> *).
PandocMonad m =>
TagParser m [Either Int ColWidth]
pColgroup = ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
 -> ParsecT
      [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int 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) (Either Int ColWidth)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int 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) (Either Int ColWidth)
forall (m :: * -> *).
PandocMonad m =>
TagParser m (Either Int 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 a.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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) ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
forall a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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

resolveRelativeLengths :: [Either Int ColWidth] -> [ColWidth]
resolveRelativeLengths :: [Either Int ColWidth] -> [ColWidth]
resolveRelativeLengths [Either Int ColWidth]
ws =
  let remaining :: Double
remaining = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ColWidth -> Double) -> [ColWidth] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ColWidth -> Double
getColWidth ([ColWidth] -> [Double]) -> [ColWidth] -> [Double]
forall a b. (a -> b) -> a -> b
$ [Either Int ColWidth] -> [ColWidth]
forall a b. [Either a b] -> [b]
rights [Either Int ColWidth]
ws)
      relatives :: Int
relatives = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Either Int ColWidth] -> [Int]
forall a b. [Either a b] -> [a]
lefts [Either Int ColWidth]
ws
      relUnit :: Double
relUnit = Double
remaining Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
relatives
      toColWidth :: Either a ColWidth -> ColWidth
toColWidth (Right ColWidth
x) = ColWidth
x
      toColWidth (Left a
i) = Double -> ColWidth
ColWidth (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
relUnit)
  in  (Either Int ColWidth -> ColWidth)
-> [Either Int ColWidth] -> [ColWidth]
forall a b. (a -> b) -> [a] -> [b]
map Either Int ColWidth -> ColWidth
forall {a}. Integral a => Either a ColWidth -> ColWidth
toColWidth [Either Int ColWidth]
ws

getColWidth :: ColWidth -> Double
getColWidth :: ColWidth -> Double
getColWidth ColWidth
ColWidthDefault = Double
0
getColWidth (ColWidth Double
w) = Double
w

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
$c== :: CellType -> CellType -> Bool
== :: CellType -> CellType -> Bool
$c/= :: CellType -> CellType -> Bool
/= :: CellType -> CellType -> Bool
Eq

pCell :: PandocMonad m
      => TagParser m Blocks
      -> CellType
      -> TagParser m (CellType, Cell)
pCell :: forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> CellType -> TagParser m (CellType, Cell)
pCell TagParser m Blocks
block CellType
celltype = 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
try (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)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal 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 a. Maybe a -> Maybe a -> Maybe a
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 a b. (a -> b -> b) -> b -> [a] -> b
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 a. Eq a => a -> [a] -> 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)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (CellType, Cell)
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 :: 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) (RowHeadColumns, Row)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
 -> ParsecT
      [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row))
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal 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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (RowHeadColumns, Row)
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a. [a] -> 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 :: forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m Row
pHeaderRow TagParser m Blocks
block = 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
try (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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])
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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 :: forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableHead
pTableHead TagParser m Blocks
block = ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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)])
    -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
forall a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> (a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ([Attribute Text]
attribs, [(RowHeadColumns, Row)]
rows) ->
      TableHead
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TableHead
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableHead)
-> TableHead
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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 :: forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m TableFoot
pTableFoot TagParser m Blocks
block = ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
(a -> b)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TableFoot
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableFoot)
-> TableFoot
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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 :: 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) TableBody
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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
  Maybe [Attribute Text]
mbattribs <- Maybe [Attribute Text]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Maybe [Attribute Text]
forall a. Maybe a
Nothing (ParsecT
   [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
 -> ParsecT
      [Tag Text]
      HTMLState
      (ReaderT HTMLLocal m)
      (Maybe [Attribute Text]))
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
forall a b. (a -> b) -> a -> b
$ [Attribute Text] -> Maybe [Attribute Text]
forall a. a -> Maybe a
Just ([Attribute Text] -> Maybe [Attribute Text])
-> (Tag Text -> [Attribute Text])
-> Tag Text
-> Maybe [Attribute Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag Text -> [Attribute Text]
forall {str}. Tag str -> [Attribute str]
getAttribs (Tag Text -> Maybe [Attribute Text])
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Tag Text)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [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) (Maybe [Attribute Text])
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) (Maybe [Attribute Text])
forall a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 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 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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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")
  Bool -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ())
-> Bool -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
forall a b. (a -> b) -> a -> b
$ Maybe [Attribute Text] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Attribute Text]
mbattribs Bool -> Bool -> Bool
|| Bool -> Bool
not ([Row] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Row]
bodyheads Bool -> Bool -> Bool
&& [Row] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Row]
rows)
  let attribs :: [Attribute Text]
attribs = [Attribute Text] -> Maybe [Attribute Text] -> [Attribute Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Attribute Text]
mbattribs
  TableBody
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TableBody
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) TableBody)
-> TableBody
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal 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 a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall (m :: * -> *).
PandocMonad m =>
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 <- [Either Int ColWidth] -> [ColWidth]
resolveRelativeLengths ([Either Int ColWidth] -> [ColWidth])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [ColWidth]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (([[Either Int ColWidth]] -> [Either Int ColWidth]
forall a. Monoid a => [a] -> a
mconcat ([[Either Int ColWidth]] -> [Either Int ColWidth])
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [[Either Int ColWidth]]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [[Either Int 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) [Either Int ColWidth]
forall (m :: * -> *).
PandocMonad m =>
TagParser m [Either Int ColWidth]
pColgroup) ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
forall a.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
-> ParsecT
     [Tag Text] HTMLState (ReaderT HTMLLocal m) [Either Int ColWidth]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT
  [Tag Text] HTMLState (ReaderT HTMLLocal m) (Either Int ColWidth)
forall (m :: * -> *).
PandocMonad m =>
TagParser m (Either Int 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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a b.
ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) b
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TableFoot
botfoot
  case [ColWidth]
-> TableHead
-> [TableBody]
-> TableFoot
-> Either String ([ColSpec], TableHead, [TableBody], TableFoot)
normalize [ColWidth]
widths TableHead
thead [TableBody]
tbodies TableFoot
tfoot of
    Left String
err -> String -> TagParser m Blocks
forall a.
String -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right ([ColSpec]
colspecs, TableHead
thead', [TableBody]
tbodies', TableFoot
tfoot') -> Blocks -> TagParser m Blocks
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
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 String ([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 a b. (a -> b -> b) -> b -> [a] -> b
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 -> (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Maybe (NonEmpty Int) -> Int) -> Maybe (NonEmpty Int) -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int] -> Maybe (NonEmpty Int)) -> [Int] -> Maybe (NonEmpty Int)
forall a b. (a -> b) -> a -> b
$ (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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Row]
rows
    then String
-> Either String ([ColSpec], TableHead, [TableBody], TableFoot)
forall a b. a -> Either a b
Left String
"empty table"
    else ([ColSpec], TableHead, [TableBody], TableFoot)
-> Either String ([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