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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
|
module AbstractHaskell.Goodies where
import Char (toLower)
import List ((\\), union)
import AbstractHaskell.Types
infixr 9 ~>
lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (y:ys) = toLower y : ys
tupleName :: Int -> QName
tupleName arity | arity > 1 = pre ('(' : replicate (arity - 1) ',' ++ ")")
| otherwise = error $ "tupleName: illegal arity " ++ show arity
ctvar :: String -> TypeExpr
ctvar s = TVar (1, s)
(~>) :: TypeExpr -> TypeExpr -> TypeExpr
t1 ~> t2 = FuncType t1 t2
baseType :: QName -> TypeExpr
baseType t = TCons t []
listType :: TypeExpr -> TypeExpr
listType a = TCons (pre "[]") [a]
tupleType :: [TypeExpr] -> TypeExpr
tupleType ts | l == 0 = baseType (pre "()")
| l == 1 = head ts
| otherwise = TCons (tupleName l) ts
where l = length ts
ioType :: TypeExpr -> TypeExpr
ioType a = TCons (pre "IO") [a]
maybeType :: TypeExpr -> TypeExpr
maybeType a = TCons (pre "Maybe") [a]
stringType :: TypeExpr
stringType = baseType (pre "String")
intType :: TypeExpr
intType = baseType (pre "Int")
boolType :: TypeExpr
boolType = baseType (pre "Bool")
dateType :: TypeExpr
dateType = baseType ("Time", "CalendarTime")
tyVarsOf :: TypeExpr -> [TVarIName]
tyVarsOf (TVar tv) = [tv]
tyVarsOf (FuncType t1 t2) = tyVarsOf t1 `union` tyVarsOf t2
tyVarsOf (TCons _ tys) = foldr union [] (map tyVarsOf tys)
tyVarsOf (ForallType tvs _ ty) = tyVarsOf ty \\ tvs
tfunc :: QName -> Int -> Visibility -> TypeExpr -> [Rule] -> FuncDecl
tfunc name arity v t rules = Func "" name arity v (CType [] t) (Rules rules)
ctfunc :: QName -> Int -> Visibility -> [Context] -> TypeExpr -> [Rule]
-> FuncDecl
ctfunc name arity v tc t rules = Func "" name arity v (CType tc t) (Rules rules)
cmtfunc :: String -> QName -> Int -> Visibility -> [Context] -> TypeExpr
-> [Rule] -> FuncDecl
cmtfunc comment name arity v tc t rules =
Func comment name arity v (CType tc t) (Rules rules)
funcDecls :: Prog -> [FuncDecl]
funcDecls (Prog _ _ _ fs _) = fs
funcName :: FuncDecl -> QName
funcName (Func _ f _ _ _ _) = f
typeOf :: FuncDecl -> TypeSig
typeOf (Func _ _ _ _ ty _) = ty
commentOf :: FuncDecl -> String
(Func cmt _ _ _ _ _) = cmt
simpleRule :: [Pattern] -> Expr -> Rules
simpleRule ps e = Rules [Rule ps (SimpleRhs e) []]
applyF :: QName -> [Expr] -> Expr
applyF f es = foldl Apply (Symbol f) es
constF :: QName -> Expr
constF f = applyF f []
applyV :: VarIName -> [Expr] -> Expr
applyV v es = foldl Apply (Var v) es
tuplePat :: [Pattern] -> Pattern
tuplePat ps = PTuple ps
tupleExpr :: [Expr] -> Expr
tupleExpr es = Tuple es
string2ac :: String -> Expr
string2ac = Lit . Stringc
pre :: String -> QName
pre f = ("Prelude", f)
cvar :: String -> Expr
cvar s = Var (1,s)
clet :: [LocalDecl] -> Expr -> Expr
clet locals cexp = if null locals then cexp else Let locals cexp
list2ac :: [Expr] -> Expr
list2ac es = List es
declVar :: VarIName -> Expr -> LocalDecl
declVar v e = LocalPat (PVar v) e []
renameSymbolInProg :: (QName -> QName) -> Prog -> Prog
renameSymbolInProg ren (Prog name imports typedecls fundecls opdecls) =
Prog
(fst (ren (name, "")))
(map (\mod -> fst $ ren (mod, "")) imports)
(map (renameSymbolInTypeDecl ren) typedecls)
(map (renameSymbolInFunc ren) fundecls)
(map (renameOpDecl ren) opdecls)
renameSymbolInTypeDecl :: (QName -> QName) -> TypeDecl -> TypeDecl
renameSymbolInTypeDecl ren tdecl = case tdecl of
Type qf vis tvars cdecls -> Type (ren qf) vis tvars
(map (renameSymbolInConsDecl ren) cdecls)
TypeSyn qf vis tvars texp -> TypeSyn (ren qf) vis tvars
(renameSymbolInTypeExpr ren texp)
Instance qf texp ctxt rules ->
Instance (ren qf) (renameSymbolInTypeExpr ren texp)
(map (renameSymbolInContext ren) ctxt)
(map renameSymbolInInstRule rules)
where
renameSymbolInInstRule (qf,rule) =
(ren qf, renameSymbolInRule ren rule)
renameSymbolInConsDecl :: (QName -> QName) -> ConsDecl -> ConsDecl
renameSymbolInConsDecl ren (Cons qf ar vis texps) =
Cons (ren qf) ar vis (map (renameSymbolInTypeExpr ren) texps)
renameSymbolInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
renameSymbolInTypeExpr ren texp = case texp of
TCons qf texps -> TCons (ren qf) (map (renameSymbolInTypeExpr ren) texps)
FuncType te1 te2 -> FuncType (renameSymbolInTypeExpr ren te1)
(renameSymbolInTypeExpr ren te2)
TVar v -> TVar v
ForallType v cx te -> ForallType v (map (renameSymbolInContext ren) cx)
(renameSymbolInTypeExpr ren te)
renameSymbolInExpr :: (QName -> QName) -> Expr -> Expr
renameSymbolInExpr ren exp = case exp of
Var _ -> exp
Lit _ -> exp
Symbol qf -> Symbol (ren qf)
Apply e1 e2 -> Apply (renameSymbolInExpr ren e1)
(renameSymbolInExpr ren e2)
InfixApply e1 op e2 -> InfixApply (renameSymbolInExpr ren e1)
(ren op)
(renameSymbolInExpr ren e2)
Lambda pats e -> Lambda (map (renameSymbolInPat ren) pats)
(renameSymbolInExpr ren e)
Let locals e -> Let (map (renameSymbolInLocal ren) locals)
(renameSymbolInExpr ren e)
DoExpr stats -> DoExpr (map (renameSymbolInStat ren) stats)
ListComp e stats -> ListComp (renameSymbolInExpr ren e)
(map (renameSymbolInStat ren) stats)
Case e branches -> Case (renameSymbolInExpr ren e)
(map (renameSymbolInBranch ren) branches)
Typed e ty -> Typed (renameSymbolInExpr ren e) ty
IfThenElse e1 e2 e3 -> IfThenElse (renameSymbolInExpr ren e1)
(renameSymbolInExpr ren e2)
(renameSymbolInExpr ren e3)
Tuple es -> Tuple (map (renameSymbolInExpr ren) es)
List es -> List (map (renameSymbolInExpr ren) es)
renameSymbolInPat :: (QName -> QName) -> Pattern -> Pattern
renameSymbolInPat ren pat = case pat of
PComb qf pats -> PComb (ren qf) (map (renameSymbolInPat ren) pats)
PAs var apat -> PAs var (renameSymbolInPat ren apat)
PTuple ps -> PTuple (map (renameSymbolInPat ren) ps)
PList ps -> PList (map (renameSymbolInPat ren) ps)
_ -> pat
renameSymbolInBranch :: (QName -> QName) -> BranchExpr -> BranchExpr
renameSymbolInBranch ren (Branch pat e) =
Branch (renameSymbolInPat ren pat) (renameSymbolInExpr ren e)
renameSymbolInStat :: (QName -> QName) -> Statement -> Statement
renameSymbolInStat ren stat = case stat of
SExpr e -> SExpr (renameSymbolInExpr ren e)
SPat pat e -> SPat (renameSymbolInPat ren pat)
(renameSymbolInExpr ren e)
SLet locals -> SLet (map (renameSymbolInLocal ren) locals)
renameSymbolInLocal :: (QName -> QName) -> LocalDecl -> LocalDecl
renameSymbolInLocal ren local = case local of
LocalFunc fdecl -> LocalFunc (renameSymbolInFunc ren fdecl)
LocalPat pat e locals -> LocalPat (renameSymbolInPat ren pat)
(renameSymbolInExpr ren e)
(map (renameSymbolInLocal ren) locals)
renameSymbolInTypeSig :: (QName -> QName) -> TypeSig -> TypeSig
renameSymbolInTypeSig _ Untyped = Untyped
renameSymbolInTypeSig ren (CType tc te) =
CType (map (renameSymbolInContext ren) tc) (renameSymbolInTypeExpr ren te)
renameSymbolInContext :: (QName -> QName) -> Context -> Context
renameSymbolInContext ren (Context qn texps) =
Context (ren qn) (map (renameSymbolInTypeExpr ren) texps)
renameSymbolInFunc :: (QName -> QName) -> FuncDecl -> FuncDecl
renameSymbolInFunc ren (Func cmt qf ar vis ctype rules) =
Func cmt (ren qf) ar vis
(renameSymbolInTypeSig ren ctype)
(renameSymbolInRules ren rules)
renameSymbolInRules :: (QName -> QName) -> Rules -> Rules
renameSymbolInRules ren (Rules rs) = Rules (map (renameSymbolInRule ren) rs)
renameSymbolInRules _ External = External
renameSymbolInRule :: (QName -> QName) -> Rule -> Rule
renameSymbolInRule ren (Rule ps rhs ds) =
Rule (map (renameSymbolInPat ren) ps)
(renameSymbolInRhs ren rhs)
(map (renameSymbolInLocal ren) ds)
renameSymbolInRhs :: (QName -> QName) -> Rhs -> Rhs
renameSymbolInRhs ren (SimpleRhs e) = SimpleRhs (renameSymbolInExpr ren e)
renameSymbolInRhs ren (GuardedRhs gs) = GuardedRhs $
map (\ (c, e) -> (renameSymbolInExpr ren c, renameSymbolInExpr ren e)) gs
renameOpDecl :: (QName -> QName) -> OpDecl -> OpDecl
renameOpDecl ren (Op qf fix prio) = Op (ren qf) fix prio
|