Skip to content
This repository
tag: v1698
Fetching contributors…

Cannot retrieve contributors at this time

file 728 lines (647 sloc) 24.828 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF mli *)

(* depends *)
module Format = Base.Format
module List = Base.List
module String = Base.String

(* alias *)
module QCons = QmlAstCons.UntypedExpr

(* shorthands *)
module Q = QmlAst

(* refactoring in progress *)

(* -- *)

let debug fmt =
  OManager.printf ("@{<cyan>[JsSerialize]@}@ @[<2>"^^fmt^^"@]@.")

module JsIdent =
struct
  module Hashtbl = Base.Hashtbl

  let table = ( Hashtbl.create 16 : (string, QmlAst.ident * QmlAst.code_elt) Hashtbl.t )

  let resolve cident =
    let string = JsPrint.string_of_ident (JsCons.Ident.ident cident) in
    match Hashtbl.find_opt table string with
    | Some ident ->
        (*
An opa toplevel identifier, previously generated by the lines below.
*)
        fst ident
    | None ->
      let ident = Ident.next string in
      let () =
        let bypass = QCons.bypass Opacapi.Opabsl.BslJsIdent.define_rename in
        let apply = QCons.apply bypass [QCons.directive (`tagged_string (string, Q.Client_closure_use)) [] []] in
        let code_elt = Q.NewVal(Annot.nolabel "Serializer.JsIdent.resolve", [ident, apply]) in
        Hashtbl.add table string (ident, code_elt)
      in
      ident

  let get_toplevel_declarations () =
    let fold _name (_, code_elt) acc = code_elt :: acc in
    let res = Hashtbl.fold fold table [] in
    Hashtbl.clear table ;
    res

  let is_toplevel_declaration ident =
    Return.set_checkpoint (
      fun label ->
        Hashtbl.iter (
          fun _ (ident', _) ->
            if Ident.equal ident ident' then Return.return label true
        ) table ;
        false
    )
end


module JsSerializer =
struct
  (* shorthand *)
  module J = JsAst

  (*
cf package stdlib.js

The following ast is the exact replication of the runtime opa ast.
We use this structure for generating the runtime ast, before serializing it.
*)

  type jsast_ident = string

  type jsast_mini_expr =
    | Verbatim of string
    | Ident of jsast_ident
    | Expr of QmlAst.expr
    | SetDistant of jsast_ident list
    | TypeUse of string
    | TypeDef of string
    | RpcUse of string
    | RpcDef of string

  type jsast_key_ident =
    | KI_key of string
    | KI_ident of jsast_ident
    | KI_key_ident of string * jsast_ident

  type jsast_code_elt = {
    ident : jsast_key_ident ;
    definition : [ `Rpc of string | `Type of string | `Nothing ];
    root : bool ;
    content : jsast_mini_expr list ;
  }

  type jsast_code = jsast_code_elt list

  (*
A printer, just for debugging
*)

  let pp_mini_expr fmt = function
    | Verbatim s -> Format.fprintf fmt "{verbatim:%S}" s
    | Ident s -> Format.fprintf fmt "{ident:%S}" s
    | Expr e -> Format.fprintf fmt "{expr:%a}" QmlPrint.pp#expr e
    | SetDistant idents -> Format.fprintf fmt "{set_distant : [%a]}" (Format.pp_list ",@ " Format.pp_print_string) idents
    | TypeUse s -> Format.fprintf fmt "{TypeUse: %s}" s
    | TypeDef s -> Format.fprintf fmt "{TypeDef: %s}" s
    | RpcUse s -> Format.fprintf fmt "{RpcUse: %s}" s
    | RpcDef s -> Format.fprintf fmt "{RpcDef: %s}" s

  let pp_key_ident fmt = function
    | KI_key s -> Format.fprintf fmt "{key:%S}" s
    | KI_ident s -> Format.fprintf fmt "{ident:%S}" s
    | KI_key_ident (key, ident) -> Format.fprintf fmt "{key:%S ident:%S}" key ident

  let pp_definition fmt = function
    | `Rpc s -> Format.fprintf fmt "`Rpc %s" s
    | `Type s -> Format.fprintf fmt "`Type %s" s
    | `Nothing -> Format.fprintf fmt "`Nothing"

  let pp_code_elt fmt elt =
    Format.fprintf fmt (
      "@[<2>{@\nident: %a ;@\nroot: %a@\ndefinition: %a@\n@[<2>content: %a@]@]@\n}"
    )
      pp_key_ident elt.ident
      Format.pp_print_bool elt.root
      pp_definition elt.definition
      (Format.pp_list ",@ " pp_mini_expr) elt.content

  let pp_code fmt code =
    let i = ref 0 in
    let pp_code_elt fmt elt =
      Format.fprintf fmt "elt %d@\n" !i ;
      incr(i) ;
      pp_code_elt fmt elt
    in
    Format.pp_list "@\n" pp_code_elt fmt code

  module X =
  struct
    type lexem = jsast_mini_expr
    type t = lexem list
    let append t lexem = lexem :: t
    let empty = []
      (* *)
    let ident s = Ident s
    let verbatim s = Verbatim s
    let qml e = Expr e
    let serialized = function
      | JsAstRuntime.SetDistant idents -> [SetDistant (List.map JsPrint.string_of_ident idents)]
      | JsAstRuntime.TaggedString (string, kind) ->
          (* escaping the string now allows us not to escape it at runtime
* same escaping as in pass_GenerateServerAst *)
          let string = JsPrint.escape_string string in
          (match kind with
           | Q.Type_use -> [TypeUse string]
           | Q.Type_def -> [TypeDef string]
           | Q.Rpc_use -> [RpcUse string]
           | Q.Rpc_def -> [RpcDef string]
           | Q.Client_closure_use -> assert false)
  end

  module S = JsPrint.Make ( X )

  (*
Function used to tag toplevel applications.
*)
  let pure_funs = ref IdentSet.empty (* FIXME: dirty -> should propagate an env instead *)

  (*
<!> BEWARE, if a new expr case appear in the ast, and potentially executed,
we may have to change the exists for itering statements inside expressions.
Currently for this particulary check (side effects), we should not enter inside
statements because statements in expression are in function definition only,
which are statements not executed.
*)
  let is_register_expr expr =
    JsWalk.OnlyExpr.exists (function
    | J.Je_runtime (_, JsAstRuntime.TaggedString (_, (QmlAst.Rpc_def | QmlAst.Type_def)) ) -> true
    | _ -> false) expr


  let is_register_element elt =
    JsWalk.OnlyStatement.exists (function
      | J.Js_var (_, _, Some e)
      | J.Js_return (_, Some e)
      | J.Js_expr (_, e) -> is_register_expr e
      | _ -> false
    ) elt

  let is_pure = function
    | J.ExprIdent ident -> IdentSet.mem ident !pure_funs
    | _ -> false

  let add_pure_funs = function
    | J.ExprIdent ident -> pure_funs := IdentSet.add ident !pure_funs
    | _ -> ()

  let is_in_local_vars local_vars = function
   | J.Je_ident(_,J.ExprIdent ident) -> IdentSet.mem ident local_vars
   | J.Je_ident(_,J.Native( `local, str) )-> IdentSet.mem (Ident.source str) local_vars
   | _ -> false

  let add_local_vars local_vars = function
    | J.ExprIdent ident -> IdentSet.add ident local_vars
    | J.Native( `local, str) -> IdentSet.add (Ident.source str) local_vars
    | _ -> local_vars

  exception Return_true

  (* side_effect comment :
if the side effect of an operator, changes a local variable there is no external (function) side-effect
since assignment op are widely used by the code generator to implement perfectly pure local environment
we need to handle this *)
  let rec is_side_effect_expr ~local_vars expr =
    JsWalk.OnlyExpr.exists (function
    | J.Je_unop (_, unop, e) when JsAst.is_side_effect_unop unop ->
      is_side_effect_expr ~local_vars e || not(is_in_local_vars local_vars e)

    | J.Je_binop (_, binop, e1, e2) when JsAst.is_side_effect_binop binop ->
      is_side_effect_expr ~local_vars e1 || is_side_effect_expr ~local_vars e1
      || not(is_in_local_vars local_vars e2)

    | J.Je_call (_, f, args, pure) ->
      let side_effect_fun = match f with
        | J.Je_ident (_, ident) when not pure -> not (is_pure ident)
        (* applied anonymous function <=> block of code,
e.g. created by the code generator, to split big datastruture,
or toplevel val with local environment *)
        | J.Je_function (_, _, _, body) -> is_side_effect ~local_vars body
        | _ -> not pure
      in side_effect_fun || List.exists (is_side_effect_expr ~local_vars) args

    | J.Je_runtime (_, e) -> (
      match e with
      | JsAstRuntime.SetDistant _ -> true
      | JsAstRuntime.TaggedString _ -> false
    )

    | _ -> false
    ) expr

  (* TODO, block statement in non toplevel mode *)
  and is_side_effect_stmt ~toplevel ~local_vars stmt =
    (* the problem with statement is that when you have {var x = 1; var y = 2}
* then in the ast, you do not say that it defines x
* (you can't even say it, you have only one definition for per code element in the ast)
* so these blocks look like they are never used, and get cleaned
* that's why toplevel statement having local_vars are considered as root (see snd_ ) *)
    let snd_ = if toplevel
      then fun (local_vars,b) -> not(IdentSet.is_empty local_vars) || b
      else snd
    in
    let se_opt_expr e = Option.default_map false (is_side_effect_expr ~local_vars) e in
    let se_stmt stmt = snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt) in
    let se_opt_stmt stmt = Option.default_map false se_stmt stmt in
    match stmt with
        | J.Js_var (_, ident, expr) -> (
          let _ = match expr with
            | Some(J.Je_function (_, _, _, body)) when not(is_side_effect ~local_vars body) -> add_pure_funs ident;
            | _ -> ()
          in
          add_local_vars local_vars ident, (match expr with
          | Some(expr) -> is_side_effect_expr ~local_vars expr
          | None -> false)
        )

        | J.Js_function (_, ident, _, body) ->
          if not(is_side_effect body) then add_pure_funs ident;
          add_local_vars local_vars ident,false

        | J.Js_return (_, Some e)
        | J.Js_expr (_, e) ->
          local_vars,is_side_effect_expr ~local_vars e

        (* this case aren't supposed to happen at toplevel, however they can appear
* when looking at the body of a function *)
        | J.Js_return (_, None)
        | J.Js_break _
        | J.Js_continue _ ->
            local_vars,false

        | J.Js_comment _ ->
            (*
We want to keep all toplevel comments in debug mode, so we considerate them as root,
the minimifier will removes comments anyway if the server is not in debug js.
*)
            local_vars, toplevel

        | J.Js_switch(_, e, cases, default) ->
          let se_case (e,stmt) = se_stmt stmt
                              || is_side_effect_expr ~local_vars e in
          local_vars,
          se_opt_stmt default
          || is_side_effect_expr ~local_vars e
          || List.exists se_case cases

        | J.Js_if(_, e, then_, opt_else) ->
          local_vars,
          is_side_effect_expr ~local_vars e
          || snd_ (is_side_effect_stmt ~toplevel ~local_vars then_)
          || se_opt_stmt opt_else

        | J.Js_dowhile(_, stmt, e)
        | J.Js_while(_, e ,stmt)
        | J.Js_with(_, e ,stmt) ->
          local_vars,
          is_side_effect_expr ~local_vars e
          || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)

        | J.Js_for(_, oe1, oe2, oe3, stmt) ->
          local_vars,
          se_opt_expr oe1
          || se_opt_expr oe2
          || se_opt_expr oe3
          || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)


        | J.Js_forin(_, e1, e2, stmt) ->
          local_vars,
          is_side_effect_expr ~local_vars e1
          || is_side_effect_expr ~local_vars e2
          || snd_ (is_side_effect_stmt ~toplevel ~local_vars stmt)

        | J.Js_block(_, stmt_list) -> local_vars, List.exists se_stmt stmt_list

        | J.Js_label _ -> local_vars, false

        (*
The rest is currently not supposed to happens, because they are not elemts
generated by the js back-end, but may in the future be used (parsing and cleaning jsbsl)
*)
        | J.Js_throw _
        | J.Js_trycatch _
          ->
            (* TODO *)
            local_vars,true

  (* side effect on local vars are ignored *)
  and is_side_effect ?(toplevel=false) ?(local_vars=IdentSet.empty) (elt:J.statement list) =
    try
      let (_,bool) = List.fold_left (fun (local_vars,bool) stmt -> if bool then raise Return_true
        else is_side_effect_stmt ~toplevel ~local_vars stmt
      ) (local_vars,false) elt
      in bool
    with Return_true -> true

  let serialize
      ~client_roots
      ?key
      ( elt : JsAst.code_elt ) =
    let ident, exprident =
      let jsident =
        match elt with
        | J.Js_var (_, ident, _)
        | J.Js_function (_, ident, _, _) ->
            ident
        | J.Js_comment (_, _, _) ->
            J.ExprIdent (Ident.next "comment")
        | _ ->
            (*
There: It is about toplevel statement parsed in the bsl.
There is an extra management of unicity keys, so these elements
will not be duplicated thanks to the unicity keys runtime cleaning.
We can put a dummy identifier for these statements.
*)
            J.ExprIdent (Ident.next "toplevel_statement")
      in
      match jsident with
      | J.ExprIdent exprident ->
          JsPrint.string_of_ident jsident, exprident
      | J.Native (_, native) ->
          native, Ident.next native
    in
    let rev_list = S.code_elt elt in
    let definition, content =
      (* reversing the list and looking for typedef and rpcdef at the same time *)
      let rec aux def_kind acc = function
        | [] -> def_kind, acc
        | h :: t ->
            let def_kind =
              match h with
              | TypeDef string -> assert (def_kind = `Nothing); `Type string
              | RpcDef string -> assert (def_kind = `Nothing); `Rpc string
              | TypeUse _
              | RpcUse _
              | SetDistant _
              | Expr _
              | Ident _
              | Verbatim _ -> def_kind in
            aux def_kind (h :: acc) t in
      aux `Nothing [] rev_list in
    (* registering a type name of a rpc doesn't count as a side effect or else you can't clean anything
* the runtime cleaning looks for more detailed dependencies to see if it will be kept or not *)
    let root =
      IdentSet.mem exprident client_roots || (definition = `Nothing && (is_side_effect ~toplevel:true [elt]) && not(is_register_element elt))
    in
    (*
Adding key unicity for registration
*)
    let ident =
      match key with
      | Some key -> KI_key_ident (key, ident)
      | None ->
          match exprident with
          | Ident.FakeSource key -> KI_key_ident (key, ident)
          | Ident.Source _ | Ident.Internal _ -> KI_ident ident
    in
    {
      ident;
      root;
      definition;
      content;
    }
end

module QmlSerializer =
struct

  module S = JsSerializer

  let cons = ref QmlAstCons.untyped_cons

  let label = Annot.nolabel "JsSerializer"

  module JsAstLabel =
  struct
    (* Meta infos, corresponding to the module JsAst of the stdlib *)
    let verbatim = "verbatim"
    let ident = "ident"
    let content = "content"
    let root = "root"

    let declaration = "declaration"
    let key = "key"
  end

  module AdHocSerialize =
  struct
    let ser_int b i =
      (* we need to make sure that the length of an integer is fixed (or predictable at least) *)
      (* big bytes first *)
      for j = 64 / 8 - 1 downto 0 do
        Buffer.add_char b (Char.chr ((i lsr (j*8)) mod 256));
      done
    let ser_string b s =
      ser_int b (String.length s);
      Buffer.add_string b s
    let ser_key_ident b = function
      | S.KI_key key -> Buffer.add_char b '\000'; ser_string b key
      | S.KI_ident ident -> Buffer.add_char b '\001'; ser_string b ident
      | S.KI_key_ident (key,ident) -> Buffer.add_char b '\002'; ser_string b key; ser_string b ident
    let ser_root b = function
      | false -> Buffer.add_char b '\000'
      | true -> Buffer.add_char b '\001'
    let ser_mini_expr ((b,l) as acc) = function
      | S.Verbatim s -> Buffer.add_char b '\000'; ser_string b s; acc
      | S.Ident s -> Buffer.add_char b '\001'; ser_string b s; acc
      | S.Expr e ->
          Buffer.add_char b '\002';
          let string = !cons#string (Buffer.contents b) in
          Buffer.reset b;
          let l = `expr e :: `string string :: l in
          (b,l)
      | S.SetDistant idents ->
          Buffer.add_char b '\003';
          ser_int b (List.length idents);
          List.iter (ser_string b) idents;
          acc
      | S.RpcDef string ->
          Buffer.add_char b '\004';
          ser_string b string;
          acc
      | S.RpcUse string ->
          Buffer.add_char b '\005';
          ser_string b string;
          acc
      | S.TypeDef string ->
          Buffer.add_char b '\006';
          ser_string b string;
          acc
      | S.TypeUse string ->
          Buffer.add_char b '\007';
          ser_string b string;
          acc
    let ser_definition b = function
      | `Nothing -> Buffer.add_char b '\000'
      | `Rpc string -> Buffer.add_char b '\001'; ser_string b string
      | `Type string -> Buffer.add_char b '\002'; ser_string b string
    let ser_content ((b,_) as acc) l =
      ser_int b (List.length l);
      List.fold_left ser_mini_expr acc l
    let ser_code_elt ((b,_) as acc) {S.content; definition; ident; root} =
      let acc = ser_content acc content in
      ser_definition b definition;
      ser_key_ident b ident;
      ser_root b root;
      acc
    let ser_code ((b,_) as acc) l =
      ser_int b (List.length l);
      List.fold_left ser_code_elt acc l
    let ser_code l =
      let b = Buffer.create 20000 in
      let acc = (b, []) in
      let (_,l) = ser_code acc l in
      let l =
        if Buffer.length b = 0 then l else
          let string = !cons#string (Buffer.contents b) in
          `string string :: l in
      let idents = List.map (fun _ -> Ident.next "adhoc") l in
      let code_elts =
        List.map2
          (fun ident e ->
             match e with
             | `string e
             | `expr e -> Q.NewVal (label, [ident, e]))
          idents l in
      let tystring = Q.TypeConst Q.TyString in
      let ty_bp = Q.TypeArrow ([tystring], tystring) in
      let rev_list =
        List.concat_map2
          (fun e ident ->
             let gen_ident () = !cons#ident ident tystring in
             let r =
               match e with
               | `string _ -> []
               | `expr _ ->
                   let bp = !cons#bypass Opacapi.Opabsl.BslClientCode.serialize_string_length ty_bp in
                   [!cons#apply bp [gen_ident ()]] in
             gen_ident () :: r
          ) l idents in
      #<If:JS_SERIALIZE$contains "overhead">
      let r = ref 0 in
      let count =
        List.fold_left
          (fun count -> function
           | `expr _ -> count
           | `string (Q.Const (_, Q.String string)) ->
                 for i = 0 to String.length string - 1 do
                   if string.[i] < '\005' then incr r
                 done;
                 count + String.length string
           | `string _ -> assert false
          ) 0 l in
      Printf.printf "length: %d, overhead: %d, %.2f%%\n%!" count !r (100. *. float !r /. float count);
      #<End>;
      code_elts, !cons#record ["adhoc", !cons#list (List.rev rev_list); "package_", !cons#string (ObjectFiles.get_current_package_name ())]
  end

  (** {6 Nodes} *)
  (**
We can extend this interface, if we need more precise js ast at runtime.
Invariant: in the returned t, there are no 2 successives lexem verbatim.
*)

  let ident string =
    let string = !cons#string string in
    !cons#record [JsAstLabel.ident, string]

  let key string =
    let string = !cons#string string in
    !cons#record [JsAstLabel.key, string]

  let key_ident key ident =
    let key = !cons#string key in
    let ident = !cons#string ident in
    !cons#record [
      JsAstLabel.key, key ;
      JsAstLabel.ident, ident ;
    ]

  let verbatim string =
    let string = !cons#string string in
    !cons#record [JsAstLabel.verbatim, string]

  let qml qml =
    !cons#record [JsAstLabel.verbatim, qml]

  let mini_expr = function
    | S.Verbatim s -> verbatim s
    | S.Ident s -> ident s
    | S.Expr e -> qml e
    | S.SetDistant _
    | S.TypeDef _
    | S.TypeUse _
    | S.RpcUse _
    | S.RpcDef _ -> assert false (* TODO if needed *)

  let declaration string =
    let string = !cons#string string in
    !cons#record [JsAstLabel.declaration, string]

  (*
Possibly optimized in the future.
Returns a list of declarations, and the expression.
*)
  let code_elt elt =
    let ident =
      match elt.S.ident with
      | S.KI_key k -> key k
      | S.KI_ident i -> ident i
      | S.KI_key_ident (k, i) -> key_ident k i
    in
    let root =
      let value = !cons#bool elt.S.root in
      let bypass = QCons.bypass Opacapi.Opabsl.BslReference.create in
      let apply = QCons.apply bypass [value] in
      apply
    in
    let content =
      let content = elt.S.content in
      QCons.directive `llarray (List.map mini_expr content) []
    in
    let code_elt =
      !cons#record [
        JsAstLabel.ident, ident ;
        JsAstLabel.root, root ;
        JsAstLabel.content, content ;
      ]
    in
    let id = Ident.next "js_code_elt" in
    let decl = Q.NewVal (label, [ id, code_elt ]) in
    let decls = [ decl ] in
    let code_elt = QCons.ident id in
    decls, code_elt

  let code code =
    let fold_map rev_decls elt =
      let decls, elt = code_elt elt in
      let rev_decls = List.rev_append decls rev_decls in
      rev_decls, elt
    in
    let rev_decls, code = List.fold_left_map fold_map [] code in
    List.rev rev_decls, code

  (*
The dependencies of the generated code is hard to predict,
because of Hole and DynamicExpr contained in it.
We use this function for computing the set of dependencies.
*)
  let get_deps acc e =
    QmlAstWalk.Expr.fold
      (fun acc e ->
         match e with
         | Q.Ident (_,i) -> IdentSet.add i acc
         | _ -> acc
      )
      acc
      e

  let insert_code ~kind ( js_code : JsSerializer.jsast_code ) ( server_code : QmlAst.code ) =
    let () =
      #<If:JS_SERIALIZE>
        let outputer oc js_code =
          let fmt = Format.formatter_of_out_channel oc in
          JsSerializer.pp_code fmt js_code
        in
        let _ = PassTracker.file ~filename:"js_serialize" outputer js_code in
        ()
      #<End>
    in
    let register_js_file_ident = OpaMapToIdent.val_ Opacapi.Client_code.register_js_code in
    let register_js_file = QCons.ident register_js_file_ident in
    let insert =
      match kind with
      | `adhoc ->
          (* the order in code_elts doesn't matter *)
          let code_elts, e = AdHocSerialize.ser_code js_code in
          let register_call = !cons#apply register_js_file [ e ] in
          List.rev (Q.NewVal (label, [ Ident.next "js_code", register_call ]) :: code_elts)
      | `ast ->
          let (!!) x = OpaMapToIdent.val_ x in
          let decls, qml_elts = code js_code in
          if false (* TODO: inspect CPS rewriter, and bypass skipping *)
          then (
            (*
Add a sequence of call to register.
Not possible currently because of a unskipped list,
and then LambdaLifting which consume all the ram.
*)
            let register_js_ident = !!Opacapi.Client_code.register_js_code_elt in
            let register_js_elt = QCons.ident register_js_ident in
            let foldr js_code_elt acc =
              let id = Ident.next "_" in
              let register_call = !cons#apply register_js_elt [js_code_elt] in
              !cons#letin id register_call acc
            in
            let void = !cons#cheap_void in
            let register_all = List.fold_right foldr qml_elts void in
            let register_elt =
              Q.NewVal (label, [ Ident.next "_", register_all ]) in
            let insert = decls @ [ register_elt ] in
            insert
          )
          else (
            let js_code = QCons.directive `llarray qml_elts [] in
            let js_code = !cons#record ["ast", js_code] in
            let register_call = !cons#apply register_js_file [ js_code ] in
            let register_elt =
              Q.NewVal (label, [ Ident.next "_", register_call ])
            in
            let insert = decls @ [ register_elt ] in
            insert
          ) in
    let deps = QmlAstWalk.CodeExpr.fold get_deps IdentSet.empty insert in
    QmlAstUtils.Code.insert ~deps ~insert server_code
end
Something went wrong with that request. Please try again.