Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 314 lines (273 sloc) 11.01 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 module B = BslTypes
19 module J = JsAst
20 module BI = BslInterface
21
22 module List = Base.List
23 module Format = Base.Format
24
25 module JS_CTrans =
26 struct
27 type env = {
28 options : Qml2jsOptions.t;
29 }
30
31 let empty () = {
32 options = Qml2jsOptions.Argv.default ()
33 }
34
35 (* checks if a value of the type can evaluate to false
36 * in a 'if' for instance *)
37 let can_be_false = function
38 | B.Const _
39 | B.Bool _
40 | B.TypeVar _
41 | B.OpaValue _
42 | B.External _ -> true
43 | B.Void _
44 | B.Option _
45 | B.Fun _ -> false
46
47 (*
48 The bsl projection will be globalized
49 Do not use global native there.
50 *)
51 let call_native name args =
52 JsCons.Expr.call ~pure:true
53 (JsCons.Expr.ident (JsCons.Ident.native name))
54 args
55
56 type private_env = {
57 local_vars : JsIdent.t list;
58 }
59
60 let fresh_param name =
61 J.ExprIdent (Ident.next name)
62 let fresh_var private_env name =
63 let ident = fresh_param name in
64 let private_env = {(*private_env with*) local_vars = ident :: private_env.local_vars} in
65 private_env, ident
66
67 let declare_local_vars private_env =
68 let local_vars = private_env.local_vars in
69 let private_env = {(*private_env with*) local_vars = []} in
70 let declarations = List.map (fun i -> JsCons.Statement.var i) local_vars in
71 private_env, declarations
72
73 let call_typer ~key typer ?ret id =
74 JsCons.Expr.comma
75 [JsCons.Expr.call ~pure:false typer [JsCons.Expr.string (BslKey.to_string key); JsCons.Expr.ident id]]
76 (match ret with
77 | None -> JsCons.Expr.ident id
78 | Some ret -> ret)
79
80 let function_projection ?(check=false) ~inputs ~outputs ~key private_env type_params type_return id =
81 let initial_local_vars = private_env.local_vars in
82 let private_env = {local_vars = []} in
83 let private_env, js_ret = fresh_var private_env "js_ret" in
84 let params = List.map (fun _ -> fresh_param "p") type_params in
85 let (private_env, projected), proj_output =
86 match outputs private_env type_return js_ret with
87 | Some (private_env, ast) -> (private_env, true), ast
88 | None -> (private_env, false), JsCons.Expr.ident js_ret in
89 let proj_input (private_env,projected) typ x =
90 match inputs private_env typ x with
91 | Some (private_env, ast) -> (private_env, true), ast
92 | None -> (private_env, projected), JsCons.Expr.ident x in
93 let (private_env, projected), arguments = List.fold_left_map2 proj_input (private_env,projected) type_params params in
94 if projected then
95 let check_arity =
96 if check
97 then
98 [JsCons.Statement.expr (
99 JsCons.Expr.call ~pure:false
100 Imp_Common.ClientLib.type_fun_arity [
101 JsCons.Expr.string (BslKey.to_string key);
102 JsCons.Expr.native "arguments";
103 JsCons.Expr.int (List.length type_params)
104 ])]
105 else [] in
106 let _private_env, declarations = declare_local_vars private_env in
107 let private_env = {(*private_env with*) local_vars = initial_local_vars} in
108 let call =
109 JsCons.Statement.assign_ident js_ret (
110 JsCons.Expr.call ~pure:true
111 (JsCons.Expr.ident id)
112 arguments
113 ) in
114 let return = JsCons.Statement.return proj_output in
115 let function_ = JsCons.Expr.function_ None params (check_arity @ declarations @ [call;return]) in
116 let function_ =
117 if check then
118 call_typer ~key Imp_Common.ClientLib.type_fun id ~ret:function_
119 else
120 function_ in
121 Some (private_env, function_)
122 else
123 None
124
125 let aux_option ?(check=false) caller key env private_env typ id =
126 (* no projection for options *)
127 let private_env, x = fresh_var private_env "js" in
128 match caller key env private_env typ x with
129 | None -> None
130 | Some (private_env, ast) ->
131 let ast =
132 if can_be_false typ then
133 (* 'some' in id ? (x = id.some, {some = ast}) : id *)
134 JsCons.Expr.cond
135 (JsCons.Expr.in_ (JsCons.Expr.string "some") (JsCons.Expr.ident id))
136 (JsCons.Expr.comma
137 [JsCons.Expr.assign_ident x (JsCons.Expr.dot (JsCons.Expr.ident id) "some")]
138 (JsCons.Expr.obj ["some", ast]))
139 (JsCons.Expr.ident id)
140 else
141 (* (x = id.some) ? {some = ast} : id (* none *) *)
142 JsCons.Expr.cond
143 (JsCons.Expr.assign_ident x (JsCons.Expr.dot (JsCons.Expr.ident id) "some"))
144 (JsCons.Expr.obj ["some", ast])
145 (JsCons.Expr.ident id) in
146 let ast =
147 if check then
148 call_typer ~key Imp_Common.ClientLib.type_option id ~ret:ast
149 else
150 ast in
151 Some (private_env, ast)
152
153
154 let aux_external ?(check=false) caller key env private_env p id =
155 List.iter
156 (fun ty ->
157 (* this is just a check that the inner
158 * types don't need a projection *)
159 let fake_env = {(*env with*) options = {env.options with Qml2jsOptions.check_bsl_types = false}} in
160 (* we must deactive check_bsl_types or else we always have a projection :/ *)
161 match caller key fake_env private_env ty id with
162 | None -> ()
163 | Some _ ->
164 Format.printf "Proj of %a@." BslKey.pp key;
165 assert false (* TODO: proper error *)
166 ) p;
167 if check then
168 Some (private_env, call_typer ~key Imp_Common.ClientLib.type_extern id)
169 else
170 None
171
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
172 (* when the relevant option is activated, inserting type checks that the js
173 * object received correspond to the type declared in the bsl *)
fccc685 Initial open-source release
MLstate authored
174 let rec aux_qml_of_js key env private_env typ id : (private_env * JsAst.expr) option =
175 match typ with
176 | B.Const (_, c) ->
177 if env.options.Qml2jsOptions.check_bsl_types then
178 let typer =
179 match c with
180 | QmlAst.TyFloat -> Imp_Common.ClientLib.type_float
181 | QmlAst.TyInt -> Imp_Common.ClientLib.type_int
182 | QmlAst.TyNull -> assert false
183 | QmlAst.TyString -> Imp_Common.ClientLib.type_string in
184 Some (private_env, call_typer ~key typer id)
185 else
186 None
187
188 | B.TypeVar _ ->
189 if env.options.Qml2jsOptions.check_bsl_types then
190 Some (private_env, call_typer ~key Imp_Common.ClientLib.type_var id)
191 else
192 None
193
194 | B.Void _ ->
195 let qml_void = Imp_Common.ClientLib.void in
196 let qml_void =
197 if env.options.Qml2jsOptions.check_bsl_types then
198 call_typer ~key Imp_Common.ClientLib.type_native_void id ~ret:qml_void
199 else
200 qml_void
201 in
202 Some (private_env, qml_void)
203
204 | B.Bool _ ->
205 if env.options.Qml2jsOptions.check_bsl_types then
206 Some (private_env, call_typer ~key Imp_Common.ClientLib.type_bool id)
207 else
208 None (* same representation for booleans *)
209
210 | B.Option (_, o) ->
211 aux_option ~check:env.options.Qml2jsOptions.check_bsl_types aux_qml_of_js key env private_env o id
212
213 | B.OpaValue (_, t) ->
214 if env.options.Qml2jsOptions.check_bsl_types then
215 let typer =
216 match t with
217 | B.Const (_, c) -> (
218 match c with
219 | QmlAst.TyFloat -> Imp_Common.ClientLib.type_float
220 | QmlAst.TyInt -> Imp_Common.ClientLib.type_int
221 | QmlAst.TyNull -> assert false
222 | QmlAst.TyString -> Imp_Common.ClientLib.type_string
223 )
224 | B.TypeVar _ -> Imp_Common.ClientLib.type_var
225 | B.Void _ -> Imp_Common.ClientLib.type_void
226 | B.Bool _ -> Imp_Common.ClientLib.type_bool
227 | B.Option _ -> Imp_Common.ClientLib.type_option
228 | B.OpaValue _ -> assert false
229 | _ -> Imp_Common.ClientLib.type_opavalue
230 in
231 Some (private_env, call_typer ~key typer id)
232 else
233 None
234
235 | B.External (_, _, p) ->
236 aux_external ~check:env.options.Qml2jsOptions.check_bsl_types aux_qml_of_js key env private_env p id
237
238 | B.Fun (_, inputs, output) ->
239 assert (not env.options.Qml2jsOptions.cps);
240 let initial_conv =
241 function_projection ~key
242 ~check:env.options.Qml2jsOptions.check_bsl_types
243 ~inputs:(aux_js_of_qml key env)
244 ~outputs:(aux_qml_of_js key env)
245 private_env
246 inputs output id in
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
247 initial_conv
fccc685 Initial open-source release
MLstate authored
248
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
249 (* in the projection qml -> js, there is no check since the typer
250 * already checks that the input of bypasses are right *)
fccc685 Initial open-source release
MLstate authored
251 and aux_js_of_qml key env private_env typ id =
252 match typ with
253 | B.Const _ ->
254 None
255
256 | B.TypeVar _ ->
257 None
258
259 | B.Void _ ->
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
260 (* Nobody cares about the returned value of a javascript function
261 * returning nothing *)
fccc685 Initial open-source release
MLstate authored
262 None
263
264 | B.Bool _ ->
265 None
266
267 | B.Option (_, o) ->
268 aux_option aux_js_of_qml key env private_env o id
269
270 | B.OpaValue _ ->
271 None
272
273 | B.External (_,_,p) ->
274 aux_external aux_js_of_qml key env private_env p id
275
276 | B.Fun (_, inputs, output) ->
277 assert (not env.options.Qml2jsOptions.cps);
278 let p private_env id =
279 function_projection ~key
280 ~inputs:(aux_qml_of_js key env)
281 ~outputs:(aux_js_of_qml key env)
282 private_env
283 inputs output id in
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
284 p private_env id
fccc685 Initial open-source release
MLstate authored
285
286 let wrap_return_of_aux = function
287 | None -> None
288 | Some (private_env, ast) ->
289 Some (private_env.local_vars, ast)
290
291 let initial_private_env = {local_vars = []}
292
293 let qml_of_js ~bslkey:key ~bsltags:_ typ ~env (BI.MetaIdent meta_ident) =
294 let o = aux_qml_of_js key env initial_private_env typ (JsCons.Ident.native meta_ident) in
295 let o = wrap_return_of_aux o in
296 env, o
297
298 let js_of_qml ~bslkey:key ~bsltags:_ typ ~env (BI.MetaIdent meta_ident) =
299 let o = aux_js_of_qml key env initial_private_env typ (JsCons.Ident.native meta_ident) in
300 let o = wrap_return_of_aux o in
301 env, o
302
303 let conversion_code env =
304 (env, (if env.options.Qml2jsOptions.qml_closure then
305 Pass_Closure.generate_applys_js ()
306 else ["",JsCons.Statement.comment "closure not activated"])
307 )
308 end
309
310 module JsImpBSL = BslLib.LibBSLForQml2Js (JS_CTrans)
311
312 let build_ctrans_env ~options =
313 {JS_CTrans.options}
Something went wrong with that request. Please try again.