Source file ast_object.ml

(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program 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 Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Import
open Ast_helper

let ffi_of_labels labels =
  Melange_ffi.External_ffi_types.ffi_obj_create
    (List.fold_right labels ~init:[] ~f:(fun { txt; _ } arg_kinds ->
         {
           Melange_ffi.External_arg_spec.Param.arg_type = Nothing;
           arg_label =
             Melange_ffi.External_arg_spec.Obj_label.obj
               (Melange_ffi.Lam_methname.translate txt);
         }
         :: arg_kinds))

let ocaml_object_as_js_object =
  let local_module_name = "J" in
  let local_fun_name = "unsafe_expr" in
  let local_extern_cont_to_obj ~loc ~ffi ~pval_type (cb : expression -> 'a) =
    Pexp_letmodule
      ( { txt = Some local_module_name; loc },
        Mod.structure ~loc
          [
            Str.primitive ~loc
              {
                pval_name = { txt = local_fun_name; loc };
                pval_type;
                pval_loc = loc;
                pval_prim = Ast_external.pval_prim_default;
                pval_attributes = [ Ast_attributes.mel_ffi ffi ];
              };
          ],
        cb
          (Exp.ident ~loc
             { txt = Ldot (Lident local_module_name, local_fun_name); loc }) )
  in
  let generate_val_method_pair ~loc (mapper : Ast_traverse.map) ~mutable_
      (val_name : string Asttypes.loc) =
    let result = Typ.var ~loc val_name.txt in
    let base =
      match mutable_ with
      | Mutable ->
          [
            Of.tag
              {
                val_name with
                txt =
                  val_name.txt
                  ^ Melange_ffi.External_ffi_types.Literals.setter_suffix;
              }
              (Ast_typ_uncurry.to_method_type ~loc mapper Nolabel result
                 [%type: unit]);
          ]
      | Immutable -> []
    in
    (result, Of.tag val_name result :: base)
  in
  fun ~loc
    (mapper : Ast_traverse.map)
    (self_pat : pattern)
    (clfs : class_field list)
  ->
    (* Attention: we should avoid type variable conflict for each method
      Since the method name is unique, there would be no conflict
      OCaml does not allow duplicate instance variable and duplicate methods,
      but it does allow duplicates between instance variable and method name,
      we should enforce such rules
      {[
        object [@u]
          val x = 3
          method x = 3
        end
      ]} should not compile with a meaningful error message
  *)

    (* Note mapper is only for API compatible
     * TODO: we should check label name to avoid conflict
     *)

    (* we need calculate the real object type
      and exposed object type, in some cases there are equivalent

      for public object type its [@meth] it does not depend on itself
      while for label argument it is [@this] which depends internal object
  *)
    let ( (internal_label_attr_types : object_field list),
          (public_label_attr_types : object_field list) ) =
      List.fold_right
        ~f:(fun
            ({ pcf_loc = loc; _ } as x : class_field)
            (label_attr_types, public_label_attr_types)
          ->
          match x.pcf_desc with
          | Pcf_method (label, public_flag, Cfk_concrete (Fresh, e)) -> (
              match e.pexp_desc with
              | Pexp_poly
                  ( { pexp_desc = Pexp_function (_, _, Pfunction_cases _); _ },
                    None ) ->
                  assert false
              | Pexp_poly
                  ( { pexp_desc = Pexp_function (args, _, Pfunction_body e); _ },
                    None ) -> (
                  let method_type =
                    Ast_typ_uncurry.generate_arg_type ~loc:x.pcf_loc mapper
                      label.txt args e
                  in
                  ( Of.tag label method_type :: label_attr_types,
                    match public_flag with
                    | Public ->
                        Of.tag label method_type :: public_label_attr_types
                    | Private -> public_label_attr_types ))
              | Pexp_poly (_, Some _) ->
                  Location.raise_errorf ~loc
                    "polymorphic type annotation not supported yet"
              | Pexp_poly (_, None) ->
                  Location.raise_errorf ~loc
                    "Unsupported JS Object syntax. Methods must take at least \
                     one argument"
              | _ ->
                  Location.raise_errorf ~loc "Unsupported syntax in js object")
          | Pcf_val (label, mutable_, Cfk_concrete (Fresh, _)) ->
              let _, label_attr =
                generate_val_method_pair ~loc:x.pcf_loc mapper label ~mutable_
              in
              (List.append label_attr label_attr_types, public_label_attr_types)
          | Pcf_val (_, _, Cfk_concrete (Override, _)) ->
              Location.raise_errorf ~loc "override flag not support currently"
          | Pcf_val (_, _, Cfk_virtual _) ->
              Location.raise_errorf ~loc "virtual flag not support currently"
          | Pcf_method (_, _, Cfk_concrete (Override, _)) ->
              Location.raise_errorf ~loc "override flag not supported"
          | Pcf_method (_, _, Cfk_virtual _) ->
              Location.raise_errorf ~loc "virtural method not supported"
          | Pcf_inherit _ | Pcf_initializer _ | Pcf_attribute _
          | Pcf_extension _ | Pcf_constraint _ ->
              Location.raise_errorf ~loc "Only method support currently")
        clfs ~init:([], [])
    in
    let internal_obj_type =
      Ast_core_type.to_js_type ~loc
        (Typ.object_ ~loc internal_label_attr_types Closed)
    in
    let public_obj_type =
      Ast_core_type.to_js_type ~loc
        (Typ.object_ ~loc public_label_attr_types Closed)
    in
    let labels, label_types, exprs, _ =
      List.fold_right
        ~f:(fun (x : class_field) (labels, label_types, exprs, aliased) ->
          match x.pcf_desc with
          | Pcf_method (label, _public_flag, Cfk_concrete (Fresh, e)) -> (
              match e.pexp_desc with
              | Pexp_poly
                  ( { pexp_desc = Pexp_function (_, _, Pfunction_cases _); _ },
                    None ) ->
                  assert false
              | Pexp_poly
                  ( ({
                       pexp_desc = Pexp_function (params, _, Pfunction_body e);
                       _;
                     } as f),
                    None ) ->
                  let alias_type =
                    match aliased with
                    | true -> None
                    | false -> Some internal_obj_type
                  in
                  let label_type =
                    Ast_typ_uncurry.generate_method_type ?alias_type x.pcf_loc
                      mapper label.txt params e
                  in
                  ( label :: labels,
                    label_type :: label_types,
                    {
                      f with
                      pexp_desc =
                        (let f =
                           match
                             List.find
                               ~f:(function
                                 | { pparam_desc = Pparam_val _; _ } -> true
                                 | { pparam_desc = Pparam_newtype _; _ } ->
                                     false)
                               params
                           with
                           | {
                            pparam_desc =
                              Pparam_val
                                ( _,
                                  _,
                                  {
                                    ppat_desc =
                                      Ppat_construct
                                        ({ txt = Lident "()"; _ }, None);
                                    _;
                                  } );
                            _;
                           } ->
                               e
                           | { pparam_desc = Pparam_val (_, _, _); _ } -> f
                           | { pparam_desc = Pparam_newtype _; _ }
                           | (exception Not_found) ->
                               assert false
                         in
                         (* the first argument is `this` *)
                         Ast_uncurry_gen.to_method_callback ~loc mapper
                           [
                             {
                               pparam_desc = Pparam_val (Nolabel, None, self_pat);
                               pparam_loc = x.pcf_loc;
                             };
                           ]
                           f);
                    }
                    :: exprs,
                    true )
              | Pexp_poly (_, Some _) ->
                  Location.raise_errorf ~loc
                    "polymorphic type annotation not supported yet"
              | Pexp_poly (_, None) ->
                  Location.raise_errorf ~loc
                    "Unsupported syntax, expect syntax like `method x () = x ` "
              | _ ->
                  Location.raise_errorf ~loc "Unsupported syntax in js object")
          | Pcf_val (label, mutable_, Cfk_concrete (Fresh, val_exp)) ->
              let label_type, _ =
                generate_val_method_pair ~loc:x.pcf_loc mapper label ~mutable_
              in
              ( label :: labels,
                label_type :: label_types,
                mapper#expression val_exp :: exprs,
                aliased )
          | Pcf_val (_, _, Cfk_concrete (Override, _)) ->
              Location.raise_errorf ~loc "override flag not support currently"
          | Pcf_val (_, _, Cfk_virtual _) ->
              Location.raise_errorf ~loc "virtual flag not support currently"
          | Pcf_method (_, _, Cfk_concrete (Override, _)) ->
              Location.raise_errorf ~loc "override flag not supported"
          | Pcf_method (_, _, Cfk_virtual _) ->
              Location.raise_errorf ~loc "virtural method not supported"
          | Pcf_inherit _ | Pcf_initializer _ | Pcf_attribute _
          | Pcf_extension _ | Pcf_constraint _ ->
              Location.raise_errorf ~loc "Only method support currently")
        clfs ~init:([], [], [], false)
    in
    let pval_type =
      List.fold_right2
        ~f:(fun label label_type acc ->
          Typ.arrow ~loc:label.Asttypes.loc (Labelled label.Asttypes.txt)
            label_type acc)
        labels label_types ~init:public_obj_type
    in
    local_extern_cont_to_obj ~loc ~ffi:(ffi_of_labels labels)
      (fun e ->
        Exp.apply ~loc e
          (List.map2 ~f:(fun l expr -> (Labelled l.txt, expr)) labels exprs))
      ~pval_type

let record_as_js_object =
  let local_module_name = "J" in
  let local_fun_name = "unsafe_expr" in
  let local_external_obj ~loc ~ffi ~pval_type args : expression_desc =
    Pexp_letmodule
      ( { txt = Some local_module_name; loc },
        Mod.structure ~loc
          [
            Str.primitive ~loc
              {
                pval_name = { txt = local_fun_name; loc };
                pval_type;
                pval_loc = loc;
                pval_prim = [ ""; "" ];
                pval_attributes = [ Ast_attributes.mel_ffi ffi ];
              };
          ],
        Exp.apply
          (Exp.ident ~loc
             { loc; txt = Ldot (Lident local_module_name, local_fun_name) })
          (List.map ~f:(fun (l, a) -> (Asttypes.Labelled l, a)) args)
          ~loc )
  in
  (* Note that OCaml type checker will not allow arbitrary
   name as type variables, for example:
   {[
     '_x'_
   ]}
   will be recognized as a invalid program *)
  let from_labels ~loc arity labels : core_type =
    let tyvars =
      List.init ~len:arity ~f:(fun i -> Typ.var ~loc ("a" ^ string_of_int i))
    in
    let result_type =
      Ast_core_type.to_js_type ~loc
        (Typ.object_ ~loc
           (List.map2 ~f:(fun x y -> Of.tag x y) labels tyvars)
           Closed)
    in
    List.fold_right2
      ~f:(fun label (* {loc ; txt = label } *) tyvar acc ->
        Typ.arrow ~loc:label.loc (Labelled label.txt) tyvar acc)
      labels tyvars ~init:result_type
  in
  fun ~loc
    (label_exprs : (Longident.t Asttypes.loc * expression) list)
    :
    expression_desc
  ->
    let labels, args, arity =
      List.fold_right
        ~f:(fun ({ txt; loc }, e) (labels, args, i) ->
          match txt with
          | Lident obj_label ->
              let obj_label =
                Ast_attributes.iter_process_mel_string_as e.pexp_attributes
                |> Option.value ~default:obj_label
              in
              ( { Asttypes.loc; txt = obj_label } :: labels,
                (obj_label, e) :: args,
                i + 1 )
          | Ldot _ | Lapply _ ->
              Location.raise_errorf ~loc
                "`%%mel.obj' literals only support simple labels")
        label_exprs ~init:([], [], 0)
    in
    local_external_obj ~loc ~ffi:(ffi_of_labels labels)
      ~pval_type:(from_labels ~loc arity labels)
      args