@@ -0,0 +1,63 @@
1+module Text.Blocks
2+ (
3+ docToBlock,
4+ blockToDoc,
5+ widthOfBlock,
6+ heightOfBlock,
7+ hcatBlocks,
8+ hsepBlocks
9+ )
10+where
11+
12+import Text.PrettyPrint
13+import Data.List (transpose, intersperse)
14+
15+data TextBlock = TextBlock Int Int [String] -- width height lines
16+instance Show TextBlock where
17+ show x = show $ blockToDoc x
18+
19+docToBlock :: Int -> Doc -> TextBlock
20+docToBlock width doc =
21+ let rendered = renderStyle (style {lineLength = width,
22+ ribbonsPerLine = 1}) doc
23+ lns = lines rendered
24+ chop [] = []
25+ chop (l:ls) = if length l > width
26+ then (take width l):(chop ((drop width l):ls))
27+ else l:(chop ls)
28+ lns' = chop lns
29+ in TextBlock width (length lns') lns'
30+
31+blockToDoc :: TextBlock -> Doc
32+blockToDoc (TextBlock _ _ lns) =
33+ if null lns
34+ then empty
35+ else text $ unlines (init lns) ++ last lns -- to avoid trailing \n
36+
37+widthOfBlock :: TextBlock -> Int
38+widthOfBlock (TextBlock width _ _) = width
39+
40+heightOfBlock :: TextBlock -> Int
41+heightOfBlock (TextBlock _ height _) = height
42+
43+-- pad line out to width using spaces
44+hPad :: Int -> String -> String
45+hPad width line =
46+ let lineLength = length line
47+ in if lineLength <= width
48+ then line ++ replicate (width - lineLength) ' '
49+ else take width line
50+
51+hcatBlocks :: [TextBlock] -> TextBlock
52+hcatBlocks [] = TextBlock 0 0 []
53+hcatBlocks ((TextBlock width1 height1 lns1):xs) =
54+ let (TextBlock width2 height2 lns2) = hcatBlocks xs
55+ height = max height1 height2
56+ width = width1 + width2
57+ lns1' = map (hPad width1) $ lns1 ++ replicate (height - height1) ""
58+ lns2' = lns2 ++ replicate (height - height2) ""
59+ lns = zipWith (++) lns1' lns2'
60+ in TextBlock width height lns
61+
62+hsepBlocks = hcatBlocks . (intersperse (TextBlock 1 1 [" "]))
63+