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