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
|
{-# 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 exp -> prPrec _i 0 (concatD [prt 0 i , prt 0 patterns , 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])
PConsTop i pattern patterns -> prPrec _i 0 (concatD [prt 0 i , prt 1 pattern , prt 0 patterns])
PCons i patterns -> prPrec _i 1 (concatD [doc (showString "(") , prt 0 i , prt 0 patterns , doc (showString ")")])
PRec fieldpatterns -> prPrec _i 1 (concatD [doc (showString "{") , prt 0 fieldpatterns , doc (showString "}")])
PType -> prPrec _i 1 (concatD [doc (showString "Type")])
PStr str -> prPrec _i 1 (concatD [prt 0 str])
PInt n -> prPrec _i 1 (concatD [prt 0 n])
PVar i -> prPrec _i 1 (concatD [prt 0 i])
PWild -> prPrec _i 1 (concatD [doc (showString "_")])
FieldPattern i pattern -> prPrec _i 0 (concatD [prt 0 i , doc (showString "=") , prt 0 pattern])
ELet letdefs exp -> prPrec _i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 letdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
ECase exp cases -> prPrec _i 0 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
EIf exp0 exp1 exp2 -> prPrec _i 0 (concatD [doc (showString "if") , prt 0 exp0 , doc (showString "then") , prt 0 exp1 , doc (showString "else") , prt 0 exp2])
EAbs varorwild exp -> prPrec _i 2 (concatD [doc (showString "\\") , prt 0 varorwild , doc (showString "->") , prt 0 exp])
EPi varorwild exp0 exp1 -> prPrec _i 2 (concatD [doc (showString "(") , prt 0 varorwild , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
EPiNoVar exp0 exp1 -> prPrec _i 2 (concatD [prt 3 exp0 , doc (showString "->") , prt 0 exp1])
EOr exp0 exp1 -> prPrec _i 3 (concatD [prt 4 exp0 , doc (showString "||") , prt 3 exp1])
EAnd exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "&&") , prt 4 exp1])
EEq exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "==") , prt 6 exp1])
ENe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "/=") , prt 6 exp1])
ELt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<") , prt 6 exp1])
ELe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString "<=") , prt 6 exp1])
EGt exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">") , prt 6 exp1])
EGe exp0 exp1 -> prPrec _i 5 (concatD [prt 6 exp0 , doc (showString ">=") , prt 6 exp1])
EAdd exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "+") , prt 7 exp1])
ESub exp0 exp1 -> prPrec _i 6 (concatD [prt 6 exp0 , doc (showString "-") , prt 7 exp1])
EMul exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "*") , prt 8 exp1])
EDiv exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "/") , prt 8 exp1])
EMod exp0 exp1 -> prPrec _i 7 (concatD [prt 7 exp0 , doc (showString "%") , prt 8 exp1])
ENeg exp -> prPrec _i 8 (concatD [doc (showString "-") , prt 8 exp])
EApp exp0 exp1 -> prPrec _i 9 (concatD [prt 9 exp0 , prt 10 exp1])
EProj exp i -> prPrec _i 10 (concatD [prt 10 exp , doc (showString ".") , prt 0 i])
EEmptyRec -> prPrec _i 11 (concatD [doc (showString "{") , doc (showString "}")])
ERecType fieldtypes -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldtypes , doc (showString "}")])
ERec fieldvalues -> prPrec _i 11 (concatD [doc (showString "{") , prt 0 fieldvalues , doc (showString "}")])
EVar i -> prPrec _i 11 (concatD [prt 0 i])
EType -> prPrec _i 11 (concatD [doc (showString "Type")])
EStr str -> prPrec _i 11 (concatD [prt 0 str])
EInt n -> prPrec _i 11 (concatD [prt 0 n])
LetDef i exp0 exp1 -> prPrec _i 0 (concatD [prt 0 i , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp1])
Case pattern exp -> prPrec _i 0 (concatD [prt 0 pattern , doc (showString "->") , prt 0 exp])
VVar i -> prPrec _i 0 (concatD [prt 0 i])
VWild -> prPrec _i 0 (concatD [doc (showString "_")])
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] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
instance Print [Decl] 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 [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 [Pattern] where
prt _ es = case es of
[] -> (concatD [])
x:xs -> (concatD [prt 1 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 [FieldType] where
prt _ es = case es of
[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
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
