Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 435 lines (390 sloc) 13.091 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 *)
44019de [cleanup] open: remove Base in opalang
Raja authored
18
19 (* depends *)
20 module List = BaseList
21
fccc685 Initial open-source release
MLstate authored
22 (* TODO remove *)
23 open SurfaceAst
24 let (|>) = InfixOperator.(|>)
25
26 (**)
27
28 let opt_of_exn exn f x = try Some (f x) with e when e = exn -> None
29 let exn_of_opt exn f x =
30 match f x with
31 | None -> raise exn
32 | Some v -> v
33
34 (* functions wrapping expressions constructors *)
35 let apply (e,r) = Apply (e,r)
36 let lambda (p,e) = Lambda (p,e)
37
38 let const e = Const e
39 let string s = Const(CString s)
40 let int i = Const(CInt i)
41 let float f = Const(CFloat f)
42
43 let ident i = Ident i
44 let letin (b,iel,e) = LetIn (b,iel,e)
45 let match_ (e,pel) = Match (e,pel)
46 let record r = Record r
47 let extendrecord (r,e) = ExtendRecord (r,e)
48 let dot (e,s) = Dot (e,s)
49 let bypass b = Bypass b
50 let dbpath (a,b) = DBPath(a,b)
51 let directive (a,el,t) = Directive (a,el,t)
52
53 (* functions wrapping code_elt constructors *)
54 let database (ident,sl,ol) = Database (ident,sl,ol)
55 let newdbdef dd = NewDbDef dd
56 let newdbvalue (sl,ty) = NewDbDef(QmlAst.Db.Db_TypeDecl(List.map (fun x -> QmlAst.Db.Decl_fld x) sl, ty)) (* transitional *)
57 let newdbdefault (sl,e) = NewDbDef(QmlAst.Db.Db_Default(List.map (fun x -> QmlAst.Db.Decl_fld x) sl, e)) (* transitional *)
58 let newtype t = NewType t
59 let newval (pel,b) = NewVal (pel,b)
60
61 (* functions wrapping pat_node constructors *)
62 let patrecord r = PatRecord (r, `closed)
63 let patextendrecord r = PatRecord (r, `open_)
64 let patany = PatAny
65 let patconst c = PatConst c
66 let patvar s = PatVar s
67 let patcoerce (p,ty) = PatCoerce (p,ty)
68 let patas (p,s) = PatAs (p,s)
69
70 (* functions wrapping type_node constructors *)
71 let typeconst c = TypeConst c
72 let typevar v = TypeVar v
73 let typearrow a = TypeArrow a
74 let typerecord r = TypeRecord r
75 let typesumsugar sl = TypeSumSugar sl
76 let typenamed ti = TypeNamed ti
77 let typeexternal = TypeExternal
78 let typeforall t = TypeForall t
79 let typemodule l = TypeModule l
80
81 (* functions wrapping other type constructors *)
82 let flatvar a = Flatvar a
83 let tyrow (a,b) = TyRow (a,b)
84 let sumname a = SumName a
85 let sumrecord a = SumRecord a
86 let sumvar a = SumVar a
87
88 module Annot =
89 struct
90 let map_annot f (a, b) = (a, f b)
91 let map_node f (a, b) = (f a, b)
92 let to_string annot = FilePos.to_string annot.QmlLoc.pos
93 let to_string' (_, annot) = to_string annot
94 end
95
96 module Coerce = struct
97 (* extracts 'foo' from '_ -> foo'
98 * ie extracts 'foo' from the type of the directive representing '(a:foo)'
99 *)
100 let extract_coercion_type = function
101 | Some ((_,t),_) -> t
102 | _ -> assert false
103 let extract_coercion_type_node t = fst (extract_coercion_type t)
104
105 let rec remove ((e,_) as e') =
106 match e with
107 | Directive (`coerce, [e], _) ->
108 remove e
109 | Directive (`coerce, _, _) ->
110 assert false
111 | _ ->
112 e'
113 let uncoerce e =
114 let rec aux ((e,label) as e') acc =
115 match e with
116 | Directive (`coerce as a, [e], [c]) ->
117 aux e ((a,c,label) :: acc)
118 | _ ->
119 e', acc
120 in
121 aux e []
122 let rec recoerce e = function
123 | [] -> e
124 | (a,c,label) :: t ->
125 recoerce (Directive (a,[e],[c]), label) t
126 let uncoerce_pat ?(pred=fun _ -> true) p =
127 let rec aux ((p,label) as p') acc =
128 match p with
129 | PatCoerce (p,ty) when pred ty ->
130 aux p ((ty,label) :: acc)
131 | _ ->
132 p', acc
133 in
134 aux p []
135 let rec recoerce_pat p = function
136 | [] -> p
137 | (ty,label) :: t ->
138 recoerce_pat (PatCoerce (p,ty),label) t
139 end
140
141 module Letin = struct
142 let rec gather_aux e =
143 let (e,coerces) = Coerce.uncoerce e in
144 match fst e with
145 | LetIn (b,iel,e) ->
146 let (coerces2,iel2,e) = gather_aux e in
147 coerces @ coerces2, (b,iel) :: iel2, e
148 | _ ->
149 coerces, [], e
150 let gather e =
151 let coerces, biell, e = gather_aux e in
152 biell, Coerce.recoerce e coerces
153
154 let rec unletin_before_renaming = function
155 (* it is important to take care of one case matches because
156 * let (a,b) = 2 in 3 is converted as match 2 with (a,b) -> 3 *)
157 | (LetIn (_,_,e), _)
158 | (Directive (`coerce, [e], _), _)
159 | (Directive (`open_ , [_;e], _), _)
160 | (Match (_, [(_,e)]),_) -> unletin_before_renaming e
161 | (Directive ((`coerce | `open_), _, _),_) -> assert false
162 | e -> e
163 let rec unletin_aux acc = function
164 | (LetIn (b,iel,e), p) -> unletin_aux (`letin (b,iel,p) :: acc) e
165 | (Directive (`coerce as a, [e], c), d) -> unletin_aux (`coerce (a,c,d) :: acc) e
166 | (Directive (`coerce, _, _),_) -> assert false
167 | (Match (e1, [(p2,e2)]),d) -> unletin_aux (`match_ (e1,p2,d) :: acc) e2
168 | e -> e, acc
169 let rec unletin_aux_for_deps acc = function
170 (* not going through one case matches for module rewriting *)
171 | (LetIn (b,iel,e), p) -> unletin_aux_for_deps (`letin (b,iel,p) :: acc) e
172 | (Directive (`coerce as a, [e], c), d) -> unletin_aux_for_deps (`coerce (a,c,d) :: acc) e
173 | (Directive (`coerce, _, _),_) -> assert false
174 | e -> e, acc
175 let unletin_for_deps e=
176 unletin_aux_for_deps [] e
177 let unletin e =
178 unletin_aux [] e
179 end
180
181 module Record = struct
182 let rec extract_fields (e,_) =
183 match e with
184 | Record r
185 | Directive (`module_, [(Record r, _)], _) -> r
186 | Directive (`coerce, [e], _) -> extract_fields e
187 | Directive (`coerce, _, _) -> assert false
188 | _ -> assert false (* FIXME *)
189 let extract_fields_through_letin_before_renaming e =
190 match Letin.unletin_before_renaming e |> fst with
191 | Record r
192 | Directive (`module_, [(Record r, _)], _) -> r
193 | _ -> assert false (* FIXME *)
194 let field_names r =
195 List.map fst r
196 let field_content r =
197 List.map snd r
198 let rec is_record (e,_) =
199 match e with
200 | Directive (`coerce, [e], _) -> is_record e
201 | Directive (`coerce, _, _) -> assert false
202 | Record _ -> true
203 | _ -> false
204 let rec is_record_or_module (e,_) =
205 match e with
206 | Record _
207 | Directive (`module_, _, _) -> true
208 | Directive (`coerce, [e], _) -> is_record_or_module e
209 | Directive (`coerce, _, _) -> assert false
210 | _ -> false
211 let is_record_or_module_through_letin_before_renaming e =
212 is_record_or_module (Letin.unletin_before_renaming e)
213 let map_content f l =
214 List.map (fun (k,v) -> (k, f v)) l
215
216 (* CHECK: the fields may not be in the right order ? *)
217 let is_tuple r =
218 List.for_alli (fun i (s,_) -> s = "f" ^ string_of_int (i+1)) r && r <> []
219
220 let get_tuple r =
221 if is_tuple r then
222 Some (List.map snd r)
223 else
224 None
225
226 let rec is_module_before_renaming (e,_) =
227 match e with
228 | Directive (`module_, _, _) -> true
229 | Directive (`coerce, [e], _) -> is_module_before_renaming e
230 | Directive (`coerce, _, _) -> assert false
231 | _ -> false
232 let rec is_module e = SurfaceAstDecons.Look.module_local ~through:[SurfaceAstDecons.Remove.Basic.coerce] e
233 let is_module_through_letin e =
234 let e, _acc = Letin.unletin_for_deps e in
235 is_module e
236
237 (* through record extension and coerce *)
238 let rec get_field_opt field e =
239 match fst e with
240 | Record l ->
241 List.assoc_opt field l
242 | ExtendRecord (l, e) ->
243 ( match List.assoc_opt field l with
244 | None -> get_field_opt field e
245 | Some _ as v -> v
246 )
247 | Directive (`coerce, [e], _) ->
248 get_field_opt field e
249 | _ ->
250 None
251 let rec get_field field e =
252 Option.get (get_field_opt field e)
253 (* order of fields not specified if one field appears several times
254 * if you say {{hd tl} with hd} then the field hd will be duplicated
255 * FIXME
256 *)
257 let rec get_fields e =
258 match fst e with
259 | Record l -> List.map fst l
260 | ExtendRecord (l, e) -> List.map fst l @ get_fields e
261 | Directive (`coerce, [e], _) -> get_fields e
262 | _ -> []
263 let get_fields_filter fields e =
264 List.map (fun field -> get_field field e) fields
265 let has_field field e =
266 Option.is_some (get_field_opt field e)
267
268 let rec get_field_opt_p field p =
269 match fst p with
270 | PatRecord (l, _) ->
271 List.assoc_opt field l
272 | PatCoerce (p,_) ->
273 get_field_opt_p field p
274 | _ ->
275 None
276
277 let rec get_fields_p p =
278 match fst p with
279 | PatRecord (l, _) -> List.map fst l
280 | PatCoerce (p,_) -> get_fields_p p
281 | _ -> []
282
283 let has_field_p field e =
284 Option.is_some (get_field_opt_p field e)
285 end
286
287 module Basictype =
288 struct
289 let get_string_opt e =
290 match Coerce.remove e with
291 | (Const (CString s), _) -> Some s
292 | _ -> None
293 let get_string x = exn_of_opt Exit get_string_opt x
294
295 let get_char_opt e =
296 match Coerce.remove e with
297 | (Const (CChar c), _) -> Some c
298 | _ -> None
299 let get_char x = exn_of_opt Exit get_char_opt x
300 end
301
302 module Datatype =
303 struct
304 (** Lists *)
305 (* what about extendrecord? *)
306 let get_list e =
307 let rec aux acc e =
308 match fst e with
309 | Record [("nil", _)] -> List.rev acc
310 | Record [("hd",e1);("tl",e2)] -> aux (e1 :: acc) e2
311 | Record [("tl",e1);("hd",e2)] -> aux (e2 :: acc) e1
312 | Directive (`coerce, [e], _) -> aux acc e
313 | _ -> raise Exit
314 in
315 aux [] e
316 let get_list_opt e = opt_of_exn Exit get_list e
317
318 (** Booleans *)
319 let bool e = Record.has_field "true" e
320 let bool_p e = Record.has_field_p "true" e
321 let is_bool e =
322 match Record.get_fields e with
323 | ["true"] | ["false"] -> true
324 | _ -> false
325 let is_bool_p e =
326 match Record.get_fields_p e with
327 | ["true"] | ["false"] -> true
328 | _ -> false
329 end
330
331 module Lambda = struct
332 let is_lambda e =
333 match Coerce.remove e with
334 | (Lambda (_,_),_) -> true
335 | _ -> false
336
337 let rec collapse e =
338 match e with
339 | Lambda (l0,(Lambda(l1,e),_)),a -> collapse (Lambda (l0@l1,e),a)
340 | _ -> e
341 end
342
343 module Rec = struct
344 module D = SurfaceAstDecons
345 let recursive_scope_before_renaming e =
346 let e =
347 D.Remove.remove
348 ~through:[ D.Remove.Basic.access_directive
349 ; D.Remove.Basic.expand
350 ; D.Remove.Basic.opacapi
351 ; D.Remove.Basic.opavalue_directive
352 ; D.Remove.Basic.coerce
353 ; D.Remove.Basic.slicer_directive
354 ; D.Remove.Basic.letin
8edc001 [feature] adding: an @async directive on bindings to perform asynchronou...
Valentin Gatien-Baron authored
355 ; D.Remove.Basic.open_
356 ; D.Remove.Basic.async ] e in
fccc685 Initial open-source release
MLstate authored
357 D.Look.module_ e || D.Look.lambda e
358
359 let recursive_scope e =
360 let e =
361 D.Remove.remove
362 ~through:[ D.Remove.Basic.access_directive
363 ; D.Remove.Basic.expand
364 ; D.Remove.Basic.opacapi
365 ; D.Remove.Basic.opavalue_directive
366 ; D.Remove.Basic.coerce
367 ; D.Remove.Basic.slicer_directive (* LOOK AGAIN: not sure *)
8edc001 [feature] adding: an @async directive on bindings to perform asynchronou...
Valentin Gatien-Baron authored
368 ; D.Remove.Basic.letin
369 ; D.Remove.Basic.async ] e in
fccc685 Initial open-source release
MLstate authored
370 D.Look.module_ e || D.Look.lambda e
371 end
372
373 module TypeConst =
374 struct
375 let type_of_node = function
376 | CInt _ -> TyInt
377 | CFloat _ -> TyFloat
378 | CString _ -> TyString
379 | CChar _ -> TyChar
380 let type_of x = type_of_node (fst x)
381 end
382
383 module TypeRecord =
384 struct
385 let field_names (TyRow (fields,_)) =
386 List.map fst fields
387 let get_tuple_length s =
388 try
389 Scanf.sscanf s "tuple_%d" (fun i -> if i > 0 then Some i else None)
390 with
391 | End_of_file
392 | Scanf.Scan_failure _ -> None
393 let is_tuple = function
394 | (TypeNamed (Typeident s, _), _) ->
395 Option.is_some (get_tuple_length (Ident.original_name s))
396 | _ -> false
397 end
398
399 module Dot =
400 struct
401 let app_to_dot e =
402 let rec aux acc ((e,_) as e') =
403 match e with
404 | Dot (e, s) -> aux (s :: acc) e
405 | Directive (`coerce, [e], _) -> aux acc e
406 | _ -> e',acc
407 in
408 aux [] e
409
410 let app_to_dot_for_renaming e =
411 let rec aux acc ((e,_) as e') =
412 match e with
413 | Dot ((Directive (`toplevel,_,_),_),_) -> e', acc
414 | Dot (e, s) -> aux (s :: acc) e
415 | Directive (`coerce, [e], _) -> aux acc e
416 | _ -> e',acc
417 in
418 aux [] e
419
420
421 let app_to_dot_safe e =
422 let rec aux acc (*acc_coerce*) ((e,label) as e') =
423 match e with
424 | Dot (e, s) -> aux ((s,label) :: acc) (*acc_coerce*) e
425 (* FIXME? *)
426 (*| Directive (`coerce, _, [e], r) -> aux acc (r :: acc_coerce) e*)
427 | _ -> e', acc(*, acc_coerce*)
428 in
429 aux [] (*[]*) e
430
431 let dot_to_app_safe e path =
432 List.fold_left (fun e (s,label) -> (Dot (e, s), label)) e path
433
434 end
Something went wrong with that request. Please try again.