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
284
285
286
287
288
289

------------------------------------------------------------------------
--- This module provides some useful functions to write the code
--- generating AbstractHaskell programs more compact and readable.
------------------------------------------------------------------------

module AbstractHaskell.Goodies where

import Data.Char            (toLower)
import Data.List            ((\\), union)

import AbstractHaskell.Types

infixr 9 ~>

--- lower the first character in a string
lowerFirst :: String -> String
lowerFirst []     = [] -- this case should not occur, but one never knows...
lowerFirst (y:ys) = toLower y : ys

--- Construct the name of an n-ary tuple.
tupleName :: Int -> QName
tupleName arity | arity > 1 = pre ('(' : replicate (arity - 1) ',' ++ ")")
                | otherwise = error $ "tupleName: illegal arity " ++ show arity

-- -----------------------------------------------------------------------------
-- Goodies for types
-- -----------------------------------------------------------------------------

--- A type variable.
ctvar :: String -> TypeExpr
ctvar s = TVar (1, s)

--- A function type.
(~>) :: TypeExpr -> TypeExpr -> TypeExpr
t1 ~> t2 = FuncType t1 t2

--- A base type (type constructor without arguments).
baseType :: QName -> TypeExpr
baseType t = TCons t []

--- Constructs a list type from element type.
listType :: TypeExpr -> TypeExpr
listType a = TCons (pre "[]") [a]

--- Constructs a tuple type from list of component types.
tupleType :: [TypeExpr] -> TypeExpr
tupleType ts | l == 0    = baseType (pre "()")
             | l == 1    = head ts
             | otherwise = TCons (tupleName l) ts
 where l = length ts

--- Constructs an IO type from a type.
ioType :: TypeExpr -> TypeExpr
ioType a = TCons (pre "IO") [a]

--- Constructs a Maybe type from element type.
maybeType :: TypeExpr -> TypeExpr
maybeType a = TCons (pre "Maybe") [a]

--- The `String` type.
stringType :: TypeExpr
stringType = baseType (pre "String")

--- The `Int` type.
intType :: TypeExpr
intType = baseType (pre "Int")

--- The `Bool` type.
boolType :: TypeExpr
boolType = baseType (pre "Bool")

--- The `Date` type.
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 \\ map fst tvs

-- -----------------------------------------------------------------------------
-- Goodies for function declarations
-- -----------------------------------------------------------------------------

--- A typed function declaration.
tfunc :: QName -> Int -> Visibility -> TypeExpr -> [Rule] -> FuncDecl
tfunc name arity v t rules = Func "" name arity v (CType [] t) (Rules rules)

--- A typed function declaration with a type context.
ctfunc :: QName -> Int -> Visibility -> [Context] -> TypeExpr -> [Rule]
       -> FuncDecl
ctfunc name arity v tc t rules = Func "" name arity v (CType tc t) (Rules rules)

--- A typed function declaration with a documentation comment.
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
commentOf (Func cmt _ _ _ _ _) = cmt

simpleRule :: [Pattern] -> Expr -> Rules
simpleRule ps e = Rules [Rule ps (SimpleRhs e) []]

-- -----------------------------------------------------------------------------
-- Building expressions
-- -----------------------------------------------------------------------------

--- An application of a qualified function name to a list of arguments.
applyF :: QName -> [Expr] -> Expr
applyF f es = foldl Apply (Symbol f) es

--- A constant, i.e., an application without arguments.
constF :: QName -> Expr
constF f = applyF f []

--- An application of a variable to a list of arguments.
applyV :: VarIName -> [Expr] -> Expr
applyV v es = foldl Apply (Var v) es

--- Constructs a tuple pattern from list of component patterns.
tuplePat :: [Pattern] -> Pattern
tuplePat ps = PTuple ps

--- Constructs a tuple expression from list of component expressions.
tupleExpr :: [Expr] -> Expr
tupleExpr es = Tuple es

--- transform a string constant into AbstractHaskell term
string2ac :: String -> Expr
string2ac = Lit . Stringc

pre :: String -> QName
pre f = ("Prelude", f)

cvar :: String -> Expr
cvar s = Var (1,s)

--- Build a let declaration (with a possibly empty list of local declarations)
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 []

-- -----------------------------------------------------------------------------
-- Perform a renaming
-- -----------------------------------------------------------------------------

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)
  TypeNew qf vis tvars cdecl  -> TypeNew (ren qf) vis tvars
                                         (renameSymbolInNewConsDecl ren cdecl)
  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)

renameSymbolInNewConsDecl :: (QName -> QName) -> NewConsDecl -> NewConsDecl
renameSymbolInNewConsDecl ren (NewCons qf vis texp) =
  NewCons (ren qf) vis $ renameSymbolInTypeExpr ren texp

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 -- PVar or PLit

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 tvs cxs qn texps) =
  Context tvs cxs (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