Moved all haskell source to src subdirectory.

git-svn-id: https://pandoc.googlecode.com/svn/trunk@1528 788f1e2b-df1e-0410-8736-df70ead52e1b

1 files changed, 146 insertions, 0 deletions

diff --git a/src/Text/Pandoc/Blocks.hs b/src/Text/Pandoc/Blocks.hs
new file mode 100644
index 000000000..122931773
--- /dev/null
+++ b/src/Text/Pandoc/Blocks.hs
@@ -0,0 +1,146 @@
+{-
+Copyright (C) 2007 John MacFarlane <jgm@berkeley.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.Blocks
+   Copyright   : Copyright (C) 2007 John MacFarlane
+   License     : GNU GPL, version 2 or above 
+
+   Maintainer  : John MacFarlane <jgm@berkeley.edu>
+   Stability   : alpha
+   Portability : portable
+
+Functions for the manipulation of fixed-width blocks of text.
+These are used in the construction of plain-text tables.
+-}
+
+module Text.Pandoc.Blocks
+               ( 
+                TextBlock (..),
+                docToBlock,
+                blockToDoc,
+                widthOfBlock,
+                heightOfBlock,
+                hcatBlocks,
+                hsepBlocks,
+                centerAlignBlock,
+                leftAlignBlock,
+                rightAlignBlock
+               )
+where
+import Text.PrettyPrint
+import Data.List ( intersperse )
+
+-- | A fixed-width block of text.  Parameters are width of block,
+-- height of block, and list of lines.
+data TextBlock = TextBlock Int Int [String]
+instance Show TextBlock where
+  show x = show $ blockToDoc x
+
+-- | Break lines in a list of lines so that none are greater than
+-- a given width.
+breakLines :: Int      -- ^ Maximum length of lines.
+           -> [String] -- ^ List of lines.
+           -> [String]
+breakLines _ [] = []
+breakLines width (l:ls) =
+  if length l > width
+     then (take width l):(breakLines width ((drop width l):ls))
+     else l:(breakLines width ls)
+
+-- | Convert a @Doc@ element into a @TextBlock@ with a specified width. 
+docToBlock :: Int  -- ^ Width of text block.
+           -> Doc  -- ^ @Doc@ to convert.
+           -> TextBlock
+docToBlock width doc =
+  let rendered    = renderStyle (style {lineLength = width, 
+                                        ribbonsPerLine = 1}) doc
+      lns         = breakLines width $ lines rendered
+  in  TextBlock width (length lns) lns
+
+-- | Convert a @TextBlock@ to a @Doc@ element.
+blockToDoc :: TextBlock -> Doc
+blockToDoc (TextBlock _ _ lns) = 
+  if null lns
+     then empty
+     else vcat $ map text lns
+
+-- | Returns width of a @TextBlock@ (number of columns).
+widthOfBlock :: TextBlock -> Int
+widthOfBlock (TextBlock width _ _) = width
+
+-- | Returns height of a @TextBlock@ (number of rows).
+heightOfBlock :: TextBlock -> Int
+heightOfBlock (TextBlock _ height _) = height
+
+-- | Pads a string out to a given width using spaces.
+hPad :: Int     -- ^ Desired width.
+     -> String  -- ^ String to pad.
+     -> String
+hPad width line = 
+  let linelen = length line
+  in  if linelen <= width
+         then line ++ replicate (width - linelen) ' '
+         else take width line
+
+-- | Concatenates a list of @TextBlock@s into a new @TextBlock@ in
+-- which they appear side by side.
+hcatBlocks :: [TextBlock] -> TextBlock
+hcatBlocks [] = TextBlock 0 0 []
+hcatBlocks [x] = x -- This is not redundant!  We don't want last item hPad'd.
+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 
+
+-- | Like @hcatBlocks@, but inserts space between the @TextBlock@s.
+hsepBlocks :: [TextBlock] -> TextBlock
+hsepBlocks = hcatBlocks . (intersperse (TextBlock 1 1 [" "]))
+
+isWhitespace :: Char -> Bool
+isWhitespace x = x `elem` " \t"
+
+-- | Left-aligns the contents of a @TextBlock@ within the block.
+leftAlignBlock :: TextBlock -> TextBlock
+leftAlignBlock (TextBlock width height lns) =
+  TextBlock width height $ map (dropWhile isWhitespace) lns
+
+-- | Right-aligns the contents of a @TextBlock@ within the block.
+rightAlignBlock :: TextBlock -> TextBlock
+rightAlignBlock (TextBlock width height lns) =
+  let rightAlignLine ln = 
+        let (spaces, rest) = span isWhitespace $ reverse $ hPad width ln
+        in  reverse (rest ++ spaces)
+  in  TextBlock width height $ map rightAlignLine lns
+
+-- | Centers the contents of a @TextBlock@ within the block.
+centerAlignBlock :: TextBlock -> TextBlock
+centerAlignBlock (TextBlock width height lns) = 
+  let centerAlignLine ln =
+        let ln' = hPad width ln
+            (startSpaces, rest) = span isWhitespace ln'
+            endSpaces = takeWhile isWhitespace (reverse ln')
+            numSpaces = length (startSpaces ++ endSpaces)
+            startSpaces' = replicate (quot numSpaces 2) ' '
+        in  startSpaces' ++ rest 
+  in  TextBlock width height $ map centerAlignLine lns
+