revert @mel.meth stuff to old behavior, add uncurried_arity0 alert

ppx/ast_core_type.ml

@@ -47,73 +47,54 @@ let is_unit ty =
 let to_js_type ~loc x = Typ.constr ~loc { txt = Ast_literal.js_obj; loc } [ x ]
 let make_obj ~loc xs = to_js_type ~loc (Typ.object_ ~loc xs Closed)
 
+let rec get_uncurry_arity_aux ty acc =
+  (* {[ 'a . 'a -> 'b ]}
+     OCaml does not support such syntax yet
+     {[ 'a -> ('a. 'a -> 'b) ]} *)
+  match ty.ptyp_desc with
+  | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc)
+  | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc
+  | _ -> acc
+
+let get_uncurry_arity_from_attribute ~zero_arity ty =
+  match (ty.ptyp_desc, zero_arity) with
+  | ( Ptyp_arrow
+        ( Nolabel,
+          { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
+          ({ ptyp_desc = Ptyp_arrow _; _ } as rest) ),
+      false ) ->
+      Some (get_uncurry_arity_aux rest 1)
+  | ( Ptyp_arrow
+        ( Nolabel,
+          { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
+          { ptyp_desc = Ptyp_arrow _; ptyp_loc; _ } ),
+      true ) ->
+      Location.raise_errorf ~loc:ptyp_loc
+        "`[@u0]' cannot be used with multiple arguments"
+  | ( Ptyp_arrow
+        ( Nolabel,
+          { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
+          _ ),
+      true ) ->
+      Some 0
+  | Ptyp_arrow (Nolabel, { ptyp_desc = Ptyp_constr _; ptyp_loc; _ }, _), true ->
+      Location.raise_errorf ~loc:ptyp_loc
+        "`[@u0]' can only be used with the `unit' type"
+  | Ptyp_arrow (_, _, rest), _ -> Some (get_uncurry_arity_aux rest 1)
+  | _ -> None
+
 (*
-(**
    {[ unit -> 'b ]} return arity 0
    {[ unit -> 'a1 -> a2']} arity 2
-   {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
-*)
-let get_uncurry_arity =
-  let rec get_uncurry_arity_aux ty acc =
-    (* {[ 'a . 'a -> 'b ]}
-       OCaml does not support such syntax yet
-       {[ 'a -> ('a. 'a -> 'b) ]} *)
-    match ty.ptyp_desc with
-    | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc)
-    | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc
-    | _ -> acc
-  in
-  fun ty ->
-    match ty.ptyp_desc with
-    | Ptyp_arrow
-        ( Nolabel,
-          { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
-          rest ) -> (
-        match rest with
-        | { ptyp_desc = Ptyp_arrow _; _ } -> Some (get_uncurry_arity_aux rest 1)
-        | _ ->
-            Format.eprintf "A FUCKIN HOY@.";
-            Some 0)
-    | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
-    | _ -> None
- *)
-let get_uncurry_arity =
-  let rec get_uncurry_arity_aux ty acc =
-    (* {[ 'a . 'a -> 'b ]}
-       OCaml does not support such syntax yet
-       {[ 'a -> ('a. 'a -> 'b) ]} *)
-    match ty.ptyp_desc with
-    | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc)
-    | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc
-    | _ -> acc
-  in
-  fun ?zero_arity ty ->
-    match (ty.ptyp_desc, zero_arity) with
-    | ( Ptyp_arrow
-          ( Nolabel,
-            { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
-            ({ ptyp_desc = Ptyp_arrow _; _ } as rest) ),
-        (None | Some false) ) ->
-        Some (get_uncurry_arity_aux rest 1)
-    | ( Ptyp_arrow
-          ( Nolabel,
-            { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
-            { ptyp_desc = Ptyp_arrow _; ptyp_loc; _ } ),
-        Some true ) ->
-        (* TODO: test this *)
-        Location.raise_errorf ~loc:ptyp_loc
-          "`[@u0]' cannot be used with multiple arguments"
-    | ( Ptyp_arrow
-          ( Nolabel,
-            { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
-            _ ),
-        Some true ) ->
-        Format.eprintf "indeed@.";
-        Some 0
-    | ( Ptyp_arrow (Nolabel, { ptyp_desc = Ptyp_constr _; ptyp_loc; _ }, _),
-        Some true ) ->
-        (* TODO: test this *)
-        Location.raise_errorf ~loc:ptyp_loc
-          "`[@u0]' can only be used with the `unit' type"
-    | Ptyp_arrow (_, _, rest), _ -> Some (get_uncurry_arity_aux rest 1)
-    | _ -> None
+   {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N *)
+let get_uncurry_arity ty =
+  match ty.ptyp_desc with
+  | Ptyp_arrow
+      ( Nolabel,
+        { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; _ }, []); _ },
+        rest ) -> (
+      match rest with
+      | { ptyp_desc = Ptyp_arrow _; _ } -> Some (get_uncurry_arity_aux rest 1)
+      | _ -> Some 0)
+  | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
+  | _ -> None

ppx/ast_core_type.mli

@@ -29,6 +29,11 @@ val is_unit : core_type -> bool
 val to_js_type : loc:Location.t -> core_type -> core_type
 val make_obj : loc:Location.t -> object_field list -> core_type
 
-val get_uncurry_arity : ?zero_arity:bool -> core_type -> int option
+val get_uncurry_arity : core_type -> int option
+(** returns 0 when it can not tell arity from the syntax. [None] means not a
+    function *)
+
+val get_uncurry_arity_from_attribute :
+  zero_arity:bool -> core_type -> int option
 (** returns 0 when it can not tell arity from the syntax. [None] means not a
     function *)

ppx/ast_exp_apply.ml

@@ -121,8 +121,7 @@ let app_exp_mapper e
              Ast_uncurry_apply.method_apply loc self obj name args
            else
              (* TODO(anmonteiro): check this zero_arity *)
-             Ast_uncurry_apply.property_apply loc self ~zero_arity:false obj
-               name args);
+             Ast_uncurry_apply.property_apply loc self obj name args);
       }
   | Some { op; loc; _ } ->
       Location.raise_errorf ~loc "%s expect f%sproperty arg0 arg2 form" op op

ppx/ast_typ_uncurry.ml

@@ -84,8 +84,9 @@ let to_method_type loc (mapper : Ast_traverse.map) (label : Asttypes.arg_label)
   let first_arg = mapper#core_type first_arg in
   let typ = mapper#core_type typ in
   let meth_type = Typ.arrow ~loc label first_arg typ in
-  let arity = Ast_core_type.get_uncurry_arity meth_type in
-  match arity with
+  (* Use the old `get_uncurry_arity` function to get the old behavior (`unit`
+     means 0-arity) *)
+  match Ast_core_type.get_uncurry_arity meth_type with
   | Some 0 ->
       Typ.constr { txt = Ldot (Ast_literal.js_meth, "arity0"); loc } [ typ ]
   | Some n ->
@@ -125,14 +126,21 @@ let to_uncurry_type loc (mapper : Ast_traverse.map) ~(zero_arity : bool)
   *)
   let first_arg = mapper#core_type first_arg in
   let typ = mapper#core_type typ in
-
   let fn_type = Typ.arrow ~loc label first_arg typ in
-  let arity = Ast_core_type.get_uncurry_arity ~zero_arity fn_type in
-  match arity with
-  | Some 0 ->
-      Typ.constr { txt = Ldot (Ast_literal.js_fn, "arity0"); loc } [ typ ]
-  | Some n ->
+  match
+    (* always `Some _` because we're passing it an arrow *)
+    ( Option.get
+        (Ast_core_type.get_uncurry_arity_from_attribute ~zero_arity fn_type),
+      Option.get (Ast_core_type.get_uncurry_arity fn_type) )
+  with
+  | 0, 0 -> Typ.constr { txt = Ldot (Ast_literal.js_fn, "arity0"); loc } [ typ ]
+  | n, 0 ->
+      Mel_ast_invariant.warn ~loc Uncurried_arity0;
+      Typ.constr
+        { txt = Ldot (Ast_literal.js_fn, "arity" ^ string_of_int n); loc }
+        [ fn_type ]
+  | n, m ->
+      assert (n = m);
       Typ.constr
         { txt = Ldot (Ast_literal.js_fn, "arity" ^ string_of_int n); loc }
         [ fn_type ]
-  | None -> assert false

ppx/ast_uncurry_apply.ml

@@ -150,6 +150,15 @@ let method_apply loc (self : Ast_traverse.map) obj name args =
 let uncurry_fn_apply loc self ~zero_arity fn args =
   generic_apply loc self ~zero_arity fn args (fun _ obj -> obj)
 
-let property_apply loc self ~zero_arity obj name args =
+let property_apply loc self obj name args =
+  let zero_arity =
+    match args with
+    | [
+     ( Nolabel,
+       { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, None); _ } );
+    ] ->
+        true
+    | _ -> false
+  in
   generic_apply loc self ~zero_arity obj args (fun loc obj ->
       Exp.mk ~loc (Ast_util.js_property loc obj name))

ppx/ast_uncurry_apply.mli

@@ -47,7 +47,6 @@ val method_apply :
 val property_apply :
   Location.t ->
   Ast_traverse.map ->
-  zero_arity:bool ->
   expression ->
   string ->
   (Asttypes.arg_label * expression) list ->

ppx/mel_ast_invariant.ml

@@ -30,34 +30,40 @@ module Warnings = struct
     | Fragile_external of string
     | Redundant_mel_string
     | Deprecated_non_namespaced_attribute
+    | Uncurried_arity0
 
   let kind = function
     | Unused_attribute _ -> "unused"
     | Fragile_external _ -> "fragile"
     | Redundant_mel_string -> "redundant"
     | Deprecated_non_namespaced_attribute -> "deprecated"
+    | Uncurried_arity0 -> "uncurried"
 
   let pp fmt t =
     match t with
     | Unused_attribute s ->
         Format.fprintf fmt
           "Unused attribute [%@%s]@\n\
            This means such annotation is not annotated properly.@\n\
-           For example, some annotations are only meaningful in externals\n"
-          s
+           For example, some annotations are only meaningful in externals" s
     | Fragile_external s ->
         Format.fprintf fmt
           "%s : the external name is inferred from val name is unsafe from \
            refactoring when changing value name"
           s
     | Redundant_mel_string ->
         Format.fprintf fmt
-          "[@mel.string] is redundant here, you can safely remove it"
+          "`[@mel.string]' is redundant here, you can safely remove it"
     | Deprecated_non_namespaced_attribute ->
         Format.fprintf fmt
           "FFI attributes without a namespace are deprecated and will be \
            removed in the next release.@\n\
            Use `mel.*' instead."
+    | Uncurried_arity0 ->
+        Format.fprintf fmt
+          "This uncurried function takes a single unit argument, but will be \
+           applied with `undefined' in the compiled JS.@\n\
+           Use `[@u0]' if it is intended to have 0-arity."
 end
 
 let warn =

ppx/mel_ast_invariant.mli

@@ -30,6 +30,7 @@ module Warnings : sig
     | Fragile_external of string
     | Redundant_mel_string
     | Deprecated_non_namespaced_attribute
+    | Uncurried_arity0
 end
 
 val is_mel_attribute : string -> bool