opa_InsertRemote.ml

(*
    Copyright © 2011, 2012 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/>.
*)

(* depends in base *)
module Format = BaseFormat
module String = BaseString
module List = BaseList

(* refactoring in progress *)
module QmlCons = QmlAstCons

(* alias *)
module TypedExpr = QmlCons.TypedExpr
module TypedPat = QmlCons.TypedPat

(* shorthand *)
module Q = QmlAst

(* -- *)

#<Debugvar:RPC_DEBUG>

(* ******************************************************************)
(* Some utilities functions *****************************************)
(* ******************************************************************)

let full_apply gamma annotmap fun_ tys args =
  let annotmap, e = QmlAstCons.TypedExpr.apply_partial gamma annotmap fun_ (tys @ args) in
  QmlAstCons.TypedExpr.directive annotmap (`full_apply (List.length tys)) [e] []

type publish_directive = [`ajax_publish of [`sync | `async] | `comet_publish ]

type call_directive = [`ajax_call of [`sync | `async] | `comet_call]

type insert_directive = [ `insert_server_value of Ident.t ]

type producted_directive = [ `hybrid_value ]

type all_input_directives = [ publish_directive | call_directive | insert_directive ]

type options = {
  optimize_insert : int;
  optimize_publish : int;
  optimize_call : int;
}

let default_options = {
  optimize_insert = 0;
  optimize_publish = 0;
  optimize_call = 0;
}

let warn_olvl = OManager.warning ~wclass:WarningClass.warn_olevel

let verbose fmt = OManager.printf ("InsertRemote : "^^fmt^^"@.")

let debug_print _f =
  #<If> OManager.printf "InsertRemote : %s@\n" (_f ())
  #<Else> ()
  #<End>
let debug_string str = debug_print (fun _ -> str)

let debug_do _f =
  #<If> _f ()
  #<Else> ()
  #<End>

let debug_code ?(str="") _code =
  ignore(str);
  #<If>
  verbose "DEBUG CODE %s" str;
  debug_do
    (fun _ ->
       List.iter
         (function
            | Q.NewVal (_, l) | Q.NewValRec (_, l) ->
                List.iter (
                  fun (ident, expr) ->
                    if String.is_contained (Option.get DebugVariables.rpc_debug)
                      (Ident.original_name ident)
                    then debug_string
                      (Format.sprintf "%s | %a = %a" str
                         QmlPrint.pp#ident ident
                         QmlPrint.pp#expr expr);
                ) l
            | _ -> ()
         )
         _code
    )
  #<End>

(* Generate optimized code if true *)
(* TODOK1 - Make some other optimization:
   - Do not instantiate at runtime if they aren't type variable
   - ...
*)
let optimized = false

let directive_to_side = function
  | `ajax_publish _ | `comet_call -> `server
  | `comet_publish | `ajax_call _ | `insert_server_value _ -> `client

let call_directive_to_sync = function
  | `ajax_call b -> b
  | _ -> `sync

let publish_directive_to_sync = function
  | `ajax_publish b -> b
  | _ -> `sync

let _call, _stub, _skel, _insert, _reset, get_info =
  #<If>
    let rc = ref 0
    and rs = ref 0
    and rsk = ref 0
    and ri = ref 0
    in
    ((fun _ -> incr rc),
     (fun _ -> incr rs),
     (fun _ -> incr rsk),
     (fun _ -> incr ri),
     (fun _ -> rc := 0; rs := 0; rsk := 0; ri := 0),
     (fun _ -> !rc, !rs, !rsk, !ri)
    )
  #<Else>
    ((fun _ -> ()),
     (fun _ -> ()),
     (fun _ -> ()),
     (fun _ -> ()),
     (fun _ -> ()),
     (fun _ -> -1, -1, -1, -1)
    )
  #<End>

let debug_info _side =
  #<If>
  debug_do
    (fun _ ->
       let c, s, sk, i = get_info () in
       let _side =
         match _side with `server -> "server" | `client -> "client" in
       verbose
         "%i stub(s) generated on %s for %i call(s) resolved. " s _side c;
       verbose
         "%i skeleton(s) generated on %s" sk _side;
       verbose
         "%i insert values resolved on %s" i _side
    )
  #<Else> ()
  #<End>

let check_hybrid_value annotmap e1 e2 =
  let t1 = QmlAnnotMap.find_ty (Q.QAnnot.expr e1) annotmap in
  let t2 = QmlAnnotMap.find_ty (Q.QAnnot.expr e2) annotmap in
  match t1, t2 with
  | Q.TypeArrow ([Q.TypeConst Q.TyString], Q.TypeVar _),
    Q.TypeConst Q.TyString -> true
  | _ -> false

(* ******************************************************************)
(* Retrieve OPA type and functions **********************************)
(* /!\ WARNING : DON'T USE BELOW FUNCTIONS UNTIL YOU READ /!\ *******)
(* /!\ COMMENT of preprocess_types. /!\ *****************************)
(* ******************************************************************)

(** *)
module TyIdent = struct

  let default_pos name = Q.Ident (Annot.nolabel "Opa_InsertRemote", Ident.source name)

  let get name ~side ?(posexpr=default_pos name) annotmap gamma =
    try
      let ident = OpaMapToIdent.val_ ~side name in
      let (ty:QmlAst.ty) = QmlTypes.Scheme.instantiate (QmlTypes.Env.Ident.find ident gamma) in
      ( (* manual check, to verify that explicit instantiation has done its job *)
        match name, ty with
        | "OpaSerialize_serialize", Q.TypeArrow ([_] , Q.TypeArrow([_], Q.TypeConst Q.TyString)) -> ()
        | "OpaSerialize_serialize", _ ->
           OManager.i_error "BAD TYPE FOR %s %a@." name QmlPrint.pp#ty ty;
        | _ -> ()
      );
      TypedExpr.ident annotmap ident ty
    with Not_found ->
      let context = QmlError.Context.annoted_expr annotmap posexpr in
      QmlError.cond_violation QmlAlphaConv.Check.unbound_id context
        "Missing ident"

end


(** This module allows access to some values and types defined on
    module OpaType (written on opa). This expression are well
    typed. For more information see the corresponding module written
    in OPA. *)
module OpaType = struct

  let tsc = ref Pass_ExplicitInstantiation.opatsc_type

  let ty = ref Pass_ExplicitInstantiation.opatype_type

  let row = ref Pass_ExplicitInstantiation.oparow_type

  let col = ref Pass_ExplicitInstantiation.opacol_type

  (** Type of list(OpaType.ty)*)
  let list_of_opaty =
    ref (Q.TypeName ([!ty], Q.TypeIdent.of_string Opacapi.Types.list))

  let tsc_implementation = TyIdent.get Opacapi.OpaTsc.implementation

end

(** This module allows access to some values and types defined on
    module OpaSerialize (written on opa). This expression are well
    typed. For more information see the corresponding module written
    in OPA. *)

module OpaSerialize = struct

  let serialize          = TyIdent.get Opacapi.OpaSerialize.serialize
  let serialize_for_js   = TyIdent.get Opacapi.OpaSerialize.serialize_for_js
  let unserialize        = TyIdent.get Opacapi.OpaSerialize.unserialize
  let unserialize_unsafe = TyIdent.get Opacapi.OpaSerialize.unserialize_unsafe

end

(** This module allows access to some values and types defined on
    module OpaRPC (written on opa). This expression are well
    typed. For more information see the corresponding module written
    in OPA. *)
module OpaRPC = struct

  let request =
    ref (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.OpaRPC.request))

  let taux_extract_values =
    let t =
      QmlAst.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.list) in
    ref (Q.TypeName ([t], Q.TypeIdent.of_string Opacapi.Types.option))

  let serialize      = TyIdent.get Opacapi.OpaRPC.serialize
  let empty_request  = TyIdent.get Opacapi.OpaRPC.empty_request
  let add_var_types  = TyIdent.get Opacapi.OpaRPC.add_var_types
  let add_row_types  = TyIdent.get Opacapi.OpaRPC.add_row_types
  let add_col_types  = TyIdent.get Opacapi.OpaRPC.add_col_types
  let add_args_with_type = TyIdent.get Opacapi.OpaRPC.add_args_with_type
  let unserialize    = TyIdent.get Opacapi.OpaRPC.unserialize
  let extract_types  = TyIdent.get Opacapi.OpaRPC.extract_types
  let extract_values = TyIdent.get Opacapi.OpaRPC.extract_values

  let send_to_other_side ~side ~sync = TyIdent.get
    (if side = `client then
       match sync with
       | `sync -> Opacapi.OpaRPC.client_send_to_server
       | `async -> Opacapi.OpaRPC.client_async_send_to_server
    else
      match sync with
      | `sync -> Opacapi.OpaRPC.server_send_to_client
      | `async -> Opacapi.OpaRPC.server_async_send_to_client) ~side

  let fake_stub  = TyIdent.get Opacapi.OpaRPC.fake_stub
  let error_stub = TyIdent.get Opacapi.OpaRPC.error_stub

  let try_cache ~side = TyIdent.get
    (match side with
     | `client -> Opacapi.OpaRPC.client_try_cache
     | `server -> Opacapi.OpaRPC.server_try_cache) ~side


  module Dispatcher = struct

    let ty_str = Q.TypeConst Q.TyString

    let ty_opt_str =
      ref (Q.TypeName ([ty_str], Q.TypeIdent.of_string Opacapi.Types.option))

    let register ~side = TyIdent.get
      (if side = `client then Opacapi.OpaRPC.client_dispatcher_register
       else Opacapi.OpaRPC.server_dispatcher_register) ~side
  end

end

module Opa2Js =
struct
  let to_string  = TyIdent.get Opacapi.Opa2Js.to_string
end

(** /!\ WARNING /!\

    This function must be used before all functions above. If this
    function is not called before you use above functions,
    QmlFlatCompiler will make an assert failure.

    Note : All types are refences and are updated by this
    function. I'm accord to you it's not very nice, but I don't want
    had a gamma argument on almost above function.
*)
let preprocess_types gamma =
  let process ty = fst (QmlTypes.type_of_type gamma ty) in
  OpaType.tsc := process Pass_ExplicitInstantiation.opatsc_type;
  OpaType.ty := process Pass_ExplicitInstantiation.opatype_type;
  OpaType.list_of_opaty :=
    process (Q.TypeName ([!OpaType.ty], Q.TypeIdent.of_string Opacapi.Types.list));
  OpaRPC.request :=
    process (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.OpaRPC.request));
  OpaRPC.taux_extract_values :=
    (let t = process (Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.list)) in
     process (Q.TypeName ([t], Q.TypeIdent.of_string Opacapi.Types.option)));
  OpaRPC.Dispatcher.ty_opt_str :=
    process (Q.TypeName ([Q.TypeConst Q.TyString], Q.TypeIdent.of_string Opacapi.Types.option))



(* ******************************************************************)
(* Utils functions for generate some expressions ********************)
(* ******************************************************************)

(** Update gamma *)
let update_gamma gamma id ty =
  QmlTypes.Env.Ident.add id (QmlTypes.Scheme.quantify ty) gamma

(** Generate typed variable.
    @param name Name of variable
    @param ty Type of variable
    @return (annotmap, gamma, id, ty, expr) [id] is the ident of
    variable. [ty] is the type of this variable. [expr] is expression
    of this variable.
*)
let generate_var ~annotmap ~gamma name ty =
  let ident = (Ident.next name) in
  let (annotmap, expr) = TypedExpr.ident annotmap ident ty in
  (annotmap, gamma(* update_gamma gamma ident ty *), ident, ty, expr)

(** Generate typed variables. Name of this variables is
    "prefix[1..n]".
    @param Prefix of variables.
    @param Type of variables.
    @param n Number of variables to generate.
    @return (annotmap, gamma, list of ident, list of expression)
*)
let generate_vars ~annotmap ~gamma prefix ty =
  let rec aux annotmap gamma id_l ex_l = function
    | 0 -> annotmap, gamma, id_l, ex_l
    | n -> let annotmap, gamma, id, _, ex =
        generate_var ~annotmap ~gamma (Printf.sprintf "%s%d" prefix n) ty in
      aux annotmap gamma (id::id_l) (ex::ex_l) (n-1) in
  aux annotmap gamma [] []

(** Generate a match on option, like this in OPA syntax :
    match [expr] with
    | {some = [id_expr]} -> [ok_expr]
    | {none} -> ko_expr

    @param expr Expression to match. This expression must be type of
    option.
    @param ident_list A list of ident for bind elements in matched
    list.
    @param ok_expr Expression when match success. Il this expression
    you can use [id_expr].
    @param ko_expr Expression when match failed.
    @return (annotmap, match expression).

*)
let generate_match_some ~annotmap ~gamma expr id_expr ty_id ok_expr ko_expr =
  let annotmap, patvar =
    TypedPat.var annotmap id_expr ty_id in
  TypedPat.match_option annotmap gamma expr patvar ok_expr ko_expr

(** Generate a pattern on list. *)
let generate_pat_list ~annotmap ident_list ty =
  let annotmap, pat_list =
    let annotmap, e1 = TypedPat.emptyrecord annotmap in
    TypedPat.record annotmap ["nil", e1]
  in
  List.fold_right
    (fun ident (annotmap, acc) ->
       let annotmap, pat = TypedPat.var annotmap ident ty in
       TypedPat.record annotmap [
         "hd", pat ;
         "tl", acc ;
       ]
    ) ident_list (annotmap, pat_list)

(** Generate a match on list(option), like this in OPA syntax :
    match [expr] with
    | {some = [ident_list]} -> [ok_expr]
    | _ -> [ko_expr]

    @param expr Expression to match. This expression must be type of
    option(list).
    @param ident_list A list of ident for bind elements in matched list.
    @param ok_expr Expression when match success. In this expression
    you can use ident of [ident_list].
    @param ko_expr Expression when match failed.
    @return (annotmap, match expression).

*)
let generate_match_some_list ~annotmap expr ident_list ok_expr ko_expr ty_ident =
  let annotmap, pat_list = generate_pat_list ~annotmap ident_list ty_ident in
  let annotmap, pat_some =
    TypedPat.record annotmap ["some", pat_list] in
  let annotmap, any = TypedPat.any annotmap in
  TypedExpr.match_ annotmap expr [(pat_some, ok_expr); (any, ko_expr)]

(**
   Generates the following expression:
   match $expr$ with
   | {field1 = [$ident_list_1$]; field2 = [$ident_list_2$], ...} -> $ok_expr$
   | _ -> $ko_expr$
*)
let generate_match_record_of_list ~annotmap expr ident_list_list ok_expr ko_expr =
  let annotmap, pat_list_list =
    List.fold_left_map
      (fun annotmap (field, ident_list, ty_ident) ->
         let annotmap, l = generate_pat_list ~annotmap ident_list ty_ident in
         annotmap, (field, l)
      ) annotmap ident_list_list in
  let annotmap, pat = TypedPat.record annotmap pat_list_list in
  let annotmap, any = TypedPat.any annotmap in
  TypedExpr.match_ annotmap expr [(pat, ok_expr); (any, ko_expr)]




(* ******************************************************************)
(* Main functions for resolving directives **************************)
(* ******************************************************************)

(** Retrieve a registering string from ident. This string it's the end
    of url where skeleton is published.
    It is NOT related to the closure identifiers
*)
let ident_to_registering renamingmap ident =
  (*try*)
    Ident.to_uniq_string (
        QmlRenamingMap.original_from_new renamingmap ident
    )
  (*with
    Not_found ->
      Printf.printf "Couldn't find original name of %s\n%!" (Ident.to_string ident);
      Ident.to_uniq_string ident*)

(** Check given [expr], and retrieve associated expression, ident, and
    type in explicit map.*)
let check_and_get ?(msg="") ~annotmap ~gamma:_ explicit_map expr =
  let iv expr str =
    invalid_arg
      (Format.sprintf
         "%s %s : unexpected expression => %a"
         msg str QmlPrint.pp#expr expr
      ) in
  match expr with
  | Q.Ident (label,ident) ->
      let o =
        try IdentMap.find ident explicit_map
        with Not_found ->
          OManager.i_error
            "Opa_InsertRemote: cannot find %s in the explicit_map"
            (Ident.to_string ident) in
      begin
        match o with
        | Some (label2, ident, kind) ->
            (* the identifier was rewritten by ei *)
            let expr2 = Q.Ident (label2, ident) in
            #<If>
              if String.is_contained (Option.get DebugVariables.rpc_debug)
                (Ident.original_name ident)
              then
                verbose
                  "@[<v2>Identifier rewritten by ei:@ the one that takes all the type variables:%a@ optimized:%a@]"
                  QmlPrint.pp#ident ident
                  QmlPrint.pp#expr expr
            #<End>;
            (* Get type and scheme of explicit instantiate expression *)
            let ty = QmlAnnotMap.find_ty_label label2 annotmap in
            let tsc = QmlTypes.Scheme.quantify ty in
            (* get nb of ty var *)
            let nb_tyvar,nb_rowvar,nb_colvar = QmlGenericScheme.full_arity tsc in
            (* Get original type and scheme of expression (before exp-inst) *)
            let oty = QmlAstCons.Type.Arrow.drop (nb_tyvar+nb_rowvar+nb_colvar) ty in
            let otsc = QmlTypes.Scheme.quantify oty in
            expr2, ident, ty, tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, kind

        | None ->
            (* the identifier was not rewritten by ei *)
            #<If>
              if String.is_contained (Option.get DebugVariables.rpc_debug)
                (Ident.original_name ident)
              then
                verbose
                  "Identifier not rewritten by ei: %a = %a"
                  QmlPrint.pp#ident ident
                  QmlPrint.pp#expr expr
            #<End>;
            let ty = QmlAnnotMap.find_ty_label label annotmap in
            let tsc = QmlTypes.Scheme.quantify ty in
            expr, ident, ty, tsc, 0, 0, 0, ty, tsc, `one_lambda 0
      end
  | _ -> iv expr "on an non ident expression"

(* ***********)
(* SKELETONS *)
(* ***********)

(** Generate a skeleton from an expression. This function is used
    for resolve [@ajax_publish, @comet_publish].
    @param expr Expression to make a skeleton. This expression must be an
    ident else raise Invalid_argument exception.
    @return A skeleton for given [expr].

    This generate skeleton maybe used both on server and client.

      fun str ->
        match OpaRPC.unserialize str with
        | {some = request} ->
          extracted_types = OpaRPC.extract_type request
          (match extracted_types with
           | {types=[v1; v2; ...]; rows=[r1,r2,...]; cols=[c1,c2,...]} ->
             (match OpaTsc.implementation extracted_types tsc with
              | { TyArrow_params = ts; TyArrow_res = tres } ->
                (match  OpaRPC.extract_value ts /* or [] if not a function type */ request  with
                | { some = [a1; a2; a3; ...] } ->
                  { some = OpaSerialize.serialize tres
                        (sliced_fun v1 v2 ... r1 r2 ... c1 c2 ... a1 a2 a3 ...) }
                | _ -> { none = () })
              | _ -> { none = () })
           | _ -> { none = () })
        | _ -> { none = () }
      : string -> string option

    Generated skeleton is good only if explicit instantiation has already taken place.

    Execution of the generated skeleton:
    1 - Unserialize RPC request represented by argument of the
    skeleton.
    2 - Extract instantiate types include in request (if original type
    scheme have type variable).
    3 - Extract value and check with instantiate type of function.
    4 - Call to the function with type arguments and values (either sync or Scheduler.push)
    5 - If sync, serialize the response.
    5 - If async, send standard reply.

    @param sync True if the call is synchronous, false if it is asynchronous i.e. result doesn't matter
    @param expr The body of the function
*)
let generate_skeleton explicit_map ~annotmap ~stdlib_gamma ~gamma ~side expr =
  (* Check and get *)
  let expr, ident, _ty, _tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, number_of_lambdas =
    check_and_get ~msg:"generate_skeleton" ~annotmap ~gamma  explicit_map expr
  in

  #<If>
    if String.is_contained (Option.get DebugVariables.rpc_debug)
      (Ident.original_name ident)
    then
      verbose
        "SKELETON %a = @\n Type : %a@\n OriginalType : %a@\nExprType : %a@\n"
        QmlPrint.pp#ident ident
        QmlPrint.pp#ty _ty
        QmlPrint.pp#ty oty
        QmlPrint.pp#ty (QmlAnnotMap.find_ty (Q.QAnnot.expr expr) annotmap)
    else ()
  #<Else>()
  #<End>;

  (* Argument of generated skeleton *)
  let annotmap, gamma, ident_arg, ty_arg, expr_arg =
    generate_var ~annotmap ~gamma "str" (Q.TypeConst Q.TyString) in

  (* Some variables of generated skeleton *)
  let annotmap, gamma, ident_req, ty_req, expr_req =
    generate_var ~annotmap ~gamma "request" !OpaRPC.request in

  (* Opa type scheme expression *)
  let annotmap, opatsc =
    Pass_ExplicitInstantiation.tsc_to_opatsc ~val_:OpaMapToIdent.val_ ~side (annotmap, gamma) otsc in

  (* List of ident for types extracted *)
  let annotmap, gamma, ident_ty_list, list_expr_ty =
    generate_vars ~annotmap ~gamma "v" !OpaType.ty nb_tyvar in
  let annotmap, gamma, ident_row_list, list_expr_row =
    generate_vars ~annotmap ~gamma "r" !OpaType.row nb_rowvar in
  let annotmap, gamma, ident_col_list, list_expr_col =
    generate_vars ~annotmap ~gamma "c" !OpaType.col nb_colvar in

  (* Pattern arrow and associated vars *)
  let annotmap, gamma, ident_tres, ty_tres, expr_tres =
    generate_var ~annotmap ~gamma "tres" !OpaType.ty in
  let annotmap, gamma, pat_arrow, n_args, expr_ins_list, is_a_function =
    let rec aux annotmap gamma = function
      | Q.TypeArrow (lt, _res) ->
          let n_args = List.length lt in
          let ts = Ident.next "ts" in
          (* FIXME: give a real type *)
          let ts_type = QmlAstCons.Type.next_var () in
          let annotmap, ts_expr = TypedExpr.ident annotmap ts ts_type in
          let annotmap, pat_ts = TypedPat.var annotmap ts ts_type in
          let annotmap, pat_res = TypedPat.var annotmap ident_tres ty_tres in
          let annotmap, pat =
            TypedPat.record annotmap [
              "TyArrow_params", pat_ts ;
              "TyArrow_res", pat_res ;
            ] in
          annotmap, gamma, pat, n_args, ts_expr, true
      | Q.TypeName (list, tyident) ->
          aux annotmap gamma
            (QmlTypesUtils.Inspect.find_and_specialize gamma tyident list)
      | _ ->
          let n_args = 0 in
          let annotmap, pat_res = TypedPat.var annotmap ident_tres ty_tres in
          let annotmap, ts_expr = TypedExpr.list (annotmap, gamma) [] in
          annotmap, gamma, pat_res, n_args, ts_expr, false in
    aux annotmap gamma oty in

  (* List of ident for values extracted *)
  let ty_ident_val_list = QmlCons.Type.typevar (Q.TypeVar.next ()) in
  let annotmap, gamma, ident_val_list, list_expr_val =
    generate_vars ~annotmap ~gamma "a" ty_ident_val_list n_args in

  (* Call to encapsulated function *)
  let annotmap, fun_call =
    let annotmap, expr =
      TypedExpr.shallow_copy annotmap expr in
    (* NOT SURE: what if the expression already has no arguments? *)
    (*try*)
      if is_a_function then
        let args_ty = list_expr_ty @ list_expr_row @ list_expr_col in
        match number_of_lambdas with
        | `one_lambda env ->
            let env_args, list_expr_val =  List.split_at env list_expr_val in
            full_apply gamma annotmap expr (args_ty @ env_args) list_expr_val
        | `two_lambdas ->
            let annotmap, apply1 = QmlAstCons.TypedExpr.apply gamma annotmap expr args_ty in
            QmlAstCons.TypedExpr.apply gamma annotmap apply1 list_expr_val
      else (
        assert (list_expr_val = []);
        TypedExpr.may_apply gamma annotmap expr (list_expr_ty @ list_expr_row @ list_expr_col)
      )
    (*with e -> Format.printf "FAILURE:@\n%a@." QmlPrint.pp#expr fun_call; raise e*)
  in

  (* Call to serialize function *)
  let annotmap, call_ser = match side with
    | `server -> TypedExpr.opa_tuple_2 (annotmap,gamma) (expr_tres,fun_call)
    | `client ->
        let annotmap, ser = OpaSerialize.serialize ~side annotmap stdlib_gamma in
        full_apply gamma annotmap ser [expr_tres] [fun_call] in

  (* Call to extract_values *)
  let annotmap, call_ext_val =
    let annotmap, ext = OpaRPC.extract_values ~side annotmap stdlib_gamma in
    TypedExpr.apply gamma annotmap ext [expr_req; expr_ins_list] in

  (* Match values *)
  let annotmap, match_values =
    let annotmap, ok_expr = TypedExpr.some annotmap gamma call_ser in
    let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr call_ser) annotmap in
    let annotmap, ko_expr =
      #<If>
        let annotmap, es =
          OpaRPC.error_stub ~side annotmap stdlib_gamma in
        let annotmap, msg =
          TypedExpr.string annotmap "match_values" in
        TypedExpr.apply gamma annotmap es [msg]
      #<Else>
        TypedExpr.none ~ty annotmap gamma
      #<End>
    in
    generate_match_some_list ~annotmap
      call_ext_val ident_val_list ok_expr ko_expr ty_ident_val_list
  in

  let ident_extracted_types = Ident.next "extracted_types" in
  (* FIXME: give a real type *)
  let type_ident_extracted_types = QmlAstCons.Type.next_var () in

  (* Call to instantiate *)
  let annotmap, call_ins =
    let annotmap, ins = OpaType.tsc_implementation ~side annotmap stdlib_gamma in
    let annotmap, expr_ty_list = TypedExpr.ident annotmap ident_extracted_types type_ident_extracted_types in
    TypedExpr.apply gamma annotmap ins [expr_ty_list ;opatsc] in

  (* Match instantiate types *)
  let annotmap, match_types =
    let annotmap, ko_expr =
      #<If>
        let annotmap, es =
          OpaRPC.error_stub ~side annotmap stdlib_gamma in
        let annotmap, msg =
          TypedExpr.string annotmap "instantiate" in
        TypedExpr.apply gamma annotmap es [msg]
      #<Else>
        TypedExpr.none annotmap gamma
      #<End>
    in
    let annotmap, any = TypedPat.any annotmap in
    TypedExpr.match_ annotmap call_ins [(pat_arrow, match_values); (any, ko_expr)]
  in
  (* Call to extract_types *)
  let annotmap, call_ext_ty =
    let annotmap, ext = OpaRPC.extract_types ~side annotmap stdlib_gamma in
    let annotmap, expr_req = TypedExpr.shallow_copy annotmap expr_req in
    TypedExpr.apply gamma annotmap ext [expr_req] in

  (* Match extracted types *)
  let annotmap, match_types =
    let annotmap, ko_expr =
      #<If>
        let annotmap, es =
          OpaRPC.error_stub ~side annotmap stdlib_gamma in
        let annotmap, msg =
          TypedExpr.string annotmap "match_types" in
        TypedExpr.apply gamma annotmap es [msg]
      #<Else>
        TypedExpr.none annotmap gamma
      #<End> in
    let annotmap, extracted_types = TypedExpr.ident annotmap ident_extracted_types type_ident_extracted_types in
    let annotmap, match_ =
      generate_match_record_of_list
        ~annotmap extracted_types [
          "types", ident_ty_list, !OpaType.ty;
          "rows", ident_row_list, !OpaType.row;
          "cols", ident_col_list, !OpaType.col;
        ] match_types ko_expr in
    TypedExpr.letin annotmap [ident_extracted_types, call_ext_ty] match_
  in

  (* Call to unserialize and match it *)
  let annotmap, call_un =
    let annotmap, un = OpaRPC.unserialize ~side annotmap stdlib_gamma in
    TypedExpr.apply gamma annotmap un [expr_arg] in
  let annotmap, match_un =
    let annotmap, ko_expr =
      #<If>
        let annotmap, es =
          OpaRPC.error_stub ~side annotmap stdlib_gamma in
        let annotmap, msg =
          TypedExpr.string annotmap "unserialize" in
        TypedExpr.apply gamma annotmap es [msg]
      #<Else>
        TypedExpr.none annotmap gamma
      #<End>
    in
    generate_match_some ~annotmap ~gamma call_un ident_req ty_req
      match_types ko_expr in

  (* Make the lambda *)
  let annotmap, fun_skeleton =
    TypedExpr.lambda annotmap [ident_arg, ty_arg] match_un in

  (* Make an ident for skeleton *)
  let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr fun_skeleton) annotmap in
  let id = Ident.refresh ~map:(fun s -> "skeleton_"^s) ident in
  let annotmap, iskeleton =
    TypedExpr.ident annotmap id ty in
  annotmap, update_gamma gamma id ty, (iskeleton, fun_skeleton)

(** Register a skeleton as an rpc.
    @param iskeleton The skeleton to be register should be identified
    by this parameter.
    @param oexpr Expression that was used for generate skeleton.
    @param side Side where the skeleton should be register.*)
let register_skeleton ~renamingmap ~annotmap ~stdlib_gamma ~gamma ~side oexpr iskeleton =
  match oexpr with
  | Q.Ident (_, oident) ->
      (* Register skeleton *)
      let annotmap, reg =
        OpaRPC.Dispatcher.register ~side annotmap stdlib_gamma in
      let annotmap, str =
        TypedExpr.tagged_string annotmap (ident_to_registering renamingmap oident) Q.Rpc_def in
      let annotmap, call =
        TypedExpr.apply gamma annotmap reg [str; iskeleton] in
      let ident = Ident.refresh ~map:(fun s -> "register_"^s) oident in
      let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr call) annotmap in
      annotmap, update_gamma gamma ident ty , (ident, call)
  | _ -> assert false (* Inexpected expr *)


(* *******)
(* STUBS *)
(** Generate a stub from an expression. This function is used
    for resolve [@ajax_call, @comet_call].
    @param expr Expression to make a skeleton. This expression must be an
    ident else raise Invalid_argument exception.
    @side Side where the stub will be used.
    @return A stub for given [expr].

    If call is synchronous, generate a stub along the lines of:
      v1, v2, .., r1, r2, ..., c1, c2, ... ->
        fun a1 -> fun a2 -> fun a3 ->
          match OpaTsc.implementation [i1; i2; ...] tsc /*type scheme of the function*/ with
          | { TyArrow_params = [t1; t2; t3; ...]; TyArrow_res = tres } } ->
            send_to_<side>
              "<function_id>"
              (OpaRPC.serialize
                (OpaRPC.add_args_with_type t3 a3
                (OpaRPC.add_args_with_type t2 a2
                (OpaRPC.add_args_with_type t1 a1
                  (OpaRPC.add_var_types i2
                  (OpaRPC.add_var_types i1 OpaRPC.empty_request))))))
            tres
          | _ -> /* Make an error */

    If call is asynchronous, generate a stub along the lines of:
      fun i1 -> fun i2 -> ... ->
        fun a1 -> fun a2 -> fun a3 ->
          match OpaTsc.implementation [i1; i2; ...] tsc /*type scheme of the function*/ with
          | { TyArrow_params = [t1; t2; t3; ...]; TyArrow_res = _ } } ->
            async_send_to_<side>
              "<function_id>"
              (OpaRPC.serialize
                (OpaRPC.add_args t3 a3
                (OpaRPC.add_args t2 a2
                (OpaRPC.add_args t1 a1
                  (OpaRPC.add_var_types i2
                  (OpaRPC.add_var_types i1 OpaRPC.empty_request))))))
          | _ -> /* Make an error */

    Generate stub make :
    1 - Instantiate type scheme
    2 - Let ret as the expected type of value returned
     (Used for check type of returned value)
    3 - Add instantiate type variable of the function to an empty
     request. (Type given at runtime, like exp-inst).
    4 - Add argument to request
    5 - Send serialized request, and check returned value with ret.
*)
let generate_stub explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync expr =
  (* Check and get *)
  let _expr, ident, _ty, _tsc, nb_tyvar, nb_rowvar, nb_colvar, oty, otsc, _number_of_lambdas =
    check_and_get ~msg:"generate_stub" ~annotmap ~gamma explicit_map expr in

  #<If>
    if String.is_contained (Option.get DebugVariables.rpc_debug)
      (Ident.original_name ident)
    then
      verbose
        "%a = %a"
        QmlPrint.pp#ident ident
        QmlPrint.pp#ty _ty
    else ()
  #<Else>()
  #<End>;

  (* Create type args *)
  let annotmap, gamma, ident_ty_list, expr_ty_list =
    generate_vars ~annotmap ~gamma "v" !OpaType.ty nb_tyvar in
  let annotmap, gamma, ident_row_list, expr_row_list =
    generate_vars ~annotmap ~gamma "r" !OpaType.row nb_rowvar in
  let annotmap, gamma, ident_col_list, expr_col_list =
    generate_vars ~annotmap ~gamma "c" !OpaType.col nb_colvar in

  (* Get type of standard args *)
  let is_lambda, typeof_args, typeof_res =
    let rec aux = function
      | Q.TypeArrow (args, res) -> true, args, res
      | Q.TypeName (list, tyident) ->
          aux (QmlTypesUtils.Inspect.find_and_specialize gamma tyident list)
      | r -> false, [], r in
    aux oty
  in
  (* Create standard args [a*] and variable for pattern arrow [t*] *)
  let annotmap, gamma,
    id_ty_std_list, expr_std_list,
    id_ins_list, ex_ins_list =
    let rec aux i annotmap gamma = function
      | [] -> annotmap, gamma, [], [], [], []
      | ty::tys ->
          let annotmap, gamma, id_l, ex_l, id_l2, ex_l2 =
            aux (i+1) annotmap gamma tys in
          let annotmap, gamma, id, _, ex =
            generate_var ~annotmap ~gamma (Printf.sprintf "a%d" i) ty in
          let annotmap, gamma, id2, _, ex2 =
            generate_var ~annotmap ~gamma
              (Printf.sprintf "t%d" i) !OpaType.ty
          in
          annotmap, gamma,
          (id,ty)::id_l, ex::ex_l, id2::id_l2, ex2::ex_l2 in
    aux 0 annotmap gamma typeof_args
  in

  (* Some variables of generated stub *)
  let annotmap, gamma, id_tres, ty_tres, ex_tres =
    generate_var ~annotmap ~gamma "tres" !OpaType.ty in

  (* Type scheme in opa *)
  let annotmap, opatsc =
    Pass_ExplicitInstantiation.tsc_to_opatsc ~val_:OpaMapToIdent.val_ ~side (annotmap, gamma) otsc in

  (* Pattern arrow *)
  let annotmap, pat_arrow =
    let annotmap, pat_res =
      TypedPat.var annotmap id_tres ty_tres in
    if not is_lambda then annotmap, pat_res
    else
      let annotmap, pat_list =
        generate_pat_list ~annotmap id_ins_list !OpaType.ty in
      let annotmap, pat =
        TypedPat.record annotmap [
          "TyArrow_params", pat_list ;
          "TyArrow_res", pat_res ;
        ] in
      annotmap, pat
  in

  (* Create request *)
  let annotmap, req =
    let annotmap, req = OpaRPC.empty_request ~side annotmap stdlib_gamma in
    let annotmap, req =
      let add_variables annotmap req ident variables =
        List.fold_left
          (fun (annotmap, req) t ->
             let annotmap, add_ty = ident ~side ?posexpr:None annotmap stdlib_gamma in
             TypedExpr.apply gamma annotmap add_ty [t;req])
          (annotmap, req) variables in
      (* Insert type var *)
      let annotmap, req = add_variables annotmap req OpaRPC.add_var_types expr_ty_list in
      let annotmap, req = add_variables annotmap req OpaRPC.add_row_types expr_row_list in
      let annotmap, req = add_variables annotmap req OpaRPC.add_col_types expr_col_list in
      annotmap, req in
    (* Insert std args *)
    List.fold_left2
      (fun (annotmap, req) t a ->
         let annotmap, add_args_with_type = OpaRPC.add_args_with_type ~side annotmap stdlib_gamma in
         TypedExpr.apply gamma annotmap add_args_with_type [t; a; req])
      (annotmap, req) ex_ins_list expr_std_list in

  (* String identifier of function *)
  let annotmap, f_id =
    TypedExpr.tagged_string annotmap (ident_to_registering renamingmap ident) Q.Rpc_use in

  (* Match send_to *)
  let annotmap, send_to =
    let annotmap, send =
      OpaRPC.send_to_other_side ~side ~sync annotmap stdlib_gamma in
    TypedExpr.apply gamma annotmap send [f_id; req; ex_tres]
  in

  (* Match instantiate *)
  let annotmap, call_ins =
    let annotmap, ins = OpaType.tsc_implementation ~side annotmap stdlib_gamma in
    let copy_list annotmap expr_ty_list =
      let annotmap, expr_ty_list =
        TypedExpr.shallow_copys annotmap expr_ty_list in
      TypedExpr.list (annotmap, gamma) expr_ty_list in
    let annotmap, ex_list_ty = copy_list annotmap expr_ty_list in
    let annotmap, ex_list_row = copy_list annotmap expr_row_list in
    let annotmap, ex_list_col = copy_list annotmap expr_col_list in
    let annotmap, instantiation = TypedExpr.record annotmap [
      "types", ex_list_ty;
      "rows", ex_list_row;
      "cols", ex_list_col;
    ] in
    TypedExpr.apply gamma annotmap ins [instantiation; opatsc]
  in
  let annotmap, match_instantiate =
    let annotmap, err_stub = OpaRPC.error_stub ~side annotmap stdlib_gamma in
    let annotmap, f_id = TypedExpr.shallow_copy annotmap f_id in
    let annotmap, ko_expr = TypedExpr.apply gamma annotmap err_stub [f_id] in
    let annotmap, any = TypedPat.any annotmap in
    TypedExpr.match_ty annotmap call_ins [(pat_arrow, send_to); (any, ko_expr)] typeof_res
  in

  (* Create lambda *)
  (*
    <!> In case ei has introduce some extra arguments, we must currently generate 2 lambdas.
    but if no argument are added, we should not create an empty lambda.
    That what the function may_lambda does.

    <!> Quentin (Fri Sep 10 17:07:29 CEST 2010) what about the first lambda ?
  *)
  let annotmap, stub =
    if not is_lambda then
      TypedExpr.may_lambda annotmap
        (List.map (fun id -> id, !OpaType.ty) ident_ty_list @
         List.map (fun id -> id, !OpaType.row) ident_row_list @
         List.map (fun id -> id, !OpaType.col) ident_col_list) match_instantiate
    else
      let annotmap, lambda =
        TypedExpr.lambda annotmap
          (List.map (fun id -> id, !OpaType.ty) ident_ty_list @
             List.map (fun id -> id, !OpaType.row) ident_row_list @
             List.map (fun id -> id, !OpaType.col) ident_col_list @
             id_ty_std_list)
          match_instantiate in
      TypedExpr.directive annotmap (`lifted_lambda (nb_tyvar + nb_colvar + nb_rowvar, [])) [lambda] [] in

  (* Expand if necessary to have a lambda with 0 args *)
  let expand = (not is_lambda) && nb_tyvar = 0 && nb_colvar = 0 && nb_rowvar = 0 in
  let annotmap, stub =
    if expand then
      (* Cache checking for non-functional stubs *)
      let annotmap, stub = TypedExpr.lambda annotmap [] stub in
      let annotmap, try_cache = OpaRPC.try_cache ~side annotmap stdlib_gamma in
      let annotmap, try_cache =
        TypedExpr.apply gamma annotmap try_cache [f_id; stub] in
      TypedExpr.lambda annotmap [] try_cache
    else annotmap, stub in
  annotmap, gamma, stub, expand

(** Create a fresh ident for a stub. *)
let make_stub_ident ~annotmap ~gamma ident stub =
  let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr stub) annotmap in
  let id = Ident.refresh ~map:(fun s -> "stub_"^s) ident in
  id, ty, update_gamma gamma id ty, id



(* ******************************************************************)
(* AST transformations **********************************************)
(* ******************************************************************)

(** A generic walker on code for resolving slicer directives :

    - When it meet a [publish_directive] (on top level), it discards
    this directive and calls the [publish_resolver]. This
    [publish_resolver] should be generate couples of (ident,
    expressions). This generated ident, expressions are inserted on
    top level by this walker.

    - When it meet a [call_directive], it replace this directive by
    expression returned by [call_resolver]. [call_resolver] should be
    return also couples of (ident, expressions). This generated ident,
    expressions are inserted on top level by this walker.
*)
let resolving_slicer_directive ~annotmap ~stdlib_gamma ~gamma ~side code
    publish_resolver generate_stub_from_publish call_resolver insert_resolver =

  (* Perform on (ident * expr) list*)
  let vlist_walker =
    List.fold_left
      (fun ((annotmap, gamma, nvals, other_nvals, vlist) as acc) (id, expr) ->
         match expr with
         | Q.Directive (_, (#publish_directive as d), [expr], _) ->
             assert(side = directive_to_side d);
             let sync = publish_directive_to_sync d in
             let annotmap, gamma, nrvals =
               publish_resolver ~annotmap ~stdlib_gamma ~gamma ~side expr in
             let annotmap, gamma, other_nrvals =
               if ObjectFiles.Arg.is_fully_separated () then
                 generate_stub_from_publish ~annotmap ~stdlib_gamma ~gamma ~side ~sync expr
               else
                 annotmap, gamma, [] in
             (annotmap, gamma, nrvals@nvals, other_nrvals@other_nvals, vlist)
         | Q.Directive (_, #publish_directive, _, _) ->
             (* Make a condition for that *)
             QmlError.i_serror None (QmlError.Context.annoted_expr annotmap expr)
               "Malformed directive";
             acc

         | Q.Directive (label, (#insert_directive as d), _, _) ->
             assert(side = directive_to_side d);
             let ty = QmlAnnotMap.find_ty (Annot.annot label) annotmap in
             let annotmap, expr =
               insert_resolver ~annotmap ~stdlib_gamma ~gamma ~side d id ty in
             annotmap, gamma,  nvals, other_nvals, (id, expr)::vlist

         (*| Directive(#call_directive, _, _) ->
             (* Make a condition for that *)
             QmlError.i_serror None (QmlError.Context.annoted_expr annotmap expr)
               "Call directive at toplevel: %a" QmlPrint.pp#expr expr;
             (annotmap, gamma, nvals, vlist)*)

         | _ ->
             let walker (annotmap, gamma, nvals) expr =
               match expr with (*TODO: If [async], don't use [call_resolver]*)
               | Q.Directive (_, (#call_directive as d), [expr], _) ->
                   assert(side = directive_to_side d);
                   let annotmap, gamma, nrvals, expr =
                     call_resolver ~annotmap ~stdlib_gamma ~gamma ~side ~sync:(call_directive_to_sync d) expr in
                   (annotmap, gamma, nrvals@nvals), expr
               | Q.Directive (_, (#call_directive), _, _) ->
                   (* Make a condition for that *)
                   QmlError.i_serror None (QmlError.Context.annoted_expr annotmap expr)
                     "Malformed directive";
                     (annotmap, gamma, nvals), expr
               | _ -> (annotmap, gamma, nvals), expr
             in
             let (annotmap, gamma, nvals), expr =
               QmlAstWalk.Expr.foldmap_down
                 walker (annotmap, gamma, nvals) expr
             in annotmap, gamma, nvals, other_nvals, ((id, expr)::vlist)
      )
  in

  (* Walk on code *)
  let annotmap, gamma, nvals, other_nvals, code =
    List.fold_left
      (fun (annotmap, gamma, nvals, other_nvals, toplvl) -> function
         | Q.NewValRec (label, vlist) ->
             let annotmap, gamma, nvals, other_nvals, vlist =
               vlist_walker (annotmap, gamma, nvals, other_nvals, []) (List.rev vlist)
             in annotmap, gamma, nvals, other_nvals, (Q.NewValRec (label, vlist)::toplvl)

         | Q.NewVal (label, vlist) ->
             let annotmap, gamma, nvals, other_nvals, vlist =
               vlist_walker (annotmap, gamma, nvals, other_nvals, []) (List.rev vlist)
             in annotmap, gamma, nvals, other_nvals, (Q.NewVal (label, vlist)::toplvl)
         | elt -> annotmap, gamma, nvals, other_nvals, (elt::toplvl)
      ) (annotmap, gamma, [], [], []) code
  in
  let label () = Annot.nolabel "resolving_slicer_directive" in
  annotmap, gamma, List.rev (Q.NewVal (label (), nvals)::code), [Q.NewVal (label (), other_nvals)]

(** Call resolver : [call_resolver]. This call resolver can be work on
    both side if it's reseted by [reset_call_resolver] beetwen two
    walk.  This resolver generate a stub if necessary for given expr.
    You can fold the generated stubs with [fold_stubs folder acc]. Folder
    must be a function like that [folder original_ident stub_ident acc].
*)
let generate_stub_from_publish,
    call_resolver, (* Main resolver *)
  clear_stubs, add_previous_stub, (* Initialize resolver *)
  fold_current_stubs, get_current_stubs (* Get resolver environnment *) =
  (* Stubs generated on the current package *)
  let current_stubs = Hashtbl.create 1024 in
  (* Stubs generated on previous package *)
  let prev_stubs = Hashtbl.create 1024 in
  (* Some functions for manipulates both hastbl *)
  let stub_mem x = Hashtbl.mem current_stubs x || Hashtbl.mem prev_stubs x in
  let stub_find x =
    try Hashtbl.find current_stubs x with Not_found ->
      Hashtbl.find prev_stubs x in
  let stub_add k x = Hashtbl.add current_stubs k x in
  let generate_stub_if_needed explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync =
    function
    | Q.Ident (_, ident) as expr ->
        if stub_mem ident then
          annotmap, gamma, []
        else (
          _stub ();
          let annotmap, gamma, stub, expanded =
            generate_stub explicit_map renamingmap
              ~annotmap ~stdlib_gamma ~gamma ~side ~sync expr in
          let sident, sty, gamma, id =
            make_stub_ident ~annotmap ~gamma ident stub in
          stub_add ident (sident, sty, expanded);
          annotmap, gamma, [(id, stub)]
        )
    | _ -> assert false in
  let generate_stub_from_publish explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync =
    generate_stub_if_needed explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side:(OpaMapToIdent.other_side side) ~sync in
  generate_stub_from_publish,
  (* call_resolver*)
  (fun explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync ->
     function
       | Q.Ident (_, ident) as expr ->
           (*add_rpc_use_declaration side (ident_to_registering renamingmap ident);*)
           _call ();
           let annotmap, gamma, newvals =
             generate_stub_if_needed explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side ~sync expr in
           let sident, sty, expanded = stub_find ident in
           let annotmap, expr = TypedExpr.ident annotmap sident sty in
           let annotmap, expr =
             if expanded then TypedExpr.apply gamma annotmap expr []
             else annotmap, expr in
           annotmap, gamma, newvals, expr
       | _ -> assert false (* Inexpected expression *)
  ),
  (fun _ -> Hashtbl.clear current_stubs; Hashtbl.clear prev_stubs),
  (fun k x -> Hashtbl.add prev_stubs k x),
  (fun folder ->
     Hashtbl.fold
       (fun ident (sident, _, _) acc -> folder ident sident acc)
       current_stubs
  ),
  (fun _ -> current_stubs)

(** Publish resolver. This resolver can be work on both side. This
    resolver generate a skeleton and an expression for register this
    skeleton. *)
let make_publish_resolver genskel explicit_map renamingmap ~annotmap ~stdlib_gamma ~gamma ~side expr =
  try
    _skel ();
    let annotmap, gamma, (iskeleton, skeleton) =
      genskel explicit_map ~annotmap ~stdlib_gamma ~gamma ~side expr in
    let annotmap, gamma, cpl_register =
      register_skeleton ~renamingmap ~annotmap ~stdlib_gamma ~gamma ~side expr iskeleton in
    (match iskeleton with
     | Q.Ident (_, iskeleton) ->
         annotmap, gamma, [(iskeleton, skeleton); cpl_register]
     | _ -> assert false)
  with Invalid_argument str ->
    (* TODOK1 - FIXME - This case should be remove... *)
    QmlError.i_error None (QmlError.Context.expr expr)
      "Error on skeleton generation (discard it) : %a@\n%s"
      QmlPrint.pp#expr expr str

(** Select an publish resolver from a level of optimization *)
let select_publish_resolver _n =
  make_publish_resolver generate_skeleton


(** Insert resolver. Produce a directive for qmljs. Its goal is to
    insert server value on client code. *)
let insert_resolver0_unoptimized ~annotmap ~stdlib_gamma ~gamma ~side (`insert_server_value ident) _id ty =
  assert(side = `client);
  _insert ();
  let add_missing_string_arg annotmap func args =
    let string_arg = Ident.next "expand_missing_string_arg" in
    let ty_string = Q.TypeConst Q.TyString in
    let annotmap, string_arg_expr = TypedExpr.ident annotmap string_arg ty_string in
    let annotmap, call = TypedExpr.apply gamma annotmap func (string_arg_expr::args) in
    let annotmap, lamb = TypedExpr.lambda annotmap [string_arg, ty_string] call in
    annotmap,lamb
  in
  (* Make client expr *)
  let annotmap, uns = OpaSerialize.unserialize_unsafe ~side annotmap stdlib_gamma in
  let annotmap, ty_expr_server =
    Pass_ExplicitInstantiation.ty_to_opaty ~val_:OpaMapToIdent.val_ ~side:`server annotmap gamma ty in
  let annotmap, ty_expr_client =
    Pass_ExplicitInstantiation.ty_to_opaty ~val_:OpaMapToIdent.val_ ~side:`client annotmap gamma ty in
  let annotmap, client_expr =
    (* TODO insert an explicit partial call here *)
    add_missing_string_arg annotmap uns [ty_expr_client]
  in

  (* Make server expr *)
  let annotmap, ser_for_js =
    OpaSerialize.serialize_for_js ~side:(OpaMapToIdent.other_side side) annotmap stdlib_gamma in
  let annotmap, serv_expr =
    let annotmap, expr = TypedExpr.ident annotmap ident ty in
    full_apply gamma annotmap ser_for_js [ty_expr_server] [expr]
    (*let annotmap, partial = TypedExpr.apply gamma annotmap ser_for_js [ty_expr_server] in
    TypedExpr.apply gamma annotmap partial [expr]*)
  in
  (* Make directive *)
  let annot = Annot.next () in
  let annotmap = QmlAnnotMap.add_ty annot (Q.TypeConst Q.TyString) annotmap in
  assert(check_hybrid_value annotmap client_expr serv_expr);
  let label = Annot.make_label annot (Q.Pos.expr client_expr) in
  let e = Q.Directive (label, `hybrid_value, [client_expr ; serv_expr], []) in
  annotmap, e

(** Second version for insert resolver. More optimized but not stable
    : back-end and implementation dependent (see opa2js.opa). *)
let insert_resolver1_optimized ~annotmap ~stdlib_gamma ~gamma ~side (`insert_server_value ident) id ty =
  assert(side = `client);
  _insert ();
  (* Make server expr *)
  let annotmap, ty_expr_server =
    Pass_ExplicitInstantiation.ty_to_opaty ~val_:OpaMapToIdent.val_ ~side:`server annotmap gamma ty in
  let annotmap, ser =
    Opa2Js.to_string ~side:(OpaMapToIdent.other_side side) annotmap stdlib_gamma in
  let annotmap, serv_expr =
    let annotmap, toplevel_var = TypedExpr.string annotmap (JsPrint.string_of_ident (JsAst.ExprIdent id)) in
    let annotmap, expr = TypedExpr.ident annotmap ident ty in
    TypedExpr.apply_partial gamma annotmap ser [ty_expr_server; toplevel_var; expr]
  in

  (* Make directive *)
  let annot = Annot.next () in
  let annotmap = QmlAnnotMap.add_ty annot (Q.TypeConst Q.TyString) annotmap in
  (* here creating an hybrid value without client expression
   * (instead of creating it with Magic.id)
   * it generates better code and doesn't break cleaning *)
  (* assert(check_hybrid_value annotmap dir); *)
  let label = Annot.make_label annot (Q.Pos.expr serv_expr) in
  let e = Q.Directive (label, `hybrid_value, [serv_expr], []) in
  annotmap, e

(** Select an insert resolver from a level of optimization *)
let rec select_insert_resolver = function
  | 0 -> insert_resolver0_unoptimized
  | 1 -> insert_resolver1_optimized
  | x when x < 0 ->
      warn_olvl "Optimization level can't be negative";
      select_insert_resolver 0
  | _ ->
      warn_olvl "Optimization level for insert is limited by 1";
      select_insert_resolver 1


(* ******************************************************************)
(* Pass *************************************************************)
(* ******************************************************************)

module S =
struct
  (* Original ident * stub ident, stub type, expanded stub *)
  type t = (QmlAst.ident, QmlAst.ident * QmlAst.ty * bool) Hashtbl.t

  let pass = "ResolveRemoteCalls"
  let pp f _ = Format.pp_print_string f "<dummy>"
end

module R = ObjectFiles.Make(S)

let error_stdlib _gamma annotmap code1 code2 e =
  let package_name = ObjectFiles.get_current_package_name () in
  let aux =
    QmlAstWalk.CodeExpr.iter
      (QmlAstWalk.Expr.iter
         (function
         | Q.Directive (_, #all_input_directives, _, _) as posexpr ->
           let context = QmlError.Context.annoted_expr annotmap posexpr in
           QmlError.serror context "Slicer directive inside %s" package_name
         | _ -> ()))
  in
  aux code1 ; aux code2 ;
  OManager.i_error (
    "InsertRemote raised %s@\n"^^
      "Possible explanation: OpaRPC is not yet defined in %s@\n"^^
      "  And yet you are defining code that need to be sliced@\n"^^
      "  (ie there is one of client only, server only,@\n"^^
      "   alias or insert_server_value in slicer.dump)@\n"^^
      "  If this is the case, some possible problems are:@\n"^^
      "  - you cannot use @@server nor @@client@\n"^^
      "    if you need the code to be client only, then it cannot be defined in this package@\n"^^
      "    if you need the code to be server only, then use @@server_private and publish it later if needed@\n"^^
      "  - you cannot define client only bypasses@\n"^^
      "  - you cannot do side effects at toplevel, except in a declaration that is @@server_private@\n"^^
      "    Note that the slicer cannot guess when bypasses do side effects when applied.@\n"^^
      "    You can update $OPAGENERAL/libqmlcompil/qmlEffects.ml so that the slicer knows when a bypass@\n"^^
      "    application can be computed safely and independently on both sides@."
  ) (Printexc.to_string e) package_name


let prelude_core  ~gamma =
  clear_stubs ();
  preprocess_types gamma;
  R.iter_with_name
    (fun pack previous_stubs ->
      Hashtbl.iter
        (fun k (s, t, e) ->
          let t = QmlRefresh.refresh_typevars_from_ty pack t in
          add_previous_stub k (s, t,e))
        previous_stubs)

let prelude ~gamma ~annotmap code1 code2 =
  try prelude_core  ~gamma
  with e when String.is_prefix "stdlib." (ObjectFiles.get_current_package_name ())
      -> error_stdlib gamma annotmap code1 code2 e

let postlude orig_renaming1 orig_renaming2 =
  (* Finalize pass *)
  (* Update renaming map *)
  let renaming1,renaming2 =
    fold_current_stubs
      (fun org stu (renaming1,renaming2) ->
         match QmlRenamingMap.original_from_new_opt orig_renaming2 org with
         | None ->
             (match QmlRenamingMap.original_from_new_opt orig_renaming1 org with
             | None ->
                 OManager.printf "error when updating renaming map on %a" QmlPrint.pp#ident org
                   (*
                     Mathieu Wed Mar  9 11:53:45 CET 2011
                     FIXME: This is a wild warning
                   *)
                 ;
                 QmlRenamingMap.add renaming1 org stu, QmlRenamingMap.add renaming2 org stu (* no idea what to do *)
             | Some org ->
                 renaming1, QmlRenamingMap.add renaming2 org stu)
         | Some org ->
             assert (Option.is_none (QmlRenamingMap.original_from_new_opt orig_renaming1 org));
             QmlRenamingMap.add renaming1 org stu, renaming2
      ) (orig_renaming1,orig_renaming2) in
  (* Save object files *)
  R.save (get_current_stubs ());
  renaming1, renaming2

(** Perform on an AST (code).
    @param expmap1 Explicit map of the computed side
    @param expmap2 Explicit map of the other side
    @param renaming1 The renaming map of the computed side
    @param renaming2 The renaming map of the other side
*)

let perform_on_code ?(options=default_options) side ~annotmap ~stdlib_gamma ~gamma
    expmap1 expmap2
    renaming1 renaming2
    code =
  #<If>
  debug_print
    (fun _ -> Printf.sprintf "BEGIN on %s code"
       (match side with | `server -> "server" | `client -> "client"));
  #<End>;


  (* Initialize pass *)
  _reset ();


  (* Transform code *)
  let annotmap, gamma, code, other_code =
    resolving_slicer_directive ~annotmap ~stdlib_gamma ~gamma ~side code
      ((select_publish_resolver options.optimize_publish) expmap1 renaming1)
      (generate_stub_from_publish expmap1 renaming1)
      (call_resolver expmap2 renaming2)
      (select_insert_resolver options.optimize_insert) in

  (* let annotmap, gamma, code = *)
  (*   #<If:RPC_ALT_SKELETON> *)
  (*     let (gamma,annotmap),new_code = skel_apply annotmap gamma in *)
  (*     annotmap, gamma, new_code @ code *)
  (*   #<Else> *)
  (*     annotmap, gamma, code *)
  (*   #<End> in *)

  #<If>
  (* Debug printing *)
  debug_info side;
  (* debug_code code; *)
  #<End>;

  annotmap, gamma, code, other_code

let need_to_process_code code1 code2 =
  let need_to_process_one_code code =
    QmlAstWalk.CodeExpr.exists
      (QmlAstWalk.Expr.exists
         (function
          | Q.Directive (_, #all_input_directives, _, _) -> true
          | _ -> false))
      code in
  let need = need_to_process_one_code code1 || need_to_process_one_code code2 in
  if not need then (
    R.save (Hashtbl.create 0); (* we need to create the object files, even if we have nothing to save *)
  );
  need

(* See mli *)
let perform_on_server_code ?options = perform_on_code ?options `server


(* See mli *)
let perform_on_client_code ?options = perform_on_code ?options `client

(* see mli *)
module S2 =
struct
  type t = Pass_ExplicitInstantiation.published_map * QmlAst.annotmap
  let pass = "opa_InsertRemote_explicit_map"
  let pp f _ = Format.pp_print_string f "<dummy>"
end
module R2 =
struct
  include ObjectFiles.MakeClientServer(S2)
  let save ~side annotmap map =
    let small_annotmap =
      IdentMap.fold
        (fun _ o acc ->
           match o with
           | None -> acc
           | Some (label, _, _) ->
               let annot = Annot.annot label in
               let annot_content = QmlAnnotMap.find annot annotmap in
               QmlAnnotMap.add annot annot_content acc)
        map QmlAnnotMap.empty in
    save ~side (map, small_annotmap)

  let load ~side annotmap map =
    fold_with_name ~side
      (fun package (annotmap,map) (old_map,old_annotmap) ->
         let old_annotmap = QmlRefresh.refresh_annotmap package old_annotmap in
         let annotmap, old_map =
           IdentMap.fold_map
             (fun _ o annotmap ->
                match o with
                | None ->
                    annotmap, None
                | Some (label, ident, number_of_lambdas) ->
                    let annot = Annot.annot label in
                    let annot_content = QmlAnnotMap.find annot old_annotmap in
                    let annot = Annot.next () in
                    let pos = Annot.pos label in
                    let annotmap = QmlAnnotMap.add annot annot_content annotmap in
                    let label = Annot.make_label annot pos in
                    annotmap, Some (label, ident, number_of_lambdas))
             old_map annotmap in
         (annotmap, IdentMap.safe_merge map old_map))
      (annotmap,map)
end