From be12ae3bca4f1c2d712e412b11a14b6473c7ab10 Mon Sep 17 00:00:00 2001
From: John MacFarlane <jgm@berkeley.edu>
Date: Fri, 16 Mar 2018 22:38:34 -0700
Subject: Better table handling for Haddock.
In the reader, we use the new Table type in Haddock.
Note that tables with col/rowspans will not translate
well into Pandoc.
In the writer, we now render tables always as grid tables,
since Haddock supports these.
---
src/Text/Pandoc/Readers/Haddock.hs | 15 ++++++++-
src/Text/Pandoc/Writers/Haddock.hs | 63 +++-----------------------------------
2 files changed, 18 insertions(+), 60 deletions(-)
(limited to 'src/Text')
diff --git a/src/Text/Pandoc/Readers/Haddock.hs b/src/Text/Pandoc/Readers/Haddock.hs
index 2f76fc1a0..b593c4cc8 100644
--- a/src/Text/Pandoc/Readers/Haddock.hs
+++ b/src/Text/Pandoc/Readers/Haddock.hs
@@ -19,7 +19,7 @@ import Data.List (intersperse, stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Text (Text, unpack)
import Documentation.Haddock.Parser
-import Documentation.Haddock.Types
+import Documentation.Haddock.Types as H
import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class (PandocMonad)
@@ -85,6 +85,18 @@ docHToBlocks d' =
DocProperty s -> B.codeBlockWith ("",["property","haskell"],[]) (trim s)
DocExamples es -> mconcat $ map (\e ->
makeExample ">>>" (exampleExpression e) (exampleResult e)) es
+ DocTable H.Table{ tableHeaderRows = headerRows
+ , tableBodyRows = bodyRows
+ }
+ -> let toCells = map (docHToBlocks . tableCellContents) . tableRowCells
+ (header, body) =
+ if null headerRows
+ then ([], map toCells bodyRows)
+ else (toCells (head headerRows),
+ map toCells (tail headerRows ++ bodyRows))
+ colspecs = replicate (maximum (map length body))
+ (AlignDefault, 0.0)
+ in B.table mempty colspecs header body
where inlineFallback = B.plain $ docHToInlines False d'
consolidatePlains = B.fromList . consolidatePlains' . B.toList
@@ -133,6 +145,7 @@ docHToInlines isCode d' =
DocAName s -> B.spanWith (s,["anchor"],[]) mempty
DocProperty _ -> mempty
DocExamples _ -> mempty
+ DocTable _ -> mempty
-- | Create an 'Example', stripping superfluous characters as appropriate
makeExample :: String -> String -> [String] -> Blocks
diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs
index 688c1f390..3f96f5802 100644
--- a/src/Text/Pandoc/Writers/Haddock.hs
+++ b/src/Text/Pandoc/Writers/Haddock.hs
@@ -35,7 +35,6 @@ Haddock: <http://www.haskell.org/haddock/doc/html/>
module Text.Pandoc.Writers.Haddock (writeHaddock) where
import Control.Monad.State.Strict
import Data.Default
-import Data.List (intersperse, transpose)
import Data.Text (Text)
import Text.Pandoc.Class (PandocMonad, report)
import Text.Pandoc.Definition
@@ -136,29 +135,15 @@ blockToHaddock _ (CodeBlock (_,_,_) str) =
-- Nothing in haddock corresponds to block quotes:
blockToHaddock opts (BlockQuote blocks) =
blockListToHaddock opts blocks
--- Haddock doesn't have tables. Use haddock tables in code.
blockToHaddock opts (Table caption aligns widths headers rows) = do
caption' <- inlineListToHaddock opts caption
let caption'' = if null caption
then empty
else blankline <> caption' <> blankline
- rawHeaders <- mapM (blockListToHaddock opts) headers
- rawRows <- mapM (mapM (blockListToHaddock opts)) rows
- let isSimple = all (==0) widths
- let isPlainBlock (Plain _) = True
- isPlainBlock _ = False
- let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows)
- (nst,tbl) <- case True of
- _ | isSimple -> (nest 2,) <$>
- pandocTable opts (all null headers) aligns widths
- rawHeaders rawRows
- | not hasBlocks -> (nest 2,) <$>
- pandocTable opts (all null headers) aligns widths
- rawHeaders rawRows
- | otherwise -> (id,) <$>
- gridTable opts blockListToHaddock
- (all null headers) aligns widths headers rows
- return $ prefixed "> " (nst $ tbl $$ blankline $$ caption'') $$ blankline
+ tbl <- gridTable opts blockListToHaddock
+ (all null headers) (map (\_ -> AlignDefault) aligns)
+ widths headers rows
+ return $ prefixed "> " (tbl $$ blankline $$ caption'') $$ blankline
blockToHaddock opts (BulletList items) = do
contents <- mapM (bulletListItemToHaddock opts) items
return $ cat contents <> blankline
@@ -174,46 +159,6 @@ blockToHaddock opts (DefinitionList items) = do
contents <- mapM (definitionListItemToHaddock opts) items
return $ cat contents <> blankline
-pandocTable :: PandocMonad m
- => WriterOptions -> Bool -> [Alignment] -> [Double]
- -> [Doc] -> [[Doc]] -> StateT WriterState m Doc
-pandocTable opts headless aligns widths rawHeaders rawRows = do
- let isSimple = all (==0) widths
- let alignHeader alignment = case alignment of
- AlignLeft -> lblock
- AlignCenter -> cblock
- AlignRight -> rblock
- AlignDefault -> lblock
- let numChars = maximum . map offset
- let widthsInChars = if isSimple
- then map ((+2) . numChars)
- $ transpose (rawHeaders : rawRows)
- else map
- (floor . (fromIntegral (writerColumns opts) *))
- widths
- let makeRow = hcat . intersperse (lblock 1 (text " ")) .
- zipWith3 alignHeader aligns widthsInChars
- let rows' = map makeRow rawRows
- let head' = makeRow rawHeaders
- let maxRowHeight = maximum $ map height (head':rows')
- let underline = cat $ intersperse (text " ") $
- map (\width -> text (replicate width '-')) widthsInChars
- let border
- | maxRowHeight > 1 = text (replicate (sum widthsInChars +
- length widthsInChars - 1) '-')
- | headless = underline
- | otherwise = empty
- let head'' = if headless
- then empty
- else border <> cr <> head'
- let body = if maxRowHeight > 1
- then vsep rows'
- else vcat rows'
- let bottom = if headless
- then underline
- else border
- return $ head'' $$ underline $$ body $$ bottom
-
-- | Convert bullet list item (list of blocks) to haddock
bulletListItemToHaddock :: PandocMonad m
=> WriterOptions -> [Block] -> StateT WriterState m Doc
--
cgit v1.2.3