summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Blocks.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Blocks.hs')
-rw-r--r--src/Text/Pandoc/Blocks.hs146
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
+