Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 451 lines (397 sloc) 19.405 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 *)
44019de [cleanup] open: remove Base in opalang
Raja authored
18
19 (* depends *)
20 module List = BaseList
21
fccc685 Initial open-source release
MLstate authored
22 (* FIXME: open *)
23 open SurfaceAst
24
25 module Fresh =
26 struct
27 (**Generate new fresh identifiers for annotations*)
28 let id () =
29 Fresh.Int.get () (* global ! *)
30
31 (**Generate new type variables*)
32 let typevar =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
33 Fresh.fresh_factory (Printf.sprintf "opa_v_%d")
fccc685 Initial open-source release
MLstate authored
34
35 (* a name that shouldn't conflict with user defined ones *)
36 let dontuse_fresh_ident =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
37 Fresh.fresh_factory (Printf.sprintf "__%d__")
fccc685 Initial open-source release
MLstate authored
38 let old_name ?name () =
39 let n = dontuse_fresh_ident () in
40 match name with
41 | None -> n
42 | Some name -> n ^ "_" ^ name
43 let name name =
44 old_name ~name ()
45
46 let ident ~descr ~label ~name =
47 Ident.next ~filename:(FilePos.get_file label.QmlLoc.pos) ~descr name
48 end
49
50 module Label =
51 struct
52 let label (_, label) : QmlLoc.annot = label
53 let copy_label label = {label with QmlLoc.notes = Fresh.id ()}
54 let undecorate (e,_label) = e
55 let builtin () = {QmlLoc.pos = FilePos.nopos "SurfaceAstCons.Label.builtin" ; QmlLoc.notes = Fresh.id ()}
56 end
57
58 module ExprIdent =
59 struct
60 type ident = Ident.t
61 let equal = Ident.equal
62 let typ s = OpaMapToIdent.typ s
63 let val_ s = OpaMapToIdent.val_ s
64 let fresh () = Ident.next "surfaceAstCons"
65 let ns_fresh ~label name = Fresh.ident ~descr:"surfaceAstCons" ~label ~name
66 end
67
68 module StringIdent =
69 struct
70 type ident = string
71 let equal s s' = String.compare s s' = 0
44019de [cleanup] open: remove Base in opalang
Raja authored
72 let val_ = Base.identity
73 let typ = Base.identity
fccc685 Initial open-source release
MLstate authored
74 let fresh = Fresh.typevar
75 let ns_fresh ~label:_ s = s
76 end
77
78 let c = Label.copy_label
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
79 let encode_tuple l = List.mapi (fun i typ -> Printf.sprintf "f%d" (i+1), typ) l
fccc685 Initial open-source release
MLstate authored
80
81 let position_stack = Stack.create ()
82 (* making sure that in dev mode, we have Stack.empty exceptions when trying to
83 * insert code without position
84 * but in release mode, we put Builtin if we don't have any position *)
85 let () = if BuildInfos.is_release then Stack.push (FilePos.nopos "SurfaceAstCons.release_default_pos") position_stack
86
87 let private_with_position' position f x =
88 Stack.push position position_stack;
89 let r = try `value (f x) with e -> `exn e in
90 ignore (Stack.pop position_stack);
91 match r with `value r -> r | `exn e -> raise e
92 let private_with_position position thunk = private_with_position' position thunk ()
93
94 let builtin = FilePos.nopos "SurfaceAstCons.builtin"
95
96 let with_builtin_position thunk = private_with_position builtin thunk
97 let with_builtin_position' f x = private_with_position' builtin f x
98
99 let with_position' position f x =
100 (*assert (position <> QmlLoc.NoPos && position <> QmlLoc.Builtin);*)
101 private_with_position' position f x
102 let with_position position thunk = with_position' position thunk ()
103
104 let with_label label thunk = with_position label.QmlLoc.pos thunk
105 let with_label' label f x = with_position' label.QmlLoc.pos f x
106
107 let with_same_pos value thunk = with_label (Label.label value) thunk
108 let with_same_pos' value f x = with_label' (Label.label value) f x
109
110 module MakeCons(Ident : SurfaceAstConsSig.IDENT) =
111 struct
112 open Ident
113 type ident = Ident.ident
114 type ident' = ident
115 module I = Ident
116 (* w is just a short name that shouldn't hide anything *)
117 (* no need to use a fresh notes, since we will call copy_label on the
118 * position *)
119 let w () = {QmlLoc.pos = Stack.top position_stack ; QmlLoc.notes = -1 }
120 (* the name is short to avoid the temptation of opening the module *)
121 module T =
122 struct
123 let name ?(label=w()) ?(tyl=[]) s = TypeNamed (Typeident (typ s),tyl), c label
124 let row_t_node ?row l = TyRow (l, row)
125 let row_t ?(label=w()) ?row l = (row_t_node ?row l, c label)
126 let args ?label l = row_t ?label (encode_tuple l)
127 let arrow ?(label=w()) l ty = ((args ~label l, ty), c label)
128 let arrow_1 ?label ty1 ty2 = arrow ?label [ty1] ty2
129 let arrow_2 ?label ty1 ty2 ty3 = arrow ?label [ty1;ty2] ty3
130 let typedef_node ?(tyvs=[]) visibility name ty : _ typedef_node =
131 {
132 SurfaceAst.ty_def_options = QmlAst.ty_def_options ;
133 SurfaceAst.ty_def_visibility = visibility ;
134 SurfaceAst.ty_def_name = Typeident name ;
135 SurfaceAst.ty_def_params = tyvs ;
136 SurfaceAst.ty_def_body = ty ;
137 }
138 let typedef ?(label=w()) ?tyvs visibility name ty : _ typedef =
139 (typedef_node ?tyvs visibility name ty, c label)
140 let record ?(label=w()) ?row l = (TypeRecord (row_t_node ?row l), c label)
141 let tuple ?label ?row l = record ?label ?row (encode_tuple l)
142 let typevar s = Flatvar s
143 let var ?(label=w()) s = (TypeVar (Flatvar s), c label)
144 let fresh ?label () = var ?label (Ident.fresh ())
145 let void ?(label=w()) () = (TypeRecord (row_t_node []), c label)
146 let coerce ?(label=w()) e ty =
147 (Directive (`coerce, [e], [ty]), c label)
148 let coerce_name ?label e n = coerce ?label e (name ?label n)
149 let external_ ?(label=w()) () = (TypeExternal, c label)
150 let string ?(label=w()) () = (TypeConst TyString, c label)
151 let int ?(label=w()) () = (TypeConst TyInt, c label)
152 let float ?(label=w()) () = (TypeConst TyFloat, c label)
153 let bool ?label () = name ?label Opacapi.Types.bool
154 end
155
156 module P =
157 struct
158 let any ?(label=w()) () = (PatAny, c label)
159 let record ?(label=w()) ?(row=false) l =
160 let rowvar = if row then `open_ else `closed in
161 PatRecord (l, rowvar), c label
162
163 let coerce ?(label=w()) p ty = (PatCoerce (p, ty), c label)
164 let coerce_name ?label p name = coerce ?label p (T.name ?label name)
165
166 let void ?(label=w()) () = coerce ~label (PatRecord ([], `closed), c label) (T.void ~label ())
167 let simple_record ?label s = record ?label [(s,void ?label ())]
168 let true_ ?label () = coerce_name ?label (simple_record ?label "true") Opacapi.Types.bool
169 let false_ ?label () = coerce_name ?label (simple_record ?label "false") Opacapi.Types.bool
170 let bool ?label b = if b then true_ ?label () else false_ ?label ()
171
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to dis...
OpaOnWindowsNow authored
172 let ident ?(label=w()) ?(directives=[]) ident = (PatVar ({ident;directives}), c label)
fccc685 Initial open-source release
MLstate authored
173 let var = ident
174
175 let string ?(label=w()) s = (PatConst (CString s), c label)
176
177 let record1 ?label s e = record ?label [(s,e)]
178 let simple_record ?label s = record ?label [(s,void ?label ())]
179 let tuple ?label l = record ?label (encode_tuple l)
180 let tuple_2 ?label f1 f2 = coerce_name ?label (tuple ?label [f1;f2]) Opacapi.Types.tuple_2
181
182 (* list *)
183 let cons ?label p1 p2 = coerce_name ?label ((*Record.*)record ?label ["hd",p1;"tl",p2]) Opacapi.Types.list
184 let nil ?label () = coerce_name ?label ((*Record.*)simple_record ?label "nil") Opacapi.Types.list
185 let hd_tl ?label hd tl = coerce_name ?label ((*Record.*)record ?label ["hd",hd;"tl",tl]) Opacapi.Types.list
186 let list ?label l = List.fold_right (cons ?label) l (nil ?label ())
187
188 (* option *)
189 let none ?label () = coerce_name ?label ((*Record.*)simple_record ?label "none") Opacapi.Types.option
190 let some ?label p = coerce_name ?label ((*Record.*)record1 ?label "some" p) Opacapi.Types.option
191 end
192
193 module E =
194 struct
195 let record ?(label=w()) l = (Record l, c label)
196 let coerce = T.coerce
197 let coerce_name = T.coerce_name
198 let void ?(label=w()) () = T.coerce ~label (Record [], c label) (T.void ~label ())
199 let simple_record ?label s = record ?label [(s,void ?label ())]
200 let true_ ?label () = T.coerce_name ?label (simple_record ?label "true") Opacapi.Types.bool
201 let false_ ?label () = T.coerce_name ?label (simple_record ?label "false") Opacapi.Types.bool
202
203 let constant ?(label=w()) const = (Const const, c label)
204 let string ?label s = constant ?label (CString s)
205 let float ?label f = constant ?label (CFloat f)
206 let big_int ?label i = constant ?label (CInt i)
207 let int ?label i = big_int ?label (Big_int.big_int_of_int i)
208 let bool ?label b = if b then true_ ?label () else false_ ?label ()
209
210 let ident ?(label=w()) i = (Ident i, c label)
211 let var = ident
212
213 (* record *)
214 let record1 ?label s e = record ?label [(s,e)]
215 let tuple ?label l = record ?label (encode_tuple l)
216 let tuple_2 ?label e1 e2 = T.coerce_name ?label (tuple ?label [e1;e2]) Opacapi.Types.tuple_2
217 let dot ?(label=w()) e s = (Dot (e,s), c label)
218 let (<.>) = dot
219
220 (* list *)
221 let cons ?label e1 e2 = T.coerce_name ?label (record ?label ["hd",e1;"tl",e2]) Opacapi.Types.list
222 let nil ?label () = T.coerce_name ?label (simple_record ?label "nil") Opacapi.Types.list
223 let list ?label l = List.fold_right (cons ?label) l (nil ?label ())
224
225 (* option *)
226 let none ?label () = T.coerce_name ?label (simple_record ?label "none") Opacapi.Types.option
227 let some ?label e = T.coerce_name ?label (record1 ?label "some" e) Opacapi.Types.option
228
229 (* function *)
230 let encode_args pl = encode_tuple pl
231
232 (* abstraction *)
233 let lambda ?(label=w()) pl e = (Lambda (encode_args pl, e), c label)
234 let lambda_var ?label i e = lambda ?label [P.ident ?label i] e
235 let lambda_ignore ?label e = lambda ?label [P.any ?label ()] e
236 let lambda_void ?label e = lambda ?label [P.void ?label ()] e
237
238 (* application *)
239 let applys ?(label=w()) e l = (Apply (e, (encode_tuple l, c label)), c label)
240 let apply ?label e1 e2 = applys ?label e1 [e2]
241 let apply_void ?label e = apply ?label e (void ?label ())
242 let apply2 ?label e1 e2 e3 = applys ?label e1 [e2;e3]
243
244 let eta_expand ?(label=w()) arity e =
245 let idents = List.init arity (fun i -> Ident.ns_fresh ~label (Printf.sprintf "eta_%d_%d" i arity)) in
246 let pats = List.map (P.var ~label) idents in
247 let exps = List.map (var ~label) idents in
248 lambda ~label pats (applys ~label e exps)
249
250 let match_ ?(label=w()) e pel = (Match (e, pel), c label)
251 let if_ ?label e1 e2 e3 =
252 match_ ?label (T.coerce_name ?label e1 Opacapi.Types.bool) [(P.true_ ?label (), e2);(P.false_ ?label (), e3)]
253 let if_then ?label e1 e2 = if_ ?label e1 e2 (void ?label ())
254 let if_not ?label e1 e3 = if_ ?label e1 (void ?label ()) e3
255
256 (* often needed pattern matchings *)
257 let match_opt ?label ?ty e pe1 pe2 =
258 let tyl = Option.map (fun x -> [x]) ty in
259 match_ ?label (T.coerce ?label e (T.name ?label ?tyl Opacapi.Types.option)) [pe1;pe2]
260 let match_option ?(label=w()) ?ty e none some =
261 let i = ns_fresh ~label "s" in
262 match_opt ~label ?ty e (P.none ~label (), none) (P.some ~label (P.ident ~label i), some i)
263
264 let letgen ?(label=w()) ~rec_ iel e = (LetIn (rec_,iel, e), c label)
265 let letrec ?label iel e = letgen ?label ~rec_:true iel e
266 let letand ?label iel e = letgen ?label ~rec_:false iel e
267 let letin ?label i e1 e2 = letand ?label [(i,e1)] e2
268 let letins ?label iel e = List.fold_right (fun (i,e) acc -> letin ?label i e acc) iel e
269
270 let bypass ?(label=w()) s = Bypass (BslKey.normalize s), c label
271
272 end
273
274 (* directives *)
275 module D =
276 struct
277 module T =
278 struct
279 module Common =
280 struct
281 let bool_arrow_void ?label () =
282 T.arrow ?label [T.bool ?label ()] (T.void ?label ())
283 let alpha_arrow_alpha ?label () =
284 let v = T.fresh ?label () in
285 T.arrow ?label [v] v
286 end
287
288 let static_source_content ?label () =
289 T.arrow ?label [] (T.record [("modified", T.float ?label ());
290 ("content", T.string ?label ())])
291 let static_binary_content ?label () =
292 T.arrow ?label [] (T.record [("modified", T.float ?label ());
293 ("content", T.name ?label Opacapi.Types.binary)])
294 let static_include_directory ?label () =
295 T.arrow ?label [] (T.record [("modified", T.float ?label ());
296 ("content", T.name ?label ~tyl:[T.string();T.string()] Opacapi.Types.stringmap)])
297 let assert_message = Common.bool_arrow_void
298 let ensure_message = Common.bool_arrow_void
299 let doctype = Common.alpha_arrow_alpha
300 let deprecated = Common.alpha_arrow_alpha
301 let warning = Common.alpha_arrow_alpha
302 let assert_ = Common.bool_arrow_void
303 let client = Common.alpha_arrow_alpha
304 let server = Common.alpha_arrow_alpha
51f92b4 [feature] adding: a no_client_calls directive
Hugo Heuzard authored
305 let no_client_calls = Common.alpha_arrow_alpha
fccc685 Initial open-source release
MLstate authored
306 let ensure = Common.bool_arrow_void
307 let fail ?label () = T.arrow ?label [T.string ?label ()] (T.fresh ?label ())
308 let force = Common.alpha_arrow_alpha
309 let private_ = Common.alpha_arrow_alpha
310 let protected = Common.alpha_arrow_alpha
311 let slicer = Common.alpha_arrow_alpha
312 let translate ?label () = T.arrow ?label [T.string ?label ()] (T.name ?label ~tyl:[T.string ?label ()] "located")
313 let unsafe_cast ?label () = T.arrow ?label [T.fresh ?label ()] (T.fresh ?label ())
314 let spawn = Common.alpha_arrow_alpha
315 let lazy_ = Common.alpha_arrow_alpha
316 let magic_to_string ?label () = T.arrow ?label [T.fresh ?label ()] (T.string ?label ())
317 let magic_to_xml ?label () = T.arrow ?label [T.fresh ?label ()] (T.name ?label Opacapi.Types.xml)
318 let side_annotation = Common.alpha_arrow_alpha
319 let visibility_annotation = Common.alpha_arrow_alpha
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support fo...
OpaOnWindowsNow authored
320 let i18n_lang ?label () = T.arrow ?label [] (T.string ?label ())
fccc685 Initial open-source release
MLstate authored
321 end
322 (*module Parser =
323 struct
324 type basic_reason =
325 | Invalid_argument of string * int
326 | Invalid_number_of_argument of int * int
327 | Invalid_name of string
328 type reason = QmlLoc.annot * basic_reason
329 exception Invalid_directive of reason list
330 let to_string (_:reason list) = assert false
331 let directive ~label name l =
332 let just_one l =
333 match l with
334 | [_] -> l
335 | _ -> raise (Invalid_directive [label,Invalid_number_of_argument (1,List.length l)]) in
336 match name with
337 | "static_source_content" -> (Directive (`static_source_content, "@static_source_content", just_one l, Some T.static_source_content), c label)
338 | "static_binary_content" -> (Directive (`static_binary_content, "@static_binary_content", just_one l, Some T.static_binary_content), c label)
339 | "assert_message" -> (Directive (`assert_message, "@assert_message", just_one l, Some T.assert_message), c label)
340 | "ensure_message" -> (Directive (`ensure_message, "@ensure_message", just_one l, Some T.ensure_message), c label)
341 | "deprecated" -> (Directive (`deprecated, "@deprecated", just_one l, Some T.deprecated), c label)
342 end*)
343 let open_ ?(label=w()) e1 e2 =
344 (Directive (`open_, [e1;e2], []), c label)
345 let doctype (path:string list) ?(label=w()) ?(access=`public) e1 =
346 (Directive (`doctype (path, access), [e1], []), c label)
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support fo...
OpaOnWindowsNow authored
347 let string ?(label=w()) l =
348 (Directive (`string, l, []), c label)
349 let i18n_lang ?(label=w()) () =
350 (Directive (`i18n_lang, [], []), c label)
fccc685 Initial open-source release
MLstate authored
351 let side_annotation ?(label=w()) side e =
352 (Directive (`side_annotation side, [e], []), c label)
353 let visibility_annotation ?(label=w()) visibility e =
354 (Directive (`visibility_annotation visibility, [e], []), c label)
355 let static_content ?(label=w()) ?factory_helper eval e =
356 (Directive (`static_content (e, eval), (match factory_helper with None -> [] | Some x -> [x]),[]),
357 c label)
358 let static_resource ?(label=w()) ?factory_helper e =
359 (Directive (`static_resource e, (match factory_helper with None -> [] | Some x -> [x]),[]),
360 c label)
361 let server_entry_point ?(label=w()) e =
362 (Directive (`server_entry_point,[e], []),
363 c label)
51f92b4 [feature] adding: a no_client_calls directive
Hugo Heuzard authored
364 let with_thread_context ?(label=w()) ctx e =
365 (Directive (`with_thread_context,[ctx;e], []),
366 c label)
367
fccc685 Initial open-source release
MLstate authored
368 end
369
370 module C =
371 struct
372 let newval_pel ?(rec_=true) ?(label=w()) pel = (NewVal (pel,rec_), c label)
373 let newval ?label ident e = newval_pel ~rec_:false ?label [(P.ident ?label ident, e)]
374 let newvalrec ?label ident e = newval_pel ~rec_:true ?label [(P.ident ?label ident, e)]
375 let newval_ignore ?label e = newval_pel ~rec_:false ?label [(P.any ?label (), e)]
376 let newtype ?(label=w()) typedef = (NewType [typedef], c label)
377 end
378
379 end
380
381 module ExprIdentCons = MakeCons(ExprIdent)
382 module StringCons = MakeCons(StringIdent)
383
384 module Fold =
385 struct
386 let dot e acc =
387 let rec aux e acc =
388 match acc with
389 | [] -> e
390 | (h,label) :: t -> aux (ExprIdentCons.E.dot ~label e h) t in
391 aux e acc
392 end
393
394 module Refresh =
395 struct
396 let copy_label = Label.copy_label
397 let const_expr_node c = c
398 let const_expr (c,l) = (const_expr_node c, copy_label l)
399 let rec record_node l = List.map (fun (i,e) -> (i, expr e)) l
400 and record (r,l) = (record_node r, copy_label l)
401 and expr (e,l) = (expr_node e, copy_label l)
402 and expr_node = function
403 | Apply (e,r) -> Apply (expr e, record r)
404 | Lambda (prn, e) -> Lambda (pat_record_node prn, expr e)
405 | Const c -> Const (const_expr_node c)
406 | (Ident _ as v) -> v
407 | LetIn (b,iel,e) -> LetIn (b,List.map (fun (i,e) -> (i,expr e)) iel, expr e)
408 | Match (e,pel) -> Match (expr e, List.map (fun (p,e) -> (pat p, expr e)) pel)
409 | Record r -> Record (record_node r)
410 | ExtendRecord (r,e) -> ExtendRecord (record_node r, expr e)
411 | Dot (e,s) -> Dot (expr e, s)
412 | (Bypass _ as v) -> v
413 | (DBPath _ as v) -> v
414 | Directive (d,el,tyl) -> Directive (d, List.map expr el, List.map ty tyl)
415 and pat (p,l) = (pat_node p, copy_label l)
416 and pat_node = function
417 | PatRecord (r, rowvar) -> PatRecord (pat_record_node r, rowvar)
418 | PatAny -> PatAny
419 | PatConst c -> PatConst (const_expr_node c)
420 | PatVar _ as v -> v
421 | PatCoerce (p,t) -> PatCoerce (pat p, ty t)
422 | PatAs (p,s) -> PatAs (pat p, s)
423 and pat_record_node l = List.map (fun (s, p) -> (s, pat p)) l
424 and ty (t,l) = (ty_node t, copy_label l)
425 and ty_node = function
426 | TypeConst _
427 | TypeExternal
428 | TypeVar _ as v -> v
429 | TypeArrow t -> TypeArrow (arrow_node t)
430 | TypeRecord r -> TypeRecord (row_node r)
431 | TypeSumSugar l -> TypeSumSugar (List.map sum l)
432 | TypeNamed t -> TypeNamed (typeinstance_node t)
433 | TypeForall (vars, t) -> TypeForall (vars, ty t)
434 | TypeModule fields -> TypeModule (fields_t_node fields)
435 and typeinstance (v,l) = (typeinstance_node v, copy_label l)
436 and typeinstance_node (i,tyl) = (i,List.map ty tyl)
437 and arrow (a,l) = (arrow_node a, copy_label l)
438 and arrow_node (r,t) = (row r, ty t)
439 and sum (s,l) = (sum_node s, copy_label l)
440 and sum_node = function
441 | SumName t -> SumName (typeinstance_node t)
442 | SumRecord t -> SumRecord (row_node t)
443 | SumVar _ as v -> v
444 and fields_t_node l = List.map (fun (i,t) -> (i,ty t)) l
445 and row (r,l) = (row_node r, copy_label l)
446 and row_node (TyRow (f,o)) = TyRow (fields_t_node f, o)
447 and typedef (a,l) = (typedef_node a, copy_label l)
448 and typedef_node ty_def =
449 { ty_def with SurfaceAst.ty_def_body = ty ty_def.SurfaceAst.ty_def_body }
450 end
Something went wrong with that request. Please try again.