{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
{- |
   Module      : Text.Pandoc.Readers.HTML.Table
   Copyright   : © 2006-2024 John MacFarlane,
                   2020-2024 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 qualified Data.Vector as V
import Control.Applicative ((<|>))
import Data.Maybe (fromMaybe, isJust)
import Data.Either (lefts, rights)
import Data.List.NonEmpty (nonEmpty)
import Data.List (foldl')
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 and the number
-- of cells at the beginning that are header cells.
pRow :: PandocMonad m
     => TagParser m Blocks
     -> TagParser m (Int, B.Row)
pRow :: forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (Int, Row)
pRow TagParser m Blocks
block = ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
 -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row))
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, 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")
  let numheadcells :: Int
numheadcells = [(CellType, Cell)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(CellType, Cell)] -> Int) -> [(CellType, Cell)] -> Int
forall a b. (a -> b) -> a -> b
$ ((CellType, Cell) -> Bool)
-> [(CellType, Cell)] -> [(CellType, Cell)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(CellType
ct,Cell
_) -> CellType
ct CellType -> CellType -> Bool
forall a. Eq a => a -> a -> Bool
== CellType
HeaderCell) [(CellType, Cell)]
cells
  (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
forall a. a -> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
numheadcells, 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 = ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Cell
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [Cell]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((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
<$> 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) [(Int, Row)]
pRows = ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [(Int, 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) (Int, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (Int, Row)
pRow TagParser m Blocks
block)
  let pThead :: TagParser m ([Attribute Text], [(Int, Row)])
pThead = TagOmission
-> Text
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [(Int, Row)]
-> TagParser m ([Attribute Text], [(Int, 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) [(Int, Row)]
pRows
  TagParser m ([Attribute Text], [(Int, Row)])
-> ParsecT
     [Tag Text]
     HTMLState
     (ReaderT HTMLLocal m)
     (Maybe ([Attribute Text], [(Int, 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], [(Int, Row)])
pThead ParsecT
  [Tag Text]
  HTMLState
  (ReaderT HTMLLocal m)
  (Maybe ([Attribute Text], [(Int, Row)]))
-> (Maybe ([Attribute Text], [(Int, 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, [(Int, 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
$ ((Int, Row) -> Row) -> [(Int, Row)] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Row) -> Row
forall a b. (a, b) -> b
snd [(Int, Row)]
rows
    Maybe ([Attribute Text], [(Int, 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 (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
$ (Int, Row) -> Row
forall a b. (a, b) -> b
snd ((Int, Row) -> Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) Row
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TagParser m Blocks
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (Int, Row)
pRow TagParser m Blocks
block ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, 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)
  [(Int, Row)]
rows <- ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) [(Int, 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) (Int, Row)
forall (m :: * -> *).
PandocMonad m =>
TagParser m Blocks -> TagParser m (Int, Row)
pRow TagParser m Blocks
block ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, Row)
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) ()
-> ParsecT [Tag Text] HTMLState (ReaderT HTMLLocal m) (Int, 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
&& [(Int, Row)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, 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
  -- we only set row head columns if all rows agree;
  -- if some rows have headings but others not, we use 0; see #8984, #8634:
  let numrows :: Int
numrows = [(Int, Row)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Row)]
rows
  let adjustRowHeadColsForCell :: Int -> Vector Int -> Cell -> Vector Int
adjustRowHeadColsForCell Int
currentrow Vector Int
headcolsv
                    (Cell Attr
_ Alignment
_ (RowSpan Int
rowspan) (ColSpan Int
colspan) [Block]
_) =
        (Int -> Int -> Int) -> Vector Int -> Vector Int
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
i Int
x -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
currentrow Bool -> Bool -> Bool
&&
                           Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
currentrow Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rowspan
                           then Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
colspan
                           else Int
x) Vector Int
headcolsv
  let adjustRowHeadCols :: Vector Int -> (Int, (Int, Row)) -> Vector Int
adjustRowHeadCols
        Vector Int
headcolsv
        (Int
currentrow, (Int
numheads, Row Attr
_ [Cell]
cells)) =
          (Vector Int -> Cell -> Vector Int)
-> Vector Int -> [Cell] -> Vector Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int -> Vector Int -> Cell -> Vector Int
adjustRowHeadColsForCell Int
currentrow) Vector Int
headcolsv
            (Int -> [Cell] -> [Cell]
forall a. Int -> [a] -> [a]
take Int
numheads [Cell]
cells)
  let headcols :: Vector Int
headcols = (Vector Int -> (Int, (Int, Row)) -> Vector Int)
-> Vector Int -> [(Int, (Int, Row))] -> Vector Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Vector Int -> (Int, (Int, Row)) -> Vector Int
adjustRowHeadCols
                         (Int -> Int -> Vector Int
forall a. Int -> a -> Vector a
V.replicate Int
numrows (Int
0 :: Int))
                         ([Int] -> [(Int, Row)] -> [(Int, (Int, Row))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [(Int, Row)]
rows)
  let rowHeadCols :: RowHeadColumns
rowHeadCols = case Vector Int -> Maybe (Int, Vector Int)
forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Int
headcols of
                       Just (Int
x, Vector Int
v) | (Int -> Bool) -> Vector Int -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x) Vector Int
v -> Int -> RowHeadColumns
RowHeadColumns Int
x
                       Maybe (Int, Vector Int)
_ -> Int -> RowHeadColumns
RowHeadColumns Int
0
  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
rowHeadCols [Row]
bodyheads (((Int, Row) -> Row) -> [(Int, Row)] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Row) -> Row
forall a b. (a, b) -> b
snd [(Int, 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