Skip to content

Commit

Permalink
progress
Browse files Browse the repository at this point in the history
  • Loading branch information
anmonteiro committed Jan 1, 2024
1 parent bde2257 commit 4a4ea3e
Show file tree
Hide file tree
Showing 12 changed files with 171 additions and 83 deletions.
6 changes: 1 addition & 5 deletions ppx/ast_attributes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 };
Expand Down
1 change: 0 additions & 1 deletion ppx/ast_attributes.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
89 changes: 65 additions & 24 deletions ppx/ast_core_type.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
2 changes: 1 addition & 1 deletion ppx/ast_core_type.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
3 changes: 2 additions & 1 deletion ppx/ast_core_type_class_type.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
79 changes: 46 additions & 33 deletions ppx/ast_exp_apply.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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;
Expand Down Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions ppx/ast_typ_uncurry.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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?
Expand All @@ -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 ]
Expand Down
14 changes: 12 additions & 2 deletions ppx/ast_typ_uncurry.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
26 changes: 14 additions & 12 deletions ppx/ast_uncurry_apply.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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))
2 changes: 2 additions & 0 deletions ppx/ast_uncurry_apply.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 ->
Expand Down
2 changes: 1 addition & 1 deletion ppx/ast_uncurry_gen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading

0 comments on commit 4a4ea3e

Please sign in to comment.