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