Skip to content

HTTPS clone URL

Subversion checkout URL

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