Source file jsoo_conv.ml

open Ppxlib
open Ast_builder.Default
open Common

let esome ~loc e =
  pexp_construct ~loc (mkl ~loc @@ Lident "Some") (Some (e ~loc))
let psome ~loc e =
  ppat_construct ~loc (mkl ~loc @@ Lident "Some") (Some (e ~loc))

let pexp_fun p e =
  pexp_fun ~loc:e.pexp_loc Nolabel None p e

let i_project ~loc n i =
  pexp_fun (
    ppat_tuple ~loc (List.init n (fun j -> if j = i then pvar ~loc "x" else ppat_any ~loc)))
    (evar ~loc "x")

let pexp_fun0 v e =
  pexp_fun (pvar ~loc:e.pexp_loc v) e

let id_fun ?typ loc =
  let pat = match typ with
    | None -> pvar ~loc "x"
    | Some t -> ppat_constraint ~loc (pvar ~loc "x") (
        ptyp_constr ~loc (llid ~loc t) []) in
  pexp_fun pat (evar ~loc "x")

let rec pexp_fun_rec expr = function
  | [] -> expr
  | h :: t -> pexp_fun0 h (pexp_fun_rec expr t)

let pexp_funs ~loc n expr =
  let l = List.init n (fun _ -> new_var ()) in
  let rec aux = function
    | [] -> expr (List.map (evar ~loc) l)
    | h :: t -> pexp_fun0 h (aux t) in
  aux l

let rec eapplys_expr l var = match l with
  | [] -> var
  | h :: t ->
    let loc = var.pexp_loc in
    eapply ~loc h [eapplys_expr t var]

let rec eapplys l var = match l with
  | [] -> var
  | h :: t ->
    let loc = var.pexp_loc in
    eapply ~loc (evar ~loc h) [eapplys t var]

let pexp_fun1 ~loc f =
  let var = new_var () in
  pexp_fun0 var (f @@ evar ~loc var)

let prop_get ~loc obj prop =
  eapply ~loc (evar ~loc "(##.)") [ obj ; evar ~loc prop ]

let method_call ~loc obj meth args =
  eapply ~loc (evar ~loc "(##)") [ obj ; pexp_apply ~loc (evar ~loc meth) args ]

let prop_try ~loc obj prop f =
    eapply ~loc (evar ~loc "(##?)") [ obj ; eapply ~loc (evar ~loc prop) [ f ] ]

let prop_set ~loc obj prop value =
  eapply ~loc (evar ~loc "(:=)") [eapply ~loc (evar ~loc "(##.)") [ obj ; evar ~loc prop ]; value ]

let literal_object ~loc self_id fields =
  let mutable_flag = function
    | `Readonly | `Case -> Immutable
    | _ -> Mutable in
  let aux = function
    | Ppx_js.Val (name, kind, ov_flag, e) ->
      [ pcf_val ~loc (name, mutable_flag kind, Cfk_concrete (ov_flag, e)) ]
    | Ppx_js.Cases (names, es) ->
      List.map2 (fun n e ->
          pcf_val ~loc (n, Immutable, Cfk_concrete (Fresh, e))) names es
    | Ppx_js.Meth (name, pv_flag, ov_flag, e, _) ->
      [ pcf_method ~loc (name, pv_flag, Cfk_concrete (ov_flag, e)) ] in
  let self = ppat_tuple ~loc [ self_id; pbool ~loc true ] in
  pexp_extension ~loc (
    {txt="js"; loc},
    PStr [
      pstr_eval ~loc (
        pexp_object ~loc (
          class_structure ~self ~fields:(List.flatten @@ List.map aux fields)
        )
      ) []
    ]
  )

let param_name p =
  let loc = p.ptyp_loc in
  match p.ptyp_desc with
  | Ptyp_var x -> x
  | _ -> Location.raise_errorf ~loc "parameter is not a variable"

let rec add_params_fun expr = function
  | [] -> expr
  | ({ptyp_desc = Ptyp_var x; ptyp_loc=loc; _}, _) :: t ->
    pexp_fun (ppat_tuple ~loc [
        pvar ~loc ("_" ^ x ^ _to_jsoo); pvar ~loc ("_" ^ x ^ _of_jsoo)])
      (add_params_fun expr t)
  | _ :: t -> add_params_fun expr t

let mconv ?(acc=[]) eto eof = {e_of=eof; e_to=eto; e_acc = acc}

let conv_map f l =
  let _, l_to, l_of, l_acc = List.fold_left (fun (i, acc_to, acc_of, acc) x ->
      let cv = f i x in
      i+1, cv.e_to :: acc_to, cv.e_of :: acc_of, cv.e_acc :: acc) (0, [],[],[]) l in
  List.rev l_to, List.rev l_of, List.flatten (List.rev l_acc)

let ml_type_to_conv ~loc ?(opt="optdef") ?(number=false) ?modules s l = match s, l with
  | "unit", [] -> mconv (pexp_fun0 "_" (eunit ~loc)) (pexp_fun0 "_" (eunit ~loc))
  | "int", [] | "Int.t", [] ->
    if number then
      mconv
        (pexp_fun1 ~loc (eapplys [js_mod "number_of_float"; "float_of_int"]))
        (pexp_fun1 ~loc (eapplys ["int_of_float"; js_mod "float_of_number"]))
    else
      mconv (id_fun ~typ:"int" loc) (id_fun ~typ:"int" loc)
  | "int32", [] | "Int32.t", [] ->
    if number then
      mconv
        (pexp_fun1 ~loc (eapplys [js_mod "number_of_float"; "Int32.to_float"]))
        (pexp_fun1 ~loc (eapplys ["Int32.of_float"; js_mod "float_of_number"]))
    else
      mconv (evar ~loc "Int32.to_int") (evar ~loc "Int32.of_int")
  | "int64", [] | "Int64.t", [] ->
    mconv
      (evar ~loc (js_mod "BigInt.of_int64"))
      (pexp_fun1 ~loc (eapplys ["Int64.of_string"; js_mod "BigInt.to_string"]))
  | "nativeint", [] | "Nativeint.t", [] ->
    mconv (evar ~loc (js_mod "BigInt.of_native"))
      (pexp_fun1 ~loc (eapplys ["Nativeint.of_string"; js_mod "BigInt.to_string"]))
  | "Z.t", [] ->
    mconv
      (pexp_fun1 ~loc (eapplys [js_mod "BigInt.of_string"; "Z.to_string"]))
      (pexp_fun1 ~loc (eapplys ["Z.of_string"; js_mod "BigInt.to_string"]))
  | "float", [] | "Float.t", [] ->
    mconv (evar ~loc (js_mod "number_of_float")) (evar ~loc (js_mod "float_of_number"))
  | "string", [] | "String.t", [] ->
    mconv (evar ~loc (js_mod "string")) (evar ~loc (js_mod "to_string"))
  | "bool", [] | "Bool.t", [] ->
    mconv (evar ~loc (js_mod "bool")) (evar ~loc (js_mod "to_bool"))
  | "char", [] | "Char.t", [] ->
    mconv
      (pexp_fun1 ~loc (eapplys_expr [
           evar ~loc (js_mod "string");
           eapply ~loc (evar ~loc "String.make") [eint ~loc 0]]))
      (pexp_fun1 ~loc (fun var -> eapply ~loc (eapplys ["String.get"; js_mod "to_string"] var) [
           eint ~loc 0]))
  | "bytes", [] | "Bytes.t", [] ->
    mconv
      (pexp_fun1 ~loc (eapplys [jsoo_mod "Typed_array.Bigstring.to_arrayBuffer"; "Bigstring.of_bytes"]))
      (pexp_fun1 ~loc (eapplys ["Bigstring.to_bytes"; jsoo_mod "Typed_array.Bigstring.of_arrayBuffer"]))
  | "array", [_]  | "Array.t", [_] ->
    mconv
      (pexp_fun1 ~loc (eapplys [js_mod "of_arrayf"; "fst"]))
      (pexp_fun1 ~loc (eapplys [js_mod "to_arrayf"; "snd"]))
  | "list", [_] | "List.t", [_] ->
    mconv
      (pexp_fun1 ~loc (eapplys [js_mod "of_listf"; "fst"]))
      (pexp_fun1 ~loc (eapplys [js_mod "to_listf"; "snd"]))
  | "option", [_] | "Option.t", [_] ->
    mconv
      (pexp_fun1 ~loc (eapplys [js_mod opt; "fst"]))
      (pexp_fun1 ~loc (eapplys [js_mod ("to_" ^ opt); "snd"]))
  | "Unsafe.any", [] | "any", [] | "Js.Unsafe.any", [] | "Js_of_ocaml.Js.Unsafe.any", []
    -> mconv (id_fun ~typ:(js_mod "Unsafe.any") loc) (id_fun ~typ:(js_mod "Unsafe.any") loc)
  | s, [] when s = js_mod "Unsafe.any"
    -> mconv (id_fun ~typ:(js_mod "Unsafe.any") loc) (id_fun ~typ:(js_mod "Unsafe.any") loc)
  | "ref", [_] ->
    mconv
      (pexp_fun (ppat_tuple ~loc [pvar ~loc "f"; ppat_any ~loc])
         (pexp_fun0 "x" (eapply ~loc (evar ~loc "f") [
              pexp_field ~loc (evar ~loc "x") (llid ~loc "contents")])))
      (pexp_fun (ppat_tuple ~loc [ppat_any ~loc; pvar ~loc "f"])
         (pexp_fun0 "x" (eapply ~loc (evar ~loc "ref") [
              eapply ~loc (evar ~loc "f") [(evar ~loc "x")] ])))
  | "Lazy.t", [_] ->
    mconv
      (pexp_fun (ppat_tuple ~loc [pvar ~loc "f"; ppat_any ~loc])
         (pexp_fun0 "x" (eapply ~loc (evar ~loc "f") [
              eapply ~loc (evar ~loc "Lazy.force") [(evar ~loc "x")] ])))
      (pexp_fun (ppat_tuple ~loc [ppat_any ~loc; pvar ~loc "f"])
         (pexp_fun0 "x" (eapply ~loc (evar ~loc "Lazy.from_val") [
              eapply ~loc (evar ~loc "f") [(evar ~loc "x")] ])))
  | "Bigstring.t", [] | "Cstruct.buffer", [] ->
    mconv
      (evar ~loc (jsoo_mod "Typed_array.Bigstring.to_arrayBuffer"))
      (evar ~loc (jsoo_mod "Typed_array.Bigstring.of_arrayBuffer"))
  | "Hex.t", [] ->
    mconv
      (pexp_fun1 ~loc (eapplys [js_mod "string"; "Hex.show"]))
      (pexp_fun0 "s" (pexp_variant ~loc "Hex" (Some (
           eapply ~loc (evar ~loc (js_mod "to_string")) [ evar ~loc "s" ]))))
  | _ ->
    let to_jsoo, of_jsoo = jsoo_name_to ?modules s, jsoo_name_of ?modules s in
    mconv (evar ~loc to_jsoo) (evar ~loc of_jsoo)

let arg_array ~loc l = pexp_array ~loc l

let add_expr0 ?modules ~loc ~name (e_to, e_of) =
  let name_to, name_of = jsoo_name_to ?modules name, jsoo_name_of ?modules name in
  let v_to = value_binding ~loc ~pat:(pvar ~loc name_to) ~expr:e_to in
  let v_of = value_binding ~loc ~pat:(pvar ~loc name_of) ~expr:e_of in
  [v_to; v_of], (name_to, name_of)

let acc_expr ?modules ~loc ~name ~params cv =
  let name_to, name_of = jsoo_name_to ?modules name, jsoo_name_of ?modules name in
  let acc = cv.e_acc in
  let cv = mconv
      (add_params_fun cv.e_to params) (add_params_fun cv.e_of params) in
  let acc = acc @ [cv, (name_to, name_of)] in
  let e_to, e_of = match params with
    | [] -> evar ~loc name_to, evar ~loc name_of
    | _ ->
      let params = List.map (fun c ->
            let s = param_name c in
            pexp_tuple ~loc [evar ~loc ("_" ^ s ^ _to_jsoo); evar ~loc ("_" ^ s ^ _of_jsoo)])
          (Jsoo_type.core_of_param params) in
      eapply ~loc (evar ~loc name_to) params,
      eapply ~loc (evar ~loc name_of) params in
  mconv ~acc e_to e_of

let enum_variant ?(typ=`string) ?camel ?snake l =
  let typs = match typ with `string -> "string" | `int -> "int" in
  let ls, fallback = List.fold_left (fun (acc_l, fallback) rf ->
      let loc = rf.prf_loc in
      match rf.prf_desc with
      | Rtag ({txt; loc}, _, []) ->
        let {fa_key; fa_code; _} = field_attributes ~key:txt ?camel ?snake rf.prf_attributes in
        let e = match fa_code, typ with (Some c, `int) -> eint ~loc c, pint ~loc c | _ -> estring ~loc fa_key, pstring ~loc fa_key in
        (txt, e) :: acc_l, fallback
      | Rtag ({txt; _}, _, [{ptyp_desc = Ptyp_constr ({txt=Lident s; _}, []); _}]) when fallback = None && s = typs ->
        acc_l, Some txt
      | _ -> Location.raise_errorf ~loc "variant case cannot be part of %s enum" typs) ([], None) l in
  List.rev ls, fallback

let enum_constructor ?rm_prefix ?(typ=`string) ?camel ?snake l =
  let typs = match typ with `string -> "string" | `int -> "int" in
  let rm_prefix = match rm_prefix with
    | Some false -> 0
    | _ -> same_prefix @@ List.map (fun pcd -> pcd.pcd_name.txt) l in
  let ls, fallback = List.fold_left (fun (acc_l, fallback) pcd ->
      let loc = pcd.pcd_loc in
      let name_cs = remove_prefix pcd.pcd_name.txt rm_prefix in
      let {fa_key; fa_code; _} = field_attributes ~key:name_cs ?camel ?snake pcd.pcd_attributes in
      let e = match fa_code, typ with (Some c, `int) -> eint ~loc c, pint ~loc c | _ -> estring ~loc fa_key, pstring ~loc fa_key in
      match pcd.pcd_args with
      | Pcstr_tuple [] -> (pcd.pcd_name.txt, e) :: acc_l, fallback
      | Pcstr_tuple [ {ptyp_desc=Ptyp_constr ({txt=Lident s; _}, _); _} ]
        when fallback = None && typs = s ->
        acc_l, Some pcd.pcd_name.txt
      | _ -> Location.raise_errorf ~loc:pcd.pcd_loc "variant case cannot be part of %s enum" typs) ([], None) l in
  List.rev ls, fallback

let enum_expr ~loc ?fallback ?(kind=`Variant) ?(typ=`string) l =
  let ppat_variant, pexp_variant = match kind with
    | `Variant -> ppat_variant ~loc , pexp_variant ~loc
    | `Construct ->
      (fun s p -> ppat_construct ~loc (llid ~loc s) p),
      (fun s e -> pexp_construct ~loc (llid ~loc s) e) in
  let apply_to e =
    match typ with
    | `string -> eapply ~loc (evar ~loc (js_mod "string")) [e]
    | `int -> eapply ~loc (evar ~loc (js_mod "number_of_float")) [ eapply ~loc (evar ~loc "float_of_int") [e] ] in
  let apply_of e =
    match typ with
    | `string -> eapply ~loc (evar ~loc (js_mod "to_string")) [e]
    | `int -> eapply ~loc (evar ~loc "int_of_float") [ eapply ~loc (evar ~loc (js_mod "float_of_number")) [e] ] in
  let e_to = pexp_function ~loc @@
    List.map (fun (ml, js) ->
        case ~guard:None ~lhs:(ppat_variant ml None)
          ~rhs:(apply_to (fst js))) l @ (
      match fallback with
      | None -> []
      | Some ml -> [
          case ~guard:None ~lhs:(ppat_variant ml (Some (pvar ~loc "x")))
            ~rhs:(apply_to (evar ~loc "x")) ]) in
  let e_of = pexp_fun1 ~loc (fun js ->
      pexp_match ~loc (apply_of js) @@
      List.map (fun (ml, js) ->
          case ~guard:None ~lhs:(snd js) ~rhs:(pexp_variant ml None)) l @ [
        match fallback with
        | None ->
          case ~guard:None ~lhs:(ppat_any ~loc)
            ~rhs:(eapply ~loc (evar ~loc "failwith") [ estring ~loc "no case matched" ])
        | Some ml ->
          case ~guard:None ~lhs:(pvar ~loc "x") ~rhs:(pexp_variant ml (Some (evar ~loc "x"))) ]) in
  mconv e_to e_of

type remember_item =
  ([ `RCase of string loc * (expression -> expression)
   | `RVal of string loc * [ `Case | `Readonly | `Readwrite | `Writeonly | `Optdef ] *
              override_flag * (expression -> expression)],
   expression -> expression -> expression) conv0

type remember = (add:value_binding list -> remember_item) list * string list

let remember_table : (string, remember) Hashtbl.t = Hashtbl.create 1024

let remember_fields id fields =
  Hashtbl.add remember_table id fields

let get_remember_fields id = Hashtbl.find_opt remember_table id

module FDMap = Map.Make(String)

let partition_rows l obj =
  List.map (function
      | `v (id, k, b, e) -> Ppx_js.Val (id, k, b, e obj)
      | `c (ids, es) -> Ppx_js.Cases (ids, List.map (fun e -> e obj) es)) @@
  snd @@ List.split @@ FDMap.bindings @@
  List.fold_left (fun acc r -> match r with
      | `RVal (id, k, b, e) ->
        FDMap.add (Ppx_js.unescape id.txt) (`v (id, k, b, e)) acc
      | `RCase (id, e) -> let txt = Ppx_js.unescape id.txt in
        match FDMap.find_opt txt acc with
        | Some (`c (ids, es)) ->
          FDMap.add txt (`c (ids @ [id], es @ [e])) acc
        | _ -> FDMap.add txt (`c ([id], [e])) acc) FDMap.empty l

let inherit_fields :
  (Longident.t, (expression -> Ppx_js.field_desc list) * string list) Hashtbl.t =
  Hashtbl.create 512

let remove_undefined_expr ~loc expr =
  pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc "x") ~expr ] @@
  pexp_let ~loc Nonrecursive [
    value_binding ~loc ~pat:(punit ~loc)
      ~expr:(eapply ~loc (evar ~loc (js_mod "remove_undefined")) [ evar ~loc "x" ]) ] @@
  evar ~loc "x"

let rec expr_of_core ~params ~name ?opt ?meth_callback ?callback
    ?array_tup ?number ?assoc ?conv ?modules ?enum ?camel ?snake ?remove_undefined c =
  let loc = c.ptyp_loc in
  let {ca_opt; ca_ignore; ca_number; ca_array; ca_cb; ca_meth_cb; ca_assoc;
       ca_case; ca_conv; ca_enum; _} =
    core_attributes ?opt ?meth_callback ?callback ?array_tup ?number ?assoc ?conv ?enum c.ptyp_attributes in
  match ca_ignore, ca_conv with
  | true, _ -> mconv (id_fun loc) (id_fun loc)
  | _, Some c -> c
  | _ ->
    match c.ptyp_desc with
    | Ptyp_any -> mconv (id_fun loc) (id_fun loc)
    | Ptyp_var v ->
      mconv (evar ~loc ("_" ^ v ^ "_" ^ to_jsoo)) (evar ~loc ("_" ^ v ^ "_" ^ of_jsoo))
    | Ptyp_constr ({txt; _}, l) ->
      let type_name = Longident.name txt in
      begin match Jsoo_type.assoc_type ?assoc:ca_assoc type_name l with
        | None ->
          let cv = ml_type_to_conv ?modules ~loc ?opt:ca_opt ?number:ca_number type_name l in
          let v, acc = List.split @@ List.map (fun c ->
              let cv = expr_of_core ?modules ?camel ?snake ?remove_undefined ~params ~name c in
              pexp_tuple ~loc [cv.e_to; cv.e_of], cv.e_acc) l in
          mconv ~acc:(List.flatten acc) (eapply ~loc cv.e_to v) (eapply ~loc cv.e_of v)
        | Some c ->
          let cv = expr_of_core ?modules ?camel ?snake ?remove_undefined ~params ~name c in
          mconv ~acc:cv.e_acc
            (eapply ~loc (evar ~loc (js_mod "Table.makef")) [cv.e_to])
            (eapply ~loc (evar ~loc (js_mod "Table.itemsf")) [cv.e_of])
      end
    | Ptyp_arrow (_, c1, c2) ->
      function_expr ?modules ?camel ?snake ~loc ~params ~name
        ?meth_callback:ca_meth_cb ?callback:ca_cb (c1, c2)
    | Ptyp_tuple l ->
      if ca_array = Some true then
        array_tuple_expr ?modules ?camel ?snake ~loc ~params ~name l
      else
        let cv1 = tuple_expr ?modules ?camel ?snake ~loc ~params ~name l in
        let tuple_name = get_tuple_name name in
        acc_expr ?modules ~loc ~name:tuple_name ~params cv1
    | Ptyp_variant (l, _, _) ->
      begin match ca_enum with
        | None ->
          let cv1 = variant_expr ?modules ?camel ?snake ~case:ca_case ~loc ~params ~name l in
          let variant_name = get_variant_name name in
          acc_expr ?modules ~loc ~name:variant_name ~params cv1
        | Some typ ->

          let ls, fallback = enum_variant ?camel ?snake ~typ l in
          enum_expr ~loc ?fallback ~typ ls
      end
    | Ptyp_object (l, _) ->
      object_expr ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l
    | _ -> Location.raise_errorf ~loc "core type not handled (only _, 'a, constr, arrow and tuple)"

and arrows_to_array ~params ~name ?opt ?(meth_start=false) ?(callback_start=false)
    ?modules ?camel ?snake ?remove_undefined c =
  let loc = c.ptyp_loc in
  match c.ptyp_desc with
  | Ptyp_arrow (_a, c1, c2) ->
    let v = Ppx_js.Arg.make1 () in
    let cv = expr_of_core ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined c1 in
    let es_to, es_of, vs_to, vs_of, e_to_end, e_of_end, acc =
      arrows_to_array ~params ~name ?opt ?modules ?camel ?snake c2 in
    begin match meth_start, callback_start, c1 with
      | _, true, {ptyp_desc = Ptyp_constr ({txt; _}, _); _} when Longident.name txt = "unit" ->
        es_to, eapply ~loc cv.e_of [evar ~loc (Ppx_js.Arg.name v)] :: es_of,
        v :: vs_to, v :: vs_of, e_to_end, e_of_end, acc @ cv.e_acc
      | true, _, {ptyp_desc = Ptyp_constr ({txt; _}, _); _} when Longident.name txt = "unit" ->
        es_to, eunit ~loc :: es_of,
        v :: vs_to, vs_of, e_to_end, e_of_end, acc @ cv.e_acc
      | _ ->
        eapply ~loc cv.e_to [evar ~loc (Ppx_js.Arg.name v)] :: es_to,
        eapply ~loc cv.e_of [evar ~loc (Ppx_js.Arg.name v)] :: es_of,
        v :: vs_to, v :: vs_of, e_to_end, e_of_end, acc @ cv.e_acc
    end
  | _ ->
    let cv = expr_of_core ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined c in
    [], [], [], [], cv.e_to, cv.e_of, cv.e_acc

and callback_expr ~loc ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined (c1, c2) =
  let cv1 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c1 in
  let cv2 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c2 in
  let f, x = new_var (), new_var () in
  let e_to = pexp_fun0 f (eapply ~loc (evar ~loc (js_mod "wrap_callback")) [
      pexp_fun0 x (eapply ~loc cv2.e_to [
          eapply ~loc (evar ~loc f) [eapply ~loc cv1.e_of [evar ~loc x]]])
    ]) in
  let es_to, _, vs_to, _, _, e_of, acc =
    arrows_to_array ~params ~name ?opt ~callback_start:true ?modules ?camel ?snake (ptyp_arrow ~loc Nolabel c1 c2) in
  let es_to = List.map (fun v -> eapply ~loc (evar ~loc (js_mod "Unsafe.inject")) [v]) es_to in
  let vs = List.map Ppx_js.Arg.name vs_to in
  let e_of =
    pexp_fun0 f (pexp_fun_rec (eapply ~loc e_of [
        eapply ~loc (evar ~loc (js_mod "Unsafe.fun_call")) [
          evar ~loc f; arg_array ~loc es_to]])
        vs) in
  mconv ~acc:(acc @ cv1.e_acc @ cv2.e_acc) e_to e_of

and meth_callback_expr ~loc ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined (c1, c2) =
  let cv1 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c1 in
  let cv2 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c2 in
  let f, x = new_var (), new_var () in
  let e_to = pexp_fun0 f (eapply ~loc (evar ~loc (js_mod "wrap_meth_callback")) [
      pexp_fun0 x (eapply ~loc cv2.e_to [
          eapply ~loc (evar ~loc f) [eapply ~loc cv1.e_of [evar ~loc x]]])
    ]) in
  let es_to, _, vs_to, _, _, e_of, acc =
    arrows_to_array ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined (ptyp_arrow ~loc Nolabel c1 c2) in
  let es_to = List.map (fun v -> eapply ~loc (evar ~loc (js_mod "Unsafe.inject")) [v]) es_to in
  let vs = List.map Ppx_js.Arg.name vs_to in
  let this_to, es_to = match es_to with [] -> assert false | h :: t -> h, t in
  let e_of =
    pexp_fun0 f (pexp_fun_rec (eapply ~loc e_of [
        eapply ~loc (evar ~loc (js_mod "Unsafe.call")) [
          evar ~loc f; this_to; arg_array ~loc es_to]])
        vs) in
  mconv ~acc:(acc @ cv1.e_acc @ cv2.e_acc) e_to e_of

and function_expr ~loc ~params ~name ?opt ?(meth_callback=false) ?(callback=false)
    ?modules ?camel ?snake ?remove_undefined (c1, c2) =
  if callback then callback_expr ~loc ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined (c1, c2)
  else if meth_callback then meth_callback_expr ~loc ~params ~name ?opt ?modules ?camel ?snake ?remove_undefined (c1, c2)
  else
    let cv1 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c1 in
    let cv2 = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c2 in
    let f, x = new_var (), new_var () in
    mconv ~acc:(cv1.e_acc @ cv2.e_acc)
      (pexp_fun0 f (pexp_fun0 x (eapply ~loc cv2.e_to [
           eapply ~loc (evar ~loc f) [eapply ~loc cv1.e_of [evar ~loc x]]])))
      (pexp_fun0 f (pexp_fun0 x (eapply ~loc cv2.e_of [
           eapply ~loc (evar ~loc f) [eapply ~loc cv1.e_to [evar ~loc x]]])))

and tuple_expr ~loc ~params ~name ?callback ?meth_callback ?number ?assoc ?modules
    ?camel ?snake ?remove_undefined = function
  | [] -> mconv (pexp_fun0 "_" (eunit ~loc)) (pexp_fun0 "_" (eunit ~loc))
  | [h] -> expr_of_core ~params ~name ?callback ?meth_callback ?number ?assoc
             ?modules ?camel ?snake ?remove_undefined h
  | l ->
    let n = List.length l in
    let obj = new_var () in
    let fields_to, fields_of, acc = conv_map (fun i c ->
        let cv = expr_of_core ~params ~name ?modules ?camel ?snake ?remove_undefined c in
        let name_js = "_" ^ string_of_int i in
        mconv ~acc:cv.e_acc
          (Ppx_js.Val (mkl ~loc name_js, `Readonly, Fresh, eapply ~loc cv.e_to [
               eapply ~loc (i_project ~loc n i) [evar ~loc obj] ]))
          (eapply ~loc cv.e_of [prop_get ~loc (evar ~loc obj) name_js]))
        l in
    mconv ~acc
      (pexp_fun0 obj @@ literal_object ~loc (pvar ~loc "_this") fields_to)
      (pexp_fun0 obj @@ pexp_tuple ~loc fields_of)

and array_tuple_expr ~loc ~params ~name ?number ?modules ?camel ?snake ?remove_undefined l =
  let es_to, es_of, acc = conv_map (fun _ c -> expr_of_core ~params ~name ?number ?modules ?camel ?snake ?remove_undefined c) l in
  let e_to =
    let vs = List.init (List.length l) (fun _ -> new_var ()) in
    pexp_fun (ppat_tuple ~loc (List.map (pvar ~loc) vs)) @@
    eapply ~loc (evar ~loc (js_mod "array")) [
      pexp_array ~loc (List.map2 (fun v e_to ->
          eapply ~loc (evar ~loc (js_mod "Unsafe.inject")) [
            eapply ~loc e_to [evar ~loc v]]) vs es_to)] in
  let e_of =
    let a = new_var () in
    pexp_fun (pvar ~loc a) @@
    pexp_let ~loc Nonrecursive [
      value_binding ~loc ~pat:(pvar ~loc a)
        ~expr:(eapply ~loc (evar ~loc (js_mod "to_array")) [evar ~loc a])] @@
    pexp_tuple ~loc (List.mapi (fun i e_of ->
        eapply ~loc e_of [
          eapply ~loc (evar ~loc (js_mod "Unsafe.coerce")) [
            eapply ~loc (evar ~loc "Array.get") [ evar ~loc a; eint ~loc i ] ] ]) es_of) in
  mconv ~acc e_to e_of

and case_expr ?(case_=false) ~loc
    ~name ?name_js
    ~add ?prop ?(kind=`Construct) ?(local=false) ?(singleton=false)
    cv var : remember_item =
  let name_js = match name_js with None -> field_name ~case:case_ name | Some n -> n in
  let econstruct = match kind with
    | `Variant -> pexp_variant ~loc name
    | `Construct -> pexp_construct ~loc (llid ~loc name) in
  let pconstruct = match kind with
    | `Variant -> ppat_variant ~loc name
    | `Construct -> ppat_construct ~loc (llid ~loc name) in
  if not singleton then
    let lhs_to =
      if local then
        ppat_alias ~loc (pconstruct (Option.map (fun _ -> ppat_any ~loc) var))
          (mkl ~loc (Option.get var))
      else
        pconstruct (Option.map (pvar ~loc) var) in
    let rhs_of = econstruct (Option.map (evar ~loc) var) in
    let e_to obj = pexp_match ~loc obj [
        case ~guard:None
          ~lhs:lhs_to
          ~rhs:(eapply ~loc (evar ~loc (js_mod "def")) [
              eapply ~loc cv.e_to [
                Option.fold ~none:(eunit ~loc) ~some:(fun v -> evar ~loc v) var ] ]);
        case ~guard:None
          ~lhs:(ppat_any ~loc) ~rhs:(evar ~loc (js_mod "undefined"))
      ] in
    let e_of obj expr = pexp_match ~loc (eapply ~loc (evar ~loc (js_mod "Optdef.to_option")) [
        prop_try ~loc obj name_js cv.e_of]) [
        case ~guard:None
          ~lhs:(psome ~loc (Option.fold ~none:ppat_any ~some:(fun v ~loc ->
              if local then ppat_construct ~loc
                  (llid ~loc name) (Some (pvar ~loc v))
              else pvar ~loc v) var))
          ~rhs:rhs_of;
        case ~guard:None ~lhs:(ppat_any ~loc) ~rhs:expr;
      ] in
    let e_to, e_of = match add with [] -> e_to, e_of | _ ->
      (fun obj -> pexp_let ~loc Nonrecursive add (e_to obj)),
      (fun obj expr -> pexp_let ~loc Nonrecursive add (e_of obj expr)) in
    if case_ then
      mconv ~acc:cv.e_acc (`RCase (mkl ~loc name_js, e_to)) e_of
    else
      mconv ~acc:cv.e_acc (`RVal (mkl ~loc name_js, prop_kind prop, Fresh, e_to)) e_of
  else
    let e_to obj = match var with
      | None ->
        pexp_let ~loc Nonrecursive [
          value_binding ~loc ~pat:(ppat_any ~loc) ~expr:obj ] (eunit ~loc)
      | Some v ->
        if local then
          eapply ~loc cv.e_to [ obj ]
        else
          pexp_let ~loc Nonrecursive [
            value_binding ~loc
              ~pat:(pconstruct (Some (pvar ~loc v)))
              ~expr:obj ] (eapply ~loc cv.e_to [evar ~loc v]) in
    let e_of obj _ = match var with
      | None ->
        pexp_let ~loc Nonrecursive
          [ value_binding ~loc ~pat:(ppat_any ~loc) ~expr:obj ]
          (econstruct None)
      | Some _ ->
        if local then
          eapply ~loc cv.e_of [ prop_get ~loc obj name_js ]
        else
          econstruct (Some (eapply ~loc cv.e_of [ prop_get ~loc obj name_js ])) in
    mconv ~acc:cv.e_acc
      (`RVal (mkl ~loc name_js, prop_kind prop, Fresh, e_to)) e_of

and row_expr ?(case=false) ?modules ?camel ?snake ?singleton ?remove_undefined ~params ~name rf =
  let c_name =
    if case then (fun txt -> field_name ~case name ^ "_" ^ txt)
    else (fun txt -> field_name ~case txt) in
  match rf.prf_desc with
  | Rtag ({txt; loc}, _, []) ->
    let cv = mconv (pexp_fun0 "_" (eunit ~loc)) (pexp_fun0 "_" (eunit ~loc)) in
    let name_js = c_name txt in
    [ case_expr ~case_:case ~loc ~name:txt ~name_js ~kind:`Variant ?singleton cv None ]
  | Rtag ({txt; loc}, _, (h :: _)) ->
    let name_js = c_name txt in
    let cv = expr_of_core ?modules ?camel ?snake ?remove_undefined ~params ~name h in
    [ case_expr ~case_:case ~loc ~name:txt ~name_js ~kind:`Variant ?singleton cv
        (Some (new_var ())) ]
  | Rinherit c ->  match c.ptyp_desc with
    | Ptyp_constr ({txt; loc}, l) ->
      begin match get_remember_fields (Longident.name txt) with
        | Some (fs, ps) ->
          let conv, _acc_expr = List.split @@ List.map2 (fun v c ->
              let cv = expr_of_core ?modules ?camel ?snake ?remove_undefined ~params ~name c in
              let l, _ = add_expr0 ?modules ~loc ~name:("_" ^ v) (cv.e_to, cv.e_of) in
              l, cv.e_acc)
              ps l in
          let param_exprs = List.flatten conv in
          let fs = List.map (fun f -> (fun ~add:_ -> f ~add:param_exprs)) fs in
          fs
        | _ -> []
      end
    | _ -> Location.raise_errorf ~loc:c.ptyp_loc "Inherit type not handled"

and variant_expr0 ?case ?(remember=true) ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l =
  let singleton = List.length l = 1 in
  let l =
    List.fold_left (fun acc rf -> row_expr ?case ?modules ?camel ?snake ?remove_undefined
                       ~params ~name ~singleton rf @ acc) [] l in
  (if remember then
      remember_fields name (l, List.map param_name (Jsoo_type.core_of_param params)));
  let e_to, e_of, acc = conv_map (fun _ e -> e ~add:[]) l in
  let rec aux obj = function
    | [] ->
      eapply ~loc (evar ~loc "failwith") [ estring ~loc "no case matched" ]
    | h :: t -> h obj (aux obj t) in
  let e_to = partition_rows e_to in
  let e_of = List.rev e_of in
  mconv ~acc e_to (fun obj -> aux obj e_of)

and variant_expr ?case ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l =
  let cv = variant_expr0 ?case ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l in
  mconv ~acc:cv.e_acc
    (pexp_fun1 ~loc (fun obj ->
         let expr = literal_object ~loc (pvar ~loc "_this") (cv.e_to obj) in
         remove_undefined_expr ~loc expr))
    (pexp_fun1 ~loc cv.e_of)

and object_expr ?modules ?camel ?snake ?(remove_undefined=false) ~name ~loc ~params l =
  let pexp_to ~loc obj lid = pexp_send ~loc obj {txt = Longident.name lid.txt; loc} in
  let l = List.map (fun pof ->
      match pof.pof_desc with
      | Oinherit c ->
        let {fa_meth; fa_meth_cb; fa_cb; fa_prop; fa_opt; fa_ignore; fa_array;
             fa_number; fa_assoc; fa_case; fa_enum; _} =
          field_attributes ~key:"" ?camel ?snake pof.pof_attributes in
        snd @@ field_expr ~meth:fa_meth ~case:fa_case ~inherit_:true ~loc
          ~name ~name_js:""
          ~params ~ignore_:fa_ignore ~mutable_:Immutable
          ?modules ?camel ?snake ?prop:fa_prop ?opt:fa_opt ?callback:fa_cb
          ?meth_callback:fa_meth_cb ?array_tup:fa_array ?number:fa_number
          ?assoc:fa_assoc ?enum:fa_enum ~remove_undefined ~pexp_to c
      | Otag ({txt; loc}, c) ->
        let {fa_meth; fa_meth_cb; fa_cb; fa_prop; fa_opt; fa_key; fa_ignore; fa_array;
             fa_number; fa_assoc; fa_case; fa_inherit; fa_enum; _} =
          field_attributes ~key:txt ?camel ?snake pof.pof_attributes in
        let name_js = field_name fa_key in
        snd @@ field_expr ~meth:fa_meth ~case:fa_case ~inherit_:fa_inherit ~loc
          ~name:txt ~name_js
          ~params ~ignore_:fa_ignore ~mutable_:Immutable
          ?modules ?camel ?snake ?prop:fa_prop ?opt:fa_opt ?callback:fa_cb
          ?meth_callback:fa_meth_cb ?array_tup:fa_array ?number:fa_number
          ?assoc:fa_assoc ?enum:fa_enum ~remove_undefined ~pexp_to c
    ) l in
  let acc = List.flatten (List.map (fun c -> c.e_acc) l) in
  let e_to obj = List.flatten @@ List.map (fun c -> c.e_to obj) l in
  let param_names = List.map (fun (c, _) -> param_name c) params in
  Hashtbl.add inherit_fields (lid name) (e_to, param_names);
  mconv ~acc
    (pexp_fun1 ~loc (fun obj ->
         let e = literal_object ~loc (pvar ~loc "_this") (List.flatten @@ List.map (fun c -> c.e_to obj) l) in
         if remove_undefined then remove_undefined_expr ~loc e else e))
    (pexp_fun1 ~loc (fun obj ->
         pexp_object ~loc @@
         class_structure ~self:(ppat_any ~loc)
           ~fields:(List.map (fun c ->
               let {txt; loc}, e = c.e_of obj in
               pcf_method ~loc ({txt=Longident.name txt;loc}, Public, Cfk_concrete (
                   Fresh, e))) l)))

and add_field_desc_params ?modules ?camel ?snake ?remove_undefined
    ~params ~name ~loc ~names cs fd =
  match cs with
  | [] -> fd
  | cs ->
    let vb =
      List.map2 (fun c n ->
          let cv = expr_of_core ?modules ?camel ?snake ?remove_undefined ~params ~name c in
          value_binding ~loc ~pat:(pvar ~loc @@ "_" ^ n ^ _to_jsoo)
            ~expr:cv.e_to) cs names in
    let aux e = pexp_let ~loc Nonrecursive vb e in
    match fd with
    | Ppx_js.Val (id, k, f, e) -> Ppx_js.Val (id, k, f, aux e)
    | Ppx_js.Meth (id, p, o, e, a) -> Ppx_js.Meth (id, p, o, aux e, a)
    | Ppx_js.Cases (ids, es) -> Ppx_js.Cases (ids, List.map aux es)

and field_expr ~meth ~case ~inherit_ ~loc ~name ~name_js ~params ~ignore_ ~mutable_
    ?modules ?camel ?snake ?prop ?opt ?callback ?meth_callback ?array_tup ?number
    ?assoc ?enum ?remove_undefined ~pexp_to c =
  if not meth then
    match case, c.ptyp_desc with
    | true, Ptyp_variant (l, _, _) ->
      (* variant with cases  { a : [ `x | ... ] }*)
      let cv = variant_expr0 ?modules ?camel ?snake ?remove_undefined ~case:true ~remember:false ~loc ~params ~name l in
      let lid_name = llid ~loc name in
      true,
      mconv ~acc:cv.e_acc (fun obj ->
          let obj_to = pexp_to ~loc obj lid_name in
          cv.e_to obj_to)
        (fun obj -> (lid_name, cv.e_of obj))
    | _, Ptyp_constr ({txt; loc}, cs) when inherit_ ->
      (* inherit  { a : ... [@inherit] }*)
      let cv =
        expr_of_core ?modules ?camel ?snake ~params ~name ?opt ?callback ?meth_callback
          ?array_tup ?number ?assoc ?remove_undefined c in
      begin match Hashtbl.find_opt inherit_fields txt with
        | None -> Location.raise_errorf ~loc "inherited fields not available"
        | Some (f_to, param_names) ->
          let lid_name = llid ~loc name in
          false,
          mconv
            (fun obj ->
               List.map
                 (add_field_desc_params ?modules ?remove_undefined ~params ~name ~loc ~names:param_names cs) @@
               f_to @@ pexp_to ~loc obj lid_name)
            (fun obj ->
               lid_name,
               eapply ~loc cv.e_of [ eapply ~loc (evar ~loc @@ js_mod "Unsafe.coerce") [obj] ] )
      end
    | _ ->
      (* prop  { a : ... }*)
      let cv =
        if ignore_ then mconv (id_fun loc) (id_fun loc)
        else expr_of_core ?modules ?camel ?snake ~params ~name ?opt ?callback ?meth_callback
            ?array_tup ?number ?assoc ?enum ?remove_undefined c in
      let prop = match c.ptyp_desc, mutable_ with
        | Ptyp_constr ({txt; _}, _), _ when Longident.name txt = "ref" -> Some "prop"
        | _, Mutable -> Some "prop"
        | _ -> prop in
      let lid_name = llid ~loc name in
      false, mconv ~acc:cv.e_acc
        (fun obj -> [ Ppx_js.Val (mkl ~loc name_js, prop_kind prop, Fresh, eapply ~loc cv.e_to [
             pexp_to ~loc obj lid_name ]) ])
        (fun obj ->
           lid_name,
           eapply ~loc cv.e_of [prop_get ~loc obj name_js])
  else
    (* meth  { a : _ -> _ }*)
    let es_to, es_of, vs_to, vs_of, e_to, e_of, acc =
      arrows_to_array ~params ~name ~meth_start:true ?camel ?snake ?remove_undefined c in
    let vs2_of = List.map Ppx_js.Arg.name vs_of in
    let vs2_to = List.map Ppx_js.Arg.name vs_to in
    let lid_name = llid ~loc name in
    false, mconv ~acc
      (fun obj -> [ Ppx_js.Meth (
           mkl ~loc name_js, Public, Fresh,
           pexp_fun_rec (eapply ~loc e_to [
               eapply ~loc (
                 pexp_to ~loc obj lid_name)
                 es_of ]) vs2_of, vs_of) ])
      (fun obj ->
         lid_name,
         pexp_fun_rec (
           eapply ~loc e_of [
             method_call ~loc obj name_js
               (List.map (fun e_to -> Nolabel, e_to) es_to)]) vs2_to)

let field_of_label_declaration ?(rm_prefix=0) ?(mut=false) ?modules ?camel ?snake ?remove_undefined ~params pld =
  let loc = pld.pld_loc in
  let name = pld.pld_name.txt in
  let key = remove_prefix name rm_prefix in
  let {fa_meth; fa_meth_cb; fa_cb; fa_prop; fa_opt; fa_key; fa_ignore; fa_array;
       fa_number; fa_assoc; fa_case; fa_inherit; fa_enum; _} =
    field_attributes ~key ?prop:(if mut then Some "prop" else None) ?camel ?snake pld.pld_attributes in
  let name_js = field_name fa_key in
  debug ~v:2 "\t\tlabel field %s -> %s" name name_js;
  field_expr ~meth:fa_meth ~case:fa_case ~inherit_:fa_inherit ~loc ~name ~name_js
    ~params ~ignore_:fa_ignore ~mutable_:pld.pld_mutable
    ?modules ?camel ?snake ?prop:fa_prop ?opt:fa_opt ?callback:fa_cb
    ?meth_callback:fa_meth_cb ?array_tup:fa_array ?number:fa_number
    ?assoc:fa_assoc ?enum:fa_enum ~pexp_to:pexp_field ?remove_undefined pld.pld_type

let record_expr ?rm_prefix ?modules ~loc ~params ?local ?mut ?name ?camel ?snake ?(singleton=false) ?(remove_undefined=false) l =
  let rm_prefix = match rm_prefix, local with
    | Some false, _ | _, Some _ -> 0
    | _ -> same_prefix @@ List.map (fun pld -> pld.pld_name.txt) l in
  let fields_to, fields_of, acc, _allow_overload =
    let l_to, l_of, l_acc, case = List.fold_left (fun (acc_to, acc_of, acc, acc_case) c ->
        let case, cv = field_of_label_declaration ?modules ~rm_prefix ~params ?mut ?camel ?snake ~remove_undefined c in
        (fun obj -> acc_to obj @ cv.e_to obj),
        (fun obj -> cv.e_of obj :: acc_of obj),
        cv.e_acc :: acc, case || acc_case)
        ((fun _obj -> []),(fun _obj -> []),[], false) l in
    l_to, l_of, List.flatten (List.rev l_acc), case in
  (match name with Some name ->
     let param_names = List.map (fun (c, _) -> param_name c) params in
     Hashtbl.add inherit_fields (lid name) (fields_to, param_names) | None -> ());
  let e_to = match local with
    | None -> pexp_fun1 ~loc (fun obj ->
        let e = literal_object ~loc (pvar ~loc "_this") (fields_to obj) in
        if remove_undefined then remove_undefined_expr ~loc e
        else e)
    | Some cs ->
      let obj = new_var () in
      let e = literal_object ~loc (pvar ~loc "_this") (fields_to (evar ~loc obj)) in
      let rhs =
        if remove_undefined then remove_undefined_expr ~loc e
        else e in
      pexp_function ~loc ((
          case ~guard:None
            ~lhs:(ppat_construct ~loc (llid ~loc cs) (Some (pvar ~loc obj)))
            ~rhs) ::
          (if singleton then []
           else
             [ case ~guard:None ~lhs:(ppat_any ~loc)
                 ~rhs:(eapply ~loc (evar ~loc "failwith") [
                     estring ~loc "wrong local record construction"]) ])) in
  mconv ~acc
    e_to
    (match local with
     | None -> pexp_fun1 ~loc @@ fun obj -> pexp_record ~loc (List.rev @@ fields_of obj) None
     | Some cs -> pexp_fun1 ~loc @@ fun obj ->
       pexp_construct ~loc (llid ~loc cs)
         (Some (pexp_record ~loc (List.rev @@ fields_of obj) None)))

let field_of_constructor_declaration
    ?(rm_prefix=0) ?(case=false) ?mut ?modules ?camel ?snake ?singleton ?remove_undefined ~params ~name pcd =
  let loc = pcd.pcd_loc in
  (match pcd.pcd_res with
   | Some _ -> Location.raise_errorf ~loc "GADT not handled"
   | None -> ());
  let name_cs = remove_prefix pcd.pcd_name.txt rm_prefix in
  let {fa_meth_cb; fa_cb; fa_prop; fa_key; fa_array; fa_number; fa_assoc; _} =
    field_attributes ~key:name_cs ?camel ?snake pcd.pcd_attributes in
  let name_js =
    if case then field_name ~case (name ^ "_" ^ fa_key)
    else field_name ~case fa_key in
  debug ~v:2 "\t\tconstructor field %s" name;
  let cv, var, local = match pcd.pcd_args with
    | Pcstr_tuple [] -> mconv (id_fun loc) (id_fun loc), None, false
    | Pcstr_tuple [c] ->
      let cv = expr_of_core ?modules ~name ~params ?callback:fa_cb
          ?meth_callback:fa_meth_cb ?number:fa_number ?assoc:fa_assoc ?camel ?snake ?remove_undefined c in
      cv, Some (new_var ()), false
    | Pcstr_tuple l ->
      let var = if l = [] then None else Some (new_var ()) in
      if fa_array = Some true then
        let cv = array_tuple_expr ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l in
        cv, var, false
      else
        let cv = tuple_expr ?modules ?camel ?snake ~loc ~name ~params ?callback:fa_cb
            ?meth_callback:fa_meth_cb ?number:fa_number ?assoc:fa_assoc ?remove_undefined l in
        let tuple_name = get_tuple_name name in
        let cv = acc_expr ~loc ~name:tuple_name ~params cv in
        cv, var, false
    | Pcstr_record l ->
      let name = "_" ^ pcd.pcd_name.txt ^ _jsoo in
      debug ~v:2 "\tadd record convs %s" name;
      let cv = record_expr ?modules ?camel ?snake ~loc ~params ~local:pcd.pcd_name.txt ?mut ?singleton ?remove_undefined l in
      let cv = acc_expr ~loc ~name ~params cv in
      cv, Some (new_var ()), true in
  case_expr
    ~case_:case ~loc
    ~name:pcd.pcd_name.txt ~name_js
    ~add:[] ?prop:fa_prop ~local
    ?singleton
    cv var

let constructor_variant_expr ?rm_prefix ?case ?mut ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l =
  let rm_prefix = match rm_prefix with
    | Some false -> 0
    | _ -> same_prefix @@ List.map (fun pcd -> pcd.pcd_name.txt) l in
  let rec aux obj = function
    | [] ->
      eapply ~loc (evar ~loc "failwith") [ estring ~loc "no case matched" ]
    | h :: t -> h obj (aux obj t) in
  let singleton = List.length l = 1 in
  let fields_to, fields_of, acc = conv_map (fun _ c ->
      field_of_constructor_declaration ?case ?mut ?modules ?camel ?snake ?remove_undefined ~singleton ~rm_prefix ~params ~name c) l in
  let fields_to = partition_rows fields_to in
  let param_names = List.map (fun (c, _) -> param_name c) params in
  Hashtbl.add inherit_fields (lid name) (fields_to, param_names);
  mconv ~acc
    (pexp_fun1 ~loc @@ fun obj ->
     let expr = literal_object ~loc (pvar ~loc "_this") (fields_to obj) in
     remove_undefined_expr ~loc expr)
    (pexp_fun1 ~loc @@ fun obj -> aux obj (List.rev fields_of))

let declaration_of_manifest ?case ?modules ?enum ?camel ?snake ?remove_undefined ~params ~name c =
  let loc = c.ptyp_loc in
  let {ca_meth_cb; ca_cb; ca_opt; ca_array; ca_number; ca_assoc; ca_conv; ca_enum; _} =
    core_attributes ?enum c.ptyp_attributes in
  match ca_conv with
  | Some c -> c
  | None ->
    match c.ptyp_desc with
    | Ptyp_tuple l ->
      if ca_array = Some true then
        array_tuple_expr ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l
      else
        tuple_expr ~loc ~params ~name ?number:ca_number ?assoc:ca_assoc ?modules ?camel ?snake ?remove_undefined l
    | Ptyp_variant (l, _, _) ->
      begin match ca_enum with
        | None -> variant_expr ?modules ?case ?camel ?snake ?remove_undefined ~loc ~params ~name l
        | Some typ ->
          let ls, fallback = enum_variant ~typ l in
          enum_expr ~loc ?fallback ~typ ls
      end
    | _ -> expr_of_core ?modules ~params ~name ?opt:ca_opt ?meth_callback:ca_meth_cb
             ?callback:ca_cb ?number:ca_number ?assoc:ca_assoc ?camel ?snake ?remove_undefined c

let declaration_of_type_kind ?rm_prefix ?case ?mut ?modules ?enum ?camel ?snake
    ?remove_undefined ~loc ~name ~params kind manifest =
  match kind, manifest with
  | Ptype_abstract, None -> Location.raise_errorf ~loc "abstract type"
  | Ptype_open, _ -> Location.raise_errorf ~loc "open type"
  | Ptype_abstract, Some manifest ->
    debug ~v:2 "\tjsoo_conv from manifest";
    declaration_of_manifest ?case ?modules ?enum ?camel ?snake ?remove_undefined
      ~params ~name manifest
  | Ptype_variant l, _ ->
    begin match enum with
      | None ->
        debug ~v:2 "\tjsoo_conv from variant";
        constructor_variant_expr ?rm_prefix ?case ?mut ?modules ?camel ?snake
          ?remove_undefined ~loc ~params ~name l
      | Some typ ->
        let ls, fallback = enum_constructor ?camel ?snake ~typ l in
        enum_expr ~loc ?fallback ~kind:`Construct ~typ ls
    end
  | Ptype_record l, _ ->
    debug ~v:2 "\tjsoo_conv from record";
    record_expr ?rm_prefix ?mut ?modules ?camel ?snake ?remove_undefined ~loc ~params ~name l

let conv_expressions ?rm_prefix ?case ?mut ?modules ?enum ?camel ?snake ?remove_undefined t =
  let loc = t.ptype_loc in
  let name = t.ptype_name.txt in
  let params = t.ptype_params in
  let cv =
    declaration_of_type_kind ?rm_prefix ?case ?mut ?modules ?enum ?camel ?snake
      ?remove_undefined ~loc ~name ~params t.ptype_kind t.ptype_manifest in
  mconv ~acc:cv.e_acc (add_params_fun cv.e_to params) (add_params_fun cv.e_of params)

let conv_signatures ?modules ~is_class_type t =
  let loc = t.ptype_loc in
  let name = t.ptype_name.txt in
  let name_js = jsoo_name ?modules name in
  let params = t.ptype_params in
  let rec aux = function
    | [] -> (fun expr -> expr), []
    | ({ptyp_desc = Ptyp_var x; _}, _) :: t ->
      let t_to = ptyp_arrow ~loc Nolabel (ptyp_var ~loc x) (ptyp_var ~loc (x ^ _jsoo)) in
      let t_of = ptyp_arrow ~loc Nolabel (ptyp_var ~loc (x ^ _jsoo)) (ptyp_var ~loc x) in
      let c, vs = aux t in
      (fun expr -> ptyp_arrow ~loc Nolabel (ptyp_tuple ~loc [t_to; t_of]) (c expr)),
      x :: vs
    | _ :: t -> aux t in
  let c, vars = aux params in
  let ml_vars = List.map (fun v -> ptyp_var ~loc v) vars in
  let js_vars = List.map (fun v -> ptyp_var ~loc (v ^ _jsoo)) vars in
  let jsoo_ct_sig = ptyp_constr ~loc (llid ~loc name_js) js_vars in
  let jsoo_sig =
    if is_class_type then ptyp_constr ~loc (llid ~loc (js_mod "t")) [jsoo_ct_sig]
        else jsoo_ct_sig in
  let ml_sig = ptyp_constr ~loc (mkl ~loc @@ Longident.parse name) ml_vars in
  let to_sig = c @@ ptyp_arrow ~loc Nolabel ml_sig jsoo_sig in
  let of_sig = c @@ ptyp_arrow ~loc Nolabel jsoo_sig ml_sig in
  to_sig, of_sig, ptyp_tuple ~loc [to_sig; of_sig]