Skip to content
This repository
Newer
Older
100644 382 lines (366 sloc) 13.169 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
44019de8 » Raja
2011-06-28 [cleanup] open: remove Base in opalang
18
19 (* depends *)
20 module List = BaseList
21
fccc6851 » MLstate
2011-06-21 Initial open-source release
22 open SurfaceAst
23
24 let foldmap_2_stable tra acc ((s,p) as c) =
25 let acc, p' = tra acc p in
26 acc,
27 if p == p' then c else (s,p')
28 let foldmap_1_stable tra acc ((p,s) as c) =
29 let acc, p' = tra acc p in
30 acc,
31 if p == p' then c else (p',s)
32 let eq_string s1 (s2:string) = s1 = s2
33
34 module Pattern =
35 struct
36 module S2 =
37 struct
38 type 'a t = 'b pat constraint 'a = 'b * _ * _
39 let foldmap tra acc ((p,lab) as orig_pat) =
40 match p with
41 | PatRecord (pr, rowvar) ->
42 let acc,pr' =
43 List.fold_left_map_stable
44 (fun acc c -> foldmap_2_stable tra acc c)
45 acc pr in
46 acc,
47 if pr == pr' then orig_pat else
48 (PatRecord (pr', rowvar), lab)
49 | PatAny _
50 | PatConst _
51 | PatVar _ -> acc, orig_pat
52 | PatAs (p,i) ->
53 let acc, p' = tra acc p in
54 acc,
55 if p == p' then orig_pat else
56 (PatAs (p',i), lab)
57 | PatCoerce (p,ty) ->
58 let acc, p' = tra acc p in
59 acc,
60 if p == p' then orig_pat else
61 (PatCoerce (p',ty),lab)
62 let map tra e = Traverse.Unoptimized.map foldmap tra e
63 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
64 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
65 end
66 include Traverse.Make2(S2)
67 let get_vars ?(acc=[]) pat =
68 fold (fun acc -> function
69 | (PatVar v,_)
70 | (PatAs (_,v),_) -> v :: acc
71 | _ -> acc) acc pat
72 let appears_eq equal ident pat =
73 exists (function
74 | (PatVar v,_)
75 | (PatAs (_,v),_) -> equal v ident
76 | _ -> false) pat
77 let appears_str ident pat = appears_eq eq_string ident pat
78 let appears ident pat = appears_eq Ident.equal ident pat
79 end
80
81 module Type =
82 struct
83 module S2 =
84 struct
85 type 'a t = 'b ty constraint 'a = 'b * _ * _
86 let foldmap tra acc ((t,lab) as orig_ty) =
87 match t with
88 | TypeConst _
89 | TypeVar _
90 | TypeExternal _ -> acc, orig_ty
91 | TypeArrow (((TyRow (fields,rowvar),lab2) as tyrow),ty) ->
92 let acc, fields' =
93 List.fold_left_map_stable
94 (fun acc p -> foldmap_2_stable tra acc p)
95 acc fields in
96 let acc, ty' = tra acc ty in
97 acc,
98 if fields == fields' then
99 if ty == ty' then
100 orig_ty
101 else
102 (TypeArrow (tyrow,ty'),lab)
103 else
104 (TypeArrow ((TyRow (fields',rowvar),lab2),ty'),lab)
105 | TypeRecord (TyRow (fields,rowvar)) ->
106 let acc, fields' =
107 List.fold_left_map_stable
108 (fun acc p -> foldmap_2_stable tra acc p)
109 acc fields in
110 acc,
111 if fields == fields' then orig_ty else
112 (TypeRecord (TyRow (fields',rowvar)),lab)
113 | TypeSumSugar suml ->
114 let acc, suml' =
115 List.fold_left_map_stable
116 (fun acc sum_t_node ->
117 foldmap_1_stable
118 (fun acc -> function
119 | SumName (ident,tyl) as ty ->
120 let acc, tyl' = List.fold_left_map_stable tra acc tyl in
121 acc,
122 if tyl == tyl' then ty else
123 SumName (ident,tyl')
124 | SumRecord (TyRow (fields,rowvar)) as ty ->
125 let acc, fields' =
126 List.fold_left_map_stable
127 (fun acc p -> foldmap_2_stable tra acc p)
128 acc fields in
129 acc,
130 if fields == fields' then ty else
131 SumRecord (TyRow (fields',rowvar))
132 | SumVar _ as ty -> acc, ty)
133 acc sum_t_node
134 ) acc suml in
135 acc,
136 if suml == suml' then orig_ty else
137 (TypeSumSugar suml', lab)
138 | TypeNamed (ident,tyl) ->
139 let acc, tyl' = List.fold_left_map_stable tra acc tyl in
140 acc,
141 if tyl == tyl' then orig_ty else
142 (TypeNamed (ident,tyl'),lab)
143 | TypeForall (vars,ty) ->
144 let acc, ty' = tra acc ty in
145 acc,
146 if ty == ty' then orig_ty else
147 (TypeForall (vars,ty'),lab)
148 | TypeModule fields ->
149 let acc, fields' =
150 List.fold_left_map_stable
151 (fun acc p -> foldmap_2_stable tra acc p)
152 acc fields in
153 acc,
154 if fields == fields' then orig_ty else
155 (TypeModule fields', lab)
156 let map tra e = Traverse.Unoptimized.map foldmap tra e
157 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
158 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
159 end
160 include Traverse.Make2(S2)
161 let get_typenames_with_acc acc ty =
162 fold (fun acc -> function
163 | (TypeNamed (Typeident ident,_),_) -> ident :: acc
164 | (TypeSumSugar l,_) ->
165 List.fold_left
166 (fun acc -> function
167 | (SumName (Typeident ident,_),_) -> ident :: acc
168 | _ -> acc) acc l
169 | _ -> acc
170 ) acc ty
171 let get_typenames ty = get_typenames_with_acc [] ty
172 let get_typenames_from_arrow_type (arrow_node,label) =
173 get_typenames (TypeArrow arrow_node, label)
174
175 end
176
177 module Expr =
178 struct
179 module S2 =
180 struct
181 type 'a t = ('b,'c) expr constraint 'a = 'b * 'c * _
182 let foldmap tra acc ((e,lab) as orig_e) =
183 match e with
184 | Bypass _
185 | Const _
186 | Ident _ -> acc, orig_e
187 | Apply (e,record) ->
188 let acc, e' = tra acc e in
189 let acc, record' =
190 foldmap_1_stable
191 (fun acc l ->
192 List.fold_left_map_stable
193 (fun acc p -> foldmap_2_stable tra acc p)
194 acc l)
195 acc record in
196 acc,
197 if e == e' && record == record' then orig_e else
198 (Apply (e',record'),lab)
199 | LetIn (rec_,iel,e) ->
200 let acc, iel' =
201 List.fold_left_map_stable
202 (fun acc ie ->
203 foldmap_2_stable tra acc ie
204 ) acc iel in
205 let acc, e' = tra acc e in
206 acc,
207 if e == e' && iel == iel' then orig_e else
208 (LetIn (rec_,iel',e'),lab)
209 | Lambda (r,e) ->
210 let acc, e' = tra acc e in
211 acc,
212 if e == e' then orig_e else
213 (Lambda (r,e'),lab)
214 | Match (e,pel) ->
215 let acc, e' = tra acc e in
216 let acc, pel' = List.fold_left_map_stable
217 (fun acc pe ->
218 foldmap_2_stable tra acc pe) acc pel in
219 acc,
220 if e == e' && pel == pel' then orig_e else
221 (Match (e',pel'),lab)
222 | Record record ->
223 let acc, record' =
224 List.fold_left_map_stable
225 (fun acc p -> foldmap_2_stable tra acc p)
226 acc record in
227 acc,
228 if record == record' then orig_e else
229 (Record record', lab)
230 | ExtendRecord (record,e) ->
231 let acc, record' =
232 List.fold_left_map_stable
233 (fun acc p -> foldmap_2_stable tra acc p)
234 acc record in
235 let acc, e' = tra acc e in
236 acc,
237 if e == e' && record == record' then orig_e else
238 (ExtendRecord (record',e'),lab)
239 | Dot (e,s) ->
240 let acc, e' = tra acc e in
241 acc,
242 if e == e' then orig_e else
243 (Dot (e',s),lab)
244 | DBPath (dbelt,kind) ->
245 let acc, dbelt' =
246 foldmap_1_stable
247 (fun acc node ->
248 List.fold_left_map_stable
249 (fun acc db_elt ->
250 foldmap_1_stable
251 (fun acc -> function
252 | FldKey _
253 | NewKey as v -> acc, v
254 | ExprKey e as v ->
255 let acc, e' = tra acc e in
256 acc,
257 if e == e' then v else
258 ExprKey e'
259 ) acc db_elt
260 ) acc node
261 ) acc dbelt in
262 acc,
263 if dbelt == dbelt' then orig_e else
264 (DBPath (dbelt',kind),lab)
265 | Directive (variant,el,t) ->
266 let acc, el' = List.fold_left_map_stable tra acc el in
267 acc,
268 if el == el' then orig_e else
269 (Directive (variant,el',t),lab)
270 let map tra e = Traverse.Unoptimized.map foldmap tra e
271 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
272 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
273 end
274 include Traverse.Make2(S2)
275 let appears_eq eq i e =
276 exists (function
277 | (Ident j,_) -> eq i j
278 | _ -> false) e
279 let appears_str i e = appears_eq eq_string i e
280 let appears i e = appears_eq Ident.equal i e
281 let used_vars_eq eq vars e =
282 fold
283 (fun acc -> function
284 | (Ident j,_) ->
285 if List.exists (eq j) vars && not (List.exists (eq j) acc)
286 then j :: acc
287 else acc
288 | _ -> acc) [] e
289 let used_vars_str vars e = used_vars_eq eq_string vars e
290 let used_vars vars e = used_vars_eq Ident.equal vars e
291 end
292
293
294 module CodeElt =
295 struct
296 module Lift2 =
297 struct
298 type 'a t = ('b,'c) expr constraint 'a = 'b * 'c * _
299 type 'a container = ('b,'c) code_elt constraint 'a = 'b * 'c * _
300 let foldmap tra acc ((code_elt_node, lab) as orig_code_elt) =
301 match code_elt_node with
302 | Package _
303 | Database _
304 | NewType _ -> acc, orig_code_elt
305 | NewVal (pel,rec_) ->
306 let acc, pel' =
307 List.fold_left_map_stable
308 (fun acc pe ->
309 foldmap_2_stable tra acc pe
310 ) acc pel in
311 acc,
312 if pel == pel' then orig_code_elt else
313 (NewVal (pel',rec_),lab)
314 | NewDbDef dbdef ->
315 let rebuild, exprs =
316 QmlAst.Db.sub_db_def
317 Traverse.Utils.sub_current
318 Traverse.Utils.sub_ignore
319 dbdef in
320 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
321 acc, (NewDbDef (rebuild exprs'), lab)
322 let map tra e = Traverse.Unoptimized.map foldmap tra e
323 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
324 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
325 end
326 include Traverse.MakeLift1(Lift2)(Expr)
327 end
328
329 module Code =
330 struct
331 module Lift2 =
332 struct
333 type 'a t = ('b,'c) expr constraint 'a = 'b * 'c * _
334 type 'a container = ('b,'c) code constraint 'a = 'b * 'c * _
335 let foldmap tra acc code = List.fold_left_map_stable (fun acc e -> CodeElt.Lift2.foldmap tra acc e) acc code
336 let map tra e = Traverse.Unoptimized.map foldmap tra e
337 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
338 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
339 end
340 include Traverse.MakeLift1(Lift2)(Expr)
341 let size code = fold (fun acc _ -> acc + 1) 0 code
342 let length = List.length
343 end
344
345 module CodeEltTopPattern =
346 struct
347 module Lift2 =
348 struct
349 type 'a t = 'b pat constraint 'a = 'b * _ * _
350 type 'a container = ('b,'c) code_elt constraint 'a = 'b * 'c * _
351 let foldmap tra acc ((code_elt_node,lab) as code_elt) =
352 match code_elt_node with
353 | NewVal (pel,rec_) ->
354 let acc, pel' =
355 List.fold_left_map_stable
356 (fun acc pe ->
357 foldmap_1_stable tra acc pe)
358 acc pel in
359 acc,
360 if pel == pel' then code_elt else
361 (NewVal (pel',rec_),lab)
362 | _ -> acc, code_elt
363 let map tra e = Traverse.Unoptimized.map foldmap tra e
364 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
365 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
366 end
367 include Traverse.MakeLift1(Lift2)(Pattern)
368 end
369
370 module CodeTopPattern =
371 struct
372 module Lift2 =
373 struct
374 type 'a t = 'b pat constraint 'a = 'b * _ * _
375 type 'a container = ('b,'c) code constraint 'a = 'b * 'c * _
376 let foldmap tra acc code = List.fold_left_map_stable (fun acc e -> CodeEltTopPattern.Lift2.foldmap tra acc e) acc code
377 let map tra e = Traverse.Unoptimized.map foldmap tra e
378 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
379 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
380 end
381 include Traverse.MakeLift1(Lift2)(Pattern)
382 end
Something went wrong with that request. Please try again.