Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 857 lines (745 sloc) 31.044 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
451 QA.Path ((make_label_from_opa_annot opa_annot), path, access_kind)
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
506
507
508 and expr_of_record e =
509 expr (SA.Record ((Parser_utils.encode_tuple [e])), Parser_utils.nlabel e)
510
511
512
513 and may_make_tuple1 (e: (_,_) SA.expr) = expr e
514
515
516
517 and apply_directive ?(special = false) opa_annot name e =
518 let args = may_make_tuple1 e in
519 let ident =
520 lookup
521 ~with_label: (make_label_from_opa_annot opa_annot) ~special e name in
522 QA.Apply ((make_label_from_opa_annot opa_annot), ident, [args])
523
524
525
526 (* used for magic_* directives only *)
527 and directive_variant_to_string = function
528 | `magic_to_string -> Opacapi.magicToString
529 | `magic_to_xml -> Opacapi.magicToXml
530
531
532
533 and directive opa_annot ((c, e, t) as d) =
534 match c, e, t with
535 | (
536 `typeof | `opensums | `openrecord | `unsafe_cast
537 | `nonexpansive | `doctype _ | `module_ | `module_field_lifting
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
538 | `spawn | `wait | `atomic | `callcc | `js_ident | `expand _
fccc685 Initial open-source release
MLstate authored
539 | `create_lazy_record | `assert_ | `fail
540 | `thread_context
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
541 | `async
fccc685 Initial open-source release
MLstate authored
542 | `throw | `catch | `tracker _
543 | `with_thread_context
544 | `sliced_expr
545 | `may_cps
546 | `specialize _
547 | `deprecated
548 | `todo
549 | `recval
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
550 | #SA.opavalue_directive
fccc685 Initial open-source release
MLstate authored
551 | #SA.distribution_directive
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
552 | `llarray
2536662 @OpaOnWindowsNow [feature] closure serialisation: restrict to new @public_env directive
OpaOnWindowsNow authored
553 | #QA.closure_instrumentation_directive
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
554 ) as variant, el, tl ->
fccc685 Initial open-source release
MLstate authored
555 let el = List.map expr el in
556 let tl = List.map ty tl in
557 QA.Directive ((make_label_from_opa_annot opa_annot), variant, el, tl)
558 (* TODO: remove Coerce from QmlAst, and use the directive instead *)
559 | `coerce, [e], [t] ->
560 let t = ty t in
561 let e = expr e in
562 QA.Coerce ((make_label_from_opa_annot opa_annot), e, t)
563 | `coerce, _, _ -> assert false
564
565 | `warncoerce, _, _ ->
566 (*
567 Currently, this directive is not in the syntax,
568 and not any pass insert it before the pass_OpaToQml.
569 *)
570 assert false
571
572 | `opacapi, args, _ -> (
573 match args with
574 | [e] -> expr e
575 | _ ->
576 (*
577 The parser ensure that the directive has exactly 1 argument.
578 *)
579 assert false
580 )
581
582 | `magic_do, args, [] -> (
583 match args with
584 | [e] ->
585 (*
586 magic_do is traduced to warncoerce in qml.
587 we do not use magic_do for funaction anymore.
588 *)
589 let e = expr e in
590 let void = QA.TypeName ([], QA.TypeIdent.of_string Opacapi.Types.void) in
591 QA.Directive
592 ((make_label_from_opa_annot opa_annot), `warncoerce, [e], [void])
593
594 | _ ->
595 (*
596 this directive is generated by the parser, with exactly 1 argument.
597 *)
598 assert false
599 )
600
601 | `fun_action, [e], [] ->
602 let e = expr e in
603 QA.Directive
604 ((make_label_from_opa_annot opa_annot), `fun_action None, [e], [])
605 (* magic directive can be converted to directive or fun call *)
606 | (`magic_to_string | `magic_to_xml) as variant, [e], []
607 when not keep_magic_directive ->
608 apply_directive opa_annot (directive_variant_to_string variant) e
609
610 | #SA.all_directives, e :: _, _ ->
611 Format.eprintf "%a%!" Arg.pp_print_directive d;
612 fail e "directive: Not implemented" (* TODO *)
613 | #SA.all_directives, [], _ ->
614 Format.eprintf "%a%!" Arg.pp_print_directive d;
615 !!! "directive: Not implemented" (* TODO *)
616
617
618 and db_path path =
619 match path with
620 | SA.FldKey s -> QA.FldKey s
621 | SA.ExprKey e -> QA.ExprKey (expr e)
622 | SA.NewKey -> QA.NewKey
623
624
625
626 module DbConv =
627 struct
628 open QA
629 let db_constraint const =
630 match const with
631 | Db.C_Ordering expr_ -> Db.C_Ordering (expr expr_)
632 | Db.C_Inclusion p -> Db.C_Inclusion p
633 | Db.C_Validation expr_ -> Db.C_Validation (expr expr_)
634 | Db.C_Inverse p -> Db.C_Inverse p
635 | Db.C_Private -> Db.C_Private
636
637 let db_def = function
638 | Db.Db_TypeDecl (path_decl, ty_) ->
639 Db.Db_TypeDecl (path_decl, (ty ty_))
640 | Db.Db_Alias (path_decl, path_decl2) ->
641 Db.Db_Alias (path_decl, path_decl2)
642 | Db.Db_Default (path_decl, expr_) ->
643 Db.Db_Default (path_decl, (expr expr_))
644 | Db.Db_Constraint (path_decl, db_const) ->
645 let db_const = db_constraint db_const in
646 Db.Db_Constraint (path_decl, db_const)
647 | Db.Db_Virtual (path_decl, handlers) ->
648 Db.Db_Virtual (path_decl, (expr handlers))
649 end
650
651
652
653 let code_elt (elt, sa_label) =
654 let qa_label = qlabel sa_label in
655 (* the scope of type variables is limited to the top-level phrase *)
656 Arg.reset_var_scopes () ;
657 match elt with
658 | SA.Database (i, flds , db_options) ->
659 ([ QA.Database
660 (qa_label, ident i,
661 List.map (fun s -> QA.Db.Decl_fld s) flds,
662 db_options) ],
663 [])
664 | SA.NewDbDef dbdef ->
665 let db_def = DbConv.db_def dbdef in
666 ([QA.NewDbValue (qa_label, db_def)], [])
667 | SA.NewType td ->
668 let typedefs = List.map (fun (ty_def, _) -> typedef ty_def) td in
669 ([QA.NewType (qa_label, typedefs)], [])
670 | SA.NewVal (pel, is_rec) ->
671 let ibel =
672 List.concat_map
673 (let rec aux (pat,e) =
674 let label = snd pat in
675 match fst pat with
676 | SA.PatCoerce (p,ty) ->
677 (* this simplification on coercions is necessary because if you a : int = 42
678 * and a slicer annotation, you don't want to introduce an indirection *)
679 aux (p, C.E.coerce ~label e ty)
680 (* 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
681 | SA.PatVar ident -> [(ident.SA.ident, false, e)]
fccc685 Initial open-source release
MLstate authored
682 | SA.PatAny -> [(PatternUtils.next ~label "_do_", true, e)]
683 | _ ->
684 let annotate = propagate_slicer_annotation e in
685 let ident = PatternUtils.next ~label "_toplevlpattern_" in
686 let ident_expr = (SA.Ident ident, Parser_utils.nlabel pat) in
687 let others =
688 List.map
689 (fun (i, e) -> (i, false, annotate e))
690 (PatternUtils.pattern_to_bindings ident_expr pat) in
691 (* we put the new ident in the roots only if there is no other names
692 * _ = (a,b) -> fresh = (a,b) a = fresh.f1 b = fresh.f2 and no new names
693 * (_,_) = (a,b) -> fresh = (a,b) and fresh is added in the roots *)
694 ((ident, (others = []), e) :: others) in
695 aux)
696 pel in
697 let ibel = List.map (fun (i, b, e) -> ((ident i), b, (expr e))) ibel in
698 let iel = List.map (fun (i, _, e) -> (i, e)) ibel in
699 let il =
700 List.filter_map (fun (i, b, _) -> if b then Some i else None) ibel in
701 if is_rec then [QA.NewValRec (qa_label, iel)], il
702 else List.map (fun bnd -> QA.NewVal (qa_label, [bnd])) iel, il
703 | SA.Package _ -> assert false
704
705
706
707 let code sa_list =
708 let fold_map ils elt =
709 let (c, il) = code_elt elt in
710 ((il :: ils), c) in
711 let (ils, code) = List.fold_left_collect fold_map [] sa_list in
712 ((List.flatten ils), code)
713
714
715
716 (* The exported function, should set option before calling code *)
717 let code ?options sa_list =
718 Option.iter set_options options ;
719 code sa_list
720 end
721
722
723
724
725 module Nonuid : ARG with type ident = SurfaceAst.nonuid =
726 struct
727 (** The type of the parameter 'ident of OpaAst *)
728 type ident = SurfaceAst.nonuid
729
730 let to_string s = s
731 let of_string s = s
732 let pp_print_directive a = OpaPrint.string#directive a
733
734 module IdentScope = QmlTypeVarsScope.TypeVarsScope(struct type id = ident end)
735 let vars = IdentScope.create 1024
736
737 let typevar ident =
738 match IdentScope.find_typevar_opt vars ident with
739 | Some v -> v
740 | _ ->
741 let tyv = QA.TypeVar.next ~name:ident () in
742 IdentScope.bind_typevar vars ident tyv;
743 tyv
744
745 let rowvar ident =
746 match IdentScope.find_rowvar_opt vars ident with
747 | Some v -> v
748 | _ ->
749 let tyv = QA.RowVar.next ~name:ident () in
750 IdentScope.bind_rowvar vars ident tyv;
751 tyv
752
753 let colvar ident =
754 match IdentScope.find_colvar_opt vars ident with
755 | Some v -> v
756 | _ ->
757 let tyv = QA.ColVar.next ~name:ident () in
758 IdentScope.bind_colvar vars ident tyv;
759 tyv
760
761 let add_local_scope () = IdentScope.add_local_scope vars
762 let remove_local_scope () = IdentScope.remove_local_scope vars
763 let get_local_vars () = IdentScope.get_local_vars vars
764 let reset_var_scopes () = IdentScope.reset vars
765
766 let typeident = QA.TypeIdent.of_string
767 let exprident = Ident.source
768 end
769
770 module Uids : ARG with type ident = SurfaceAst.uids =
771 struct
772 (** The type of the parameter 'ident of OpaAst *)
773 type ident = SurfaceAst.uids
774
775 let to_string = Ident.to_string
776 let of_string = Ident.source
777 let pp_print_directive a = OpaPrint.ident#directive a
778
779 module IdentScope = QmlTypeVarsScope.TypeVarsScope(struct type id = ident end)
780 let vars = IdentScope.create 1024
781
782 let typevar ident =
783 match IdentScope.find_typevar_opt vars ident with
784 | Some v -> v
785 | _ ->
786 let tyv = QA.TypeVar.next ~name:(Ident.original_name ident) () in
787 IdentScope.bind_typevar vars ident tyv;
788 tyv
789
790 let rowvar ident =
791 match IdentScope.find_rowvar_opt vars ident with
792 | Some v -> v
793 | _ ->
794 let tyv = QA.RowVar.next ~name:(Ident.original_name ident) () in
795 IdentScope.bind_rowvar vars ident tyv;
796 tyv
797
798 let colvar ident =
799 match IdentScope.find_colvar_opt vars ident with
800 | Some v -> v
801 | _ ->
802 let tyv = QA.ColVar.next ~name:(Ident.original_name ident) () in
803 IdentScope.bind_colvar vars ident tyv;
804 tyv
805
806 let add_local_scope () = IdentScope.add_local_scope vars
807 let remove_local_scope () = IdentScope.remove_local_scope vars
808 let get_local_vars () = IdentScope.get_local_vars vars
809 let reset_var_scopes () = IdentScope.reset vars
810
811 let typeident ?(check=true) ident =
812 (* FIXME: if you have duplicate type definitions in the stdlib,
813 * this is going to break *)
814 match ident with
815 | Ident.Source _ -> QA.TypeIdent.of_ident ident
816 | Ident.FakeSource _ -> assert false (* fakesources are never used for types *)
817 | Ident.Internal _ ->
818 let package_name = Ident.get_package_name ident in
819 if ObjectFiles.stdlib_package_names package_name then
820 (* for types from the standard library we generate source type identifier
821 * because the compiler inserts call to these identifiers brutally by
822 * just saying "list" without mentioning the package *)
823 QA.TypeIdent.of_string ~check (Ident.original_name ident)
824 else
825 QA.TypeIdent.of_ident ident
826
827 let exprident ident = ident
828 end
829
830 module NonuidOpaToQml = MakeOpaToQml (SurfaceAstCons.StringCons) (Nonuid)
831 module UidsOpaToQml = MakeOpaToQml (SurfaceAstCons.ExprIdentCons) (Uids)
832
833 module Parser =
834 struct
835 exception Exception of string
836
837 let of_string ?filename source =
838 let opa_code =
839 try OpaParser.code ?filename source
840 with
841 (* An error message has been printed by the parseOpa function. *)
842 | exn -> raise (Exception (Printexc.to_string exn)) in
152be35 [fix] opatop: ignore package directives instead of failing
François-Régis Sinot authored
843 let opa_code =
844 List.filter
845 (function
846 | (SA.Package _, _) as c ->
847 (try OManager.error "Ignoring package directive %a@\n" OpaPrint.string_and_pos#code_elt c
848 with _ -> false)
849 | _ -> true)
850 opa_code
851 in
fccc685 Initial open-source release
MLstate authored
852 let _, qml_code =
853 try NonuidOpaToQml.code ~options opa_code
854 with exn -> raise (Exception (Printexc.to_string exn)) in
855 qml_code
856 end
Something went wrong with that request. Please try again.