Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 401 lines (384 sloc) 13.994 kb
fccc685 Initial open-source release
MLstate authored
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 *)
44019de [cleanup] open: remove Base in opalang
Raja authored
18
19 (* depends *)
20 module List = BaseList
21
fccc685 Initial open-source release
MLstate authored
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,_)
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
70 | (PatAs (_,v),_) -> v.ident :: acc
fccc685 Initial open-source release
MLstate authored
71 | _ -> acc) acc pat
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
72 let appears_eq equal target_ident pat =
fccc685 Initial open-source release
MLstate authored
73 exists (function
74 | (PatVar v,_)
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
75 | (PatAs (_,v),_) -> equal (v.ident) target_ident
fccc685 Initial open-source release
MLstate authored
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
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new q…
BourgerieQuentin authored
251 (fun acc elt ->
252 let rebuild, exprs =
253 QmlAst.Db.sub_path_elt
254 Traverse.Utils.sub_current
255 Traverse.Utils.sub_ignore
256 elt in
257 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
258 acc, rebuild exprs'
259 )
260 (*fun acc -> function
fccc685 Initial open-source release
MLstate authored
261 | FldKey _
262 | NewKey as v -> acc, v
263 | ExprKey e as v ->
264 let acc, e' = tra acc e in
265 acc,
266 if e == e' then v else
267 ExprKey e'
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new q…
BourgerieQuentin authored
268 *) acc db_elt
fccc685 Initial open-source release
MLstate authored
269 ) acc node
270 ) acc dbelt in
5fdc6b9 @BourgerieQuentin [enhance] compiler: (big) Common path typing beetween several backend…
BourgerieQuentin authored
271 let acc, kind' =
272 let rebuild, exprs =
273 QmlAst.Db.sub_db_kind
274 Traverse.Utils.sub_current
275 Traverse.Utils.sub_ignore
276 kind in
277 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
278 acc, rebuild exprs'
279 in
fccc685 Initial open-source release
MLstate authored
280 acc,
5fdc6b9 @BourgerieQuentin [enhance] compiler: (big) Common path typing beetween several backend…
BourgerieQuentin authored
281 if dbelt == dbelt' && kind == kind' then orig_e else
282 (DBPath (dbelt',kind'),lab)
fccc685 Initial open-source release
MLstate authored
283 | Directive (variant,el,t) ->
284 let acc, el' = List.fold_left_map_stable tra acc el in
285 acc,
286 if el == el' then orig_e else
287 (Directive (variant,el',t),lab)
288 let map tra e = Traverse.Unoptimized.map foldmap tra e
289 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
290 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
291 end
292 include Traverse.Make2(S2)
293 let appears_eq eq i e =
294 exists (function
295 | (Ident j,_) -> eq i j
296 | _ -> false) e
297 let appears_str i e = appears_eq eq_string i e
298 let appears i e = appears_eq Ident.equal i e
299 let used_vars_eq eq vars e =
300 fold
301 (fun acc -> function
302 | (Ident j,_) ->
303 if List.exists (eq j) vars && not (List.exists (eq j) acc)
304 then j :: acc
305 else acc
306 | _ -> acc) [] e
307 let used_vars_str vars e = used_vars_eq eq_string vars e
308 let used_vars vars e = used_vars_eq Ident.equal vars e
309 end
310
311
312 module CodeElt =
313 struct
314 module Lift2 =
315 struct
316 type 'a t = ('b,'c) expr constraint 'a = 'b * 'c * _
317 type 'a container = ('b,'c) code_elt constraint 'a = 'b * 'c * _
318 let foldmap tra acc ((code_elt_node, lab) as orig_code_elt) =
319 match code_elt_node with
320 | Package _
321 | Database _
322 | NewType _ -> acc, orig_code_elt
323 | NewVal (pel,rec_) ->
324 let acc, pel' =
325 List.fold_left_map_stable
326 (fun acc pe ->
327 foldmap_2_stable tra acc pe
328 ) acc pel in
329 acc,
330 if pel == pel' then orig_code_elt else
331 (NewVal (pel',rec_),lab)
332 | NewDbDef dbdef ->
333 let rebuild, exprs =
334 QmlAst.Db.sub_db_def
335 Traverse.Utils.sub_current
336 Traverse.Utils.sub_ignore
337 dbdef in
338 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
339 acc, (NewDbDef (rebuild exprs'), lab)
340 let map tra e = Traverse.Unoptimized.map foldmap tra e
341 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
342 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
343 end
344 include Traverse.MakeLift1(Lift2)(Expr)
345 end
346
347 module Code =
348 struct
349 module Lift2 =
350 struct
351 type 'a t = ('b,'c) expr constraint 'a = 'b * 'c * _
352 type 'a container = ('b,'c) code constraint 'a = 'b * 'c * _
353 let foldmap tra acc code = List.fold_left_map_stable (fun acc e -> CodeElt.Lift2.foldmap tra acc e) acc code
354 let map tra e = Traverse.Unoptimized.map foldmap tra e
355 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
356 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
357 end
358 include Traverse.MakeLift1(Lift2)(Expr)
359 let size code = fold (fun acc _ -> acc + 1) 0 code
360 let length = List.length
361 end
362
363 module CodeEltTopPattern =
364 struct
365 module Lift2 =
366 struct
367 type 'a t = 'b pat constraint 'a = 'b * _ * _
368 type 'a container = ('b,'c) code_elt constraint 'a = 'b * 'c * _
369 let foldmap tra acc ((code_elt_node,lab) as code_elt) =
370 match code_elt_node with
371 | NewVal (pel,rec_) ->
372 let acc, pel' =
373 List.fold_left_map_stable
374 (fun acc pe ->
375 foldmap_1_stable tra acc pe)
376 acc pel in
377 acc,
378 if pel == pel' then code_elt else
379 (NewVal (pel',rec_),lab)
380 | _ -> acc, code_elt
381 let map tra e = Traverse.Unoptimized.map foldmap tra e
382 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
383 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
384 end
385 include Traverse.MakeLift1(Lift2)(Pattern)
386 end
387
388 module CodeTopPattern =
389 struct
390 module Lift2 =
391 struct
392 type 'a t = 'b pat constraint 'a = 'b * _ * _
393 type 'a container = ('b,'c) code constraint 'a = 'b * 'c * _
394 let foldmap tra acc code = List.fold_left_map_stable (fun acc e -> CodeEltTopPattern.Lift2.foldmap tra acc e) acc code
395 let map tra e = Traverse.Unoptimized.map foldmap tra e
396 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
397 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
398 end
399 include Traverse.MakeLift1(Lift2)(Pattern)
400 end
Something went wrong with that request. Please try again.