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.

2 files changed, 18 insertions, 60 deletions

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