Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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