From b2376ae8ee22f80db866f9e09e7f1c79019f7e08 Mon Sep 17 00:00:00 2001 From: glennsl Date: Fri, 25 Feb 2022 19:41:16 +0100 Subject: [PATCH 1/4] ppx: allow locally abstract type in component definition --- ppx/ppx.ml | 2 ++ ppx/test/input_ocaml.ml | 2 ++ ppx/test/pp_ocaml.expected | 32 ++++++++++++++++++++++++++++++++ 3 files changed, 36 insertions(+) diff --git a/ppx/ppx.ml b/ppx/ppx.ml index 0de6e511..ee18b13b 100644 --- a/ppx/ppx.ml +++ b/ppx/ppx.ml @@ -681,6 +681,8 @@ let process_value_binding ~pstr_loc ~inside_component ~mapper binding = spelunk_for_fun_expr inner_fun_expr | { pexp_desc = Pexp_sequence (_wrapper_expr, inner_fun_expr) } -> spelunk_for_fun_expr inner_fun_expr + | {pexp_desc= Pexp_newtype (_label, inner_fun_expr)} -> + spelunk_for_fun_expr inner_fun_expr | exp -> Location.raise_errorf ~loc:exp.pexp_loc "react.component calls can only be on function definitions or \ diff --git a/ppx/test/input_ocaml.ml b/ppx/test/input_ocaml.ml index 0363d66b..a0d2eccb 100644 --- a/ppx/test/input_ocaml.ml +++ b/ppx/test/input_ocaml.ml @@ -13,6 +13,8 @@ let%component make ~children:(first, second) () = div [||] [ first; second ] let%component make ?(name = "") = div [||] [ name ] let%component make () = div [||] [] +let%component make (type a) ~(foo : a) : _ = div [||] [] + let%component make ~(bar : int option) = div [||] [ React.string (string_of_int (Option.value ~default:0 bar)) ] () diff --git a/ppx/test/pp_ocaml.expected b/ppx/test/pp_ocaml.expected index 67afc4d7..4a935277 100644 --- a/ppx/test/pp_ocaml.expected +++ b/ppx/test/pp_ocaml.expected @@ -222,6 +222,38 @@ let make = ((let make (Props : < > Js_of_ocaml.Js.t) = make () in fun ?key -> fun () -> React.create_element make (make_props ?key ())) [@merlin.hide ]) +let make = + let make_props + : foo:a -> + ?key:string -> + unit -> < foo: a Js_of_ocaml.Js.readonly_prop > Js_of_ocaml.Js.t + = + fun ~foo -> + fun ?key -> + fun () -> + let open Js_of_ocaml.Js.Unsafe in + obj + [|("key", + (inject + (Js_of_ocaml.Js.Optdef.option + (Option.map Js_of_ocaml.Js.string key))));("foo", + ( + inject + foo))|] + [@@merlin.hide ] in + let make (type a) ~foo:(foo : a) = (div [||] [] : _) in + ((let make + (Props : < foo: a Js_of_ocaml.Js.readonly_prop > Js_of_ocaml.Js.t) = + make + ~foo:(fun (type res) -> fun (type a0) -> + fun (a0 : a0 Js_of_ocaml.Js.t) -> + fun (_ : a0 -> < get: res ;.. > Js_of_ocaml.Js.gen_prop) + -> (Js_of_ocaml.Js.Unsafe.get a0 "foo" : res) + (Props : < .. > Js_of_ocaml.Js.t) (fun x -> x#foo)) in + fun ~foo -> + fun ?key -> + fun () -> React.create_element make (make_props ?key ~foo ())) + [@merlin.hide ]) let make = let make_props : bar:int option -> From 787cd90fd00586f2e57329dcc3bb7390eb59b5fa Mon Sep 17 00:00:00 2001 From: glennsl Date: Fri, 25 Feb 2022 20:08:28 +0100 Subject: [PATCH 2/4] ppx: allow type constraint on component definitions --- ppx/ppx.ml | 12 ++++++++---- ppx/test/input_ocaml.ml | 2 ++ ppx/test/pp_ocaml.expected | 35 +++++++++++++++++++++++++++++++++++ 3 files changed, 45 insertions(+), 4 deletions(-) diff --git a/ppx/ppx.ml b/ppx/ppx.ml index ee18b13b..10b44902 100644 --- a/ppx/ppx.ml +++ b/ppx/ppx.ml @@ -139,9 +139,11 @@ let filter_attr_name key attr = else false (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) -let getFnName binding = - match binding with - | { pvb_pat = { ppat_desc = Ppat_var { txt } } } -> txt +let rec getFnName = function + | {ppat_desc= Ppat_var {txt}} -> + txt + | {ppat_desc= Ppat_constraint (pat, _)} -> + getFnName pat | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") @@ -657,7 +659,7 @@ let process_value_binding ~pstr_loc ~inside_component ~mapper binding = if has_attr_on_binding binding || inside_component then let binding_loc = binding.pvb_loc in let binding_pat_loc = binding.pvb_pat.ppat_loc in - let fn_name = getFnName binding in + let fn_name = getFnName binding.pvb_pat in let modified_binding_old binding = let expression = binding.pvb_expr in (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) @@ -683,6 +685,8 @@ let process_value_binding ~pstr_loc ~inside_component ~mapper binding = spelunk_for_fun_expr inner_fun_expr | {pexp_desc= Pexp_newtype (_label, inner_fun_expr)} -> spelunk_for_fun_expr inner_fun_expr + | {pexp_desc= Pexp_constraint (inner_fun_expr, _typ)} -> + spelunk_for_fun_expr inner_fun_expr | exp -> Location.raise_errorf ~loc:exp.pexp_loc "react.component calls can only be on function definitions or \ diff --git a/ppx/test/input_ocaml.ml b/ppx/test/input_ocaml.ml index a0d2eccb..3909e4c8 100644 --- a/ppx/test/input_ocaml.ml +++ b/ppx/test/input_ocaml.ml @@ -15,6 +15,8 @@ let%component make () = div [||] [] let%component make (type a) ~(foo : a) : _ = div [||] [] +let%component make : type a. foo:a -> _ = fun ~foo:_ -> div [||] [] + let%component make ~(bar : int option) = div [||] [ React.string (string_of_int (Option.value ~default:0 bar)) ] () diff --git a/ppx/test/pp_ocaml.expected b/ppx/test/pp_ocaml.expected index 4a935277..df01a8c3 100644 --- a/ppx/test/pp_ocaml.expected +++ b/ppx/test/pp_ocaml.expected @@ -254,6 +254,41 @@ let make = fun ?key -> fun () -> React.create_element make (make_props ?key ~foo ())) [@merlin.hide ]) +let make = + let make_props + : foo:'foo -> + ?key:string -> + unit -> + < foo: 'foo Js_of_ocaml.Js.readonly_prop > Js_of_ocaml.Js.t + = + fun ~foo -> + fun ?key -> + fun () -> + let open Js_of_ocaml.Js.Unsafe in + obj + [|("key", + (inject + (Js_of_ocaml.Js.Optdef.option + (Option.map Js_of_ocaml.Js.string key))));("foo", + ( + inject + foo))|] + [@@merlin.hide ] in + let make (type a) = (fun ~foo:_ -> div [||] [] : foo:a -> _) in + ((let make + (Props : + < foo: 'foo Js_of_ocaml.Js.readonly_prop > Js_of_ocaml.Js.t) + = + make + ~foo:(fun (type res) -> fun (type a0) -> + fun (a0 : a0 Js_of_ocaml.Js.t) -> + fun (_ : a0 -> < get: res ;.. > Js_of_ocaml.Js.gen_prop) + -> (Js_of_ocaml.Js.Unsafe.get a0 "foo" : res) + (Props : < .. > Js_of_ocaml.Js.t) (fun x -> x#foo)) in + fun ~foo -> + fun ?key -> + fun () -> React.create_element make (make_props ?key ~foo ())) + [@merlin.hide ]) let make = let make_props : bar:int option -> From c2e86017e9d29e4cc6e09545e3c6bbf6b79fabbe Mon Sep 17 00:00:00 2001 From: glennsl Date: Fri, 25 Feb 2022 20:21:52 +0100 Subject: [PATCH 3/4] ppx: use Location.raise_errorf instead of invalid_arg in a few more places --- ppx/ppx.ml | 53 ++++++++++++++++++++++++++--------------------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/ppx/ppx.ml b/ppx/ppx.ml index 10b44902..35c73db5 100644 --- a/ppx/ppx.ml +++ b/ppx/ppx.ml @@ -80,11 +80,11 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc - | (Nolabel, _) :: _rest -> - raise - (Invalid_argument - "JSX: found non-labelled argument before the last position") - | arg :: rest -> allButLast_ rest (arg :: acc) + | (Nolabel, {pexp_loc}) :: _rest -> + Location.raise_errorf ~loc:pexp_loc + "JSX: found non-labelled argument before the last position" + | arg :: rest -> + allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in match @@ -98,9 +98,9 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = , if removeLastPositionUnit then allButLast props else props ) | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _ -> - raise - (Invalid_argument "JSX: somehow there's more than one `children` label") + | _first :: (_, {pexp_loc}) :: _rest, _props -> + Location.raise_errorf ~loc:pexp_loc + "JSX: somehow there's more than one `children` label" let unerasableIgnore loc = { attr_name = { txt = "warning"; loc } @@ -144,19 +144,19 @@ let rec getFnName = function txt | {ppat_desc= Ppat_constraint (pat, _)} -> getFnName pat - | _ -> - raise (Invalid_argument "react.component calls cannot be destructured.") + | {ppat_loc} -> + Location.raise_errorf ~loc:ppat_loc + "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> - { propsName = str } - | { txt }, _ -> - raise - (Invalid_argument - ("react.component only accepts props as an option, given: " - ^ Longident.last_exn txt)) + | {txt= Lident "props"}, {pexp_desc= Pexp_ident {txt= Lident str}} -> + {propsName= str} + | {txt; loc}, _ -> + Location.raise_errorf ~loc + "react.component only accepts props as an option, given: %s" + (Longident.last_exn txt) (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) let get_props_attr payload = @@ -171,16 +171,15 @@ let get_props_attr payload = List.fold_left getPropsNameValue default_props recordFields | Some (PStr - ({ pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) - } - :: _rest)) -> - { propsName = "props" } - | Some (PStr ({ pstr_desc = Pstr_eval (_, _) } :: _rest)) -> - raise - (Invalid_argument - "react.component accepts a record config with props as an options.") - | _ -> default_props + ({ pstr_desc= + Pstr_eval ({pexp_desc= Pexp_ident {txt= Lident "props"}}, _) } + :: _rest ) ) -> + {propsName= "props"} + | Some (PStr ({pstr_desc= Pstr_eval (_, _); pstr_loc} :: _rest)) -> + Location.raise_errorf ~loc:pstr_loc + "react.component accepts a record config with props as an options." + | _ -> + default_props (* Plucks the label, loc, and type_ from an AST node *) let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = From f7a708db10a513572c09ab603cf58051520bcae7 Mon Sep 17 00:00:00 2001 From: glennsl Date: Tue, 15 Mar 2022 20:52:34 +0100 Subject: [PATCH 4/4] style: formatting --- ppx/ppx.ml | 39 ++++++++++++++++++--------------------- ppx/test/input_ocaml.ml | 2 -- 2 files changed, 18 insertions(+), 23 deletions(-) diff --git a/ppx/ppx.ml b/ppx/ppx.ml index 35c73db5..efe10a1d 100644 --- a/ppx/ppx.ml +++ b/ppx/ppx.ml @@ -80,11 +80,10 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc - | (Nolabel, {pexp_loc}) :: _rest -> + | (Nolabel, { pexp_loc }) :: _rest -> Location.raise_errorf ~loc:pexp_loc "JSX: found non-labelled argument before the last position" - | arg :: rest -> - allButLast_ rest (arg :: acc) + | arg :: rest -> allButLast_ rest (arg :: acc) in let allButLast lst = allButLast_ lst [] |> List.rev in match @@ -98,7 +97,7 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = , if removeLastPositionUnit then allButLast props else props ) | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _first :: (_, {pexp_loc}) :: _rest, _props -> + | _first :: (_, { pexp_loc }) :: _rest, _props -> Location.raise_errorf ~loc:pexp_loc "JSX: somehow there's more than one `children` label" @@ -140,20 +139,18 @@ let filter_attr_name key attr = (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName = function - | {ppat_desc= Ppat_var {txt}} -> - txt - | {ppat_desc= Ppat_constraint (pat, _)} -> - getFnName pat - | {ppat_loc} -> + | { ppat_desc = Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat + | { ppat_loc } -> Location.raise_errorf ~loc:ppat_loc "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) let getPropsNameValue _acc (loc, exp) = match (loc, exp) with - | {txt= Lident "props"}, {pexp_desc= Pexp_ident {txt= Lident str}} -> - {propsName= str} - | {txt; loc}, _ -> + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> + { propsName = str } + | { txt; loc }, _ -> Location.raise_errorf ~loc "react.component only accepts props as an option, given: %s" (Longident.last_exn txt) @@ -171,15 +168,15 @@ let get_props_attr payload = List.fold_left getPropsNameValue default_props recordFields | Some (PStr - ({ pstr_desc= - Pstr_eval ({pexp_desc= Pexp_ident {txt= Lident "props"}}, _) } - :: _rest ) ) -> - {propsName= "props"} - | Some (PStr ({pstr_desc= Pstr_eval (_, _); pstr_loc} :: _rest)) -> + ({ pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) + } + :: _rest)) -> + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _); pstr_loc } :: _rest)) -> Location.raise_errorf ~loc:pstr_loc "react.component accepts a record config with props as an options." - | _ -> - default_props + | _ -> default_props (* Plucks the label, loc, and type_ from an AST node *) let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = @@ -682,9 +679,9 @@ let process_value_binding ~pstr_loc ~inside_component ~mapper binding = spelunk_for_fun_expr inner_fun_expr | { pexp_desc = Pexp_sequence (_wrapper_expr, inner_fun_expr) } -> spelunk_for_fun_expr inner_fun_expr - | {pexp_desc= Pexp_newtype (_label, inner_fun_expr)} -> + | { pexp_desc = Pexp_newtype (_label, inner_fun_expr) } -> spelunk_for_fun_expr inner_fun_expr - | {pexp_desc= Pexp_constraint (inner_fun_expr, _typ)} -> + | { pexp_desc = Pexp_constraint (inner_fun_expr, _typ) } -> spelunk_for_fun_expr inner_fun_expr | exp -> Location.raise_errorf ~loc:exp.pexp_loc diff --git a/ppx/test/input_ocaml.ml b/ppx/test/input_ocaml.ml index 3909e4c8..c6cd334e 100644 --- a/ppx/test/input_ocaml.ml +++ b/ppx/test/input_ocaml.ml @@ -12,9 +12,7 @@ let%component make ~children:kids = div [||] kids let%component make ~children:(first, second) () = div [||] [ first; second ] let%component make ?(name = "") = div [||] [ name ] let%component make () = div [||] [] - let%component make (type a) ~(foo : a) : _ = div [||] [] - let%component make : type a. foo:a -> _ = fun ~foo:_ -> div [||] [] let%component make ~(bar : int option) =