08231f5 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Factor out T.P.Readers.LaTeX.Table.

08231f5John MacFarlane6 years ago

pandoc.cabal+1

compare with master

unifiedsplit

@@ -631,6 +631,7 @@ library

631 Text.Pandoc.Readers.LaTeX.Lang,

632 Text.Pandoc.Readers.LaTeX.SIunitx,

633 Text.Pandoc.Readers.LaTeX.Accent,

634+ Text.Pandoc.Readers.LaTeX.Table,

634 Text.Pandoc.Readers.Odt.Base,

635 Text.Pandoc.Readers.Odt.Base,

635 Text.Pandoc.Readers.Odt.Namespaces,

636 Text.Pandoc.Readers.Odt.Namespaces,

636 Text.Pandoc.Readers.Odt.StyleReader,

637 Text.Pandoc.Readers.Odt.StyleReader,

src/Text/Pandoc/Readers/LaTeX.hs+5−363

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

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

@@ -32,7 +31,6 @@ import Control.Monad

32import Control.Monad.Except (throwError)

31import Control.Monad.Except (throwError)

33import Data.Char (isDigit, isLetter, toUpper, chr)

32import Data.Char (isDigit, isLetter, toUpper, chr)

34import Data.Default

33import Data.Default

35−import Data.Functor (($>))

36import Data.List (intercalate)

34import Data.List (intercalate)

37import qualified Data.Map as M

35import qualified Data.Map as M

38import Data.Maybe (fromMaybe, maybeToList)

36import Data.Maybe (fromMaybe, maybeToList)

@@ -58,6 +56,7 @@ import Text.Pandoc.Readers.LaTeX.Types (ExpansionPoint (..), Macro (..),

58 ArgSpec (..), Tok (..), TokType (..))

56 ArgSpec (..), Tok (..), TokType (..))

59import Text.Pandoc.Readers.LaTeX.Parsing

57import Text.Pandoc.Readers.LaTeX.Parsing

60import Text.Pandoc.Readers.LaTeX.Accent (accentCommands)

58import Text.Pandoc.Readers.LaTeX.Accent (accentCommands)

59+import Text.Pandoc.Readers.LaTeX.Table (tableEnvironments)

61import Text.Pandoc.Readers.LaTeX.Lang (polyglossiaLangToBCP47,

60import Text.Pandoc.Readers.LaTeX.Lang (polyglossiaLangToBCP47,

62 babelLangToBCP47)

61 babelLangToBCP47)

63import Text.Pandoc.Readers.LaTeX.SIunitx

62import Text.Pandoc.Readers.LaTeX.SIunitx

@@ -551,12 +550,8 @@ inlineCommand' = try $ do

551 <|> ignore rawcommand

550 <|> ignore rawcommand

552 lookupListDefault raw names inlineCommands

551 lookupListDefault raw names inlineCommands

553

552

554−

555tok :: PandocMonad m => LP m Inlines

553tok :: PandocMonad m => LP m Inlines

556−tok = try $ spaces >> grouped inline <|> inlineCommand' <|> singleChar'

554+tok = tokWith inline

557− where singleChar' = do

558− Tok _ _ t <- singleChar

559− return $ str t

560

555

561opt :: PandocMonad m => LP m Inlines

556opt :: PandocMonad m => LP m Inlines

562opt = do

557opt = do

@@ -1118,12 +1113,6 @@ treatAsInline = Set.fromList

1118 , "pagebreak"

1113 , "pagebreak"

1119 ]

1114 ]

1120

1115

1121−label :: PandocMonad m => LP m ()

1122−label = do

1123− controlSeq "label"

1124− t <- braced

1125− updateState $ \st -> st{ sLastLabel = Just $ untokenize t }

1126−

1127dolabel :: PandocMonad m => LP m Inlines

1116dolabel :: PandocMonad m => LP m Inlines

1128dolabel = do

1117dolabel = do

1129 v <- braced

1118 v <- braced

@@ -1421,13 +1410,6 @@ bracketedNum = do

1421 Just i -> return i

1410 Just i -> return i

1422 _ -> return 0

1411 _ -> return 0

1423

1412

1424−setCaption :: PandocMonad m => LP m ()

1425−setCaption = try $ do

1426− skipopts

1427− ils <- tok

1428− optional $ try $ spaces *> label

1429− updateState $ \st -> st{ sCaption = Just ils }

1430−

1431looseItem :: PandocMonad m => LP m Blocks

1413looseItem :: PandocMonad m => LP m Blocks

1432looseItem = do

1414looseItem = do

1433 inListItem <- sInListItem <$> getState

1415 inListItem <- sInListItem <$> getState

@@ -1441,10 +1423,6 @@ epigraph = do

1441 p2 <- grouped block

1423 p2 <- grouped block

1442 return $ divWith ("", ["epigraph"], []) (p1 <> p2)

1424 return $ divWith ("", ["epigraph"], []) (p1 <> p2)

1443

1425

1444−resetCaption :: PandocMonad m => LP m ()

1445−resetCaption = updateState $ \st -> st{ sCaption = Nothing

1446− , sLastLabel = Nothing }

1447−

1448section :: PandocMonad m => Attr -> Int -> LP m Blocks

1426section :: PandocMonad m => Attr -> Int -> LP m Blocks

1449section (ident, classes, kvs) lvl = do

1427section (ident, classes, kvs) lvl = do

1450 skipopts

1428 skipopts

@@ -1585,7 +1563,7 @@ blockCommands = M.fromList

1585 , ("item", looseItem)

1563 , ("item", looseItem)

1586 , ("documentclass", skipopts *> braced *> preamble)

1564 , ("documentclass", skipopts *> braced *> preamble)

1587 , ("centerline", para . trimInlines <$> (skipopts *> tok))

1565 , ("centerline", para . trimInlines <$> (skipopts *> tok))

1588− , ("caption", mempty <$ setCaption)

1566+ , ("caption", mempty <$ setCaption inline)

1589 , ("bibliography", mempty <$ (skipopts *> braced >>=

1567 , ("bibliography", mempty <$ (skipopts *> braced >>=

1590 addMeta "bibliography" . splitBibs . untokenize))

1568 addMeta "bibliography" . splitBibs . untokenize))

1591 , ("addbibresource", mempty <$ (skipopts *> braced >>=

1569 , ("addbibresource", mempty <$ (skipopts *> braced >>=

@@ -1623,7 +1601,8 @@ blockCommands = M.fromList

1623

1601

1624

1602

1625environments :: PandocMonad m => M.Map Text (LP m Blocks)

1603environments :: PandocMonad m => M.Map Text (LP m Blocks)

1604+environments = M.union (tableEnvironments blocks inline) $

1626−environments = M.fromList

1605+ M.fromList

1627 [ ("document", env "document" blocks <* skipMany anyTok)

1606 [ ("document", env "document" blocks <* skipMany anyTok)

1628 , ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract"))

1607 , ("abstract", mempty <$ (env "abstract" blocks >>= addMeta "abstract"))

1629 , ("sloppypar", env "sloppypar" blocks)

1608 , ("sloppypar", env "sloppypar" blocks)

@@ -1633,13 +1612,6 @@ environments = M.fromList

1633 , ("figure", env "figure" $ skipopts *> figure)

1612 , ("figure", env "figure" $ skipopts *> figure)

1634 , ("subfigure", env "subfigure" $ skipopts *> tok *> figure)

1613 , ("subfigure", env "subfigure" $ skipopts *> tok *> figure)

1635 , ("center", divWith ("", ["center"], []) <$> env "center" blocks)

1614 , ("center", divWith ("", ["center"], []) <$> env "center" blocks)

1636− , ("longtable", env "longtable" $

1637− resetCaption *> simpTable "longtable" False >>= addTableCaption)

1638− , ("table", env "table" $

1639− skipopts *> resetCaption *> blocks >>= addTableCaption)

1640− , ("tabular*", env "tabular*" $ simpTable "tabular*" True)

1641− , ("tabularx", env "tabularx" $ simpTable "tabularx" True)

1642− , ("tabular", env "tabular" $ simpTable "tabular" False)

1643 , ("quote", blockQuote <$> env "quote" blocks)

1615 , ("quote", blockQuote <$> env "quote" blocks)

1644 , ("quotation", blockQuote <$> env "quotation" blocks)

1616 , ("quotation", blockQuote <$> env "quotation" blocks)

1645 , ("verse", blockQuote <$> env "verse" blocks)

1617 , ("verse", blockQuote <$> env "verse" blocks)

@@ -1805,9 +1777,6 @@ italicize (Para ils) = Para [Emph ils]

1805italicize (Plain ils) = Plain [Emph ils]

1777italicize (Plain ils) = Plain [Emph ils]

1806italicize x = x

1778italicize x = x

1807

1779

1808−env :: PandocMonad m => Text -> LP m a -> LP m a

1809−env name p = p <* end_ name

1810−

1811rawEnv :: PandocMonad m => Text -> LP m Blocks

1780rawEnv :: PandocMonad m => Text -> LP m Blocks

1812rawEnv name = do

1781rawEnv name = do

1813 exts <- getOption readerExtensions

1782 exts <- getOption readerExtensions

@@ -2045,333 +2014,6 @@ orderedList' = try $ do

2045 bs <- listenv "enumerate" (many item)

2014 bs <- listenv "enumerate" (many item)

2046 return $ orderedListWith (start, style, delim) bs

2015 return $ orderedListWith (start, style, delim) bs

2047

2016

2048−-- tables

2049−

2050−hline :: PandocMonad m => LP m ()

2051−hline = try $ do

2052− spaces

2053− controlSeq "hline" <|>

2054− -- booktabs rules:

2055− controlSeq "toprule" <|>

2056− controlSeq "bottomrule" <|>

2057− controlSeq "midrule" <|>

2058− controlSeq "endhead" <|>

2059− controlSeq "endfirsthead"

2060− spaces

2061− optional opt

2062− return ()

2063−

2064−lbreak :: PandocMonad m => LP m Tok

2065−lbreak = (controlSeq "\\" <|> controlSeq "tabularnewline")

2066− <* skipopts <* spaces

2067−

2068−amp :: PandocMonad m => LP m Tok

2069−amp = symbol '&'

2070−

2071−-- Split a Word into individual Symbols (for parseAligns)

2072−splitWordTok :: PandocMonad m => LP m ()

2073−splitWordTok = do

2074− inp <- getInput

2075− case inp of

2076− (Tok spos Word t : rest) ->

2077− setInput $ map (Tok spos Symbol . T.singleton) (T.unpack t) <> rest

2078− _ -> return ()

2079−

2080−parseAligns :: PandocMonad m => LP m [(Alignment, ColWidth, ([Tok], [Tok]))]

2081−parseAligns = try $ do

2082− let maybeBar = skipMany

2083− (try $ sp *> (() <$ symbol '|' <|> () <$ (symbol '@' >> braced)))

2084− let cAlign = AlignCenter <$ symbol 'c'

2085− let lAlign = AlignLeft <$ symbol 'l'

2086− let rAlign = AlignRight <$ symbol 'r'

2087− let parAlign = AlignLeft <$ symbol 'p'

2088− -- aligns from tabularx

2089− let xAlign = AlignLeft <$ symbol 'X'

2090− let mAlign = AlignLeft <$ symbol 'm'

2091− let bAlign = AlignLeft <$ symbol 'b'

2092− let alignChar = splitWordTok *> ( cAlign <|> lAlign <|> rAlign <|> parAlign

2093− <|> xAlign <|> mAlign <|> bAlign )

2094− let alignPrefix = symbol '>' >> braced

2095− let alignSuffix = symbol '<' >> braced

2096− let colWidth = try $ do

2097− symbol '{'

2098− ds <- trim . untokenize <$> manyTill anyTok (controlSeq "linewidth")

2099− spaces

2100− symbol '}'

2101− return $ safeRead ds

2102− let alignSpec = do

2103− pref <- option [] alignPrefix

2104− spaces

2105− al <- alignChar

2106− width <- colWidth <|> option Nothing (do s <- untokenize <$> braced

2107− pos <- getPosition

2108− report $ SkippedContent s pos

2109− return Nothing)

2110− spaces

2111− suff <- option [] alignSuffix

2112− return (al, width, (pref, suff))

2113− let starAlign = do -- '*{2}{r}' == 'rr', we just expand like a macro

2114− symbol '*'

2115− spaces

2116− ds <- trim . untokenize <$> braced

2117− spaces

2118− spec <- braced

2119− case safeRead ds of

2120− Just n ->

2121− getInput >>= setInput . (mconcat (replicate n spec) ++)

2122− Nothing -> Prelude.fail $ "Could not parse " <> T.unpack ds <> " as number"

2123− bgroup

2124− spaces

2125− maybeBar

2126− aligns' <- many $ try $ spaces >> optional starAlign >>

2127− (alignSpec <* maybeBar)

2128− spaces

2129− egroup

2130− spaces

2131− return $ map toSpec aligns'

2132− where

2133− toColWidth (Just w) | w > 0 = ColWidth w

2134− toColWidth _ = ColWidthDefault

2135− toSpec (x, y, z) = (x, toColWidth y, z)

2136−

2137−-- N.B. this parser returns a Row that may have erroneous empty cells

2138−-- in it. See the note above fixTableHead for details.

2139−parseTableRow :: PandocMonad m

2140− => Text -- ^ table environment name

2141− -> [([Tok], [Tok])] -- ^ pref/suffixes

2142− -> LP m Row

2143−parseTableRow envname prefsufs = do

2144− notFollowedBy (spaces *> end_ envname)

2145− -- add prefixes and suffixes in token stream:

2146− let celltoks (pref, suff) = do

2147− prefpos <- getPosition

2148− contents <- mconcat <$>

2149− many ( snd <$> withRaw (controlSeq "parbox" >> parbox) -- #5711

2150− <|>

2151− snd <$> withRaw (inlineEnvironment <|> dollarsMath)

2152− <|>

2153− (do notFollowedBy

2154− (() <$ amp <|> () <$ lbreak <|> end_ envname)

2155− count 1 anyTok) )

2156−

2157− suffpos <- getPosition

2158− option [] (count 1 amp)

2159− return $ map (setpos prefpos) pref ++ contents ++ map (setpos suffpos) suff

2160− rawcells <- mapM celltoks prefsufs

2161− cells <- mapM (parseFromToks parseTableCell) rawcells

2162− spaces

2163− return $ Row nullAttr cells

2164−

2165−parseTableCell :: PandocMonad m => LP m Cell

2166−parseTableCell = do

2167− spaces

2168− updateState $ \st -> st{ sInTableCell = True }

2169− cell' <- multicolumnCell

2170− <|> multirowCell

2171− <|> parseSimpleCell

2172− <|> parseEmptyCell

2173− updateState $ \st -> st{ sInTableCell = False }

2174− spaces

2175− return cell'

2176− where

2177− -- The parsing of empty cells is important in LaTeX, especially when dealing

2178− -- with multirow/multicolumn. See #6603.

2179− parseEmptyCell = spaces $> emptyCell

2180−

2181−cellAlignment :: PandocMonad m => LP m Alignment

2182−cellAlignment = skipMany (symbol '|') *> alignment <* skipMany (symbol '|')

2183− where

2184− alignment = do

2185− c <- untoken <$> singleChar

2186− return $ case c of

2187− "l" -> AlignLeft

2188− "r" -> AlignRight

2189− "c" -> AlignCenter

2190− "*" -> AlignDefault

2191− _ -> AlignDefault

2192−

2193−plainify :: Blocks -> Blocks

2194−plainify bs = case toList bs of

2195− [Para ils] -> plain (fromList ils)

2196− _ -> bs

2197−

2198−multirowCell :: PandocMonad m => LP m Cell

2199−multirowCell = controlSeq "multirow" >> do

2200− -- Full prototype for \multirow macro is:

2201− -- \multirow[vpos]{nrows}[bigstruts]{width}[vmove]{text}

2202− -- However, everything except `nrows` and `text` make

2203− -- sense in the context of the Pandoc AST

2204− _ <- optional $ symbol '[' *> cellAlignment <* symbol ']' -- vertical position

2205− nrows <- fmap (fromMaybe 1 . safeRead . untokenize) braced

2206− _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- bigstrut-related

2207− _ <- symbol '{' *> manyTill anyTok (symbol '}') -- Cell width

2208− _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- Length used for fine-tuning

2209− content <- symbol '{' *> (plainify <$> blocks) <* symbol '}'

2210− return $ cell AlignDefault (RowSpan nrows) (ColSpan 1) content

2211−

2212−multicolumnCell :: PandocMonad m => LP m Cell

2213−multicolumnCell = controlSeq "multicolumn" >> do

2214− span' <- fmap (fromMaybe 1 . safeRead . untokenize) braced

2215− alignment <- symbol '{' *> cellAlignment <* symbol '}'

2216−

2217− let singleCell = do

2218− content <- plainify <$> blocks

2219− return $ cell alignment (RowSpan 1) (ColSpan span') content

2220−

2221− -- Two possible contents: either a \multirow cell, or content.

2222− -- E.g. \multicol{1}{c}{\multirow{2}{1em}{content}}

2223− -- Note that a \multirow cell can be nested in a \multicolumn,

2224− -- but not the other way around. See #6603

2225− let nestedCell = do

2226− (Cell _ _ (RowSpan rs) _ bs) <- multirowCell

2227− return $ cell

2228− alignment

2229− (RowSpan rs)

2230− (ColSpan span')

2231− (fromList bs)

2232−

2233− symbol '{' *> (nestedCell <|> singleCell) <* symbol '}'

2234−

2235−-- Parse a simple cell, i.e. not multirow/multicol

2236−parseSimpleCell :: PandocMonad m => LP m Cell

2237−parseSimpleCell = simpleCell <$> (plainify <$> blocks)

2238−

2239−-- LaTeX tables are stored with empty cells underneath multirow cells

2240−-- denoting the grid spaces taken up by them. More specifically, if a

2241−-- cell spans m rows, then it will overwrite all the cells in the

2242−-- columns it spans for (m-1) rows underneath it, requiring padding

2243−-- cells in these places. These padding cells need to be removed for

2244−-- proper table reading. See #6603.

2245−--

2246−-- These fixTable functions do not otherwise fix up malformed

2247−-- input tables: that is left to the table builder.

2248−fixTableHead :: TableHead -> TableHead

2249−fixTableHead (TableHead attr rows) = TableHead attr rows'

2250− where

2251− rows' = fixTableRows rows

2252−

2253−fixTableBody :: TableBody -> TableBody

2254−fixTableBody (TableBody attr rhc th tb)

2255− = TableBody attr rhc th' tb'

2256− where

2257− th' = fixTableRows th

2258− tb' = fixTableRows tb

2259−

2260−fixTableRows :: [Row] -> [Row]

2261−fixTableRows = fixTableRows' $ repeat Nothing

2262− where

2263− fixTableRows' oldHang (Row attr cells : rs)

2264− = let (newHang, cells') = fixTableRow oldHang cells

2265− rs' = fixTableRows' newHang rs

2266− in Row attr cells' : rs'

2267− fixTableRows' _ [] = []

2268−

2269−-- The overhang is represented as Just (relative cell dimensions) or

2270−-- Nothing for an empty grid space.

2271−fixTableRow :: [Maybe (ColSpan, RowSpan)] -> [Cell] -> ([Maybe (ColSpan, RowSpan)], [Cell])

2272−fixTableRow oldHang cells

2273− -- If there's overhang, drop cells until their total width meets the

2274− -- width of the occupied grid spaces (or we run out)

2275− | (n, prefHang, restHang) <- splitHang oldHang

2276− , n > 0

2277− = let cells' = dropToWidth getCellW n cells

2278− (restHang', cells'') = fixTableRow restHang cells'

2279− in (prefHang restHang', cells'')

2280− -- Otherwise record the overhang of a pending cell and fix the rest

2281− -- of the row

2282− | c@(Cell _ _ h w _):cells' <- cells

2283− = let h' = max 1 h

2284− w' = max 1 w

2285− oldHang' = dropToWidth getHangW w' oldHang

2286− (newHang, cells'') = fixTableRow oldHang' cells'

2287− in (toHang w' h' <> newHang, c : cells'')

2288− | otherwise

2289− = (oldHang, [])

2290− where

2291− getCellW (Cell _ _ _ w _) = w

2292− getHangW = maybe 1 fst

2293− getCS (ColSpan n) = n

2294−

2295− toHang c r

2296− | r > 1 = [Just (c, r)]

2297− | otherwise = replicate (getCS c) Nothing

2298−

2299− -- Take the prefix of the overhang list representing filled grid

2300− -- spaces. Also return the remainder and the length of this prefix.

2301− splitHang = splitHang' 0 id

2302−

2303− splitHang' !n l (Just (c, r):xs)

2304− = splitHang' (n + c) (l . (toHang c (r-1) ++)) xs

2305− splitHang' n l xs = (n, l, xs)

2306−

2307− -- Drop list items until the total width of the dropped items

2308− -- exceeds the passed width.

2309− dropToWidth _ n l | n < 1 = l

2310− dropToWidth wproj n (c:cs) = dropToWidth wproj (n - wproj c) cs

2311− dropToWidth _ _ [] = []

2312−

2313−simpTable :: PandocMonad m => Text -> Bool -> LP m Blocks

2314−simpTable envname hasWidthParameter = try $ do

2315− when hasWidthParameter $ () <$ (spaces >> tok)

2316− skipopts

2317− colspecs <- parseAligns

2318− let (aligns, widths, prefsufs) = unzip3 colspecs

2319− optional $ controlSeq "caption" *> setCaption

2320− spaces

2321− optional label

2322− spaces

2323− optional lbreak

2324− spaces

2325− skipMany hline

2326− spaces

2327− header' <- option [] . try . fmap (:[]) $

2328− parseTableRow envname prefsufs <* lbreak <* many1 hline

2329− spaces

2330− rows <- sepEndBy (parseTableRow envname prefsufs)

2331− (lbreak <* optional (skipMany hline))

2332− spaces

2333− optional $ controlSeq "caption" *> setCaption

2334− spaces

2335− optional label

2336− spaces

2337− optional lbreak

2338− spaces

2339− lookAhead $ controlSeq "end" -- make sure we're at end

2340− let th = fixTableHead $ TableHead nullAttr header'

2341− let tbs = [fixTableBody $ TableBody nullAttr 0 [] rows]

2342− let tf = TableFoot nullAttr []

2343− return $ table emptyCaption (zip aligns widths) th tbs tf

2344−

2345−addTableCaption :: PandocMonad m => Blocks -> LP m Blocks

2346−addTableCaption = walkM go

2347− where go (Table attr c spec th tb tf) = do

2348− st <- getState

2349− let mblabel = sLastLabel st

2350− capt <- case (sCaption st, mblabel) of

2351− (Just ils, Nothing) -> return $ caption Nothing (plain ils)

2352− (Just ils, Just lab) -> do

2353− num <- getNextNumber sLastTableNum

2354− setState

2355− st{ sLastTableNum = num

2356− , sLabels = M.insert lab

2357− [Str (renderDottedNum num)]

2358− (sLabels st) }

2359− return $ caption Nothing (plain ils) -- add number??

2360− (Nothing, _) -> return c

2361− let attr' = case (attr, mblabel) of

2362− ((_,classes,kvs), Just ident) ->

2363− (ident,classes,kvs)

2364− _ -> attr

2365− return $ addAttrDiv attr' $ Table nullAttr capt spec th tb tf

2366− go x = return x

2367−

2368−-- TODO: For now we add a Div to contain table attributes, since

2369−-- most writers don't do anything yet with attributes on Table.

2370−-- This can be removed when that changes.

2371−addAttrDiv :: Attr -> Block -> Block

2372−addAttrDiv ("",[],[]) b = b

2373−addAttrDiv attr b = Div attr [b]

2374−

2375block :: PandocMonad m => LP m Blocks

2017block :: PandocMonad m => LP m Blocks

2376block = do

2018block = do

2377 res <- (mempty <$ spaces1)

2019 res <- (mempty <$ spaces1)

src/Text/Pandoc/Readers/LaTeX/Parsing.hs+33

@@ -54,6 +54,7 @@ module Text.Pandoc.Readers.LaTeX.Parsing

54 , comment

55 , anyTok

56 , singleChar

57+ , tokWith

57 , specialChars

58 , specialChars

58 , endline

59 , endline

59 , blankline

60 , blankline

@@ -80,6 +81,10 @@ module Text.Pandoc.Readers.LaTeX.Parsing

80 , rawopt

81 , rawopt

81 , overlaySpecification

82 , overlaySpecification

82 , getNextNumber

83 , getNextNumber

84+ , label

85+ , setCaption

86+ , resetCaption

87+ , env

83 ) where

88 ) where

85import Control.Applicative (many, (<|>))

90import Control.Applicative (many, (<|>))

@@ -914,3 +919,31 @@ getNextNumber getCurrentNum = do

914 Just n -> [n, 1]

919 Just n -> [n, 1]

915 Nothing -> [1]

920 Nothing -> [1]

916

921

922+label :: PandocMonad m => LP m ()

923+label = do

924+ controlSeq "label"

925+ t <- braced

926+ updateState $ \st -> st{ sLastLabel = Just $ untokenize t }

927+

928+setCaption :: PandocMonad m => LP m Inlines -> LP m ()

929+setCaption inline = try $ do

930+ skipopts

931+ ils <- tokWith inline

932+ optional $ try $ spaces *> label

933+ updateState $ \st -> st{ sCaption = Just ils }

934+

935+resetCaption :: PandocMonad m => LP m ()

936+resetCaption = updateState $ \st -> st{ sCaption = Nothing

937+ , sLastLabel = Nothing }

938+

939+env :: PandocMonad m => Text -> LP m a -> LP m a

940+env name p = p <* end_ name

941+

942+tokWith :: PandocMonad m => LP m Inlines -> LP m Inlines

943+tokWith inlineParser = try $ spaces >>

944+ grouped inlineParser

945+ <|> (lookAhead anyControlSeq >> inlineParser)

946+ <|> singleChar'

947+ where singleChar' = do

948+ Tok _ _ t <- singleChar

949+ return $ str t

src/Text/Pandoc/Readers/LaTeX/Table.hsnew file+373

@@ -0,0 +1,373 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Text.Pandoc.Readers.LaTeX.Table

4+ ( tableEnvironments )

5+where

7+import Data.Functor (($>))

8+import Text.Pandoc.Class

9+import Text.Pandoc.Readers.LaTeX.Parsing

10+import Text.Pandoc.Readers.LaTeX.Types

11+import Text.Pandoc.Builder as B

12+import qualified Data.Map as M

13+import Data.Text (Text)

14+import Data.Maybe (fromMaybe)

15+import qualified Data.Text as T

16+import Control.Applicative ((<|>), optional, many)

17+import Control.Monad (when, void)

18+import Text.Pandoc.Shared (safeRead, trim)

19+import Text.Pandoc.Logging (LogMessage(SkippedContent))

20+import Text.Pandoc.Walk (walkM)

21+import Text.Pandoc.Parsing hiding (blankline, many, mathDisplay, mathInline,

22+ optional, space, spaces, withRaw, (<|>))

23+

24+tableEnvironments :: PandocMonad m

25+ => LP m Blocks

26+ -> LP m Inlines

27+ -> M.Map Text (LP m Blocks)

28+tableEnvironments blocks inline =

29+ M.fromList

30+ [ ("longtable", env "longtable" $

31+ resetCaption *>

32+ simpTable blocks inline "longtable" False >>= addTableCaption)

33+ , ("table", env "table" $

34+ skipopts *> resetCaption *> blocks >>= addTableCaption)

35+ , ("tabular*", env "tabular*" $ simpTable blocks inline "tabular*" True)

36+ , ("tabularx", env "tabularx" $ simpTable blocks inline "tabularx" True)

37+ , ("tabular", env "tabular" $ simpTable blocks inline "tabular" False)

38+ ]

39+

40+hline :: PandocMonad m => LP m ()

41+hline = try $ do

42+ spaces

43+ controlSeq "hline" <|>

44+ -- booktabs rules:

45+ controlSeq "toprule" <|>

46+ controlSeq "bottomrule" <|>

47+ controlSeq "midrule" <|>

48+ controlSeq "endhead" <|>

49+ controlSeq "endfirsthead"

50+ spaces

51+ optional rawopt

52+ return ()

53+

54+lbreak :: PandocMonad m => LP m Tok

55+lbreak = (controlSeq "\\" <|> controlSeq "tabularnewline")

56+ <* skipopts <* spaces

57+

58+amp :: PandocMonad m => LP m Tok

59+amp = symbol '&'

60+

61+-- Split a Word into individual Symbols (for parseAligns)

62+splitWordTok :: PandocMonad m => LP m ()

63+splitWordTok = do

64+ inp <- getInput

65+ case inp of

66+ (Tok spos Word t : rest) ->

67+ setInput $ map (Tok spos Symbol . T.singleton) (T.unpack t) <> rest

68+ _ -> return ()

69+

70+parseAligns :: PandocMonad m => LP m [(Alignment, ColWidth, ([Tok], [Tok]))]

71+parseAligns = try $ do

72+ let maybeBar = skipMany

73+ (try $ sp *> (() <$ symbol '|' <|> () <$ (symbol '@' >> braced)))

74+ let cAlign = AlignCenter <$ symbol 'c'

75+ let lAlign = AlignLeft <$ symbol 'l'

76+ let rAlign = AlignRight <$ symbol 'r'

77+ let parAlign = AlignLeft <$ symbol 'p'

78+ -- aligns from tabularx

79+ let xAlign = AlignLeft <$ symbol 'X'

80+ let mAlign = AlignLeft <$ symbol 'm'

81+ let bAlign = AlignLeft <$ symbol 'b'

82+ let alignChar = splitWordTok *> ( cAlign <|> lAlign <|> rAlign <|> parAlign

83+ <|> xAlign <|> mAlign <|> bAlign )

84+ let alignPrefix = symbol '>' >> braced

85+ let alignSuffix = symbol '<' >> braced

86+ let colWidth = try $ do

87+ symbol '{'

88+ ds <- trim . untokenize <$> manyTill anyTok (controlSeq "linewidth")

89+ spaces

90+ symbol '}'

91+ return $ safeRead ds

92+ let alignSpec = do

93+ pref <- option [] alignPrefix

94+ spaces

95+ al <- alignChar

96+ width <- colWidth <|> option Nothing (do s <- untokenize <$> braced

97+ pos <- getPosition

98+ report $ SkippedContent s pos

99+ return Nothing)

100+ spaces

101+ suff <- option [] alignSuffix

102+ return (al, width, (pref, suff))

103+ let starAlign = do -- '*{2}{r}' == 'rr', we just expand like a macro

104+ symbol '*'

105+ spaces

106+ ds <- trim . untokenize <$> braced

107+ spaces

108+ spec <- braced

109+ case safeRead ds of

110+ Just n ->

111+ getInput >>= setInput . (mconcat (replicate n spec) ++)

112+ Nothing -> Prelude.fail $ "Could not parse " <> T.unpack ds <> " as number"

113+ bgroup

114+ spaces

115+ maybeBar

116+ aligns' <- many $ try $ spaces >> optional starAlign >>

117+ (alignSpec <* maybeBar)

118+ spaces

119+ egroup

120+ spaces

121+ return $ map toSpec aligns'

122+ where

123+ toColWidth (Just w) | w > 0 = ColWidth w

124+ toColWidth _ = ColWidthDefault

125+ toSpec (x, y, z) = (x, toColWidth y, z)

126+

127+-- N.B. this parser returns a Row that may have erroneous empty cells

128+-- in it. See the note above fixTableHead for details.

129+parseTableRow :: PandocMonad m

130+ => LP m Blocks -- ^ block parser

131+ -> LP m Inlines -- ^ inline parser

132+ -> Text -- ^ table environment name

133+ -> [([Tok], [Tok])] -- ^ pref/suffixes

134+ -> LP m Row

135+parseTableRow blocks inline envname prefsufs = do

136+ notFollowedBy (spaces *> end_ envname)

137+ -- add prefixes and suffixes in token stream:

138+ let celltoks (pref, suff) = do

139+ prefpos <- getPosition

140+ contents <- mconcat <$>

141+ many ( snd <$> withRaw

142+ ((lookAhead (controlSeq "parbox") >>

143+ void blocks) -- #5711

144+ <|>

145+ (lookAhead (controlSeq "begin") >> void inline)

146+ <|>

147+ (lookAhead (symbol '$') >> void inline))

148+ <|>

149+ (do notFollowedBy

150+ (() <$ amp <|> () <$ lbreak <|> end_ envname)

151+ count 1 anyTok) )

152+

153+ suffpos <- getPosition

154+ option [] (count 1 amp)

155+ return $ map (setpos prefpos) pref ++ contents ++ map (setpos suffpos) suff

156+ rawcells <- mapM celltoks prefsufs

157+ cells <- mapM (parseFromToks (parseTableCell blocks)) rawcells

158+ spaces

159+ return $ Row nullAttr cells

160+

161+parseTableCell :: PandocMonad m => LP m Blocks -> LP m Cell

162+parseTableCell blocks = do

163+ spaces

164+ updateState $ \st -> st{ sInTableCell = True }

165+ cell' <- multicolumnCell blocks

166+ <|> multirowCell blocks

167+ <|> parseSimpleCell

168+ <|> parseEmptyCell

169+ updateState $ \st -> st{ sInTableCell = False }

170+ spaces

171+ return cell'

172+ where

173+ -- The parsing of empty cells is important in LaTeX, especially when dealing

174+ -- with multirow/multicolumn. See #6603.

175+ parseEmptyCell = spaces $> emptyCell

176+ parseSimpleCell = simpleCell <$> (plainify <$> blocks)

177+

178+

179+cellAlignment :: PandocMonad m => LP m Alignment

180+cellAlignment = skipMany (symbol '|') *> alignment <* skipMany (symbol '|')

181+ where

182+ alignment = do

183+ c <- untoken <$> singleChar

184+ return $ case c of

185+ "l" -> AlignLeft

186+ "r" -> AlignRight

187+ "c" -> AlignCenter

188+ "*" -> AlignDefault

189+ _ -> AlignDefault

190+

191+plainify :: Blocks -> Blocks

192+plainify bs = case toList bs of

193+ [Para ils] -> plain (fromList ils)

194+ _ -> bs

195+

196+multirowCell :: PandocMonad m => LP m Blocks -> LP m Cell

197+multirowCell blocks = controlSeq "multirow" >> do

198+ -- Full prototype for \multirow macro is:

199+ -- \multirow[vpos]{nrows}[bigstruts]{width}[vmove]{text}

200+ -- However, everything except `nrows` and `text` make

201+ -- sense in the context of the Pandoc AST

202+ _ <- optional $ symbol '[' *> cellAlignment <* symbol ']' -- vertical position

203+ nrows <- fmap (fromMaybe 1 . safeRead . untokenize) braced

204+ _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- bigstrut-related

205+ _ <- symbol '{' *> manyTill anyTok (symbol '}') -- Cell width

206+ _ <- optional $ symbol '[' *> manyTill anyTok (symbol ']') -- Length used for fine-tuning

207+ content <- symbol '{' *> (plainify <$> blocks) <* symbol '}'

208+ return $ cell AlignDefault (RowSpan nrows) (ColSpan 1) content

209+

210+multicolumnCell :: PandocMonad m => LP m Blocks -> LP m Cell

211+multicolumnCell blocks = controlSeq "multicolumn" >> do

212+ span' <- fmap (fromMaybe 1 . safeRead . untokenize) braced

213+ alignment <- symbol '{' *> cellAlignment <* symbol '}'

214+

215+ let singleCell = do

216+ content <- plainify <$> blocks

217+ return $ cell alignment (RowSpan 1) (ColSpan span') content

218+

219+ -- Two possible contents: either a \multirow cell, or content.

220+ -- E.g. \multicol{1}{c}{\multirow{2}{1em}{content}}

221+ -- Note that a \multirow cell can be nested in a \multicolumn,

222+ -- but not the other way around. See #6603

223+ let nestedCell = do

224+ (Cell _ _ (RowSpan rs) _ bs) <- multirowCell blocks

225+ return $ cell

226+ alignment

227+ (RowSpan rs)

228+ (ColSpan span')

229+ (fromList bs)

230+

231+ symbol '{' *> (nestedCell <|> singleCell) <* symbol '}'

232+

233+-- LaTeX tables are stored with empty cells underneath multirow cells

234+-- denoting the grid spaces taken up by them. More specifically, if a

235+-- cell spans m rows, then it will overwrite all the cells in the

236+-- columns it spans for (m-1) rows underneath it, requiring padding

237+-- cells in these places. These padding cells need to be removed for

238+-- proper table reading. See #6603.

239+--

240+-- These fixTable functions do not otherwise fix up malformed

241+-- input tables: that is left to the table builder.

242+fixTableHead :: TableHead -> TableHead

243+fixTableHead (TableHead attr rows) = TableHead attr rows'

244+ where

245+ rows' = fixTableRows rows

246+

247+fixTableBody :: TableBody -> TableBody

248+fixTableBody (TableBody attr rhc th tb)

249+ = TableBody attr rhc th' tb'

250+ where

251+ th' = fixTableRows th

252+ tb' = fixTableRows tb

253+

254+fixTableRows :: [Row] -> [Row]

255+fixTableRows = fixTableRows' $ repeat Nothing

256+ where

257+ fixTableRows' oldHang (Row attr cells : rs)

258+ = let (newHang, cells') = fixTableRow oldHang cells

259+ rs' = fixTableRows' newHang rs

260+ in Row attr cells' : rs'

261+ fixTableRows' _ [] = []

262+

263+-- The overhang is represented as Just (relative cell dimensions) or

264+-- Nothing for an empty grid space.

265+fixTableRow :: [Maybe (ColSpan, RowSpan)] -> [Cell] -> ([Maybe (ColSpan, RowSpan)], [Cell])

266+fixTableRow oldHang cells

267+ -- If there's overhang, drop cells until their total width meets the

268+ -- width of the occupied grid spaces (or we run out)

269+ | (n, prefHang, restHang) <- splitHang oldHang

270+ , n > 0

271+ = let cells' = dropToWidth getCellW n cells

272+ (restHang', cells'') = fixTableRow restHang cells'

273+ in (prefHang restHang', cells'')

274+ -- Otherwise record the overhang of a pending cell and fix the rest

275+ -- of the row

276+ | c@(Cell _ _ h w _):cells' <- cells

277+ = let h' = max 1 h

278+ w' = max 1 w

279+ oldHang' = dropToWidth getHangW w' oldHang

280+ (newHang, cells'') = fixTableRow oldHang' cells'

281+ in (toHang w' h' <> newHang, c : cells'')

282+ | otherwise

283+ = (oldHang, [])

284+ where

285+ getCellW (Cell _ _ _ w _) = w

286+ getHangW = maybe 1 fst

287+ getCS (ColSpan n) = n

288+

289+ toHang c r

290+ | r > 1 = [Just (c, r)]

291+ | otherwise = replicate (getCS c) Nothing

292+

293+ -- Take the prefix of the overhang list representing filled grid

294+ -- spaces. Also return the remainder and the length of this prefix.

295+ splitHang = splitHang' 0 id

296+

297+ splitHang' !n l (Just (c, r):xs)

298+ = splitHang' (n + c) (l . (toHang c (r-1) ++)) xs

299+ splitHang' n l xs = (n, l, xs)

300+

301+ -- Drop list items until the total width of the dropped items

302+ -- exceeds the passed width.

303+ dropToWidth _ n l | n < 1 = l

304+ dropToWidth wproj n (c:cs) = dropToWidth wproj (n - wproj c) cs

305+ dropToWidth _ _ [] = []

306+

307+simpTable :: PandocMonad m

308+ => LP m Blocks

309+ -> LP m Inlines

310+ -> Text

311+ -> Bool

312+ -> LP m Blocks

313+simpTable blocks inline envname hasWidthParameter = try $ do

314+ when hasWidthParameter $ () <$ tokWith inline

315+ skipopts

316+ colspecs <- parseAligns

317+ let (aligns, widths, prefsufs) = unzip3 colspecs

318+ optional $ controlSeq "caption" *> setCaption inline

319+ spaces

320+ optional label

321+ spaces

322+ optional lbreak

323+ spaces

324+ skipMany hline

325+ spaces

326+ header' <- option [] . try . fmap (:[]) $

327+ parseTableRow blocks inline envname prefsufs <*

328+ lbreak <* many1 hline

329+ spaces

330+ rows <- sepEndBy (parseTableRow blocks inline envname prefsufs)

331+ (lbreak <* optional (skipMany hline))

332+ spaces

333+ optional $ controlSeq "caption" *> setCaption inline

334+ spaces

335+ optional label

336+ spaces

337+ optional lbreak

338+ spaces

339+ lookAhead $ controlSeq "end" -- make sure we're at end

340+ let th = fixTableHead $ TableHead nullAttr header'

341+ let tbs = [fixTableBody $ TableBody nullAttr 0 [] rows]

342+ let tf = TableFoot nullAttr []

343+ return $ table emptyCaption (zip aligns widths) th tbs tf

344+

345+addTableCaption :: PandocMonad m => Blocks -> LP m Blocks

346+addTableCaption = walkM go

347+ where go (Table attr c spec th tb tf) = do

348+ st <- getState

349+ let mblabel = sLastLabel st

350+ capt <- case (sCaption st, mblabel) of

351+ (Just ils, Nothing) -> return $ caption Nothing (plain ils)

352+ (Just ils, Just lab) -> do

353+ num <- getNextNumber sLastTableNum

354+ setState

355+ st{ sLastTableNum = num

356+ , sLabels = M.insert lab

357+ [Str (renderDottedNum num)]

358+ (sLabels st) }

359+ return $ caption Nothing (plain ils) -- add number??

360+ (Nothing, _) -> return c

361+ let attr' = case (attr, mblabel) of

362+ ((_,classes,kvs), Just ident) ->

363+ (ident,classes,kvs)

364+ _ -> attr

365+ return $ addAttrDiv attr' $ Table nullAttr capt spec th tb tf

366+ go x = return x

367+

368+-- TODO: For now we add a Div to contain table attributes, since

369+-- most writers don't do anything yet with attributes on Table.

370+-- This can be removed when that changes.

371+addAttrDiv :: Attr -> Block -> Block

372+addAttrDiv ("",[],[]) b = b

373+addAttrDiv attr b = Div attr [b]