Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 297 lines (282 sloc) 10.572 kb
fccc685 Initial open-source release
MLstate authored
1 open SurfaceAst
2
44019de [cleanup] open: remove Base in opalang
Raja authored
3 let identity = Base.identity
4
fccc685 Initial open-source release
MLstate authored
5 module Fixpoint =
6 struct
7 (* used for removing nodes *)
8 let rec repeat f e =
9 let e' = f e in
10 if e == e' then e' else repeat f e'
11 (* could avoid some comparisons by saying
12 * let rec repeats fs e_o =
13 * let rec aux ... =
14 * match ... with
15 * | [] -> it e == e_0 then e else repeats fs e
16 *)
17 let repeats fs e =
18 let rec aux e l did_something =
19 match l with
20 | [] -> if did_something then init e else e
21 | h :: t ->
22 let e' = repeat h e in
23 aux e' t (did_something || e != e')
24 and init e = aux e fs false in
25 init e
26
27 (* used for removing nodes and getting the context *)
28 let rec repeat' f (e,recombiner) =
29 let e', recombiner' = f e in
30 let recombiner'' = if recombiner' == identity then recombiner else fun e -> recombiner (recombiner' e) in
31 if e == e' then
32 e, recombiner''
33 else
34 repeat' f (e',recombiner'')
35
36 let repeats' fs e =
37 let rec aux e l did_something =
38 match l with
39 | [] -> if did_something then init e else e
40 | h :: t ->
41 let e' = repeat' h e in
42 aux e' t (did_something || fst e != fst e')
43 and init e = aux e fs false in
44 init e
45 end
46
47
48 module Remove =
49 struct
50 type ('a,'b) through = ('a, 'b) expr -> ('a, 'b) expr
51 let fail label = failwith (Printf.sprintf "SurfaceAstDecons.Remove.fail: %s" (FilePos.to_string label.QmlLoc.pos))
52
53 module Basic =
54 struct
55 let access_directive = function
56 | (Directive (#access_directive,[e],_),_) -> e
57 | (Directive (#access_directive,_,_),_) -> assert false
58 | e -> e
59 let access_not_public = function
60 | (Directive (`public,_,_),_) as e -> e
61 | (Directive (#access_directive,[e],_),_) -> e
62 | (Directive (#access_directive,_,_),_) -> assert false
8edc001 [feature] adding: an @async directive on bindings to perform asynchronou...
Valentin Gatien-Baron authored
63 | e -> e
64 let async = function
65 | (Directive (`async, [e], _),_) -> e
66 | (Directive (`async, _, _),_) -> assert false
fccc685 Initial open-source release
MLstate authored
67 | e -> e
b8e78a0 @BourgerieQuentin [enhance] compiler, utils: Added for convenience a set for binding_direc...
BourgerieQuentin authored
68 let binding_directive = function
69 | (Directive (#binding_directive, [e], _),_) -> e
70 | (Directive (#binding_directive, _, _),_) -> assert false
71 | e -> e
fccc685 Initial open-source release
MLstate authored
72 let coerce = function
73 | (Directive (`coerce,[e],_),_) -> e
74 | (Directive (`coerce,_,_),_) -> assert false
75 | e -> e
76 let deprecated = function
77 | Directive (`deprecated, [ _ ; e ], _), _ -> e
78 | Directive (`deprecated, _, _), _ -> assert false
79 | e -> e
80 let directive = function
81 | (Directive (_,[e],_),_) -> e
82 | e -> e
83 let doctype = function
84 | (Directive (`doctype _,[e],_),_) -> e
85 | (Directive (`doctype _,_,_),_) -> assert false
86 | e -> e
87 let expand = function
88 | (Directive (`expand _, [e], _), _) -> e
89 | (Directive (`expand _, _, _), _) -> assert false
90 | e -> e
91 let magic_directive = function
92 | Directive (`specialize _, e::_, _), _ -> e
93 | Directive (#magic_directive, [e], _), _ -> e
94 | Directive (#magic_directive, _, _), _ -> assert false
95 | e -> e
96 let lambda = function
97 | (Lambda (_,e),_) -> e
98 | e -> e
99 let letin = function
100 | (LetIn (_,_,e),_) -> e
101 | e -> e
102 let opacapi = function
103 | (Directive (`opacapi, [e], _), _) -> e
104 | (Directive (`opacapi, _, _),_) -> assert false
105 | e -> e
106 let opavalue_directive = function
107 | (Directive (#opavalue_directive, [e], _), _) -> e
108 | (Directive (#opavalue_directive, _, _),_) -> assert false
109 | e -> e
110 let open_ = function
111 | (Directive (`open_, [_;e], _),_) -> e
112 | (Directive (`open_, _, _),_) -> assert false
113 | e -> e
114 let private_ = function
115 | (Directive (`private_, [e], _),_) -> e
116 | (Directive (`private_, _, _),_) -> assert false
117 | e -> e
118 let slicer_directive = function
119 | (Directive (#distribution_directive,[e],_),_) -> e
120 | (Directive (#distribution_directive,_,_),_) -> assert false
121 | e -> e
122 let side_annotation = function
123 | (Directive (`side_annotation _,[e],_),_) -> e
124 | (Directive (`side_annotation _,_,_),_) -> assert false
125 | e -> e
126 let visibility_annotation = function
127 | (Directive (`visibility_annotation _,[e],_),_) -> e
128 | (Directive (`visibility_annotation _,_,_),_) -> assert false
129 | e -> e
130
131
132
133 end
134 let remove ~through e = Fixpoint.repeats through e
135 let coerce e = Fixpoint.repeat Basic.coerce e
136 (* with conjunctive types, this could be well typed
137 * but then you would need `coerce None; `wrap None *)
138 (* let rec translate = function
139 | `coerce -> [Basic.coerce]
140 and translates v = List.concat_map translate v
141 let general ~through e =
142 let through = translates through in
143 Fixpoint.repeats ~through e *)
144 end
145
146 module Look =
147 struct
148 type ('a,'b) through = ('a,'b) Remove.through
149 let default_removals = []
150 let apply ?(through=default_removals) e =
151 match Fixpoint.repeats through e with
152 | (Apply _,_) -> true
153 | _ -> false
154 let lambda ?(through=default_removals) e =
155 match Fixpoint.repeats through e with
156 | (Lambda _,_) -> true
157 | _ -> false
158 let module_ ?(through=default_removals) e =
159 match Fixpoint.repeats through e with
160 | (Directive (`module_,_,_),_) -> true
161 | _ -> false
162 let private_ ?(through=default_removals) e =
163 match Fixpoint.repeats through e with
164 | (Directive (`private_,_,_),_) -> true
165 | _ -> false
166 let record ?(through=default_removals) e =
167 match Fixpoint.repeats through e with
168 | (Record _,_) -> true
169 | _ -> false
170 (* assume that the module has local directive, not that it is a local module *)
171 let module_local ?(through=default_removals) e =
172 match Fixpoint.repeats through e with
173 | (Directive (`module_,[(Record ((_,(Directive (`local _,_,_),_))::_),_)],_),_) -> true
174 | _ -> false
175 let at ?(through=default_removals) ~at e =
176 let e = Fixpoint.repeats through e in
177 let e' = Fixpoint.repeats at e in
178 e != e'
179 end
180
181 module Context =
182 struct
183 type ('a,'b,'c) through_with_context = ('a,'b) expr -> ('a, 'b) expr * (('a, 'c) expr -> ('a, 'c) expr)
184 (* put them in alphabetical order *)
185 module Basic =
186 struct
187 let coerce = function
188 | (Directive (`coerce,[e],b),c) -> e, (fun e -> (Directive (`coerce,[e],b),c))
189 | (Directive (`coerce,_,_),_) -> assert false
190 | e -> e, identity
191 let directive = function
192 | (Directive (a,[e],c),d) -> e, (fun e -> (Directive (a,[e],c),d))
193 | e -> e, identity
194 let lambda = function
195 | (Lambda (a,e),b) -> e, (fun e -> (Lambda (a,e),b))
196 | e -> e, identity
197 let letin = function
198 | (LetIn (rec_,a,e),b) -> e, (fun e -> (LetIn (rec_,a,e),b))
199 | e -> e, identity
200 let opavalue_directive = function
201 | (Directive (#opavalue_directive as v,[e],b),c) ->
202 e, (fun e -> (Directive (v,[e],b),c))
203 | (Directive (#opavalue_directive,_,_),_) -> assert false
204 | e -> e, identity
205 let opacapi = function
206 | (Directive (`opacapi,[e],c),d) -> e, (fun e -> (Directive (`opacapi,[e],c),d))
207 | (Directive (`opacapi, _, _),_) -> assert false
208 | e -> e, identity
209 let open_ = function
210 | (Directive (`open_,[b;e],c),d) -> e, (fun e -> (Directive (`open_,[b;e],c),d))
211 | (Directive (`open_, _, _),_) -> assert false
212 | e -> e, identity
213 let doctype = function
214 | (Directive (`doctype arg,[e],b),c) -> e, (fun e -> (Directive (`doctype arg,[e],b),c))
215 | (Directive (`doctype _,_,_),_) -> assert false
216 | e -> e, identity
217 let slicer_directive = function
218 | (Directive (#distribution_directive as v,[e],b),c) ->
219 e, (fun e -> (Directive (v,[e],b),c))
220 | (Directive (#distribution_directive,_,_),_) -> assert false
221 | e -> e, identity
b8e78a0 @BourgerieQuentin [enhance] compiler, utils: Added for convenience a set for binding_direc...
BourgerieQuentin authored
222 let binding_directive = function
223 | (Directive (#binding_directive as v,[e],b),c) ->
224 e, (fun e -> (Directive (v,[e],b),c))
225 | (Directive (#binding_directive,_,_),_) -> assert false
226 | e -> e, identity
fccc685 Initial open-source release
MLstate authored
227 let side_annotation = function
228 | (Directive (`side_annotation _ as v,[e],b),c) ->
229 e, (fun e -> (Directive (v,[e],b),c))
230 | (Directive (`side_annotation _,_,_),_) -> assert false
231 | e -> e, identity
232 let visibility_annotation = function
233 | (Directive (`visibility_annotation _ as v,[e],b),c) ->
234 e, (fun e -> (Directive (v,[e],b),c))
235 | (Directive (`visibility_annotation _,_,_),_) -> assert false
236 | e -> e, identity
237 end
238 let remove ~through e = Fixpoint.repeats' (through : (_,_,_) through_with_context list) (e,identity)
239 let filter
240 ~(keep:('a, 'b, 'c) through_with_context list)
241 ~(throw:('a, 'b) Remove.through list) e
242 : ('a, 'b) SurfaceAst.expr * (('a, 'c) SurfaceAst.expr -> ('a, 'c) SurfaceAst.expr) =
243 let rec aux acc e =
244 let e' = Fixpoint.repeats throw e in
245 let e'',acc = Fixpoint.repeats' keep (e',acc) in
246 if e == e'' then
247 e, acc
248 else
249 aux acc e'' in
250 aux identity e
251 let filter2 ~keep1 ~keep2 ~throw e =
252 let rec aux acc1 acc2 e =
253 let e' = Fixpoint.repeats throw e in
254 let e'',acc1 = Fixpoint.repeats' keep1 (e',acc1) in
255 let e''',acc2 = Fixpoint.repeats' keep2 (e'',acc2) in
256 if e == e''' then
257 e, acc1, acc2
258 else
259 aux acc1 acc2 e''' in
260 aux identity identity e
261 let uncoerce e = Fixpoint.repeat' Basic.coerce (e,identity)
262 let unletin e = Fixpoint.repeat' Basic.letin (e,identity)
263 end
264
265 module FoldThrough =
266 struct
267 (* faire une contrepartie dans surfaceAstCons *)
268 let default_removals = Look.default_removals
269 let dot ?(through=default_removals) e =
270 let rec aux acc e =
271 match Fixpoint.repeats through e with
272 | (Dot (e,s),lab) -> aux ((s,lab)::acc) e
273 | e -> e, acc in
274 aux [] e
275 let arity ?(through=default_removals) e =
276 match Fixpoint.repeats through e with
277 | (Lambda (r,_),_) -> Some (List.length r)
278 | _ -> None
279 let fields ?(through=default_removals) e =
280 match Fixpoint.repeats through e with
281 | (Record r,_)
282 | (Directive (`module_, [(Record r, _)], _),_) -> Some r
283 | _ -> None
284 end
285
286 module FoldContext =
287 struct
288 let default_removals = Look.default_removals
289 let letin ?(through=default_removals) e =
290 let rec aux acc e =
291 match Fixpoint.repeats' through e with
292 (* BEWARE: dropping the rec_ flag *)
293 | ((LetIn (_,bindings,e),_),recombiner) -> aux (List.rev_append bindings acc) (e,recombiner)
294 | (e,recombiner) -> e, acc, recombiner in
295 aux [] (e,identity)
296 end
Something went wrong with that request. Please try again.