progress

ppx/ast_attributes.ml

@@ -138,17 +138,13 @@ let process_pexp_fun_attributes_rev attrs =
       match txt with "mel.open" -> (true, acc) | _ -> (st, attr :: acc))
     ~init:(false, []) attrs
 
+(* TODO: recognize `@u0` *)
 let process_uncurried attrs =
   List.fold_left
     ~f:(fun (st, acc) ({ attr_name = { txt; _ }; _ } as attr) ->
       match (txt, st) with "u", _ -> (true, acc) | _, _ -> (st, attr :: acc))
     ~init:(false, []) attrs
 
-let is_uncurried attr =
-  match attr with
-  | { attr_name = { Location.txt = "u"; _ }; _ } -> true
-  | _ -> false
-
 let mel_get =
   {
     attr_name = { txt = "mel.get"; loc = Location.none };

ppx/ast_attributes.mli

@@ -42,7 +42,6 @@ val warn_if_non_namespaced : loc:location -> label -> unit
 val process_attributes_rev : attribute list -> attr_kind * attribute list
 val process_pexp_fun_attributes_rev : attribute list -> bool * attribute list
 val process_uncurried : attribute list -> bool * attribute list
-val is_uncurried : attribute -> bool
 val mel_get : attribute
 val mel_get_index : attribute
 val mel_get_arity : attribute

ppx/ast_core_type.ml

@@ -47,32 +47,73 @@ 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)
 
-(**
-
-{[ 'a . 'a -> 'b ]}
-OCaml does not support such syntax yet
-{[ 'a -> ('a. 'a -> 'b) ]}
-
-*)
-let rec get_uncurry_arity_aux ty acc =
-  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
-
+(*
 (**
    {[ unit -> 'b ]} return arity 0
    {[ unit -> 'a1 -> a2']} arity 2
    {[ '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
+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

ppx/ast_core_type.mli

@@ -29,6 +29,6 @@ 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 : core_type -> int option
+val get_uncurry_arity : ?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_core_type_class_type.ml

@@ -87,7 +87,8 @@ let typ_mapper ((self, super) : Ast_traverse.map * (core_type -> core_type))
    _;
   } -> (
       match fst (Ast_attributes.process_attributes_rev ptyp_attributes) with
-      | Uncurry _ -> Ast_typ_uncurry.to_uncurry_type loc self label args body
+      | Uncurry { zero_arity; _ } ->
+          Ast_typ_uncurry.to_uncurry_type loc self ~zero_arity label args body
       | Meth_callback _ ->
           Ast_typ_uncurry.to_method_callback_type loc self label args body
       | Method _ -> Ast_typ_uncurry.to_method_type loc self label args body

ppx/ast_exp_apply.ml

@@ -68,26 +68,40 @@ let view_as_app fn (s : string list) : app_pattern option =
 
 let inner_ops = [ "##"; "#@" ]
 
-let rec exclude_with_val =
-  let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list =
-    match xs with
-    | [] -> []
-    | x :: xs -> if p x then exclude xs p else x :: exclude xs p
+let is_uncurried =
+  let is_uncurried attr =
+    match attr with
+    | { attr_name = { Location.txt = "u0"; _ }; _ } -> `Arity_0
+    | { attr_name = { Location.txt = "u"; _ }; _ } -> `Arity_n
+    | _ -> `No
   in
-  fun l p ->
-    match l with
-    | [] -> None
-    | a0 :: xs -> (
-        if p a0 then Some (exclude xs p)
-        else
-          match xs with
-          | [] -> None
-          | a1 :: rest -> (
-              if p a1 then Some (a0 :: exclude rest p)
-              else
-                match exclude_with_val rest p with
-                | None -> None
-                | Some rest -> Some (a0 :: a1 :: rest)))
+  let pred x = match is_uncurried x with `No -> false | _ -> true in
+  let rec exclude_with_val =
+    let rec exclude (xs : 'a list) =
+      match xs with
+      | [] -> []
+      | x :: xs -> if pred x then exclude xs else x :: exclude xs
+    in
+    fun l ->
+      match l with
+      | [] -> None
+      | a0 :: xs -> (
+          match is_uncurried a0 with
+          | `Arity_0 -> Some (exclude xs, true)
+          | `Arity_n -> Some (exclude xs, false)
+          | `No -> (
+              match xs with
+              | [] -> None
+              | a1 :: rest -> (
+                  match is_uncurried a1 with
+                  | `Arity_0 -> Some (a0 :: exclude rest, true)
+                  | `Arity_n -> Some (a0 :: exclude rest, false)
+                  | `No -> (
+                      match exclude_with_val rest with
+                      | None -> None
+                      | Some (rest, u) -> Some (a0 :: a1 :: rest, u)))))
+  in
+  fun l -> exclude_with_val l
 
 let app_exp_mapper e
     ((self, super) : Ast_traverse.map * (expression -> expression)) fn args =
@@ -105,7 +119,10 @@ let app_exp_mapper e
         pexp_desc =
           (if op = "##" then
              Ast_uncurry_apply.method_apply loc self obj name args
-           else Ast_uncurry_apply.property_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);
       }
   | Some { op; loc; _ } ->
       Location.raise_errorf ~loc "%s expect f%sproperty arg0 arg2 form" op op
@@ -208,12 +225,9 @@ let app_exp_mapper e
                     pexp_loc_stack = [];
                   }
               | _ -> (
-                  match
-                    ( exclude_with_val f_.pexp_attributes
-                        Ast_attributes.is_uncurried,
-                      f_.pexp_desc )
-                  with
-                  | Some other_attributes, Pexp_apply (fn1, args) ->
+                  match (is_uncurried f_.pexp_attributes, f_.pexp_desc) with
+                  | Some (other_attributes, zero_arity), Pexp_apply (fn1, args)
+                    ->
                       (* a |. f b c [@u]
                          Cannot process uncurried application early as the arity is wip *)
                       let fn1 = self#expression fn1 in
@@ -225,8 +239,8 @@ let app_exp_mapper e
                         fn1.pexp_attributes;
                       {
                         pexp_desc =
-                          Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self fn1
-                            ((Nolabel, a) :: args);
+                          Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self
+                            ~zero_arity fn1 ((Nolabel, a) :: args);
                         pexp_loc = e.pexp_loc;
                         pexp_loc_stack = e.pexp_loc_stack;
                         pexp_attributes = e.pexp_attributes @ other_attributes;
@@ -327,15 +341,14 @@ let app_exp_mapper e
       | Some { op; _ } -> Location.raise_errorf "invalid %s syntax" op
       | None ->
           let e =
-            match
-              exclude_with_val e.pexp_attributes Ast_attributes.is_uncurried
-            with
+            match is_uncurried e.pexp_attributes with
             | None -> super e
-            | Some pexp_attributes ->
+            | Some (pexp_attributes, zero_arity) ->
                 {
                   e with
                   pexp_desc =
-                    Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self fn args;
+                    Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self
+                      ~zero_arity fn args;
                   pexp_attributes;
                 }
           in

ppx/ast_typ_uncurry.ml

@@ -115,8 +115,8 @@ let generate_arg_type loc (mapper : Ast_traverse.map) method_name label pat body
         to_method_type loc mapper label x method_rest
     | _ -> assert false
 
-let to_uncurry_type loc (mapper : Ast_traverse.map) (label : Asttypes.arg_label)
-    (first_arg : core_type) (typ : core_type) =
+let to_uncurry_type loc (mapper : Ast_traverse.map) ~(zero_arity : bool)
+    (label : Asttypes.arg_label) (first_arg : core_type) (typ : core_type) =
   (* no need to error for optional here,
      since we can not make it
      TODO: still error out for external?
@@ -127,7 +127,7 @@ let to_uncurry_type loc (mapper : Ast_traverse.map) (label : Asttypes.arg_label)
   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 fn_type 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 ]

ppx/ast_typ_uncurry.mli

@@ -49,9 +49,19 @@ type uncurry_type_gen =
   core_type)
   cxt
 
-val to_uncurry_type : uncurry_type_gen
+val to_uncurry_type :
+  Ast_helper.loc ->
+  Ast_traverse.map ->
+  zero_arity:bool ->
+  Asttypes.arg_label ->
+  (* label for error checking *)
+  core_type ->
+  (* First arg *)
+  core_type ->
+  (* Tail *)
+  core_type
 (** syntax :
-    {[ int -> int -> int [@bs]]}
+    {[ int -> int -> int [@u]]}
 *)
 
 val to_method_type : uncurry_type_gen

ppx/ast_uncurry_apply.ml

@@ -29,7 +29,6 @@ open Ast_helper
    have a final checking for property arities
      [#=],
 *)
-let jsInternal = Ast_literal.js_internal
 
 (* we use the trick
    [( opaque e : _) ] to avoid it being inspected,
@@ -56,7 +55,7 @@ let opaque_full_apply ~loc e =
         [ (Nolabel, e) ],
       Typ.any ~loc () )
 
-let generic_apply loc (self : Ast_traverse.map) obj args
+let generic_apply loc (self : Ast_traverse.map) ~zero_arity obj args
     (cb : loc -> expression -> expression) =
   let obj = self#expression obj in
   let args =
@@ -68,18 +67,21 @@ let generic_apply loc (self : Ast_traverse.map) obj args
   in
   let fn = cb loc obj in
   let args =
-    match args with
-    | [
-     ( Nolabel,
-       { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, None); _ } );
-    ] ->
+    match (args, zero_arity) with
+    | ( [
+          ( Nolabel,
+            { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, None); _ }
+          );
+        ],
+        true ) ->
         []
     | _ -> args
   in
   let arity = List.length args in
   if arity = 0 then
     Pexp_apply
-      (Exp.ident { txt = Ldot (jsInternal, "run"); loc }, [ (Nolabel, fn) ])
+      ( Exp.ident { txt = Ldot (Ast_literal.js_internal, "run"); loc },
+        [ (Nolabel, fn) ] )
   else
     let arity_s = string_of_int arity in
     opaque_full_apply ~loc
@@ -145,9 +147,9 @@ let method_apply loc (self : Ast_traverse.map) obj name args =
             ])
          args)
 
-let uncurry_fn_apply loc self fn args =
-  generic_apply loc self fn args (fun _ obj -> obj)
+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 obj name args =
-  generic_apply loc self obj args (fun loc obj ->
+let property_apply loc self ~zero_arity obj name args =
+  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

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

ppx/ast_uncurry_gen.ml

@@ -91,7 +91,7 @@ let to_uncurry_fn loc (self : Ast_traverse.map) ~zero_arity
   let arity =
     let arity =
       match (rev_extra_args, zero_arity) with
-      | [ (_, _) ], true -> 0
+      | [ _ ], true -> 0
       | [ _ ], false -> len (* Ast_pat.is_unit_cont ~yes:0 ~no:len p *)
       | _ -> len
     in