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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Syntax.Print where
-- pretty-printer generated by the BNF converter
import Transfer.Syntax.Abs
import Data.Char
import Data.List (intersperse)
-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0
type Doc = [ShowS] -> [ShowS]
doc :: ShowS -> Doc
doc = (:)
render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
rend i ss = case ss of
"[" :ts -> showChar '[' . rend i ts
"(" :ts -> showChar '(' . rend i ts
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
";" :ts -> showChar ';' . new i . rend i ts
t : "," :ts -> showString t . space "," . rend i ts
t : ")" :ts -> showString t . showChar ')' . rend i ts
t : "]" :ts -> showString t . showChar ']' . rend i ts
t :ts -> space t . rend i ts
_ -> id
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
space t = showString t . (\s -> if null s then "" else (' ':s))
parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
concatD :: [Doc] -> Doc
concatD = foldr (.) id
unwordsD :: [Doc] -> Doc
unwordsD = concatD . intersperse (doc (showChar ' '))
replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)
-- the printer class does the job
class Print a where
prt :: Int -> a -> Doc
instance Print Char where
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
instance Print String where
prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
_ | s == q -> showChar '\\' . showChar s
'\\'-> showString "\\\\"
'\n' -> showString "\\n"
'\t' -> showString "\\t"
_ -> showChar s
prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Integer where
prt _ x = doc (shows x)
instance Print Double where
prt _ x = doc (shows x)
instance Print (Tree c) where
prt _i e = case e of
Module imports decls -> prPrec _i 0 (concatD [prt 0 imports , prt 0 decls])
Import i -> prPrec _i 0 (concatD [doc (showString "import") , prt 0 i])
DataDecl i exp consdecls -> prPrec _i 0 (concatD [doc (showString "data") , prt 0 i , doc (showString ":") , prt 0 exp , doc (showString "where") , doc (showString "{") , prt 0 consdecls , doc (showString "}")])
TypeDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
ValueDecl i patterns guard exp -> prPrec _i 0 (concatD [prt 0 i , prt 0 patterns , prt 0 guard , doc (showString "=") , prt 0 exp])
DeriveDecl i0 i1 -> prPrec _i 0 (concatD [doc (showString "derive") , prt 0 i0 , prt 0 i1])
ConsDecl i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
GuardExp exp -> prPrec _i 0 (concatD [doc (showString "|") , prt 1 exp])
GuardNo -> prPrec _i 0 (concatD [])
POr pattern0 pattern1 -> prPrec _i 0 (concatD [prt 1 pattern0 , doc (showString "||") , prt 0 pattern1])
PListCons pattern0 pattern1 -> prPrec _i 1 (concatD [prt 2 pattern0 , doc (showString "::") , prt 1 pattern1])
PConsTop i pattern patterns -> prPrec _i 2 (concatD [prt 0 i , prt 3 pattern , prt 0 patterns])
PCons i patterns -> prPrec _i 3 (concatD [doc (showString "(") , prt 0 i , prt 0 patterns , doc (showString ")")])
PRec fieldpatterns -> prPrec _i 3 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
PEmptyList -> prPrec _i 3 (concatD [doc (showString "[") , doc (showString "]")])
PList commapatterns -> prPrec _i 3 (concatD [doc (showString "[") , prt 0 commapatterns , doc (showString "]")])
PTuple commapattern commapatterns -> prPrec _i 3 (concatD [doc (showString "(") , prt 0 commapattern , doc (showString ",") , prt 0 commapatterns , doc (showString ")")])
PType -> prPrec _i 3 (concatD [doc (showString "Type")])
PStr str -> prPrec _i 3 (concatD [prt 0 str])
PInt n -> prPrec _i 3 (concatD [prt 0 n])
PVar i -> prPrec _i 3 (concatD [prt 0 i])
PWild -> prPrec _i 3 (concatD [doc (showString "_")])
CommaPattern pattern -> prPrec _i 0 (concatD [prt 0 pattern])
FieldPattern i pattern -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 pattern])
EPi varorwild exp0 exp1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 varorwild , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
EPiNoVar exp0 exp1 -> prPrec _i 0 (concatD [prt 1 exp0 , doc (showString "->") , prt 0 exp1])
EAbs varorwild exp -> prPrec _i 1 (concatD [doc (showString "\\") , prt 0 varorwild , doc (showString "->") , prt 1 exp])
ELet letdefs exp -> prPrec _i 1 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 1 exp])
ECase exp cases -> prPrec _i 1 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EIf exp0 exp1 exp2 -> prPrec _i 1 (concatD [doc (showString "if") , prt 0 exp0 , doc (showString "then") , prt 0 exp1 , doc (showString "else") , prt 1 exp2])
EDo binds exp -> prPrec _i 1 (concatD [doc (showString "do") , doc (showString "{") , prt 0 binds , prt 0 exp , doc (showString "}")])
EBind exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString ">>=") , prt 4 exp1])
EBindC exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString ">>") , prt 4 exp1])
EOr exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "||") , prt 4 exp1])
EAnd exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "&&") , prt 5 exp1])
EEq exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "==") , prt 7 exp1])
ENe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "/=") , prt 7 exp1])
ELt exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "<") , prt 7 exp1])
ELe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString "<=") , prt 7 exp1])
EGt exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString ">") , prt 7 exp1])
EGe exp0 exp1 -> prPrec _i 6 (concatD [prt 7 exp0 , doc (showString ">=") , prt 7 exp1])
EListCons exp0 exp1 -> prPrec _i 7 (concatD [prt 8 exp0 , doc (showString "::") , prt 7 exp1])
EAdd exp0 exp1 -> prPrec _i 8 (concatD [prt 8 exp0 , doc (showString "+") , prt 9 exp1])
ESub exp0 exp1 -> prPrec _i 8 (concatD [prt 8 exp0 , doc (showString "-") , prt 9 exp1])
EMul exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "*") , prt 10 exp1])
EDiv exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "/") , prt 10 exp1])
EMod exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , doc (showString "%") , prt 10 exp1])
ENeg exp -> prPrec _i 10 (concatD [doc (showString "-") , prt 10 exp])
EApp exp0 exp1 -> prPrec _i 11 (concatD [prt 11 exp0 , prt 12 exp1])
EProj exp i -> prPrec _i 12 (concatD [prt 12 exp , doc (showString ".") , prt 0 i])
ERecType fieldtypes -> prPrec _i 13 (concatD [doc (showString "sig") , doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
ERec fieldvalues -> prPrec _i 13 (concatD [doc (showString "rec") , doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
EEmptyList -> prPrec _i 13 (concatD [doc (showString "[") , doc (showString "]")])
EList exps -> prPrec _i 13 (concatD [doc (showString "[") , prt 0 exps , doc (showString "]")])
ETuple exp exps -> prPrec _i 13 (concatD [doc (showString "(") , prt 0 exp , doc (showString ",") , prt 0 exps , doc (showString ")")])
EVar i -> prPrec _i 13 (concatD [prt 0 i])
EType -> prPrec _i 13 (concatD [doc (showString "Type")])
EStr str -> prPrec _i 13 (concatD [prt 0 str])
EInteger n -> prPrec _i 13 (concatD [prt 0 n])
EDouble d -> prPrec _i 13 (concatD [prt 0 d])
EMeta -> prPrec _i 13 (concatD [doc (showString "?")])
VVar i -> prPrec _i 0 (concatD [prt 0 i])
VWild -> prPrec _i 0 (concatD [doc (showString "_")])
LetDef i exp0 exp1 -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp1])
Case pattern guard exp -> prPrec _i 0 (concatD [prt 0 pattern , prt 0 guard , doc (showString "->") , prt 0 exp])
BindVar varorwild exp -> prPrec _i 0 (concatD [prt 0 varorwild , doc (showString "<-") , prt 0 exp])
BindNoVar exp -> prPrec _i 0 (concatD [prt 0 exp])
FieldType i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp])
FieldValue i exp -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 exp])
Ident str -> prPrec _i 0 (doc (showString str))
instance Print [Import] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Decl] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [ConsDecl] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [CommaPattern] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print [Pattern] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 3 x , prt 0 xs])
instance Print [FieldPattern] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [LetDef] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Case] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Bind] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldType] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [FieldValue] where
prt _ es = case es of
[] -> (concatD [])
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Exp] where
prt _ es = case es of
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
