Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 729 lines (647 sloc) 24.828 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 (* depends *)
21 module Format = Base.Format
22 module List = Base.List
23 module String = Base.String
24
25 (* alias *)
26 module QCons = QmlAstCons.UntypedExpr
27
28 (* shorthands *)
29 module Q = QmlAst
30
31 (* refactoring in progress *)
32
33 (* -- *)
34
35 let debug fmt =
36 OManager.printf ("@{<cyan>[JsSerialize]@}@ @[<2>"^^fmt^^"@]@.")
37
38 module JsIdent =
39 struct
40 module Hashtbl = Base.Hashtbl
41
42 let table = ( Hashtbl.create 16 : (string, QmlAst.ident * QmlAst.code_elt) Hashtbl.t )
43
44 let resolve cident =
45 let string = JsPrint.string_of_ident (JsCons.Ident.ident cident) in
46 match Hashtbl.find_opt table string with
47 | Some ident ->
48 (*
49 An opa toplevel identifier, previously generated by the lines below.
50 *)
51 fst ident
52 | None ->
53 let ident = Ident.next string in
54 let () =
55 let bypass = QCons.bypass Opacapi.Opabsl.BslJsIdent.define_rename in
56 let apply = QCons.apply bypass [QCons.directive (`tagged_string (string, Q.Client_closure_use)) [] []] in
57 let code_elt = Q.NewVal(Annot.nolabel "Serializer.JsIdent.resolve", [ident, apply]) in
58 Hashtbl.add table string (ident, code_elt)
59 in
60 ident
61
62 let get_toplevel_declarations () =
63 let fold _name (_, code_elt) acc = code_elt :: acc in
64 let res = Hashtbl.fold fold table [] in
65 Hashtbl.clear table ;
66 res
67
68 let is_toplevel_declaration ident =
69 Return.set_checkpoint (
70 fun label ->
71 Hashtbl.iter (
72 fun _ (ident', _) ->
73 if Ident.equal ident ident' then Return.return label true
74 ) table ;
75 false
76 )
77 end
78
79
80 module JsSerializer =
81 struct
82 (* shorthand *)
83 module J = JsAst
84
85 (*
86 cf package stdlib.js
87
88 The following ast is the exact replication of the runtime opa ast.
89 We use this structure for generating the runtime ast, before serializing it.
90 *)
91
92 type jsast_ident = string
93
94 type jsast_mini_expr =
95 | Verbatim of string
96 | Ident of jsast_ident
97 | Expr of QmlAst.expr
98 | SetDistant of jsast_ident list
99 | TypeUse of string
100 | TypeDef of string
101 | RpcUse of string
102 | RpcDef of string
103
104 type jsast_key_ident =
105 | KI_key of string
106 | KI_ident of jsast_ident
107 | KI_key_ident of string * jsast_ident
108
109 type jsast_code_elt = {
110 ident : jsast_key_ident ;
111 definition : [ `Rpc of string | `Type of string | `Nothing ];
112 root : bool ;
113 content : jsast_mini_expr list ;
114 }
115
116 type jsast_code = jsast_code_elt list
117
118 (*
119 A printer, just for debugging
120 *)
121
122 let pp_mini_expr fmt = function
123 | Verbatim s -> Format.fprintf fmt "{verbatim:%S}" s
124 | Ident s -> Format.fprintf fmt "{ident:%S}" s
125 | Expr e -> Format.fprintf fmt "{expr:%a}" QmlPrint.pp#expr e
126 | SetDistant idents -> Format.fprintf fmt "{set_distant : [%a]}" (Format.pp_list ",@ " Format.pp_print_string) idents
127 | TypeUse s -> Format.fprintf fmt "{TypeUse: %s}" s
128 | TypeDef s -> Format.fprintf fmt "{TypeDef: %s}" s
129 | RpcUse s -> Format.fprintf fmt "{RpcUse: %s}" s
130 | RpcDef s -> Format.fprintf fmt "{RpcDef: %s}" s
131
132 let pp_key_ident fmt = function
133 | KI_key s -> Format.fprintf fmt "{key:%S}" s
134 | KI_ident s -> Format.fprintf fmt "{ident:%S}" s
135 | KI_key_ident (key, ident) -> Format.fprintf fmt "{key:%S ident:%S}" key ident
136
137 let pp_definition fmt = function
138 | `Rpc s -> Format.fprintf fmt "`Rpc %s" s
139 | `Type s -> Format.fprintf fmt "`Type %s" s
140 | `Nothing -> Format.fprintf fmt "`Nothing"
141
142 let pp_code_elt fmt elt =
143 Format.fprintf fmt (
144 "@[<2>{@\nident: %a ;@\nroot: %a@\ndefinition: %a@\n@[<2>content: %a@]@]@\n}"
145 )
146 pp_key_ident elt.ident
147 Format.pp_print_bool elt.root
148 pp_definition elt.definition
149 (Format.pp_list ",@ " pp_mini_expr) elt.content
150
151 let pp_code fmt code =
152 let i = ref 0 in
153 let pp_code_elt fmt elt =
154 Format.fprintf fmt "elt %d@\n" !i ;
155 incr(i) ;
156 pp_code_elt fmt elt
157 in
158 Format.pp_list "@\n" pp_code_elt fmt code
159
160 module X =
161 struct
162 type lexem = jsast_mini_expr
163 type t = lexem list
164 let append t lexem = lexem :: t
165 let empty = []
166 (* *)
167 let ident s = Ident s
168 let verbatim s = Verbatim s
169 let qml e = Expr e
170 let serialized = function
171 | JsAstRuntime.SetDistant idents -> [SetDistant (List.map JsPrint.string_of_ident idents)]
172 | JsAstRuntime.TaggedString (string, kind) ->
173 (* escaping the string now allows us not to escape it at runtime
174 * same escaping as in pass_GenerateServerAst *)
175 let string = JsPrint.escape_string string in
176 (match kind with
177 | Q.Type_use -> [TypeUse string]
178 | Q.Type_def -> [TypeDef string]
179 | Q.Rpc_use -> [RpcUse string]
180 | Q.Rpc_def -> [RpcDef string]
181 | Q.Client_closure_use -> assert false)
182 end
183
184 module S = JsPrint.Make ( X )
185
186 (*
187 Function used to tag toplevel applications.
188 *)
189 let pure_funs = ref IdentSet.empty (* FIXME: dirty -> should propagate an env instead *)
190
191 (*
192 <!> BEWARE, if a new expr case appear in the ast, and potentially executed,
193 we may have to change the exists for itering statements inside expressions.
194 Currently for this particulary check (side effects), we should not enter inside
195 statements because statements in expression are in function definition only,
196 which are statements not executed.
197 *)
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
198 let is_register_expr expr =
199 JsWalk.OnlyExpr.exists (function
200 | J.Je_runtime (_, JsAstRuntime.TaggedString (_, (QmlAst.Rpc_def | QmlAst.Type_def)) ) -> true
201 | _ -> false) expr
202
203
204 let is_register_element elt =
205 JsWalk.OnlyStatement.exists (function
206 | J.Js_var (_, _, Some e)
207 | J.Js_return (_, Some e)
208 | J.Js_expr (_, e) -> is_register_expr e
209 | _ -> false
210 ) elt
211
212 let is_pure = function
213 | J.ExprIdent ident -> IdentSet.mem ident !pure_funs
214 | _ -> false
215
216 let add_pure_funs = function
217 | J.ExprIdent ident -> pure_funs := IdentSet.add ident !pure_funs
218 | _ -> ()
219
220 let is_in_local_vars local_vars = function
221 | J.Je_ident(_,J.ExprIdent ident) -> IdentSet.mem ident local_vars
222 | J.Je_ident(_,J.Native( `local, str) )-> IdentSet.mem (Ident.source str) local_vars
223 | _ -> false
224
225 let add_local_vars local_vars = function
226 | J.ExprIdent ident -> IdentSet.add ident local_vars
227 | J.Native( `local, str) -> IdentSet.add (Ident.source str) local_vars
228 | _ -> local_vars
229
230 exception Return_true
231
232 (* side_effect comment :
233 if the side effect of an operator, changes a local variable there is no external (function) side-effect
234 since assignment op are widely used by the code generator to implement perfectly pure local environment
235 we need to handle this *)
236 let rec is_side_effect_expr ~local_vars expr =
237 JsWalk.OnlyExpr.exists (function
c33cbe8 Rudy Sicard [fix] qmljs_Serializer: side-effect bug with assignement (introduce by a...
OpaOnWindowsNow authored
238 | J.Je_unop (_, unop, e) when JsAst.is_side_effect_unop unop ->
239 is_side_effect_expr ~local_vars e || not(is_in_local_vars local_vars e)
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
240
c33cbe8 Rudy Sicard [fix] qmljs_Serializer: side-effect bug with assignement (introduce by a...
OpaOnWindowsNow authored
241 | J.Je_binop (_, binop, e1, e2) when JsAst.is_side_effect_binop binop ->
242 is_side_effect_expr ~local_vars e1 || is_side_effect_expr ~local_vars e1
243 || not(is_in_local_vars local_vars e2)
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
244
245 | J.Je_call (_, f, args, pure) ->
246 let side_effect_fun = match f with
247 | J.Je_ident (_, ident) when not pure -> not (is_pure ident)
248 (* applied anonymous function <=> block of code,
249 e.g. created by the code generator, to split big datastruture,
250 or toplevel val with local environment *)
251 | J.Je_function (_, _, _, body) -> is_side_effect ~local_vars body
252 | _ -> not pure
253 in side_effect_fun || List.exists (is_side_effect_expr ~local_vars) args
254
255 | J.Je_runtime (_, e) -> (
256 match e with
257 | JsAstRuntime.SetDistant _ -> true
258 | JsAstRuntime.TaggedString _ -> false
259 )
260
261 | _ -> false
262 ) expr
263
264 (* TODO, block statement in non toplevel mode *)
265 and is_side_effect_stmt ~toplevel ~local_vars stmt =
266 (* the problem with statement is that when you have {var x = 1; var y = 2}
267 * then in the ast, you do not say that it defines x
268 * (you can't even say it, you have only one definition for per code element in the ast)
269 * so these blocks look like they are never used, and get cleaned
270 * that's why toplevel statement having local_vars are considered as root (see snd_ ) *)
271 let snd_ = if toplevel
272 then fun (local_vars,b) -> not(IdentSet.is_empty local_vars) || b
273 else snd
274 in
275 let se_opt_expr e = Option.default_map false (is_side_effect_expr ~local_vars) e in
276 let se_stmt stmt = snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt) in
277 let se_opt_stmt stmt = Option.default_map false se_stmt stmt in
278 match stmt with
279 | J.Js_var (_, ident, expr) -> (
280 let _ = match expr with
281 | Some(J.Je_function (_, _, _, body)) when not(is_side_effect ~local_vars body) -> add_pure_funs ident;
282 | _ -> ()
283 in
284 add_local_vars local_vars ident, (match expr with
285 | Some(expr) -> is_side_effect_expr ~local_vars expr
286 | None -> false)
287 )
fccc685 Initial open-source release
MLstate authored
288
289 | J.Js_function (_, ident, _, body) ->
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
290 if not(is_side_effect body) then add_pure_funs ident;
291 add_local_vars local_vars ident,false
fccc685 Initial open-source release
MLstate authored
292
293 | J.Js_return (_, Some e)
294 | J.Js_expr (_, e) ->
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
295 local_vars,is_side_effect_expr ~local_vars e
fccc685 Initial open-source release
MLstate authored
296
297 (* this case aren't supposed to happen at toplevel, however they can appear
298 * when looking at the body of a function *)
299 | J.Js_return (_, None)
300 | J.Js_break _
301 | J.Js_continue _ ->
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
302 local_vars,false
fccc685 Initial open-source release
MLstate authored
303
304 | J.Js_comment _ ->
305 (*
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
306 We want to keep all toplevel comments in debug mode, so we considerate them as root,
fccc685 Initial open-source release
MLstate authored
307 the minimifier will removes comments anyway if the server is not in debug js.
308 *)
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
309 local_vars, toplevel
310
311 | J.Js_switch(_, e, cases, default) ->
312 let se_case (e,stmt) = se_stmt stmt
313 || is_side_effect_expr ~local_vars e in
314 local_vars,
315 se_opt_stmt default
316 || is_side_effect_expr ~local_vars e
317 || List.exists se_case cases
318
319 | J.Js_if(_, e, then_, opt_else) ->
320 local_vars,
321 is_side_effect_expr ~local_vars e
322 || snd_ (is_side_effect_stmt ~toplevel ~local_vars then_)
323 || se_opt_stmt opt_else
324
325 | J.Js_dowhile(_, stmt, e)
326 | J.Js_while(_, e ,stmt)
327 | J.Js_with(_, e ,stmt) ->
328 local_vars,
329 is_side_effect_expr ~local_vars e
330 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
331
332 | J.Js_for(_, oe1, oe2, oe3, stmt) ->
333 local_vars,
334 se_opt_expr oe1
335 || se_opt_expr oe2
336 || se_opt_expr oe3
337 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
338
339
340 | J.Js_forin(_, e1, e2, stmt) ->
341 local_vars,
342 is_side_effect_expr ~local_vars e1
343 || is_side_effect_expr ~local_vars e2
344 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
345
346 | J.Js_block(_, stmt_list) -> local_vars, List.exists se_stmt stmt_list
347
348 | J.Js_label _ -> local_vars, false
349
350 (*
351 The rest is currently not supposed to happens, because they are not elemts
352 generated by the js back-end, but may in the future be used (parsing and cleaning jsbsl)
353 *)
354 | J.Js_throw _
fccc685 Initial open-source release
MLstate authored
355 | J.Js_trycatch _
356 ->
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
357 (* TODO *)
358 local_vars,true
359
360 (* side effect on local vars are ignored *)
361 and is_side_effect ?(toplevel=false) ?(local_vars=IdentSet.empty) (elt:J.statement list) =
362 try
363 let (_,bool) = List.fold_left (fun (local_vars,bool) stmt -> if bool then raise Return_true
364 else is_side_effect_stmt ~toplevel ~local_vars stmt
365 ) (local_vars,false) elt
366 in bool
367 with Return_true -> true
fccc685 Initial open-source release
MLstate authored
368
369 let serialize
370 ~client_roots
371 ?key
372 ( elt : JsAst.code_elt ) =
373 let ident, exprident =
374 let jsident =
375 match elt with
376 | J.Js_var (_, ident, _)
377 | J.Js_function (_, ident, _, _) ->
378 ident
379 | J.Js_comment (_, _, _) ->
380 J.ExprIdent (Ident.next "comment")
381 | _ ->
382 (*
383 There: It is about toplevel statement parsed in the bsl.
384 There is an extra management of unicity keys, so these elements
385 will not be duplicated thanks to the unicity keys runtime cleaning.
386 We can put a dummy identifier for these statements.
387 *)
388 J.ExprIdent (Ident.next "toplevel_statement")
389 in
390 match jsident with
391 | J.ExprIdent exprident ->
392 JsPrint.string_of_ident jsident, exprident
393 | J.Native (_, native) ->
394 native, Ident.next native
395 in
396 let rev_list = S.code_elt elt in
397 let definition, content =
398 (* reversing the list and looking for typedef and rpcdef at the same time *)
399 let rec aux def_kind acc = function
400 | [] -> def_kind, acc
401 | h :: t ->
402 let def_kind =
403 match h with
404 | TypeDef string -> assert (def_kind = `Nothing); `Type string
405 | RpcDef string -> assert (def_kind = `Nothing); `Rpc string
406 | TypeUse _
407 | RpcUse _
408 | SetDistant _
409 | Expr _
410 | Ident _
411 | Verbatim _ -> def_kind in
412 aux def_kind (h :: acc) t in
413 aux `Nothing [] rev_list in
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
414 (* registering a type name of a rpc doesn't count as a side effect or else you can't clean anything
415 * the runtime cleaning looks for more detailed dependencies to see if it will be kept or not *)
fccc685 Initial open-source release
MLstate authored
416 let root =
a577a3c Rudy Sicard [enhance] qmljs_Serializer: rework top-level side-effet detection to han...
OpaOnWindowsNow authored
417 IdentSet.mem exprident client_roots || (definition = `Nothing && (is_side_effect ~toplevel:true [elt]) && not(is_register_element elt))
fccc685 Initial open-source release
MLstate authored
418 in
419 (*
420 Adding key unicity for registration
421 *)
422 let ident =
423 match key with
424 | Some key -> KI_key_ident (key, ident)
425 | None ->
426 match exprident with
427 | Ident.FakeSource key -> KI_key_ident (key, ident)
428 | Ident.Source _ | Ident.Internal _ -> KI_ident ident
429 in
430 {
431 ident;
432 root;
433 definition;
434 content;
435 }
436 end
437
438 module QmlSerializer =
439 struct
440
441 module S = JsSerializer
442
443 let cons = ref QmlAstCons.untyped_cons
444
445 let label = Annot.nolabel "JsSerializer"
446
447 module JsAstLabel =
448 struct
449 (* Meta infos, corresponding to the module JsAst of the stdlib *)
450 let verbatim = "verbatim"
451 let ident = "ident"
452 let content = "content"
453 let root = "root"
454
455 let declaration = "declaration"
456 let key = "key"
457 end
458
459 module AdHocSerialize =
460 struct
461 let ser_int b i =
462 (* we need to make sure that the length of an integer is fixed (or predictable at least) *)
463 (* big bytes first *)
464 for j = 64 / 8 - 1 downto 0 do
465 Buffer.add_char b (Char.chr ((i lsr (j*8)) mod 256));
466 done
467 let ser_string b s =
468 ser_int b (String.length s);
469 Buffer.add_string b s
470 let ser_key_ident b = function
471 | S.KI_key key -> Buffer.add_char b '\000'; ser_string b key
472 | S.KI_ident ident -> Buffer.add_char b '\001'; ser_string b ident
473 | S.KI_key_ident (key,ident) -> Buffer.add_char b '\002'; ser_string b key; ser_string b ident
474 let ser_root b = function
475 | false -> Buffer.add_char b '\000'
476 | true -> Buffer.add_char b '\001'
477 let ser_mini_expr ((b,l) as acc) = function
478 | S.Verbatim s -> Buffer.add_char b '\000'; ser_string b s; acc
479 | S.Ident s -> Buffer.add_char b '\001'; ser_string b s; acc
480 | S.Expr e ->
481 Buffer.add_char b '\002';
482 let string = !cons#string (Buffer.contents b) in
483 Buffer.reset b;
484 let l = `expr e :: `string string :: l in
485 (b,l)
486 | S.SetDistant idents ->
487 Buffer.add_char b '\003';
488 ser_int b (List.length idents);
489 List.iter (ser_string b) idents;
490 acc
491 | S.RpcDef string ->
492 Buffer.add_char b '\004';
493 ser_string b string;
494 acc
495 | S.RpcUse string ->
496 Buffer.add_char b '\005';
497 ser_string b string;
498 acc
499 | S.TypeDef string ->
500 Buffer.add_char b '\006';
501 ser_string b string;
502 acc
503 | S.TypeUse string ->
504 Buffer.add_char b '\007';
505 ser_string b string;
506 acc
507 let ser_definition b = function
508 | `Nothing -> Buffer.add_char b '\000'
509 | `Rpc string -> Buffer.add_char b '\001'; ser_string b string
510 | `Type string -> Buffer.add_char b '\002'; ser_string b string
511 let ser_content ((b,_) as acc) l =
512 ser_int b (List.length l);
513 List.fold_left ser_mini_expr acc l
514 let ser_code_elt ((b,_) as acc) {S.content; definition; ident; root} =
515 let acc = ser_content acc content in
516 ser_definition b definition;
517 ser_key_ident b ident;
518 ser_root b root;
519 acc
520 let ser_code ((b,_) as acc) l =
521 ser_int b (List.length l);
522 List.fold_left ser_code_elt acc l
523 let ser_code l =
524 let b = Buffer.create 20000 in
525 let acc = (b, []) in
526 let (_,l) = ser_code acc l in
527 let l =
528 if Buffer.length b = 0 then l else
529 let string = !cons#string (Buffer.contents b) in
530 `string string :: l in
531 let idents = List.map (fun _ -> Ident.next "adhoc") l in
532 let code_elts =
533 List.map2
534 (fun ident e ->
535 match e with
536 | `string e
537 | `expr e -> Q.NewVal (label, [ident, e]))
538 idents l in
539 let tystring = Q.TypeConst Q.TyString in
540 let ty_bp = Q.TypeArrow ([tystring], tystring) in
541 let rev_list =
542 List.concat_map2
543 (fun e ident ->
544 let gen_ident () = !cons#ident ident tystring in
545 let r =
546 match e with
547 | `string _ -> []
548 | `expr _ ->
549 let bp = !cons#bypass Opacapi.Opabsl.BslClientCode.serialize_string_length ty_bp in
550 [!cons#apply bp [gen_ident ()]] in
551 gen_ident () :: r
552 ) l idents in
553 #<If:JS_SERIALIZE$contains "overhead">
554 let r = ref 0 in
555 let count =
556 List.fold_left
557 (fun count -> function
558 | `expr _ -> count
559 | `string (Q.Const (_, Q.String string)) ->
560 for i = 0 to String.length string - 1 do
561 if string.[i] < '\005' then incr r
562 done;
563 count + String.length string
564 | `string _ -> assert false
565 ) 0 l in
566 Printf.printf "length: %d, overhead: %d, %.2f%%\n%!" count !r (100. *. float !r /. float count);
567 #<End>;
568 code_elts, !cons#record ["adhoc", !cons#list (List.rev rev_list); "package_", !cons#string (ObjectFiles.get_current_package_name ())]
569 end
570
571 (** {6 Nodes} *)
572 (**
573 We can extend this interface, if we need more precise js ast at runtime.
574 Invariant: in the returned t, there are no 2 successives lexem verbatim.
575 *)
576
577 let ident string =
578 let string = !cons#string string in
579 !cons#record [JsAstLabel.ident, string]
580
581 let key string =
582 let string = !cons#string string in
583 !cons#record [JsAstLabel.key, string]
584
585 let key_ident key ident =
586 let key = !cons#string key in
587 let ident = !cons#string ident in
588 !cons#record [
589 JsAstLabel.key, key ;
590 JsAstLabel.ident, ident ;
591 ]
592
593 let verbatim string =
594 let string = !cons#string string in
595 !cons#record [JsAstLabel.verbatim, string]
596
597 let qml qml =
598 !cons#record [JsAstLabel.verbatim, qml]
599
600 let mini_expr = function
601 | S.Verbatim s -> verbatim s
602 | S.Ident s -> ident s
603 | S.Expr e -> qml e
604 | S.SetDistant _
605 | S.TypeDef _
606 | S.TypeUse _
607 | S.RpcUse _
608 | S.RpcDef _ -> assert false (* TODO if needed *)
609
610 let declaration string =
611 let string = !cons#string string in
612 !cons#record [JsAstLabel.declaration, string]
613
614 (*
615 Possibly optimized in the future.
616 Returns a list of declarations, and the expression.
617 *)
618 let code_elt elt =
619 let ident =
620 match elt.S.ident with
621 | S.KI_key k -> key k
622 | S.KI_ident i -> ident i
623 | S.KI_key_ident (k, i) -> key_ident k i
624 in
625 let root =
626 let value = !cons#bool elt.S.root in
627 let bypass = QCons.bypass Opacapi.Opabsl.BslReference.create in
628 let apply = QCons.apply bypass [value] in
629 apply
630 in
631 let content =
632 let content = elt.S.content in
633 QCons.directive `llarray (List.map mini_expr content) []
634 in
635 let code_elt =
636 !cons#record [
637 JsAstLabel.ident, ident ;
638 JsAstLabel.root, root ;
639 JsAstLabel.content, content ;
640 ]
641 in
642 let id = Ident.next "js_code_elt" in
643 let decl = Q.NewVal (label, [ id, code_elt ]) in
644 let decls = [ decl ] in
645 let code_elt = QCons.ident id in
646 decls, code_elt
647
648 let code code =
649 let fold_map rev_decls elt =
650 let decls, elt = code_elt elt in
651 let rev_decls = List.rev_append decls rev_decls in
652 rev_decls, elt
653 in
654 let rev_decls, code = List.fold_left_map fold_map [] code in
655 List.rev rev_decls, code
656
657 (*
658 The dependencies of the generated code is hard to predict,
659 because of Hole and DynamicExpr contained in it.
660 We use this function for computing the set of dependencies.
661 *)
662 let get_deps acc e =
663 QmlAstWalk.Expr.fold
664 (fun acc e ->
665 match e with
666 | Q.Ident (_,i) -> IdentSet.add i acc
667 | _ -> acc
668 )
669 acc
670 e
671
672 let insert_code ~kind ( js_code : JsSerializer.jsast_code ) ( server_code : QmlAst.code ) =
673 let () =
674 #<If:JS_SERIALIZE>
675 let outputer oc js_code =
676 let fmt = Format.formatter_of_out_channel oc in
677 JsSerializer.pp_code fmt js_code
678 in
679 let _ = PassTracker.file ~filename:"js_serialize" outputer js_code in
680 ()
681 #<End>
682 in
683 let register_js_file_ident = OpaMapToIdent.val_ Opacapi.Client_code.register_js_code in
684 let register_js_file = QCons.ident register_js_file_ident in
685 let insert =
686 match kind with
687 | `adhoc ->
688 (* the order in code_elts doesn't matter *)
689 let code_elts, e = AdHocSerialize.ser_code js_code in
690 let register_call = !cons#apply register_js_file [ e ] in
691 List.rev (Q.NewVal (label, [ Ident.next "js_code", register_call ]) :: code_elts)
692 | `ast ->
693 let (!!) x = OpaMapToIdent.val_ x in
694 let decls, qml_elts = code js_code in
695 if false (* TODO: inspect CPS rewriter, and bypass skipping *)
696 then (
697 (*
698 Add a sequence of call to register.
699 Not possible currently because of a unskipped list,
700 and then LambdaLifting which consume all the ram.
701 *)
702 let register_js_ident = !!Opacapi.Client_code.register_js_code_elt in
703 let register_js_elt = QCons.ident register_js_ident in
704 let foldr js_code_elt acc =
705 let id = Ident.next "_" in
706 let register_call = !cons#apply register_js_elt [js_code_elt] in
707 !cons#letin id register_call acc
708 in
709 let void = !cons#cheap_void in
710 let register_all = List.fold_right foldr qml_elts void in
711 let register_elt =
712 Q.NewVal (label, [ Ident.next "_", register_all ]) in
713 let insert = decls @ [ register_elt ] in
714 insert
715 )
716 else (
717 let js_code = QCons.directive `llarray qml_elts [] in
718 let js_code = !cons#record ["ast", js_code] in
719 let register_call = !cons#apply register_js_file [ js_code ] in
720 let register_elt =
721 Q.NewVal (label, [ Ident.next "_", register_call ])
722 in
723 let insert = decls @ [ register_elt ] in
724 insert
725 ) in
726 let deps = QmlAstWalk.CodeExpr.fold get_deps IdentSet.empty insert in
727 QmlAstUtils.Code.insert ~deps ~insert server_code
728 end
Something went wrong with that request. Please try again.