Allow alignments to be specified in Markdown grid tables.

2 files changed, 52 insertions, 26 deletions

diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 6c30fe3c3..b3459eec0 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -1271,14 +1271,22 @@ gridTableSplitLine :: [Int] -> String -> [String]
 gridTableSplitLine indices line = map removeFinalBar $ tail $
   splitStringByIndices (init indices) $ trimr line
 
-gridPart :: Char -> Parser [Char] st (Int, Int)
+gridPart :: Char -> Parser [Char] st ((Int, Int), Alignment)
 gridPart ch = do
+  leftColon <- option False (True <$ char ':')
   dashes <- many1 (char ch)
+  rightColon <- option False (True <$ char ':')
   char '+'
-  let lengthDashes = length dashes
-  return (lengthDashes, lengthDashes + 1)
-
-gridDashedLines :: Char -> Parser [Char] st [(Int,Int)]
+  let lengthDashes = length dashes + (if leftColon then 1 else 0) +
+                       (if rightColon then 1 else 0)
+  let alignment = case (leftColon, rightColon) of
+                       (True, True)   -> AlignCenter
+                       (True, False)  -> AlignLeft
+                       (False, True)  -> AlignRight
+                       (False, False) -> AlignDefault
+  return ((lengthDashes, lengthDashes + 1), alignment)
+
+gridDashedLines :: Char -> Parser [Char] st [((Int, Int), Alignment)]
 gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
 
 removeFinalBar :: String -> String
@@ -1296,19 +1304,17 @@ gridTableHeader headless = try $ do
   optional blanklines
   dashes <- gridDashedLines '-'
   rawContent  <- if headless
-                    then return $ repeat ""
-                    else many1
-                         (notFollowedBy (gridTableSep '=') >> char '|' >>
-                           many1Till anyChar newline)
-  if headless
-     then return ()
-     else gridTableSep '=' >> return ()
-  let lines'   = map snd dashes
+                    then return []
+                    else many1 (try (char '|' >> anyLine))
+  underDashes <- if headless
+                    then return dashes
+                    else gridDashedLines '='
+  guard $ length dashes == length underDashes
+  let lines'   = map (snd . fst) underDashes
   let indices  = scanl (+) 0 lines'
-  let aligns   = replicate (length lines') AlignDefault
-  -- RST does not have a notion of alignments
+  let aligns   = map snd underDashes
   let rawHeads = if headless
-                    then replicate (length dashes) ""
+                    then replicate (length underDashes) ""
                     else map (unlines . map trim) $ transpose
                        $ map (gridTableSplitLine indices) rawContent
   heads <- fmap sequence $ mapM (parseFromString parseBlocks . trim) rawHeads
@@ -1317,7 +1323,7 @@ gridTableHeader headless = try $ do
 gridTableRawLine :: [Int] -> MarkdownParser [String]
 gridTableRawLine indices = do
   char '|'
-  line <- many1Till anyChar newline
+  line <- anyLine
   return (gridTableSplitLine indices line)
 
 -- | Parse row of grid table.
diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs
index 6e6b6dcae..f46699d74 100644
--- a/src/Text/Pandoc/Writers/Markdown.hs
+++ b/src/Text/Pandoc/Writers/Markdown.hs
@@ -632,12 +632,13 @@ pandocTable opts headless aligns widths rawHeaders rawRows =  do
 
 gridTable :: WriterOptions -> Bool -> [Alignment] -> [Double]
           -> [Doc] -> [[Doc]] -> MD Doc
-gridTable opts headless _aligns widths headers' rawRows =  do
+gridTable opts headless aligns widths headers' rawRows =  do
   let numcols = length headers'
   let widths' = if all (==0) widths
                    then replicate numcols (1.0 / fromIntegral numcols)
                    else widths
-  let widthsInChars = map (floor . (fromIntegral (writerColumns opts) *)) widths'
+  let widthsInChars = map
+         ((\x -> x - 1) . floor . (fromIntegral (writerColumns opts) *)) widths'
   let hpipeBlocks blocks = hcat [beg, middle, end]
         where h       = maximum (1 : map height blocks)
               sep'    = lblock 3 $ vcat (map text $ replicate h " | ")
@@ -647,15 +648,34 @@ gridTable opts headless _aligns widths headers' rawRows =  do
   let makeRow = hpipeBlocks . zipWith lblock widthsInChars
   let head' = makeRow headers'
   let rows' = map (makeRow . map chomp) rawRows
-  let border ch = char '+' <> char ch <>
-                  (hcat $ intersperse (char ch <> char '+' <> char ch) $
-                          map (\l -> text $ replicate l ch) widthsInChars) <>
-                  char ch <> char '+'
-  let body = vcat $ intersperse (border '-') rows'
+  let borderpart ch align widthInChars =
+        let widthInChars' = if widthInChars < 1 then 1 else widthInChars
+        in (if (align == AlignLeft || align == AlignCenter)
+               then char ':'
+               else char ch) <>
+           text (replicate widthInChars' ch) <>
+           (if (align == AlignRight || align == AlignCenter)
+               then char ':'
+               else char ch)
+  let border ch aligns' widthsInChars' =
+        char '+' <>
+        hcat (intersperse (char '+') (zipWith (borderpart ch)
+                aligns' widthsInChars')) <> char '+'
+  let body = vcat $ intersperse (border '-' (repeat AlignDefault) widthsInChars)
+                    rows'
   let head'' = if headless
                   then empty
-                  else head' $$ border '='
-  return $ border '-' $$ head'' $$ body $$ border '-'
+                  else head' $$ border '=' aligns widthsInChars
+  if headless
+     then return $
+           border '-' aligns widthsInChars $$
+           body $$
+           border '-' (repeat AlignDefault) widthsInChars
+     else return $
+           border '-' (repeat AlignDefault) widthsInChars $$
+           head'' $$
+           body $$
+           border '-' (repeat AlignDefault) widthsInChars
 
 itemEndsWithTightList :: [Block] -> Bool
 itemEndsWithTightList bs =