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