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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
module Prettify
(
-- * Constructors
Doc(..)
-- * Basic combinators
, (Prettify.<>)
, empty
, char
, text
, line
-- * Derived combinators
, double
, fsep
, hcat
, punctuate
-- * Renderers
, compact
, pretty
) where
{--
import Data.Monoid (Monoid(..))
instance Monoid Doc where
mempty = empty
mappend = (<>)
--}
{-- snippet Doc --}
data Doc = Empty
| Char Char
| Text String
| Line
| Concat Doc Doc
| Union Doc Doc
deriving (Show,Eq)
{-- /snippet Doc --}
{-- snippet append --}
(<>) :: Doc -> Doc -> Doc
Empty <> y = y
x <> Empty = x
x <> y = x `Concat` y
{-- /snippet append --}
{-- snippet basic --}
empty :: Doc
empty = Empty
char :: Char -> Doc
char c = Char c
text :: String -> Doc
text "" = Empty
text s = Text s
double :: Double -> Doc
double d = text (show d)
{-- /snippet basic --}
{-- snippet line --}
line :: Doc
line = Line
{-- /snippet line --}
{-- snippet hcat --}
hcat :: [Doc] -> Doc
hcat = fold (Prettify.<>)
fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold f = foldr f empty
{-- /snippet hcat --}
{-- snippet fsep --}
fsep :: [Doc] -> Doc
fsep = fold (</>)
(</>) :: Doc -> Doc -> Doc
x </> y = x Prettify.<> softline Prettify.<> y
softline :: Doc
softline = group line
{-- /snippet fsep --}
{-- snippet group --}
group :: Doc -> Doc
group x = flatten x `Union` x
{-- /snippet group --}
{-- snippet flatten --}
flatten :: Doc -> Doc
flatten (x `Concat` y) = flatten x `Concat` flatten y
flatten Line = Char ' '
flatten (x `Union` _) = flatten x
flatten other = other
{-- /snippet flatten --}
{-- snippet punctuate --}
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p [] = []
punctuate p [d] = [d]
punctuate p (d:ds) = (d Prettify.<> p) : punctuate p ds
{-- /snippet punctuate --}
{-- snippet compact --}
compact :: Doc -> String
compact x = transform [x]
where transform [] = ""
transform (d:ds) =
case d of
Empty -> transform ds
Char c -> c : transform ds
Text s -> s ++ transform ds
Line -> '\n' : transform ds
a `Concat` b -> transform (a:b:ds)
_ `Union` b -> transform (b:ds)
{-- /snippet compact --}
{-- snippet pretty.type --}
pretty :: Int -> Doc -> String
{-- /snippet pretty.type --}
{-- snippet pretty --}
pretty width x = best 0 [x]
where best col (d:ds) =
case d of
Empty -> best col ds
Char c -> c : best (col + 1) ds
Text s -> s ++ best (col + length s) ds
Line -> '\n' : best 0 ds
a `Concat` b -> best col (a:b:ds)
a `Union` b -> nicest col (best col (a:ds))
(best col (b:ds))
best _ _ = ""
nicest col a b | (width - least) `fits` a = a
| otherwise = b
where least = min width col
{-- /snippet pretty --}
{-- snippet fits --}
fits :: Int -> String -> Bool
w `fits` _ | w < 0 = False
w `fits` "" = True
w `fits` ('\n':_) = True
w `fits` (c:cs) = (w - 1) `fits` cs
{-- /snippet fits --}
{-- snippet nest --}
nest :: Int -> Doc -> Doc
{-- /snippet nest --}
nest = undefined
{-- snippet fill --}
fill :: Int -> Doc -> Doc
{-- /snippet fill --}
fill = undefined
--instance Show Doc where
-- show doc = pretty 80 doc
|
