Skip to content
This repository
Newer
Older
100644 288 lines (273 sloc) 10.168 kb
fccc6851 »
2011-06-21 Initial open-source release
1 open SurfaceAst
2
44019de8 »
2011-06-28 [cleanup] open: remove Base in opalang
3 let identity = Base.identity
4
fccc6851 »
2011-06-21 Initial open-source release
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
8edc0012 »
2011-07-06 [feature] adding: an @async directive on bindings to perform asynchro…
63 | e -> e
64 let async = function
65 | (Directive (`async, [e], _),_) -> e
66 | (Directive (`async, _, _),_) -> assert false
fccc6851 »
2011-06-21 Initial open-source release
67 | e -> e
68 let coerce = function
69 | (Directive (`coerce,[e],_),_) -> e
70 | (Directive (`coerce,_,_),_) -> assert false
71 | e -> e
72 let deprecated = function
73 | Directive (`deprecated, [ _ ; e ], _), _ -> e
74 | Directive (`deprecated, _, _), _ -> assert false
75 | e -> e
76 let directive = function
77 | (Directive (_,[e],_),_) -> e
78 | e -> e
79 let doctype = function
80 | (Directive (`doctype _,[e],_),_) -> e
81 | (Directive (`doctype _,_,_),_) -> assert false
82 | e -> e
83 let expand = function
84 | (Directive (`expand _, [e], _), _) -> e
85 | (Directive (`expand _, _, _), _) -> assert false
86 | e -> e
87 let magic_directive = function
88 | Directive (`specialize _, e::_, _), _ -> e
89 | Directive (#magic_directive, [e], _), _ -> e
90 | Directive (#magic_directive, _, _), _ -> assert false
91 | e -> e
92 let lambda = function
93 | (Lambda (_,e),_) -> e
94 | e -> e
95 let letin = function
96 | (LetIn (_,_,e),_) -> e
97 | e -> e
98 let opacapi = function
99 | (Directive (`opacapi, [e], _), _) -> e
100 | (Directive (`opacapi, _, _),_) -> assert false
101 | e -> e
102 let opavalue_directive = function
103 | (Directive (#opavalue_directive, [e], _), _) -> e
104 | (Directive (#opavalue_directive, _, _),_) -> assert false
105 | e -> e
106 let open_ = function
107 | (Directive (`open_, [_;e], _),_) -> e
108 | (Directive (`open_, _, _),_) -> assert false
109 | e -> e
110 let private_ = function
111 | (Directive (`private_, [e], _),_) -> e
112 | (Directive (`private_, _, _),_) -> assert false
113 | e -> e
114 let slicer_directive = function
115 | (Directive (#distribution_directive,[e],_),_) -> e
116 | (Directive (#distribution_directive,_,_),_) -> assert false
117 | e -> e
118 let side_annotation = function
119 | (Directive (`side_annotation _,[e],_),_) -> e
120 | (Directive (`side_annotation _,_,_),_) -> assert false
121 | e -> e
122 let visibility_annotation = function
123 | (Directive (`visibility_annotation _,[e],_),_) -> e
124 | (Directive (`visibility_annotation _,_,_),_) -> assert false
125 | e -> e
126
127
128
129 end
130 let remove ~through e = Fixpoint.repeats through e
131 let coerce e = Fixpoint.repeat Basic.coerce e
132 (* with conjunctive types, this could be well typed
133 * but then you would need `coerce None; `wrap None *)
134 (* let rec translate = function
135 | `coerce -> [Basic.coerce]
136 and translates v = List.concat_map translate v
137 let general ~through e =
138 let through = translates through in
139 Fixpoint.repeats ~through e *)
140 end
141
142 module Look =
143 struct
144 type ('a,'b) through = ('a,'b) Remove.through
145 let default_removals = []
146 let apply ?(through=default_removals) e =
147 match Fixpoint.repeats through e with
148 | (Apply _,_) -> true
149 | _ -> false
150 let lambda ?(through=default_removals) e =
151 match Fixpoint.repeats through e with
152 | (Lambda _,_) -> true
153 | _ -> false
154 let module_ ?(through=default_removals) e =
155 match Fixpoint.repeats through e with
156 | (Directive (`module_,_,_),_) -> true
157 | _ -> false
158 let private_ ?(through=default_removals) e =
159 match Fixpoint.repeats through e with
160 | (Directive (`private_,_,_),_) -> true
161 | _ -> false
162 let record ?(through=default_removals) e =
163 match Fixpoint.repeats through e with
164 | (Record _,_) -> true
165 | _ -> false
166 (* assume that the module has local directive, not that it is a local module *)
167 let module_local ?(through=default_removals) e =
168 match Fixpoint.repeats through e with
169 | (Directive (`module_,[(Record ((_,(Directive (`local _,_,_),_))::_),_)],_),_) -> true
170 | _ -> false
171 let at ?(through=default_removals) ~at e =
172 let e = Fixpoint.repeats through e in
173 let e' = Fixpoint.repeats at e in
174 e != e'
175 end
176
177 module Context =
178 struct
179 type ('a,'b,'c) through_with_context = ('a,'b) expr -> ('a, 'b) expr * (('a, 'c) expr -> ('a, 'c) expr)
180 (* put them in alphabetical order *)
181 module Basic =
182 struct
183 let coerce = function
184 | (Directive (`coerce,[e],b),c) -> e, (fun e -> (Directive (`coerce,[e],b),c))
185 | (Directive (`coerce,_,_),_) -> assert false
186 | e -> e, identity
187 let directive = function
188 | (Directive (a,[e],c),d) -> e, (fun e -> (Directive (a,[e],c),d))
189 | e -> e, identity
190 let lambda = function
191 | (Lambda (a,e),b) -> e, (fun e -> (Lambda (a,e),b))
192 | e -> e, identity
193 let letin = function
194 | (LetIn (rec_,a,e),b) -> e, (fun e -> (LetIn (rec_,a,e),b))
195 | e -> e, identity
196 let opavalue_directive = function
197 | (Directive (#opavalue_directive as v,[e],b),c) ->
198 e, (fun e -> (Directive (v,[e],b),c))
199 | (Directive (#opavalue_directive,_,_),_) -> assert false
200 | e -> e, identity
201 let opacapi = function
202 | (Directive (`opacapi,[e],c),d) -> e, (fun e -> (Directive (`opacapi,[e],c),d))
203 | (Directive (`opacapi, _, _),_) -> assert false
204 | e -> e, identity
205 let open_ = function
206 | (Directive (`open_,[b;e],c),d) -> e, (fun e -> (Directive (`open_,[b;e],c),d))
207 | (Directive (`open_, _, _),_) -> assert false
208 | e -> e, identity
209 let doctype = function
210 | (Directive (`doctype arg,[e],b),c) -> e, (fun e -> (Directive (`doctype arg,[e],b),c))
211 | (Directive (`doctype _,_,_),_) -> assert false
212 | e -> e, identity
213 let slicer_directive = function
214 | (Directive (#distribution_directive as v,[e],b),c) ->
215 e, (fun e -> (Directive (v,[e],b),c))
216 | (Directive (#distribution_directive,_,_),_) -> assert false
217 | e -> e, identity
218 let side_annotation = function
219 | (Directive (`side_annotation _ as v,[e],b),c) ->
220 e, (fun e -> (Directive (v,[e],b),c))
221 | (Directive (`side_annotation _,_,_),_) -> assert false
222 | e -> e, identity
223 let visibility_annotation = function
224 | (Directive (`visibility_annotation _ as v,[e],b),c) ->
225 e, (fun e -> (Directive (v,[e],b),c))
226 | (Directive (`visibility_annotation _,_,_),_) -> assert false
227 | e -> e, identity
228 end
229 let remove ~through e = Fixpoint.repeats' (through : (_,_,_) through_with_context list) (e,identity)
230 let filter
231 ~(keep:('a, 'b, 'c) through_with_context list)
232 ~(throw:('a, 'b) Remove.through list) e
233 : ('a, 'b) SurfaceAst.expr * (('a, 'c) SurfaceAst.expr -> ('a, 'c) SurfaceAst.expr) =
234 let rec aux acc e =
235 let e' = Fixpoint.repeats throw e in
236 let e'',acc = Fixpoint.repeats' keep (e',acc) in
237 if e == e'' then
238 e, acc
239 else
240 aux acc e'' in
241 aux identity e
242 let filter2 ~keep1 ~keep2 ~throw e =
243 let rec aux acc1 acc2 e =
244 let e' = Fixpoint.repeats throw e in
245 let e'',acc1 = Fixpoint.repeats' keep1 (e',acc1) in
246 let e''',acc2 = Fixpoint.repeats' keep2 (e'',acc2) in
247 if e == e''' then
248 e, acc1, acc2
249 else
250 aux acc1 acc2 e''' in
251 aux identity identity e
252 let uncoerce e = Fixpoint.repeat' Basic.coerce (e,identity)
253 let unletin e = Fixpoint.repeat' Basic.letin (e,identity)
254 end
255
256 module FoldThrough =
257 struct
258 (* faire une contrepartie dans surfaceAstCons *)
259 let default_removals = Look.default_removals
260 let dot ?(through=default_removals) e =
261 let rec aux acc e =
262 match Fixpoint.repeats through e with
263 | (Dot (e,s),lab) -> aux ((s,lab)::acc) e
264 | e -> e, acc in
265 aux [] e
266 let arity ?(through=default_removals) e =
267 match Fixpoint.repeats through e with
268 | (Lambda (r,_),_) -> Some (List.length r)
269 | _ -> None
270 let fields ?(through=default_removals) e =
271 match Fixpoint.repeats through e with
272 | (Record r,_)
273 | (Directive (`module_, [(Record r, _)], _),_) -> Some r
274 | _ -> None
275 end
276
277 module FoldContext =
278 struct
279 let default_removals = Look.default_removals
280 let letin ?(through=default_removals) e =
281 let rec aux acc e =
282 match Fixpoint.repeats' through e with
283 (* BEWARE: dropping the rec_ flag *)
284 | ((LetIn (_,bindings,e),_),recombiner) -> aux (List.rev_append bindings acc) (e,recombiner)
285 | (e,recombiner) -> e, acc, recombiner in
286 aux [] (e,identity)
287 end
Something went wrong with that request. Please try again.