From 09523f39d1559c5a2335b6802cbe85eaa3b696b7 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Thu, 28 Dec 2023 20:41:01 +0000 Subject: [PATCH] progress --- ppx/ast_attributes.ml | 6 +-- ppx/ast_attributes.mli | 1 - ppx/ast_core_type.ml | 89 ++++++++++++++++++++++++--------- ppx/ast_core_type.mli | 2 +- ppx/ast_core_type_class_type.ml | 3 +- ppx/ast_exp_apply.ml | 79 +++++++++++++++++------------ ppx/ast_typ_uncurry.ml | 6 +-- ppx/ast_typ_uncurry.mli | 14 +++++- ppx/ast_uncurry_apply.ml | 26 +++++----- ppx/ast_uncurry_apply.mli | 2 + ppx/ast_uncurry_gen.ml | 2 +- test/blackbox-tests/uncurry-0.t | 24 +++++++++ 12 files changed, 171 insertions(+), 83 deletions(-) create mode 100644 test/blackbox-tests/uncurry-0.t diff --git a/ppx/ast_attributes.ml b/ppx/ast_attributes.ml index 88d805358..b9bafb2c6 100644 --- a/ppx/ast_attributes.ml +++ b/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 }; diff --git a/ppx/ast_attributes.mli b/ppx/ast_attributes.mli index d04d84c96..7b46c81b4 100644 --- a/ppx/ast_attributes.mli +++ b/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 diff --git a/ppx/ast_core_type.ml b/ppx/ast_core_type.ml index e8e375dd7..fb93e3e32 100644 --- a/ppx/ast_core_type.ml +++ b/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 diff --git a/ppx/ast_core_type.mli b/ppx/ast_core_type.mli index 4fce18ba5..62b2e258c 100644 --- a/ppx/ast_core_type.mli +++ b/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 *) diff --git a/ppx/ast_core_type_class_type.ml b/ppx/ast_core_type_class_type.ml index 244c1abcc..5f8091762 100644 --- a/ppx/ast_core_type_class_type.ml +++ b/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 diff --git a/ppx/ast_exp_apply.ml b/ppx/ast_exp_apply.ml index 5d51f2e8d..240e91d69 100644 --- a/ppx/ast_exp_apply.ml +++ b/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 diff --git a/ppx/ast_typ_uncurry.ml b/ppx/ast_typ_uncurry.ml index 73560f8b7..e6695704b 100644 --- a/ppx/ast_typ_uncurry.ml +++ b/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 ] diff --git a/ppx/ast_typ_uncurry.mli b/ppx/ast_typ_uncurry.mli index 980bc840e..925262047 100644 --- a/ppx/ast_typ_uncurry.mli +++ b/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 diff --git a/ppx/ast_uncurry_apply.ml b/ppx/ast_uncurry_apply.ml index da2a751a6..bcb3bafd8 100644 --- a/ppx/ast_uncurry_apply.ml +++ b/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)) diff --git a/ppx/ast_uncurry_apply.mli b/ppx/ast_uncurry_apply.mli index 2ed24cb61..2e5a6fa4b 100644 --- a/ppx/ast_uncurry_apply.mli +++ b/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 -> diff --git a/ppx/ast_uncurry_gen.ml b/ppx/ast_uncurry_gen.ml index daff7f62b..a66f4b0b6 100644 --- a/ppx/ast_uncurry_gen.ml +++ b/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 diff --git a/test/blackbox-tests/uncurry-0.t b/test/blackbox-tests/uncurry-0.t new file mode 100644 index 000000000..34b465794 --- /dev/null +++ b/test/blackbox-tests/uncurry-0.t @@ -0,0 +1,24 @@ + + $ . ./setup.sh + +Test some error cases + + $ cat > x.ml < external valToFn : 'a -> (int -> 'a[@u0]) = "foo" + > EOF + $ melc -ppx melppx x.ml + File "x.ml", line 1, characters 26-29: + 1 | external valToFn : 'a -> (int -> 'a[@u0]) = "foo" + ^^^ + Error: `[@u0]' can only be used with the `unit' type + [2] + + $ cat > x.ml < external valToFn : 'a -> (unit -> int -> 'a[@u0]) = "foo" + > EOF + $ melc -ppx melppx x.ml + File "x.ml", line 1, characters 34-43: + 1 | external valToFn : 'a -> (unit -> int -> 'a[@u0]) = "foo" + ^^^^^^^^^ + Error: `[@u0]' cannot be used with multiple arguments + [2]