Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 403 lines (354 sloc) 13.77 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 *)
18 (**
19 @deprecated Use OpaWalk instead
20 *)
21
22 (* TODO remove *)
23 open SurfaceAst
24 open SurfaceAstHelper
25
26 let (|>) = InfixOperator.(|>)
27 let (@*) = InfixOperator.(@*)
28
29 (* FIXME: add some signatures *)
30
31 let unannot sub (v,annot) =
32 let unsub, l = sub v in
33 (fun l -> (unsub l, annot)), l
34
35 (**
36 Traversal functions on patterns
37 *)
38
39 module SPat = struct
40 open Traverse.Utils
41 type 'a t = 'b pat constraint 'a = 'b * 'c * 'd
42
43 let sub_p = sub_current
44 let sub_ident x = sub_ignore x
45 let sub_pat_record_node pr = sub_list (sub_2 sub_ignore sub_p) pr
46 let sub_pat_record pr = unannot sub_pat_record_node pr
47
48 let sub_pat_node = function
49 | PatRecord (pr, rowvar) -> (
50 match rowvar with
51 | `closed ->
52 wrap patrecord (sub_pat_record_node pr)
53 | `open_ ->
54 wrap patextendrecord (sub_pat_record_node pr)
55 )
56 | (PatAny | PatConst _ | PatVar _) as v -> sub_ignore v
57 | PatCoerce (p,ty) -> wrap patcoerce (sub_2 sub_p sub_ignore (p,ty))
58 | PatAs (p, i) -> wrap patas (sub_2 sub_p sub_ignore (p,i))
59
60 let sub_pat c = unannot sub_pat_node c
61 let subs_cons x = sub_pat x
62
63 (* only goes through opa top level patterns *)
64 let sub_code_elt_node = function
65 | NewVal (pel,b) -> wrap newval (sub_2 (sub_list (sub_2 sub_p sub_ignore)) sub_ignore (pel,b))
66 | v -> sub_ignore v
67
68 let sub_code_elt c = unannot sub_code_elt_node c
69 let sub_code c = sub_list sub_code_elt c
70 end
71
72 module PatTraverse =
73 Traverse.Make(SPat)
74
75 module Pattern =
76 struct
77 let get_vars_gen add empty p =
78 PatTraverse.fold (fun acc -> function
79 | (PatVar a, _) -> add a acc
80 | (PatAs (_,a), _) -> add a acc
81 | _ -> acc
82 ) empty p
83 (* TODO: one functor applied to string and exprident? *)
84 let get_vars_string p = get_vars_gen StringSet.add StringSet.empty p
85 let get_vars_ident p = get_vars_gen IdentSet.add IdentSet.empty p
86 let get_vars_ident' p = p |> get_vars_ident |> IdentSet.elements
87 let get_vars_code l =
88 PatTraverse.lift_fold SPat.sub_code
89 (fun acc -> function
90 | (PatVar a, _) -> IdentSet.add a acc
91 | (PatAs (_,a), _) -> IdentSet.add a acc
92 | _ -> acc
93 ) IdentSet.empty l
94 (* FIXME: we can have duplicates *)
95 (* FIXME: almost the same function is defined several times already! *)
96 let get_var_list sub l =
97 (* using fold_right to keep the order *)
98 PatTraverse.lift_fold_right_down sub
99 (fun x acc ->
100 match x with
101 | (PatVar a, _) -> a :: acc
102 | (PatAs (_,a), _) -> a :: acc
103 | _ -> acc
104 ) l []
105 let get_var_list_pattern l = get_var_list SPat.sub_p l
106 let get_var_list_code_elt_node l =
107 get_var_list SPat.sub_code_elt_node l
108 let get_var_list_code l =
109 get_var_list SPat.sub_code l
110 end
111
112 (**
113 Traversal functions on 'expr'
114 *)
115
116 module SExpr =
117 struct
118 open Traverse.Utils
119 type 'a t = ('b, 'c) expr constraint 'a = 'b * 'c * _
120
121 let sub_e e = sub_current e
122 let sub_ident x = sub_ignore x
123 let sub_ty x = sub_ignore x
124 let sub_record_node l = sub_list (sub_2 sub_ignore sub_e) l
125 let sub_record r = unannot sub_record_node r
126 let sub_pattern x = sub_ignore x
127 let sub_db_elt = function
128 | FldKey _
129 | NewKey as v -> sub_ignore v
130 | ExprKey e -> wrap (fun x -> ExprKey x) (sub_e e)
131
132 let sub_db_def x = QmlAst.Db.sub_db_def sub_e sub_ty x
133
134
135 (* this part does not depend on the type of identifiers, and so can be used by renaming
136 * for uninteresting cases *)
137 let sub_expr_no_ident = function
138 | Const _ as e -> sub_ignore e
139 | Apply (e, r) -> wrap apply (sub_2 sub_e sub_record (e,r))
140 | Record r -> wrap record (sub_record_node r)
141 | ExtendRecord (r,e) -> wrap extendrecord (sub_2 sub_record_node sub_e (r,e))
142 | Dot (e,s) -> wrap dot (sub_2 sub_e sub_ignore (e,s))
143 | Bypass b -> wrap bypass (sub_ignore b)
144 | DBPath (a,b) -> wrap dbpath (sub_2 (unannot (sub_list (unannot sub_db_elt))) sub_ignore (a,b))
145 | _ -> assert false
146 let sub_expr_node' fd = function
147 | Ident _ as e -> sub_ignore e
148 | Lambda (p, e) -> wrap lambda (sub_2 sub_ignore sub_e (p,e))
149 | LetIn (b,iel,e) -> wrap letin (sub_3 sub_ignore (sub_list (sub_2 sub_ident sub_e)) sub_e (b,iel,e))
150 | Match (e, pel) -> wrap match_ (sub_2 sub_e (sub_list (sub_2 sub_pattern sub_e)) (e,pel))
151 | Directive (a,el,t) -> wrap directive (sub_3 sub_ignore (sub_list sub_e) sub_ignore (fd a,el,t))
152 | e -> sub_expr_no_ident e
153
154 let sub_expr' fd x = unannot (sub_expr_node' fd) x
44019de [cleanup] open: remove Base in opalang
Raja authored
155 let sub_expr_node e = sub_expr_node' Base.identity e
fccc685 Initial open-source release
MLstate authored
156 let sub_expr x = unannot sub_expr_node x
157
158
159 let subs_cons x = sub_expr x
160
161
162 (* unbuild/rebuild code into expressions *)
163 let sub_code_elt_node = function
164 | (Database _ | NewType _ | Package _) as e ->
165 sub_ignore e
166 | NewDbDef dbdef ->
167 wrap newdbdef (sub_db_def dbdef)
168 | NewVal (pel,b) ->
169 wrap newval (sub_2 (sub_list (sub_2 sub_ignore sub_e)) sub_ignore (pel,b))
170
171 let sub_code_elt c = unannot sub_code_elt_node c
172 let sub_code c = sub_list sub_code_elt c
173 end
174
175 module ExprTraverse =
176 struct
177 include Traverse.Make(SExpr)
178
179 (*
180 * Functions in this module can map on an expression
181 * while changing its type
182 * it is supposed to be used by passes that remove directives
183 * (so that the type is changed accordingly)
184 *)
185 module Heterogeneous =
186 struct
187 let map_down fd f e =
188 let rec aux e =
189 let build, l = SExpr.sub_expr' fd (f e) in
190 let l = List.map aux l in
191 build l in
192 aux e
193 let lift_map_down fd f code =
194 let build, l = SExpr.sub_code code in
195 let l = List.map (fun e -> map_down fd f e) l in
196 build l
197 let map_down_to_fixpoint fd f e =
198 let rec aux e =
199 let e' = f e in
200 if e' == e then
201 let build, l = SExpr.sub_expr' fd e in
202 let l = List.map aux l in
203 build l
204 else
205 aux e' in
206 aux e
207 let lift_map_down_to_fixpoint fd f code =
208 let build, l = SExpr.sub_code code in
209 let l = List.map (fun e -> map_down_to_fixpoint fd f e) l in
210 build l
211 let foldmap_down fd f acc e =
212 let rec aux acc e =
213 let acc, e = f acc e in
214 let build, l = SExpr.sub_expr' fd e in
215 let acc, l = List.fold_left_map aux acc l in
216 acc, build l in
217 aux acc e
218 let foldmap = foldmap_down
219
220 let traverse_foldmap fd f acc e =
221 let rec tra acc e =
222 let build, l = SExpr.sub_expr' fd e in
223 let acc, l = List.fold_left_map (f tra) acc l in
224 acc, build l
225 in f tra acc e
226
227 end
228 let lift_map_down = lift_map_down
229 end
230
231 module Expr =
232 struct
233 let appears equal i e =
234 ExprTraverse.exists
235 (function
236 | (Ident i', _) when equal i i' -> true
237 | _ -> false
238 ) e
239 let get_code_exprs e =
240 snd (SExpr.sub_code e)
241
242 (* FIXME: really dirty *)
243 let fold_with_env (add_env:'b->Ident.t->'a option->'b) env f acc expr =
244 let get_name_and_expr_if_local = function
245 | (field, (Directive (`local name, [e], _), _label)) -> Some (field, name, e)
246 | (_, (Directive (`local _, _, _), _)) -> assert false
247 | _ -> None in
248 let get_local_name_and_expr fe =
249 Option.get (get_name_and_expr_if_local fe) in
250 let add_record r env =
251 match r with
252 | [] -> None
253 | h :: _ ->
254 match get_name_and_expr_if_local h with
255 | None ->
256 (* case after dependency analysis *)
257 assert (List.for_all (Option.is_none @* get_name_and_expr_if_local) r);
258 None
259 | Some _ ->
260 (* before and while dependency analysis *)
261 Some (
262 List.fold_right
263 (fun fe (env,r) ->
264 let (field,name,e) = get_local_name_and_expr fe in
265 (add_env env name (Some e), (field,e) :: r))
266 r
267 (env,[])
268 ) in
269 let add_bnd env (n,e) =
270 add_env env n (Some e) in
271 (* FIXME: use the generic function to find vars in patterns *)
272 let add_lambda r env =
273 PatTraverse.lift_fold SPat.sub_pat_record_node
274 (fun env ->
275 function
276 | (PatVar a, _) -> add_env env a None
277 | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
278 | _ -> env) env r in
279 let add_pat pat env =
280 PatTraverse.fold
281 (fun env ->
282 function
283 | (PatVar a, _) -> add_env env a None
284 | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
285 | _ -> env) env pat in
286 let rec process_pattern_expr tra env acc (pat,expr) =
287 let env_bnd = add_pat pat env in
288 process_expr tra env_bnd acc expr
289 and process_expr tra env acc expr =
290 let env, acc = f env acc expr in
291 match fst expr with
292 | Lambda (r, expr) ->
293 process_expr tra (add_lambda r env) acc expr
294 | Record r ->
295 ( match add_record r env with
296 | Some (env, r) ->
297 process_expr tra env acc (Record r, snd expr)
298 | None ->
299 tra env acc expr )
300 | LetIn (rec_, bnd, expr) ->
301 let full_env = List.fold_left add_bnd env bnd in
302 let local_env = if rec_ then full_env else env in
303 let acc =
304 List.fold_left (fun acc (_,expr) -> process_expr tra local_env acc expr) acc bnd in
305 process_expr tra full_env acc expr
306 | Match (expr, pel) ->
307 let acc = process_expr tra env acc expr in
308 List.fold_left (process_pattern_expr tra env) acc pel
309 | _ -> tra env acc expr in
310 ExprTraverse.traverse_fold_context_down process_expr env acc expr
311
312 let wrap f =
313 (fun env acc expr -> env, f env acc expr)
314
315 let fold_with_expr_map ?(env = IdentMap.empty) f acc expr =
316 fold_with_env (fun map id optval -> IdentMap.add id optval map) env (wrap f) acc expr
317
318 let traverse_fold_with_set ?(env = IdentSet.empty) f acc expr =
319 fold_with_env (fun map id _optval -> IdentSet.add id map) env f acc expr
320
321 let fold_with_set ?env f acc expr =
322 traverse_fold_with_set ?env (wrap f) acc expr
323
324 let get_vars_gen add empty p =
325 ExprTraverse.fold (fun acc -> function
326 | (Ident a, _) -> add a acc
327 | _ -> acc
328 ) empty p
329 (* TODO: one functor applied to string and exprident? *)
330 let get_vars_stringset p = get_vars_gen StringSet.add StringSet.empty p
331 let get_vars_identset p = get_vars_gen IdentSet.add IdentSet.empty p
332 let get_vars_identlist p = p |> get_vars_identset |> IdentSet.elements
333 end
334
335
336 module Code =
337 struct
338 let get_pattern_expr code =
339 List.concat_map (function
340 | (NewVal (pel,_), _) -> pel
341 | _ -> []
342 ) code
343
344 let map_up f code = ExprTraverse.lift_map_up SExpr.sub_code f code
345 end
346
347 (**
348 General purpose traversal functions on types
349 *)
350
351 module SType =
352 struct
353 open Traverse.Utils
354 type 'a t = 'b ty constraint 'a = 'b * 'c * 'd
355 let sub_t = sub_current
356 let sub_fields x = sub_list (sub_2 sub_ignore sub_t) x
357 let sub_row_t_node (TyRow (fields,rowvar)) =
358 wrap tyrow (sub_2 sub_fields sub_ignore (fields,rowvar))
359 let sub_row_t v = unannot sub_row_t_node v
360 let sub_arrow_t_node (row_t,ty) =
361 sub_2 sub_row_t sub_t (row_t,ty)
362 let sub_arrow_t v = unannot sub_arrow_t_node v
363 let sub_typeinstance_node (ident,tyl) =
364 sub_2 sub_ignore (sub_list sub_t) (ident,tyl)
365 let sub_sum_t_node = function
366 | SumName ti -> wrap sumname (sub_typeinstance_node ti)
367 | SumRecord row_t -> wrap sumrecord (sub_row_t_node row_t)
368 | SumVar _ as v -> sub_ignore v
369 let sub_sum_t v = unannot sub_sum_t_node v
370 let sub_ty_node = function
371 | TypeConst _
372 | TypeVar _
373 | TypeExternal as v -> sub_ignore v
374 | TypeArrow r -> wrap typearrow (sub_arrow_t_node r)
375 | TypeRecord r -> wrap typerecord (sub_row_t_node r)
376 | TypeSumSugar l -> wrap typesumsugar (sub_list sub_sum_t l)
377 | TypeNamed ti -> wrap typenamed (sub_typeinstance_node ti)
378 | TypeForall (vars, t) -> wrap typeforall (sub_2 sub_ignore sub_t (vars, t))
379 | TypeModule fields -> wrap typemodule (sub_fields fields)
380 let sub_ty ty = unannot sub_ty_node ty
381
382 let subs_cons = sub_ty
383 end
384
385 module TypeTraverse =
386 Traverse.Make(SType)
387
388 module Type =
389 struct
390 (* FIXME: we can have duplicates *)
391 let get_typename_list sub l =
392 TypeTraverse.lift_fold_right_down sub
393 (fun x acc ->
394 match x with
395 | (TypeNamed (Typeident ident, _tyl), _) -> ident :: acc
396 | _ -> acc
397 ) l []
398 let get_typename_list_arrow_t l =
399 get_typename_list SType.sub_arrow_t l
400 let get_typename_list_type l =
401 get_typename_list SType.sub_t l
402 end
Something went wrong with that request. Please try again.