Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 728 lines (646 sloc) 24.703 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 @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
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
238 | J.Je_unop (_, unop, e) ->
239 JsAst.is_side_effect_unop unop && not(is_in_local_vars local_vars e)
240
241 | J.Je_binop (_, binop, e, _) ->
242 JsAst.is_side_effect_binop binop && not(is_in_local_vars local_vars e)
243
244 | J.Je_call (_, f, args, pure) ->
245 let side_effect_fun = match f with
246 | J.Je_ident (_, ident) when not pure -> not (is_pure ident)
247 (* applied anonymous function <=> block of code,
248 e.g. created by the code generator, to split big datastruture,
249 or toplevel val with local environment *)
250 | J.Je_function (_, _, _, body) -> is_side_effect ~local_vars body
251 | _ -> not pure
252 in side_effect_fun || List.exists (is_side_effect_expr ~local_vars) args
253
254 | J.Je_runtime (_, e) -> (
255 match e with
256 | JsAstRuntime.SetDistant _ -> true
257 | JsAstRuntime.TaggedString _ -> false
258 )
259
260 | _ -> false
261 ) expr
262
263 (* TODO, block statement in non toplevel mode *)
264 and is_side_effect_stmt ~toplevel ~local_vars stmt =
265 (* the problem with statement is that when you have {var x = 1; var y = 2}
266 * then in the ast, you do not say that it defines x
267 * (you can't even say it, you have only one definition for per code element in the ast)
268 * so these blocks look like they are never used, and get cleaned
269 * that's why toplevel statement having local_vars are considered as root (see snd_ ) *)
270 let snd_ = if toplevel
271 then fun (local_vars,b) -> not(IdentSet.is_empty local_vars) || b
272 else snd
273 in
274 let se_opt_expr e = Option.default_map false (is_side_effect_expr ~local_vars) e in
275 let se_stmt stmt = snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt) in
276 let se_opt_stmt stmt = Option.default_map false se_stmt stmt in
277 match stmt with
278 | J.Js_var (_, ident, expr) -> (
279 let _ = match expr with
280 | Some(J.Je_function (_, _, _, body)) when not(is_side_effect ~local_vars body) -> add_pure_funs ident;
281 | _ -> ()
282 in
283 add_local_vars local_vars ident, (match expr with
284 | Some(expr) -> is_side_effect_expr ~local_vars expr
285 | None -> false)
286 )
fccc685 Initial open-source release
MLstate authored
287
288 | J.Js_function (_, ident, _, body) ->
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
289 if not(is_side_effect body) then add_pure_funs ident;
290 add_local_vars local_vars ident,false
fccc685 Initial open-source release
MLstate authored
291
292 | J.Js_return (_, Some e)
293 | J.Js_expr (_, e) ->
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
294 local_vars,is_side_effect_expr ~local_vars e
fccc685 Initial open-source release
MLstate authored
295
296 (* this case aren't supposed to happen at toplevel, however they can appear
297 * when looking at the body of a function *)
298 | J.Js_return (_, None)
299 | J.Js_break _
300 | J.Js_continue _ ->
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
301 local_vars,false
fccc685 Initial open-source release
MLstate authored
302
303 | J.Js_comment _ ->
304 (*
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
305 We want to keep all toplevel comments in debug mode, so we considerate them as root,
fccc685 Initial open-source release
MLstate authored
306 the minimifier will removes comments anyway if the server is not in debug js.
307 *)
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
308 local_vars, toplevel
309
310 | J.Js_switch(_, e, cases, default) ->
311 let se_case (e,stmt) = se_stmt stmt
312 || is_side_effect_expr ~local_vars e in
313 local_vars,
314 se_opt_stmt default
315 || is_side_effect_expr ~local_vars e
316 || List.exists se_case cases
317
318 | J.Js_if(_, e, then_, opt_else) ->
319 local_vars,
320 is_side_effect_expr ~local_vars e
321 || snd_ (is_side_effect_stmt ~toplevel ~local_vars then_)
322 || se_opt_stmt opt_else
323
324 | J.Js_dowhile(_, stmt, e)
325 | J.Js_while(_, e ,stmt)
326 | J.Js_with(_, e ,stmt) ->
327 local_vars,
328 is_side_effect_expr ~local_vars e
329 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
330
331 | J.Js_for(_, oe1, oe2, oe3, stmt) ->
332 local_vars,
333 se_opt_expr oe1
334 || se_opt_expr oe2
335 || se_opt_expr oe3
336 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
337
338
339 | J.Js_forin(_, e1, e2, stmt) ->
340 local_vars,
341 is_side_effect_expr ~local_vars e1
342 || is_side_effect_expr ~local_vars e2
343 || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)
344
345 | J.Js_block(_, stmt_list) -> local_vars, List.exists se_stmt stmt_list
346
347 | J.Js_label _ -> local_vars, false
348
349 (*
350 The rest is currently not supposed to happens, because they are not elemts
351 generated by the js back-end, but may in the future be used (parsing and cleaning jsbsl)
352 *)
353 | J.Js_throw _
fccc685 Initial open-source release
MLstate authored
354 | J.Js_trycatch _
355 ->
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
356 (* TODO *)
357 local_vars,true
358
359 (* side effect on local vars are ignored *)
360 and is_side_effect ?(toplevel=false) ?(local_vars=IdentSet.empty) (elt:J.statement list) =
361 try
362 let (_,bool) = List.fold_left (fun (local_vars,bool) stmt -> if bool then raise Return_true
363 else is_side_effect_stmt ~toplevel ~local_vars stmt
364 ) (local_vars,false) elt
365 in bool
366 with Return_true -> true
fccc685 Initial open-source release
MLstate authored
367
368 let serialize
369 ~client_roots
370 ?key
371 ( elt : JsAst.code_elt ) =
372 let ident, exprident =
373 let jsident =
374 match elt with
375 | J.Js_var (_, ident, _)
376 | J.Js_function (_, ident, _, _) ->
377 ident
378 | J.Js_comment (_, _, _) ->
379 J.ExprIdent (Ident.next "comment")
380 | _ ->
381 (*
382 There: It is about toplevel statement parsed in the bsl.
383 There is an extra management of unicity keys, so these elements
384 will not be duplicated thanks to the unicity keys runtime cleaning.
385 We can put a dummy identifier for these statements.
386 *)
387 J.ExprIdent (Ident.next "toplevel_statement")
388 in
389 match jsident with
390 | J.ExprIdent exprident ->
391 JsPrint.string_of_ident jsident, exprident
392 | J.Native (_, native) ->
393 native, Ident.next native
394 in
395 let rev_list = S.code_elt elt in
396 let definition, content =
397 (* reversing the list and looking for typedef and rpcdef at the same time *)
398 let rec aux def_kind acc = function
399 | [] -> def_kind, acc
400 | h :: t ->
401 let def_kind =
402 match h with
403 | TypeDef string -> assert (def_kind = `Nothing); `Type string
404 | RpcDef string -> assert (def_kind = `Nothing); `Rpc string
405 | TypeUse _
406 | RpcUse _
407 | SetDistant _
408 | Expr _
409 | Ident _
410 | Verbatim _ -> def_kind in
411 aux def_kind (h :: acc) t in
412 aux `Nothing [] rev_list in
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
413 (* registering a type name of a rpc doesn't count as a side effect or else you can't clean anything
414 * the runtime cleaning looks for more detailed dependencies to see if it will be kept or not *)
fccc685 Initial open-source release
MLstate authored
415 let root =
a577a3c @OpaOnWindowsNow [enhance] qmljs_Serializer: rework top-level side-effet detection to …
OpaOnWindowsNow authored
416 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
417 in
418 (*
419 Adding key unicity for registration
420 *)
421 let ident =
422 match key with
423 | Some key -> KI_key_ident (key, ident)
424 | None ->
425 match exprident with
426 | Ident.FakeSource key -> KI_key_ident (key, ident)
427 | Ident.Source _ | Ident.Internal _ -> KI_ident ident
428 in
429 {
430 ident;
431 root;
432 definition;
433 content;
434 }
435 end
436
437 module QmlSerializer =
438 struct
439
440 module S = JsSerializer
441
442 let cons = ref QmlAstCons.untyped_cons
443
444 let label = Annot.nolabel "JsSerializer"
445
446 module JsAstLabel =
447 struct
448 (* Meta infos, corresponding to the module JsAst of the stdlib *)
449 let verbatim = "verbatim"
450 let ident = "ident"
451 let content = "content"
452 let root = "root"
453
454 let declaration = "declaration"
455 let key = "key"
456 end
457
458 module AdHocSerialize =
459 struct
460 let ser_int b i =
461 (* we need to make sure that the length of an integer is fixed (or predictable at least) *)
462 (* big bytes first *)
463 for j = 64 / 8 - 1 downto 0 do
464 Buffer.add_char b (Char.chr ((i lsr (j*8)) mod 256));
465 done
466 let ser_string b s =
467 ser_int b (String.length s);
468 Buffer.add_string b s
469 let ser_key_ident b = function
470 | S.KI_key key -> Buffer.add_char b '\000'; ser_string b key
471 | S.KI_ident ident -> Buffer.add_char b '\001'; ser_string b ident
472 | S.KI_key_ident (key,ident) -> Buffer.add_char b '\002'; ser_string b key; ser_string b ident
473 let ser_root b = function
474 | false -> Buffer.add_char b '\000'
475 | true -> Buffer.add_char b '\001'
476 let ser_mini_expr ((b,l) as acc) = function
477 | S.Verbatim s -> Buffer.add_char b '\000'; ser_string b s; acc
478 | S.Ident s -> Buffer.add_char b '\001'; ser_string b s; acc
479 | S.Expr e ->
480 Buffer.add_char b '\002';
481 let string = !cons#string (Buffer.contents b) in
482 Buffer.reset b;
483 let l = `expr e :: `string string :: l in
484 (b,l)
485 | S.SetDistant idents ->
486 Buffer.add_char b '\003';
487 ser_int b (List.length idents);
488 List.iter (ser_string b) idents;
489 acc
490 | S.RpcDef string ->
491 Buffer.add_char b '\004';
492 ser_string b string;
493 acc
494 | S.RpcUse string ->
495 Buffer.add_char b '\005';
496 ser_string b string;
497 acc
498 | S.TypeDef string ->
499 Buffer.add_char b '\006';
500 ser_string b string;
501 acc
502 | S.TypeUse string ->
503 Buffer.add_char b '\007';
504 ser_string b string;
505 acc
506 let ser_definition b = function
507 | `Nothing -> Buffer.add_char b '\000'
508 | `Rpc string -> Buffer.add_char b '\001'; ser_string b string
509 | `Type string -> Buffer.add_char b '\002'; ser_string b string
510 let ser_content ((b,_) as acc) l =
511 ser_int b (List.length l);
512 List.fold_left ser_mini_expr acc l
513 let ser_code_elt ((b,_) as acc) {S.content; definition; ident; root} =
514 let acc = ser_content acc content in
515 ser_definition b definition;
516 ser_key_ident b ident;
517 ser_root b root;
518 acc
519 let ser_code ((b,_) as acc) l =
520 ser_int b (List.length l);
521 List.fold_left ser_code_elt acc l
522 let ser_code l =
523 let b = Buffer.create 20000 in
524 let acc = (b, []) in
525 let (_,l) = ser_code acc l in
526 let l =
527 if Buffer.length b = 0 then l else
528 let string = !cons#string (Buffer.contents b) in
529 `string string :: l in
530 let idents = List.map (fun _ -> Ident.next "adhoc") l in
531 let code_elts =
532 List.map2
533 (fun ident e ->
534 match e with
535 | `string e
536 | `expr e -> Q.NewVal (label, [ident, e]))
537 idents l in
538 let tystring = Q.TypeConst Q.TyString in
539 let ty_bp = Q.TypeArrow ([tystring], tystring) in
540 let rev_list =
541 List.concat_map2
542 (fun e ident ->
543 let gen_ident () = !cons#ident ident tystring in
544 let r =
545 match e with
546 | `string _ -> []
547 | `expr _ ->
548 let bp = !cons#bypass Opacapi.Opabsl.BslClientCode.serialize_string_length ty_bp in
549 [!cons#apply bp [gen_ident ()]] in
550 gen_ident () :: r
551 ) l idents in
552 #<If:JS_SERIALIZE$contains "overhead">
553 let r = ref 0 in
554 let count =
555 List.fold_left
556 (fun count -> function
557 | `expr _ -> count
558 | `string (Q.Const (_, Q.String string)) ->
559 for i = 0 to String.length string - 1 do
560 if string.[i] < '\005' then incr r
561 done;
562 count + String.length string
563 | `string _ -> assert false
564 ) 0 l in
565 Printf.printf "length: %d, overhead: %d, %.2f%%\n%!" count !r (100. *. float !r /. float count);
566 #<End>;
567 code_elts, !cons#record ["adhoc", !cons#list (List.rev rev_list); "package_", !cons#string (ObjectFiles.get_current_package_name ())]
568 end
569
570 (** {6 Nodes} *)
571 (**
572 We can extend this interface, if we need more precise js ast at runtime.
573 Invariant: in the returned t, there are no 2 successives lexem verbatim.
574 *)
575
576 let ident string =
577 let string = !cons#string string in
578 !cons#record [JsAstLabel.ident, string]
579
580 let key string =
581 let string = !cons#string string in
582 !cons#record [JsAstLabel.key, string]
583
584 let key_ident key ident =
585 let key = !cons#string key in
586 let ident = !cons#string ident in
587 !cons#record [
588 JsAstLabel.key, key ;
589 JsAstLabel.ident, ident ;
590 ]
591
592 let verbatim string =
593 let string = !cons#string string in
594 !cons#record [JsAstLabel.verbatim, string]
595
596 let qml qml =
597 !cons#record [JsAstLabel.verbatim, qml]
598
599 let mini_expr = function
600 | S.Verbatim s -> verbatim s
601 | S.Ident s -> ident s
602 | S.Expr e -> qml e
603 | S.SetDistant _
604 | S.TypeDef _
605 | S.TypeUse _
606 | S.RpcUse _
607 | S.RpcDef _ -> assert false (* TODO if needed *)
608
609 let declaration string =
610 let string = !cons#string string in
611 !cons#record [JsAstLabel.declaration, string]
612
613 (*
614 Possibly optimized in the future.
615 Returns a list of declarations, and the expression.
616 *)
617 let code_elt elt =
618 let ident =
619 match elt.S.ident with
620 | S.KI_key k -> key k
621 | S.KI_ident i -> ident i
622 | S.KI_key_ident (k, i) -> key_ident k i
623 in
624 let root =
625 let value = !cons#bool elt.S.root in
626 let bypass = QCons.bypass Opacapi.Opabsl.BslReference.create in
627 let apply = QCons.apply bypass [value] in
628 apply
629 in
630 let content =
631 let content = elt.S.content in
632 QCons.directive `llarray (List.map mini_expr content) []
633 in
634 let code_elt =
635 !cons#record [
636 JsAstLabel.ident, ident ;
637 JsAstLabel.root, root ;
638 JsAstLabel.content, content ;
639 ]
640 in
641 let id = Ident.next "js_code_elt" in
642 let decl = Q.NewVal (label, [ id, code_elt ]) in
643 let decls = [ decl ] in
644 let code_elt = QCons.ident id in
645 decls, code_elt
646
647 let code code =
648 let fold_map rev_decls elt =
649 let decls, elt = code_elt elt in
650 let rev_decls = List.rev_append decls rev_decls in
651 rev_decls, elt
652 in
653 let rev_decls, code = List.fold_left_map fold_map [] code in
654 List.rev rev_decls, code
655
656 (*
657 The dependencies of the generated code is hard to predict,
658 because of Hole and DynamicExpr contained in it.
659 We use this function for computing the set of dependencies.
660 *)
661 let get_deps acc e =
662 QmlAstWalk.Expr.fold
663 (fun acc e ->
664 match e with
665 | Q.Ident (_,i) -> IdentSet.add i acc
666 | _ -> acc
667 )
668 acc
669 e
670
671 let insert_code ~kind ( js_code : JsSerializer.jsast_code ) ( server_code : QmlAst.code ) =
672 let () =
673 #<If:JS_SERIALIZE>
674 let outputer oc js_code =
675 let fmt = Format.formatter_of_out_channel oc in
676 JsSerializer.pp_code fmt js_code
677 in
678 let _ = PassTracker.file ~filename:"js_serialize" outputer js_code in
679 ()
680 #<End>
681 in
682 let register_js_file_ident = OpaMapToIdent.val_ Opacapi.Client_code.register_js_code in
683 let register_js_file = QCons.ident register_js_file_ident in
684 let insert =
685 match kind with
686 | `adhoc ->
687 (* the order in code_elts doesn't matter *)
688 let code_elts, e = AdHocSerialize.ser_code js_code in
689 let register_call = !cons#apply register_js_file [ e ] in
690 List.rev (Q.NewVal (label, [ Ident.next "js_code", register_call ]) :: code_elts)
691 | `ast ->
692 let (!!) x = OpaMapToIdent.val_ x in
693 let decls, qml_elts = code js_code in
694 if false (* TODO: inspect CPS rewriter, and bypass skipping *)
695 then (
696 (*
697 Add a sequence of call to register.
698 Not possible currently because of a unskipped list,
699 and then LambdaLifting which consume all the ram.
700 *)
701 let register_js_ident = !!Opacapi.Client_code.register_js_code_elt in
702 let register_js_elt = QCons.ident register_js_ident in
703 let foldr js_code_elt acc =
704 let id = Ident.next "_" in
705 let register_call = !cons#apply register_js_elt [js_code_elt] in
706 !cons#letin id register_call acc
707 in
708 let void = !cons#cheap_void in
709 let register_all = List.fold_right foldr qml_elts void in
710 let register_elt =
711 Q.NewVal (label, [ Ident.next "_", register_all ]) in
712 let insert = decls @ [ register_elt ] in
713 insert
714 )
715 else (
716 let js_code = QCons.directive `llarray qml_elts [] in
717 let js_code = !cons#record ["ast", js_code] in
718 let register_call = !cons#apply register_js_file [ js_code ] in
719 let register_elt =
720 Q.NewVal (label, [ Ident.next "_", register_call ])
721 in
722 let insert = decls @ [ register_elt ] in
723 insert
724 ) in
725 let deps = QmlAstWalk.CodeExpr.fold get_deps IdentSet.empty insert in
726 QmlAstUtils.Code.insert ~deps ~insert server_code
727 end
Something went wrong with that request. Please try again.