Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 517 lines (440 sloc) 15.076 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 (* CF mli *)
19
20 (* refactoring *)
21 module TypeIdent = QmlAst.TypeIdent
22
23 (* alias *)
24 module Q = QmlAst
25 module List = Base.List
26
27 type directive = QmlAst.qml_directive
28
29 (*
30 Some common types
31 *)
32 module Ty =
33 struct
34 let next () = Q.TypeVar (QmlAst.TypeVar.next ())
35
36 let any () =
37 let alpha = next () in
38 let beta = next () in
39 Q.TypeArrow ([alpha], beta)
40
41 let id () =
42 let alpha = next () in
43 Q.TypeArrow ([alpha], alpha)
44
45 let id_apply ?(left=Base.identity) ?(right=Base.identity) () =
46 let alpha = next () in
47 Q.TypeArrow ([left alpha], right alpha)
48
49 let void = Q.TypeRecord (Q.TyRow ([], None))
50 let string = Q.TypeConst Q.TyString
51
52 (* Named types *)
53
54 (*
55 FIXME: use opacapi for types definition
56 *)
57
58 let named_type name args =
59 Q.TypeName (args, TypeIdent.of_string name)
60
61 let option t = named_type Opacapi.Types.option [t]
62 let continuation t = named_type Opacapi.Types.continuation [t]
63 let bool = named_type Opacapi.Types.bool []
64 let opaty = named_type Opacapi.Types.OpaType.ty []
65 let oparow = named_type Opacapi.Types.OpaType.row []
66 let opacol = named_type Opacapi.Types.OpaType.col []
67 let future t = named_type Opacapi.Types.Cps.future [t]
68 let embedded_obj =
69 let name = Opacapi.Types.path_embedded_obj in
70 named_type name []
71
72 let thread_context_t = named_type Opacapi.Types.ThreadContext.t []
73
74 let llarray t = named_type Opacapi.Types.llarray [t]
75
76
77
78 (* Specific directives *)
79
80 let assertion () =
81 Q.TypeArrow ([bool], void)
82
83 let fail ~with_message =
84 let args = if with_message then [string] else [] in
85 let alpha = next () in
86 Q.TypeArrow (args, alpha)
87
88 let typeof () =
89 let alpha = next () in
90 Q.TypeArrow ([alpha], opaty)
91
92 let callcc () =
93 let alpha = next () in
94 let f_cont =
95 Q.TypeArrow ([continuation alpha], void)
96 in
97 Q.TypeArrow ([f_cont], alpha)
98
99 let deprecated () =
100 let deprecated = named_type Opacapi.Types.Deprecated.argument [] in
101 let alpha = next () in
102 Q.TypeArrow ([ deprecated ; alpha ], alpha)
103
104 let todo () =
105 let alpha = next () in
106 Q.TypeArrow ([], alpha)
107
108 (* -> option(ThreadContext.t) *)
109 let thread_context () =
110 Q.TypeArrow ([], option thread_context_t)
111
112 (* ThreadContext.t, 'a -> 'a *)
113 let with_thread_context () =
114 let alpha = next () in
115 Q.TypeArrow ([thread_context_t ; alpha], alpha)
116
117 let exc =
118 let exc_colvar = QmlAst.ColVar.next () in (* Fixed once and for all *)
119 Q.TypeSum (Q.TyCol ([], Some exc_colvar))
120
121 (* exc -> 'a *)
122 let throw () =
123 let alpha = next () in
124 Q.TypeArrow ([exc], alpha)
125
126 (* (exc -> 'a), 'a -> 'a *)
127 let catch () =
128 let alpha = next () in
129 let handler = Q.TypeArrow([exc], alpha) in
130 Q.TypeArrow ([handler ; alpha], alpha)
131
132 let opensums () =
133 let alpha = next () in
134 let beta = next () in
135 Q.TypeArrow ([alpha], beta)
136
137 let openrecord () =
138 let alpha = next () in
139 let beta = next () in
140 Q.TypeArrow ([alpha], beta)
141
142 let opavalue_make_performer tys build_add build =
143 let ty, add_args =
144 match tys with
145 | [Q.TypeName (args, _) as ty] ->
146 let lf = List.map
147 (fun param ->
148 match param with
149 | Q.TypeVar _ -> build_add param
150 | _ -> OManager.error "OpaValue directive : parameters of named type can be only a type variable")
151 args in
152 ty, lf
153 | _ -> OManager.error "OpaValue directive should take exclusively named type"
154 in
155 build add_args ty
156
157 end
158
159 (*
160 Trying to keep an organisation in that file
161 we regroup directives by their groups
162
163 We return a arrow corresponding to the type of the directive.
164 The typer will check the arity of the exprs list wrt the returned type.
165 A directive with no argument should be typed as a apply with no args.
166 *)
167 (*
168 let type_directive directive _exprs tys =
169 match directive with
170
171 let simple_slicer_directive directive _exprs _tys =
172 match directive with
173
174 let slicer_directive directive _exprs _tys =
175 match directive with
176
177 (* TODO: continue to regroup directives semantically *)
178 let other_directive directive _exprs _tys =
179 match directive with
180 *)
181 (*
182 TODO: continue to split directives with groups of topic,
183 and split this function.
184 *)
185 let ty directive exprs tys =
186 match (directive:directive) with
187
188 (* === *)
189 (* Type *)
190 | `coerce -> (
191 match tys with
192 | [ty] -> Q.TypeArrow ([ty], ty)
193 | _ -> assert false
194 )
195 | `module_ -> Ty.id ()
196 | `module_field_lifting -> Ty.id ()
197 | `opensums -> Ty.opensums ()
198 | `openrecord -> Ty.openrecord ()
199 | `unsafe_cast -> Q.TypeArrow ([Ty.next()], Ty.next())
200 | `nonexpansive -> Ty.id ()
201 | `warncoerce -> Ty.id ()
202
203 (* === *)
204 (* Simple slicer *)
205 | `side_annotation _
206 | `visibility_annotation _
207 | `ajax_call _
208 | `ajax_publish _
209 | `comet_call
210 | `comet_publish -> Ty.id ()
211 | `insert_server_value _ ->
212 (match tys with
213 | [ty] -> Q.TypeArrow ([], ty)
214 | _ -> assert false)
215 | `sliced_expr ->
216 let ty = Ty.next () in
217 Q.TypeArrow ([ty;ty], ty)
218
219 (* === *)
220 (* Errors *)
221 | `assert_ -> Ty.assertion ()
222 | `fail ->
223 let with_message = not (List.is_empty exprs) in
224 Ty.fail ~with_message
225
226 (* === *)
227 (* Coding *)
228 | `deprecated -> Ty.deprecated ()
229 | `todo -> Ty.todo ()
230
231 (* === *)
232 (* Magic *)
233 | `typeof -> Ty.typeof ()
234 | `specialize _ ->
235 let n = List.length exprs in
236 assert (n >= 1);
237 let ty = Ty.next () in
238 Q.TypeArrow (ty :: List.init (n-1) (fun _ -> Ty.next ()), ty)
239
240 (* === *)
241 (* Thread context *)
242 | `thread_context -> Ty.thread_context ()
243 | `with_thread_context -> Ty.with_thread_context ()
244
245 (* === *)
246 (* Exceptions *)
247 | `throw -> Ty.throw ()
248 | `catch -> Ty.catch ()
249
250 (* === *)
251 (* CPS and concurrency *)
252 | `atomic
253 | `immovable -> Ty.id ()
254 | `spawn ->
255 let t = Ty.next () in
256 Q.TypeArrow ([t], Ty.future t)
257 | `wait ->
258 let t = Ty.next () in
259 Q.TypeArrow ([Ty.future t], t)
260 | `callcc -> Ty.callcc ()
261 | `cps_stack_lambda _
262 | `cps_stack_apply _
43a556e [cleanup] garbage: collecting some directives
Valentin Gatien-Baron authored
263 | `async
fccc685 Initial open-source release
MLstate authored
264 | `may_cps
265 | `apply_cont
266 -> Ty.id ()
267
268 (* === *)
269 (* Expansion *)
270 | `expand _ -> Ty.id ()
271
272 (* === *)
273 (* Closures *)
274 | `closure_create _
275 | `closure_apply
276 | `closure_create_no_function _
277 | `closure_define_function _
278 -> assert false (* don't care, those directives are used internally by
279 * the closure pass *)
280 | `lifted_lambda _
281 | `full_apply _
282 | `partial_apply _ ->
283 Ty.id ()
284
285 (* === *)
286 (* FunActions *)
287 | `fun_action kind -> (
288 match kind with
289 | Some Q.Deserialize ->
290 let tv = Ty.next () in
291 let arg = Q.TypeRecord (Q.TyRow (["arg", tv; "serialized_arg", Ty.string], None)) in
292 Q.TypeArrow ([arg], tv)
293 | None
294 | Some Q.Client_id -> Ty.id ()
295 )
296
297 (* === *)
298 (* opadoc *)
299 | `doctype _ -> Ty.id ()
300
301 (* === *)
302 (* Back-end *)
303 | `backend_ident _ -> (
304 match tys with
305 | [ty] -> Q.TypeArrow ([],ty)
306 | _ -> assert false
307 )
308
309 | `hybrid_value ->
310 let res = Ty.next () in
311 let t_client = Q.TypeArrow ([Ty.string], res) in
312 let t_server = Ty.string in
313 let args =
314 match exprs with
315 | [_client; _server] -> [t_client ; t_server]
316 | [_server] -> [t_server]
317 | _ -> assert false in
318 Q.TypeArrow (args, res)
319
320 | `js_ident -> Q.TypeArrow ([Ty.string], Ty.string)
321
322 | `restricted_bypass _ -> Ty.id ()
323
324 | `llarray ->
325 let ty_arg = Ty.next () in
326 let args = List.rev_map (fun _ -> ty_arg) exprs in
327 Q.TypeArrow (args, Ty.llarray ty_arg)
328
329 (* === *)
330 (* Lazyness *)
331 | `create_lazy_record -> (
332 let t = Ty.next () in
333 match exprs with
334 | [_] -> Q.TypeArrow ([t],t)
335 | [_;_] -> Q.TypeArrow ([t;Ty.embedded_obj],t)
336 | _ -> assert false
337 )
338
339 (* === *)
340 (* Explicit Instantiation *)
341 | `apply_ty_arg (lt,lrow,lcol) ->
342 let t = Ty.next () in
343 let opatys = List.map (fun _ -> Ty.opaty) lt in
344 let oparows = List.map (fun _ -> Ty.oparow) lrow in
345 let opacols = List.map (fun _ -> Ty.opacol) lcol in
346 Q.TypeArrow ([Q.TypeArrow (opatys @ oparows @ opacols, t)], t)
347 | `abstract_ty_arg (lt,lrow,lcol) ->
348 let t = Ty.next () in
349 let opatys = List.map (fun _ -> Ty.opaty) lt in
350 let oparows = List.map (fun _ -> Ty.oparow) lrow in
351 let opacols = List.map (fun _ -> Ty.opacol) lcol in
352 Q.TypeArrow ([t], Q.TypeArrow (opatys @ oparows @ opacols, t))
353
354 (* === *)
355 (* Debug *)
356 | `tracker _ -> Ty.id ()
357
358 (* === *)
359 | `at_init ->
360 let alpha = Ty.next() in
361 Q.TypeArrow ([], Q.TypeArrow ([Ty.named_type Opacapi.Types.OPA.Init.value [alpha]], alpha))
362
363 | `tagged_string _ ->
364 Q.TypeArrow ([], Q.TypeConst Q.TyString)
365
366 (* === *)
367 (* Enrich magic *)
368 | `stringifier ->
369 let stringifier =
370 Ty.opavalue_make_performer tys
371 (fun param -> Q.TypeArrow ([param], Ty.string))
372 (fun add ty -> Q.TypeArrow (add@[ty], Ty.string))
373 in Q.TypeArrow ([stringifier], stringifier)
374
375 | `comparator ->
376 let comparison = Ty.named_type Opacapi.Types.Order.comparison [] in
377 let comparator = Ty.opavalue_make_performer tys
378 (fun param -> Q.TypeArrow ([param; param], comparison))
379 (fun add ty -> Q.TypeArrow (add@[ty; ty], comparison)) in
380 Q.TypeArrow ([comparator], comparator)
381
382 | `serializer ->
383 let options = Ty.named_type Opacapi.Types.OpaSerialize.options [] in
384 let json = Ty.named_type Opacapi.Types.RPC.Json.json [] in
385 let serializer = Ty.opavalue_make_performer tys
386 (fun param -> Q.TypeArrow ([param; options], json))
387 (fun add ty -> Q.TypeArrow (add@[ty;options], json)) in
388 let unserializer = Ty.opavalue_make_performer tys
389 (fun param -> Q.TypeArrow ([json], (Ty.named_type Opacapi.Types.option [param])))
390 (fun add ty -> Q.TypeArrow (add@[json], (Ty.named_type Opacapi.Types.option [ty]))) in
391 let cpl =
392 Q.TypeRecord
393 (Q.TyRow ([("f1", serializer);
394 ("f2", unserializer)], None)) in
395 Q.TypeArrow ([cpl], cpl)
396
397 | `xmlizer ->
398 let xml = Ty.named_type Opacapi.Types.xml [] in
399 let xmlizer = Ty.opavalue_make_performer tys
400 (fun param -> Q.TypeArrow ([param], xml))
401 (fun add ty -> Q.TypeArrow (add@[ty], xml)) in
402 Q.TypeArrow ([xmlizer], xmlizer)
403
404 | `recval ->
405 Ty.id ()
406
2536662 @OpaOnWindowsNow [feature] closure serialisation: restrict to new @public_env directive
OpaOnWindowsNow authored
407 (* === *)
408 (* closure_instrumentation *)
409 | `public_env -> Ty.id ()
410
fccc685 Initial open-source release
MLstate authored
411 (* utils *)
412
413 let create_lazy_record_arguments = function
414 | [ expr ] -> expr, None
415 | [ expr ; info ] -> expr, Some info
416 | _ -> assert false
417
418 let create_lazy_record_exprs record info =
419 match info with
420 | Some info -> [ record ; info ]
421 | None -> [ record ]
2536662 @OpaOnWindowsNow [feature] closure serialisation: restrict to new @public_env directive
OpaOnWindowsNow authored
422
423 module Format = Base.Format
424
425 let to_string d =
426 match d with
427 | `deprecated -> "deprecated"
428 | `todo -> "todo"
429 | `at_init -> "at_init"
430 | `module_ -> "module"
431 | `module_field_lifting -> "module_field_lifting"
432 | `coerce -> "coerce"
433 | `nonexpansive -> "nonexpansive"
434 | `unsafe_cast -> "unsafe_cast"
435 | `opensums -> "opensums"
436 | `openrecord -> "openrecord"
437 | `assert_ -> "assert"
438 | `typeof -> "typeof"
439 | `atomic -> "atomic"
440 | `immovable -> "immovable"
441 | `thread_context -> "thread_context"
442 | `with_thread_context -> "with_thread_context"
443 | `js_ident -> "js_ident"
444 | `throw -> "throw"
445 | `catch -> "catch"
446 | `spawn -> "spawn"
447 | `wait -> "wait"
448 | `callcc -> "callcc"
449 | `restricted_bypass pass -> "restricted_bypass["^ pass ^ "]"
450 | `fail -> "fail"
451 | `create_lazy_record -> "create_lazy_record"
452 | `warncoerce -> "warncoerce"
453 | `apply_ty_arg _ -> "apply_ty_arg _"
454 | `abstract_ty_arg _ -> "abstract_ty_arg _"
455 | `closure_create _ -> "closure_create"
456 | `closure_apply -> "closure_apply"
457 | `closure_create_no_function _ -> "closure_create_no_function"
458 | `closure_define_function _ -> "closure_define_function"
459 | `ajax_publish b -> Printf.sprintf "ajax_publish(%s)" (match b with `sync -> "`sync" | `async -> "`async")
460 | `ajax_call b -> Printf.sprintf "ajax_call(%s)" (match b with `sync -> "`sync" | `async -> "`async")
461 | `comet_publish -> "comet_publish"
462 | `comet_call -> "comet_call"
463 | `insert_server_value i -> Printf.sprintf "insert_server_value(%s)" (Ident.to_string i)
464 | `doctype _ -> "doctype"
465 | `hybrid_value -> "hybrid_value"
466 | `backend_ident s -> Printf.sprintf "backend_ident[%s]" s
467 | `tracker _ -> "track"
468 | `expand _ -> "expand"
469 | `fun_action None -> "fun_action"
470 | `fun_action (Some Q.Client_id) -> "fun_action[Client_id]"
471 | `fun_action (Some Q.Deserialize) -> "fun_action[Deserialize]"
472 | `cps_stack_lambda _ -> "cps_stack_lambda"
473 | `cps_stack_apply _ -> "cps_stack_apply"
474 | `async -> "async"
475 | `sliced_expr -> "sliced_expr"
476 | `may_cps -> "may_cps"
477 | `stringifier -> "stringifier"
478 | `comparator -> "comparator"
479 | `serializer -> "serializer"
480 | `xmlizer -> "xmlizer"
481 | `llarray -> "llarray"
482 | `specialize variant -> Printf.sprintf "specialize%s" (match variant with `strict -> "_strict" | `polymorphic -> "")
483 | `partial_apply (None, ser) -> Printf.sprintf "partial_apply[ser:%B]" ser
484 | `partial_apply (Some i, ser) -> Printf.sprintf "partial_apply[missing:%d,ser:%B]" i ser
485 | `full_apply n -> Printf.sprintf "full_apply[env %d]" n
486 | `lifted_lambda (n,l) ->
487 Format.sprintf "lifted_lambda[env %d,[%a]]"
488 n
489 (Format.pp_list "@ " (fun f i -> Format.pp_print_string f (Ident.to_string i))) l
490 | `tagged_string (s, kind) ->
491 Printf.sprintf "tagged_string[%S, %s]" s
492 (match kind with
493 | Q.Rpc_use -> "rpc_use"
494 | Q.Rpc_def -> "rpc_def"
495 | Q.Type_def -> "type_def"
496 | Q.Type_use -> "type_use"
497 | Q.Client_closure_use -> "client_closure_use")
498 | `apply_cont -> "apply_cont"
499 | `recval -> "recval"
500 | `side_annotation a -> (
501 match a with
502 | `server -> "server"
503 | `client -> "client"
504 | `both -> "both"
505 | `prefer_server -> "prefer_server"
506 | `prefer_client -> "prefer_client"
507 | `prefer_both -> "prefer_both"
508 | `both_implem -> "both_implem"
509 )
510 | `visibility_annotation `private_ -> "server_private"
511 | `visibility_annotation (`public `sync) -> "publish"
512 | `visibility_annotation (`public `async) -> "publish_async"
513 | `visibility_annotation (`public `funaction) -> "publish_funaction"
514
515 | `public_env -> "public_env"
516
Something went wrong with that request. Please try again.