Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 890 lines (779 sloc) 32.138 kB
fccc685 Initial open-source release
MLstate authored
1 (*
c1a67b5 @BourgerieQuentin [feature] compiler, database: Added path selection to surface ast
BourgerieQuentin authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
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
2d63a40 [cleanup] open: remove Base in opaToQml
Raja authored
19 (* depends *)
20 module List = BaseList
fccc685 Initial open-source release
MLstate authored
21
22 let (|>) = InfixOperator.(|>)
23
24 (* shorthands *)
25 module QA = QmlAst
26 module QC = QmlAstCons
27 module SA = SurfaceAst
28 module SH = SurfaceAstHelper
29 module L = QmlLoc
30
31 (* open QmlTypeVarsScope *)
32
33 (* errors *)
34
35 type error = string
36 exception Exception of error
37 external string_of_error : error -> string = "%identity"
38
39 let (!!!) fmt =
40 Format.ksprintf (fun s -> raise (Exception s)) fmt
41
42 (*
43 Options of the conversion, set before a code transformation
44 *)
45
46 (* HACK : please, clean-up in opa lang *)
47 module Parser_utils = OpaParserUtils
48
49 type options = unit
50
51 let set_options () = ()
52
53 let options = ()
54
55
56 let propagate_slicer_annotation e =
57 let module D = SurfaceAstDecons in
58 let throw = [D.Remove.Basic.letin;
59 D.Remove.Basic.opacapi;
60 D.Remove.Basic.coerce;
61 D.Remove.Basic.doctype] in
62 let _, visibility_annotater, side_annotater =
63 D.Context.filter2
64 ~keep1:[D.Context.Basic.visibility_annotation]
65 ~keep2:[D.Context.Basic.side_annotation]
66 ~throw
67 e in
68 let reannotate e =
69 let e =
70 if D.Look.at ~at:[D.Remove.Basic.visibility_annotation]
71 ~through:(D.Remove.Basic.side_annotation :: throw)
72 e
73 then e
74 else visibility_annotater e in
75 let e =
76 if D.Look.at ~at:[D.Remove.Basic.side_annotation]
77 ~through:(D.Remove.Basic.visibility_annotation :: throw)
78 e
79 then e
80 else side_annotater e in
81 e in
82 reannotate
83
84 (* a few utility functions that simplifies opa patterns
85 * because they are more expressive that old qml ones (no coerce, no 'as')
86 * and qml ones (no 'as)
87 *)
88 module PatternUtils (C : SurfaceAstConsSig.CONS) =
89 struct
90 let next = C.I.ns_fresh
91
92 let copy_label = Parser_utils.copy_label
93 let same_pos v (_, label) = (v, copy_label label)
94
95 let simplify_lambda (r,e) =
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
96 let (res, (a, _)) =
fccc685 Initial open-source release
MLstate authored
97 List.fold_right_map
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
98 (fun (s,p) (e, n) ->
fccc685 Initial open-source release
MLstate authored
99 SurfaceAstCons.with_same_pos p (fun () -> let label = snd p in
100 match fst p with
101 | SA.PatAny
102 | SA.PatVar _ ->
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
103 (s,p), (e, n-1)
fccc685 Initial open-source release
MLstate authored
104 | SA.PatCoerce ((SA.PatRecord ([], `closed), _), _) ->
105 (* special case for void so that the code is more readable *)
106 let i = next ~label "remove_void" in
107 let void = next ~label "void" in
108 (s, C.P.var void),
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
109 (same_pos (SA.LetIn (false,[(i, C.T.coerce (same_pos (SA.Ident void) p) (C.T.void ()))], e)) p, n-1)
fccc685 Initial open-source release
MLstate authored
110 | SA.PatCoerce ((SA.PatVar v, l) as p, ty) ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
111 let v = v.SA.ident in
fccc685 Initial open-source release
MLstate authored
112 let i = next ~label "remove_coerce" in
113 (s, p),
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
114 ((same_pos (SA.LetIn (false,[(i,C.T.coerce (SA.Ident v,l) ty)], e)) e), n-1)
fccc685 Initial open-source release
MLstate authored
115 | _ ->
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
116 let i = next ~label (Printf.sprintf "arg%i" n) in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
117 (s, same_pos (SA.PatVar {SA.ident=i;SA.directives=[]}) p),
5592c83 @BourgerieQuentin [fix] compiler, stdlib: map sringifier + prettu name for simplify_lam…
BourgerieQuentin authored
118 ((same_pos (SA.Match (same_pos (SA.Ident i) p, [(p, e)])) e), n-1)
119 )
120 ) r (e, List.length r)
121 in res, a
fccc685 Initial open-source release
MLstate authored
122
123 (* FIXME: move me *)
124 let map2_2 f (x,y) = (x, f y)
125 let (@>) f g x = x |> f |> g
126
127 let rec rebuild ~and_coerces map ((p,label) as pp) =
128 SurfaceAstCons.with_label label (fun () ->
129 match IntMap.find_opt label.QmlLoc.notes map with
130 | Some i -> pp, (SA.Ident i, copy_label label)
131 | None ->
132 match p with
133 | SA.PatVar a ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
134 pp, (SA.Ident a.SA.ident, copy_label label)
fccc685 Initial open-source release
MLstate authored
135 | SA.PatRecord (spl, rowvar) ->
136 if rowvar = `open_ then (
137 let context = OpaError.Context.annot label in
138 OpaError.error context (
139 "You cannot put a 'as'%s around a '...' pattern"
140 )
141 (if and_coerces then " or a coercion (which includes tuples and lists patterns)" else "")
142 ) ;
143 let sl, pel = List.split (List.map (map2_2 (rebuild ~and_coerces map)) spl) in
144 let pl, el = List.split pel in
145 let spl = List.combine sl pl in
146 let sel = List.combine sl el in
147 (SA.PatRecord (spl, `closed), label), (SA.Record sel, copy_label label)
148 | SA.PatConst c ->
149 pp, (SA.Const c, label)
150 | SA.PatCoerce (p,ty) ->
151 let p, e = rebuild ~and_coerces map p in
152 p, C.T.coerce e ty
153 | SA.PatAs (p,i) ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
154 p, (SA.Ident i.SA.ident, label)
fccc685 Initial open-source release
MLstate authored
155 | SA.PatAny ->
156 let i = next ~label "rebuild" in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
157 (SA.PatVar {SA.ident=i;directives=[]}, label), (SA.Ident i, copy_label label)
fccc685 Initial open-source release
MLstate authored
158 )
159
160 let remove_as ~and_coerces p e =
161 let (_map,acc),p =
162 SurfaceAstTraversal.PatTraverse.foldmap_up
163 (fun (map,acc) ((p,label) as p') ->
164 match p with
165 | SA.PatAs (p, s) ->
166 let p,e = rebuild ~and_coerces map p in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
167 let map = IntMap.add label.QmlLoc.notes s.SA.ident map in
168 let map = IntMap.add (snd p).QmlLoc.notes s.SA.ident map in
169 (map, (s.SA.ident,e,p)::acc), p
fccc685 Initial open-source release
MLstate authored
170 | SA.PatCoerce (pc, _) when and_coerces ->
171 let i = next ~label "remove_coerce" in
172 let p,e = rebuild ~and_coerces map p' in
173 let map = IntMap.add label.QmlLoc.notes i map in
174 let map = IntMap.add (snd pc).QmlLoc.notes i map in
175 (map, (i,e,p)::acc), p
176 | _ ->
177 (map, acc), p'
178 ) (IntMap.empty,[]) p in
179 let acc = List.fold_left (fun acc (i,e,p) -> same_pos (SA.LetIn (false,[(i, e)],acc)) p) e acc in
180 acc,p
181
182 (* p = expr *)
183 let rec pattern_to_bindings expr p =
184 let label = snd p in
185 match fst p with
186 | SA.PatVar v ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
187 [(v.SA.ident, SurfaceAstCons.Refresh.expr expr)]
fccc685 Initial open-source release
MLstate authored
188 | SA.PatRecord (spl, _) ->
189 List.concat_map
190 (fun (s, p) ->
191 pattern_to_bindings (same_pos (SA.Dot (expr, s)) p) p
192 ) spl
193 | SA.PatAny _ -> []
194 | SA.PatConst _ ->
195 (* how to rewrite 2 = x in Qml ?
196 * one could do assert (2 = x)
197 * or _ = match x with 2 -> {} | _ -> error("")
198 *)
199 assert false
200 | SA.PatAs (p, s) ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
201 (s.SA.ident, expr) :: pattern_to_bindings expr p
fccc685 Initial open-source release
MLstate authored
202 | SA.PatCoerce (p, ty) ->
203 let i = next ~label "pattern_to_bindings" in
204 SurfaceAstCons.with_same_pos p (fun () ->
205 (i, C.T.coerce expr ty) :: pattern_to_bindings expr p
206 )
207 end
208
209 (* functorisation for the 2 traductions *)
210 module type ARG =
211 sig
212 (** The type of the parameter 'ident of OpaAst *)
213 type ident
214 val to_string : ident -> string
215 val of_string : string -> ident
216 val typevar : ident -> QA.typevar
217 val rowvar : ident -> QA.rowvar
218 val colvar : ident -> QA.colvar
219 val add_local_scope : unit -> unit
220 val remove_local_scope : unit -> unit
221 val get_local_vars : unit -> QA.typevar list * QA.rowvar list * QA.colvar list
222 val reset_var_scopes : unit -> unit
223 (** should be invoked before each top-level phrase *)
224 val typeident : ?check:bool -> ident -> QA.TypeIdent.t
225 val exprident : ident -> Ident.t
226 val pp_print_directive : (ident, [< SurfaceAst.all_directives ]) SurfaceAst.directive LangPrint.pprinter
227 end
228
229 module MakeOpaToQml (C : SurfaceAstConsSig.CONS) (Arg : ARG with type ident = C.ident) =
230 struct
231 module PatternUtils = PatternUtils (C)
232
233 let qlabel sa_label = Annot.next_label sa_label.QmlLoc.pos
234
235 let keep_magic_directive = false
236
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
237 let fail p s = raise (Exception (Printf.sprintf "%s : %s" (SH.Annot.to_string' p) s))
fccc685 Initial open-source release
MLstate authored
238 (* indicate mostly a node that can't be converted to the new ast *)
239
240 let rec const_ty_node = function
241 | SA.TyInt -> QA.TyInt
242 | SA.TyFloat -> QA.TyFloat
243 | SA.TyString -> QA.TyString
244
245 and ty x = ty_node (fst x)
246 and ty_node = function
247 | SA.TypeConst c -> QA.TypeConst (const_ty_node c)
248 | SA.TypeVar (SA.Flatvar tv) -> QA.TypeVar (Arg.typevar tv)
249 | SA.TypeArrow arrow -> typearrow_aux arrow
250 | SA.TypeRecord row -> typerecord row
251 | SA.TypeSumSugar ts -> ty_sum ts
252 (* if accept_anonymous_sum_type.contents then ty_sum ts else fail (List.hd ts) "Anonymous sum types are not yet supported in this version of the compiler. Please define the sum type and use the name from the definition instead of the anonymous sum type. (Note that, e.g, type expression \"private({a} / {b})\" contains an anonymous sum type!)" *)
253 | SA.TypeNamed (SA.Typeident s,tyl) ->
254 QA.TypeName (List.map ty tyl, Arg.typeident ~check:false s)
255 | SA.TypeExternal -> QA.TypeAbstract
256 | SA.TypeForall (vars, t) ->
257 QA.TypeForall
258 (List.map (function (SA.Flatvar v) -> Arg.typevar v) vars,
259 [], [], ty t)
260 | SA.TypeModule fields ->
261 let aux_module_field (s, t) =
262 Arg.add_local_scope ();
263 let t = ty t in
264 let (ty_vars, row_vars, col_vars) as vars = Arg.get_local_vars () in
265 let t_quantified =
266 if vars = ([], [], []) then t
267 else QA.TypeForall (ty_vars, row_vars, col_vars, t) in
268 Arg.remove_local_scope () ;
269 (s, t_quantified) in
270 let fields = List.map aux_module_field fields in
271 QA.TypeRecord(QA.TyRow(fields, None))
272
273 and ty_sum ts =
274 let ts', last = List.extract_last ts in
275 let ts, colvar =
276 match last with
277 | SA.SumVar (SA.Colvar v),_ -> ts', Some (Arg.colvar v)
278 | _ -> ts, None in
279 let is_TypeRecord = function
280 | SA.SumRecord (SA.TyRow (_, None)),_ -> true
281 | _ -> false in
282 if List.for_all is_TypeRecord ts then (
283 QA.TypeSum
284 (QA.TyCol
285 (List.map
286 (function
287 | (SA.SumRecord row,_) ->
288 let fields, rowvar = typerow row in
289 assert (rowvar = None) ;
290 fields
291 | _ -> assert false
292 ) ts, colvar))
293 )
294 else (
295 assert (colvar = None) ;
296 QA.TypeSumSugar
297 (List.map
298 (function
299 | (SA.SumRecord row,_) -> ty_node (SA.TypeRecord row)
300 | (SA.SumName n,_) -> ty_node (SA.TypeNamed n)
301 | (SA.SumVar (SA.Colvar _),_) -> assert false) ts)
302 )
303
304 and typearrow x = typearrow_aux (fst x)
305 and typearrow_aux (row, t) =
306 let SA.TyRow (fields, rowvaro) = fst row in
307 assert (rowvaro = None);
308 QA.TypeArrow ((List.map (fun (_,x) -> ty x) fields), ty t)
309
310 and typerecord row =
311 let l,r=typerow row in
312 QA.TypeRecord (QA.TyRow (l, r))
313 and typerow (SA.TyRow (fields, rowvaro)) =
314 let l = List.map (fun (s, t) -> (s, (ty t))) fields in
315 let r = Option.map (function SA.Rowvar v -> Arg.rowvar v) rowvaro in
316 (l, r)
317
318 let typeident_aux = Arg.typeident
319 let typeident ?(check=true)(SA.Typeident i) = typeident_aux ~check i
320
321 let typedef ty_def =
322 let vars =
323 List.map
324 (function SA.Flatvar var -> Arg.typevar var)
325 ty_def.SurfaceAst.ty_def_params in
326 let visibility' =
327 (match ty_def.SurfaceAst.ty_def_visibility with
328 | SA.TDV_public -> QmlAst.TDV_public
329 | SA.TDV_abstract ->
330 QmlAst.TDV_abstract (ObjectFiles.get_current_package_name ())
331 | SA.TDV_private ->
332 QmlAst.TDV_private (ObjectFiles.get_current_package_name ())) in
333 let SA.Typeident ti = ty_def.SurfaceAst.ty_def_name in
334 {
335 QmlAst.ty_def_options = ty_def.SA.ty_def_options ;
336 QmlAst.ty_def_visibility = visibility' ;
337 QmlAst.ty_def_name = Arg.typeident ~check:false ti ;
338 QmlAst.ty_def_params = vars ;
339 QmlAst.ty_def_body = ty ty_def.SurfaceAst.ty_def_body ;
340 }
341
342 (* Note that the OPA annot [opa_annot] is only used for error messages
343 purpose. *)
344 let const_expr (const_node, opa_annot) =
345 match const_node with
346 | SA.CInt i ->
347 (try QA.Int (Big_int.int_of_big_int i)
348 with Failure "int_of_big_int" ->
349 let context = OpaError.Context.annot opa_annot in
350 OpaError.error context
351 "Too big integer literal : %s@\nThe biggest int handled : %d"
352 (Big_int.string_of_big_int i)
353 Pervasives.max_int)
354 | SA.CFloat f -> QA.Float f
355 | SA.CString s -> QA.String s
356
357 let ident = Arg.exprident
358
359
360 (* ************************************************************************ *)
361 (** {b Descr}: Creates a new label, i.e. key in an annotation map + position
362 in source code. The key in annotation map is a fresh one. The position
363 in source code is copied from the OPA annotation received in input.
364 {b Visibility}: Not exported outside this module. *)
365 (* ************************************************************************ *)
366 let make_label_from_opa_annot opa_annot =
367 let annot = Annot.next () in
368 let pos = opa_annot.QmlLoc.pos in
369 Annot.make_label annot pos
370
371
372
373 let lookup ~with_label ?(special = false) e x =
374 if special then QA.Ident (with_label, (Ident.source x))
375 else
376 match OpaMapToIdent.val_opt x with
377 | None ->
378 OManager.error
379 "Please define %s (used at %s)@\n"
380 x
381 (SurfaceAstHelper.Annot.to_string' e)
382 | Some ident -> QA.Ident (with_label, ident)
383
384
385
386 let rec pat (pat, e) =
387
388 (* ********************************************************************** *)
389 (** {b Descr}: Local function to process general patterns.
390 {b Visibility}: Local to the surrounding function. *)
391 (* ********************************************************************** *)
392 let rec aux (x, opa_annot) =
393 match x with
394 | SA.PatRecord (fields, rowvar) ->
395 let fields = List.map (fun (field, opa_pat) -> field, aux opa_pat) fields in
396 QA.PatRecord (make_label_from_opa_annot opa_annot, fields, rowvar)
397 | SA.PatAny -> QA.PatAny (make_label_from_opa_annot opa_annot)
398 | SA.PatConst c ->
399 QA.PatConst
400 (make_label_from_opa_annot opa_annot, (const_expr (c, opa_annot)))
401 | SA.PatVar i ->
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
402 QA.PatVar (make_label_from_opa_annot opa_annot, ident i.SA.ident)
fccc685 Initial open-source release
MLstate authored
403 | SA.PatCoerce (p, ty_) ->
404 let ty_ = ty ty_ in
405 let p = aux p in
406 QA.PatCoerce ((make_label_from_opa_annot opa_annot), p, ty_)
407 | SA.PatAs (p, i) ->
408 #<If:PATTERNS_REAL_PATAS $equals "0">
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
409 fail p (Printf.sprintf "PatAs %s" (Arg.to_string i.SA.ident))
fccc685 Initial open-source release
MLstate authored
410 #<Else>
411 let p = aux p in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
412 QA.PatAs (make_label_from_opa_annot opa_annot, p, ident i.SA.ident)
fccc685 Initial open-source release
MLstate authored
413 #<End>
414 in
415 (* Effective body of the function [pat] dealing with a whole
416 pattern-matching case, i.e. a left-side pattern and a right-side
417 expression. *)
418 let (e, pat) =
419 #<If:PATTERNS_REAL_PATAS $equals "0">
420 PatternUtils.remove_as ~and_coerces: false pat e
421 #<Else>
422 e, pat
423 #<End>
424 in
425 let pat = aux pat in
426 let e = expr e in
427 (pat, e)
428
429
430 and expr original_expr =
431 (* ********************************************************************** *)
432 (** {b Descr}: Local function to process a record expression. It simply
433 recursively apply on each sub-expression of the record expression and
434 rebuild a QML isomorphic record expression.
435 {b Visibility}: Local to the surrounding function. *)
436 (* ********************************************************************** *)
437 let rec aux_record (r, opa_annot) =
438 (* CHECK : the order of the pattern has no importance for qml *)
439 let fields =
440 List.map
441 (fun (field_name, field_expr) -> (field_name, (aux field_expr)))
442 r in
443 QA.Record ((make_label_from_opa_annot opa_annot), fields)
444
445 (* ********************************************************************** *)
446 (** {b Descr}: Local function to process general expressions.
447 {b Visibility}: Local to the surrounding function. *)
448 (* ********************************************************************** *)
449 and aux (x, opa_annot) =
450 match x with
c1a67b5 @BourgerieQuentin [feature] compiler, database: Added path selection to surface ast
BourgerieQuentin authored
451 | SA.DBPath (path, k, s) ->
fccc685 Initial open-source release
MLstate authored
452 let path = List.map (fun (elt, _) -> db_path elt) (fst path) in
c1a67b5 @BourgerieQuentin [feature] compiler, database: Added path selection to surface ast
BourgerieQuentin authored
453 QA.Path ((make_label_from_opa_annot opa_annot), path, kind k, select s)
fccc685 Initial open-source release
MLstate authored
454 | SA.Apply (e, r) ->
455 let e = aux e in
456 let args = List.map (fun (_, e') -> aux e') (fst r) in
457 QA.Apply ((make_label_from_opa_annot opa_annot), e, args)
458 | SA.Lambda (params, body) ->
459 let (params, body) = PatternUtils.simplify_lambda (params, body) in
460 let params =
461 let extract_ident (s_, p) =
462 match fst p with
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
463 | SA.PatVar i -> ident i.SA.ident
fccc685 Initial open-source release
MLstate authored
464 | SA.PatAny -> Ident.nextf "anonymous_lambda_arg_%s" s_
465 (* not equivalent but once typing is done, it doesn't matter *)
466 (*| SA.PatRecord [] -> fresh_ident ()*)
467 | _ -> fail p "LambdaPattern" in
468 List.map extract_ident params in
469 let body = aux body in
470 QA.Lambda ((make_label_from_opa_annot opa_annot), params, body)
471 | SA.Const c ->
472 QA.Const
473 ((make_label_from_opa_annot opa_annot), const_expr (c, opa_annot))
474 | SA.Ident i ->
475 QA.Ident ((make_label_from_opa_annot opa_annot), (ident i))
476 | SA.LetIn (rec_, iel, e) ->
477 let iel = List.map (fun (i, e') -> ((ident i), (aux e'))) iel in
478 let e = aux e in
479 let new_label = make_label_from_opa_annot opa_annot in
480 if rec_ then QA.LetRecIn (new_label, iel, e)
481 else QA.LetIn (new_label, iel, e)
482 | SA.Match (e, pel) ->
483 let e = aux e in
484 let pel = List.map pat pel in
485 QA.Match ((make_label_from_opa_annot opa_annot), e, pel)
486 | SA.Record r -> aux_record (r, opa_annot)
487 | SA.ExtendRecord (r, e) ->
488 let inner =
489 let i = PatternUtils.next ~label:opa_annot "surfaceAstConverte" in
490 aux
491 (SA.LetIn (false, [(i,e)], (SA.Ident i, Parser_utils.nlabel e)),
492 Parser_utils.nlabel e) in
493 let fold acc (s, e) =
494 let e = aux e in
495 QA.ExtendRecord
496 ((make_label_from_opa_annot opa_annot), s, e, acc) in
497 List.fold_left fold inner (List.rev r)
498 | SA.Dot (e, f) ->
499 QA.Dot ((make_label_from_opa_annot opa_annot), (aux e), f)
500 (* TODO: opalang does not depends on libbsl SA.Bypass of string *)
501 | SA.Bypass bslkey ->
502 QA.Bypass ((make_label_from_opa_annot opa_annot), bslkey)
503 | SA.Directive d -> directive opa_annot d in
504
505 (* Effective body of the function [expr] dealing with expressions. *)
506 aux original_expr
507
d466bb2 @BourgerieQuentin [enhance] compiler: opalang take care of new update ast
BourgerieQuentin authored
508 and kind k = match k with
2dc656e @BourgerieQuentin [feature] compiler, database: Added update options in the database as…
BourgerieQuentin authored
509 | QA.Db.Update (update, options) ->
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new q…
BourgerieQuentin authored
510 let rebuild, exprs =
511 QmlAst.Db.sub_db_update
512 Traverse.Utils.sub_current
513 Traverse.Utils.sub_ignore
514 update in
515 let exprs' = List.map expr exprs in
2dc656e @BourgerieQuentin [feature] compiler, database: Added update options in the database as…
BourgerieQuentin authored
516 let update = rebuild exprs' in
517 let rebuild, exprs =
518 QmlAst.Db.sub_db_update_options
519 Traverse.Utils.sub_current
520 Traverse.Utils.sub_ignore
521 options in
522 let exprs' = List.map expr exprs in
523 let options = rebuild exprs' in
524 QA.Db.Update (update, options)
d466bb2 @BourgerieQuentin [enhance] compiler: opalang take care of new update ast
BourgerieQuentin authored
525 | QA.Db.Default -> QA.Db.Default
526 | QA.Db.Option -> QA.Db.Option
527 | QA.Db.Valpath -> QA.Db.Valpath
528 | QA.Db.Ref -> QA.Db.Ref
fccc685 Initial open-source release
MLstate authored
529
c1a67b5 @BourgerieQuentin [feature] compiler, database: Added path selection to surface ast
BourgerieQuentin authored
530 and select s =
531 let rebuild, exprs =
532 QmlAst.Db.sub_db_select
533 Traverse.Utils.sub_current
534 Traverse.Utils.sub_ignore
535 s in
536 let exprs' = List.map expr exprs in
537 rebuild exprs'
538
fccc685 Initial open-source release
MLstate authored
539 and expr_of_record e =
540 expr (SA.Record ((Parser_utils.encode_tuple [e])), Parser_utils.nlabel e)
541
542
543
544 and may_make_tuple1 (e: (_,_) SA.expr) = expr e
545
546
547
548 and apply_directive ?(special = false) opa_annot name e =
549 let args = may_make_tuple1 e in
550 let ident =
551 lookup
552 ~with_label: (make_label_from_opa_annot opa_annot) ~special e name in
553 QA.Apply ((make_label_from_opa_annot opa_annot), ident, [args])
554
555
556
557 (* used for magic_* directives only *)
558 and directive_variant_to_string = function
559 | `magic_to_string -> Opacapi.magicToString
560 | `magic_to_xml -> Opacapi.magicToXml
561
562
563
564 and directive opa_annot ((c, e, t) as d) =
565 match c, e, t with
566 | (
567 `typeof | `opensums | `openrecord | `unsafe_cast
568 | `nonexpansive | `doctype _ | `module_ | `module_field_lifting
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
569 | `spawn | `wait | `atomic | `callcc | `js_ident | `expand _
fccc685 Initial open-source release
MLstate authored
570 | `create_lazy_record | `assert_ | `fail
571 | `thread_context
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
572 | `async
fccc685 Initial open-source release
MLstate authored
573 | `throw | `catch | `tracker _
574 | `with_thread_context
575 | `sliced_expr
576 | `may_cps
577 | `specialize _
578 | `deprecated
579 | `todo
580 | `recval
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
581 | #SA.opavalue_directive
fccc685 Initial open-source release
MLstate authored
582 | #SA.distribution_directive
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
583 | `llarray
2536662 @OpaOnWindowsNow [feature] closure serialisation: restrict to new @public_env directive
OpaOnWindowsNow authored
584 | #QA.closure_instrumentation_directive
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
585 ) as variant, el, tl ->
fccc685 Initial open-source release
MLstate authored
586 let el = List.map expr el in
587 let tl = List.map ty tl in
588 QA.Directive ((make_label_from_opa_annot opa_annot), variant, el, tl)
589 (* TODO: remove Coerce from QmlAst, and use the directive instead *)
590 | `coerce, [e], [t] ->
591 let t = ty t in
592 let e = expr e in
593 QA.Coerce ((make_label_from_opa_annot opa_annot), e, t)
594 | `coerce, _, _ -> assert false
595
596 | `warncoerce, _, _ ->
597 (*
598 Currently, this directive is not in the syntax,
599 and not any pass insert it before the pass_OpaToQml.
600 *)
601 assert false
602
603 | `opacapi, args, _ -> (
604 match args with
605 | [e] -> expr e
606 | _ ->
607 (*
608 The parser ensure that the directive has exactly 1 argument.
609 *)
610 assert false
611 )
612
613 | `magic_do, args, [] -> (
614 match args with
615 | [e] ->
616 (*
617 magic_do is traduced to warncoerce in qml.
618 we do not use magic_do for funaction anymore.
619 *)
620 let e = expr e in
621 let void = QA.TypeName ([], QA.TypeIdent.of_string Opacapi.Types.void) in
622 QA.Directive
623 ((make_label_from_opa_annot opa_annot), `warncoerce, [e], [void])
624
625 | _ ->
626 (*
627 this directive is generated by the parser, with exactly 1 argument.
628 *)
629 assert false
630 )
631
632 | `fun_action, [e], [] ->
633 let e = expr e in
634 QA.Directive
635 ((make_label_from_opa_annot opa_annot), `fun_action None, [e], [])
636 (* magic directive can be converted to directive or fun call *)
637 | (`magic_to_string | `magic_to_xml) as variant, [e], []
638 when not keep_magic_directive ->
639 apply_directive opa_annot (directive_variant_to_string variant) e
640
641 | #SA.all_directives, e :: _, _ ->
642 Format.eprintf "%a%!" Arg.pp_print_directive d;
643 fail e "directive: Not implemented" (* TODO *)
644 | #SA.all_directives, [], _ ->
645 Format.eprintf "%a%!" Arg.pp_print_directive d;
646 !!! "directive: Not implemented" (* TODO *)
647
648
649 and db_path path =
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new q…
BourgerieQuentin authored
650 let rebuild, exprs =
651 QmlAst.Db.sub_path_elt
652 Traverse.Utils.sub_current
653 Traverse.Utils.sub_ignore
654 path in
655 let exprs' = List.map expr exprs in
656 rebuild exprs'
fccc685 Initial open-source release
MLstate authored
657
658
659 module DbConv =
660 struct
661 open QA
662 let db_constraint const =
663 match const with
664 | Db.C_Ordering expr_ -> Db.C_Ordering (expr expr_)
665 | Db.C_Inclusion p -> Db.C_Inclusion p
666 | Db.C_Validation expr_ -> Db.C_Validation (expr expr_)
667 | Db.C_Inverse p -> Db.C_Inverse p
668 | Db.C_Private -> Db.C_Private
669
670 let db_def = function
671 | Db.Db_TypeDecl (path_decl, ty_) ->
672 Db.Db_TypeDecl (path_decl, (ty ty_))
673 | Db.Db_Alias (path_decl, path_decl2) ->
674 Db.Db_Alias (path_decl, path_decl2)
675 | Db.Db_Default (path_decl, expr_) ->
676 Db.Db_Default (path_decl, (expr expr_))
677 | Db.Db_Constraint (path_decl, db_const) ->
678 let db_const = db_constraint db_const in
679 Db.Db_Constraint (path_decl, db_const)
680 | Db.Db_Virtual (path_decl, handlers) ->
681 Db.Db_Virtual (path_decl, (expr handlers))
682 end
683
684
685
686 let code_elt (elt, sa_label) =
687 let qa_label = qlabel sa_label in
688 (* the scope of type variables is limited to the top-level phrase *)
689 Arg.reset_var_scopes () ;
690 match elt with
691 | SA.Database (i, flds , db_options) ->
692 ([ QA.Database
693 (qa_label, ident i,
694 List.map (fun s -> QA.Db.Decl_fld s) flds,
695 db_options) ],
696 [])
697 | SA.NewDbDef dbdef ->
698 let db_def = DbConv.db_def dbdef in
699 ([QA.NewDbValue (qa_label, db_def)], [])
700 | SA.NewType td ->
701 let typedefs = List.map (fun (ty_def, _) -> typedef ty_def) td in
702 ([QA.NewType (qa_label, typedefs)], [])
703 | SA.NewVal (pel, is_rec) ->
704 let ibel =
705 List.concat_map
706 (let rec aux (pat,e) =
707 let label = snd pat in
708 match fst pat with
709 | SA.PatCoerce (p,ty) ->
710 (* this simplification on coercions is necessary because if you a : int = 42
711 * and a slicer annotation, you don't want to introduce an indirection *)
712 aux (p, C.E.coerce ~label e ty)
713 (* the boolean is true when we will keep this name in the future roots *)
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
714 | SA.PatVar ident -> [(ident.SA.ident, false, e)]
fccc685 Initial open-source release
MLstate authored
715 | SA.PatAny -> [(PatternUtils.next ~label "_do_", true, e)]
716 | _ ->
717 let annotate = propagate_slicer_annotation e in
718 let ident = PatternUtils.next ~label "_toplevlpattern_" in
719 let ident_expr = (SA.Ident ident, Parser_utils.nlabel pat) in
720 let others =
721 List.map
722 (fun (i, e) -> (i, false, annotate e))
723 (PatternUtils.pattern_to_bindings ident_expr pat) in
724 (* we put the new ident in the roots only if there is no other names
725 * _ = (a,b) -> fresh = (a,b) a = fresh.f1 b = fresh.f2 and no new names
726 * (_,_) = (a,b) -> fresh = (a,b) and fresh is added in the roots *)
727 ((ident, (others = []), e) :: others) in
728 aux)
729 pel in
730 let ibel = List.map (fun (i, b, e) -> ((ident i), b, (expr e))) ibel in
731 let iel = List.map (fun (i, _, e) -> (i, e)) ibel in
732 let il =
733 List.filter_map (fun (i, b, _) -> if b then Some i else None) ibel in
734 if is_rec then [QA.NewValRec (qa_label, iel)], il
735 else List.map (fun bnd -> QA.NewVal (qa_label, [bnd])) iel, il
736 | SA.Package _ -> assert false
737
738
739
740 let code sa_list =
741 let fold_map ils elt =
742 let (c, il) = code_elt elt in
743 ((il :: ils), c) in
744 let (ils, code) = List.fold_left_collect fold_map [] sa_list in
745 ((List.flatten ils), code)
746
747
748
749 (* The exported function, should set option before calling code *)
750 let code ?options sa_list =
751 Option.iter set_options options ;
752 code sa_list
753 end
754
755
756
757
758 module Nonuid : ARG with type ident = SurfaceAst.nonuid =
759 struct
760 (** The type of the parameter 'ident of OpaAst *)
761 type ident = SurfaceAst.nonuid
762
763 let to_string s = s
764 let of_string s = s
765 let pp_print_directive a = OpaPrint.string#directive a
766
767 module IdentScope = QmlTypeVarsScope.TypeVarsScope(struct type id = ident end)
768 let vars = IdentScope.create 1024
769
770 let typevar ident =
771 match IdentScope.find_typevar_opt vars ident with
772 | Some v -> v
773 | _ ->
774 let tyv = QA.TypeVar.next ~name:ident () in
775 IdentScope.bind_typevar vars ident tyv;
776 tyv
777
778 let rowvar ident =
779 match IdentScope.find_rowvar_opt vars ident with
780 | Some v -> v
781 | _ ->
782 let tyv = QA.RowVar.next ~name:ident () in
783 IdentScope.bind_rowvar vars ident tyv;
784 tyv
785
786 let colvar ident =
787 match IdentScope.find_colvar_opt vars ident with
788 | Some v -> v
789 | _ ->
790 let tyv = QA.ColVar.next ~name:ident () in
791 IdentScope.bind_colvar vars ident tyv;
792 tyv
793
794 let add_local_scope () = IdentScope.add_local_scope vars
795 let remove_local_scope () = IdentScope.remove_local_scope vars
796 let get_local_vars () = IdentScope.get_local_vars vars
797 let reset_var_scopes () = IdentScope.reset vars
798
799 let typeident = QA.TypeIdent.of_string
800 let exprident = Ident.source
801 end
802
803 module Uids : ARG with type ident = SurfaceAst.uids =
804 struct
805 (** The type of the parameter 'ident of OpaAst *)
806 type ident = SurfaceAst.uids
807
808 let to_string = Ident.to_string
809 let of_string = Ident.source
810 let pp_print_directive a = OpaPrint.ident#directive a
811
812 module IdentScope = QmlTypeVarsScope.TypeVarsScope(struct type id = ident end)
813 let vars = IdentScope.create 1024
814
815 let typevar ident =
816 match IdentScope.find_typevar_opt vars ident with
817 | Some v -> v
818 | _ ->
819 let tyv = QA.TypeVar.next ~name:(Ident.original_name ident) () in
820 IdentScope.bind_typevar vars ident tyv;
821 tyv
822
823 let rowvar ident =
824 match IdentScope.find_rowvar_opt vars ident with
825 | Some v -> v
826 | _ ->
827 let tyv = QA.RowVar.next ~name:(Ident.original_name ident) () in
828 IdentScope.bind_rowvar vars ident tyv;
829 tyv
830
831 let colvar ident =
832 match IdentScope.find_colvar_opt vars ident with
833 | Some v -> v
834 | _ ->
835 let tyv = QA.ColVar.next ~name:(Ident.original_name ident) () in
836 IdentScope.bind_colvar vars ident tyv;
837 tyv
838
839 let add_local_scope () = IdentScope.add_local_scope vars
840 let remove_local_scope () = IdentScope.remove_local_scope vars
841 let get_local_vars () = IdentScope.get_local_vars vars
842 let reset_var_scopes () = IdentScope.reset vars
843
844 let typeident ?(check=true) ident =
845 (* FIXME: if you have duplicate type definitions in the stdlib,
846 * this is going to break *)
847 match ident with
848 | Ident.Source _ -> QA.TypeIdent.of_ident ident
849 | Ident.FakeSource _ -> assert false (* fakesources are never used for types *)
850 | Ident.Internal _ ->
851 let package_name = Ident.get_package_name ident in
852 if ObjectFiles.stdlib_package_names package_name then
853 (* for types from the standard library we generate source type identifier
854 * because the compiler inserts call to these identifiers brutally by
855 * just saying "list" without mentioning the package *)
856 QA.TypeIdent.of_string ~check (Ident.original_name ident)
857 else
858 QA.TypeIdent.of_ident ident
859
860 let exprident ident = ident
861 end
862
863 module NonuidOpaToQml = MakeOpaToQml (SurfaceAstCons.StringCons) (Nonuid)
864 module UidsOpaToQml = MakeOpaToQml (SurfaceAstCons.ExprIdentCons) (Uids)
865
866 module Parser =
867 struct
868 exception Exception of string
869
870 let of_string ?filename source =
871 let opa_code =
872 try OpaParser.code ?filename source
873 with
874 (* An error message has been printed by the parseOpa function. *)
875 | exn -> raise (Exception (Printexc.to_string exn)) in
152be35 [fix] opatop: ignore package directives instead of failing
François-Régis Sinot authored
876 let opa_code =
877 List.filter
878 (function
879 | (SA.Package _, _) as c ->
880 (try OManager.error "Ignoring package directive %a@\n" OpaPrint.string_and_pos#code_elt c
881 with _ -> false)
882 | _ -> true)
883 opa_code
884 in
fccc685 Initial open-source release
MLstate authored
885 let _, qml_code =
886 try NonuidOpaToQml.code ~options opa_code
887 with exn -> raise (Exception (Printexc.to_string exn)) in
888 qml_code
889 end
Something went wrong with that request. Please try again.