blob: 995b2d009e397dd7fe83df98b43af33ecbc1292f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
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 [" "]))
|
