From 1a8b32afd5cb5b230ff5170e4203fc8a361f140d Mon Sep 17 00:00:00 2001
From: fiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b>
Date: Wed, 4 Jul 2007 18:53:12 +0000
Subject: Added Text.Pandoc.Blocks module for prettyprinting of text tables.

git-svn-id: https://pandoc.googlecode.com/svn/trunk@620 788f1e2b-df1e-0410-8736-df70ead52e1b
---
 src/Text/Pandoc/Blocks.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)
 create mode 100644 src/Text/Pandoc/Blocks.hs

(limited to 'src/Text/Pandoc/Blocks.hs')

diff --git a/src/Text/Pandoc/Blocks.hs b/src/Text/Pandoc/Blocks.hs
new file mode 100644
index 000000000..995b2d009
--- /dev/null
+++ b/src/Text/Pandoc/Blocks.hs
@@ -0,0 +1,63 @@
+module Text.Blocks
+               ( 
+                docToBlock,
+                blockToDoc,
+                widthOfBlock,
+                heightOfBlock,
+                hcatBlocks,
+                hsepBlocks
+               )
+where
+
+import Text.PrettyPrint
+import Data.List (transpose, intersperse)
+
+data TextBlock = TextBlock Int Int [String] -- width height lines
+instance Show TextBlock where
+  show x = show $ blockToDoc x
+
+docToBlock :: Int -> Doc -> TextBlock
+docToBlock width doc =
+  let rendered    = renderStyle (style {lineLength = width, 
+                                        ribbonsPerLine = 1}) doc
+      lns         = lines rendered
+      chop []     = []
+      chop (l:ls) = if length l > width
+                       then (take width l):(chop ((drop width l):ls))
+                       else l:(chop ls)
+      lns'        = chop lns
+  in  TextBlock width (length lns') lns' 
+
+blockToDoc :: TextBlock -> Doc
+blockToDoc (TextBlock _ _ lns) = 
+  if null lns
+     then empty
+     else text $ unlines (init lns) ++ last lns  -- to avoid trailing \n
+
+widthOfBlock :: TextBlock -> Int
+widthOfBlock (TextBlock width _ _) = width
+
+heightOfBlock :: TextBlock -> Int
+heightOfBlock (TextBlock _ height _) = height
+
+-- pad line out to width using spaces
+hPad :: Int -> String -> String
+hPad width line = 
+  let lineLength = length line
+  in  if lineLength <= width 
+         then line ++ replicate (width - lineLength) ' '
+         else take width line
+
+hcatBlocks :: [TextBlock] -> TextBlock
+hcatBlocks [] = TextBlock 0 0 []
+hcatBlocks ((TextBlock width1 height1 lns1):xs) = 
+  let (TextBlock width2 height2 lns2) = hcatBlocks xs
+      height = max height1 height2
+      width  = width1 + width2
+      lns1'  = map (hPad width1) $ lns1 ++ replicate (height - height1) ""
+      lns2'  = lns2 ++ replicate (height - height2) ""
+      lns    = zipWith (++) lns1' lns2'
+   in TextBlock width height lns 
+
+hsepBlocks = hcatBlocks . (intersperse (TextBlock 1 1 [" "]))
+
-- 
cgit v1.2.3