From 338303754bede2d219bec2e97906b8b130b7face Mon Sep 17 00:00:00 2001 From: David Sancho Date: Thu, 18 Jul 2024 18:33:47 +0200 Subject: [PATCH] Add browser_only transformation to useEffect automatically (#145) --- demo/server/dune | 10 +- packages/browser-ppx/ppx.ml | 210 +++++++++++++++--------- packages/browser-ppx/tests/use_effect.t | 76 +++++++++ packages/melange.js/test.ml | 5 + packages/melange.ppx/double_hash.ml | 7 +- packages/melange.ppx/pipe_first.ml | 8 +- 6 files changed, 237 insertions(+), 79 deletions(-) create mode 100644 packages/browser-ppx/tests/use_effect.t diff --git a/demo/server/dune b/demo/server/dune index d876a9d16..83b386b13 100644 --- a/demo/server/dune +++ b/demo/server/dune @@ -2,6 +2,14 @@ (name server) (enabled_if (= %{profile} "dev")) - (libraries tiny_httpd shared_native react reactDOM js lwt.unix unix) + (libraries + tiny_httpd + tiny_httpd.core + shared_native + react + reactDOM + js + lwt.unix + unix) (preprocess (pps server_reason_react_ppx melange_native_ppx browser_ppx lwt_ppx))) diff --git a/packages/browser-ppx/ppx.ml b/packages/browser-ppx/ppx.ml index 687d0da65..6b8806e9a 100644 --- a/packages/browser-ppx/ppx.ml +++ b/packages/browser-ppx/ppx.ml @@ -139,45 +139,48 @@ module Browser_only = struct Builder.value_binding ~loc ~pat:pattern ~expr:(error_only_works_on ~loc)) - let extractor = Ast_pattern.(single_expr_payload __) + let extractor_single_payload = Ast_pattern.(single_expr_payload __) let expression_handler ~ctxt payload = - let loc = Expansion_context.Extension.extension_point_loc ctxt in + let replace_fun_body_with_raise_impossible ~loc pexp_desc = + match pexp_desc with + | Pexp_constraint + ( { + pexp_desc = + Pexp_fun (arg_label, _arg_expression, pattern, expression); + }, + type_constraint ) -> + let fn = browser_only_fun ~loc arg_label pattern expression in + Builder.pexp_constraint ~loc + { fn with pexp_attributes = expression.pexp_attributes } + type_constraint + | Pexp_fun (arg_label, _arg_expression, pattern, expr) -> + let function_name = get_function_name pattern.ppat_desc in + let new_fun_pattern = remove_type_constraint pattern in + Builder.pexp_fun ~loc arg_label None new_fun_pattern + (last_expr_to_raise_impossible ~loc function_name expr) + | Pexp_let (rec_flag, value_bindings, expression) -> + let pexp_let = + Builder.pexp_let ~loc rec_flag + (List.map + (fun binding -> + browser_only_value_binding binding.pvb_pat binding.pvb_expr) + value_bindings) + expression + in + [%expr [%e pexp_let]] + | _ -> error_only_works_on ~loc + in match !mode with | Js -> payload - | Native -> ( - match payload.pexp_desc with - | Pexp_constraint - ( { - pexp_desc = - Pexp_fun (arg_label, _arg_expression, pattern, expression); - }, - type_constraint ) -> - let fn = browser_only_fun ~loc arg_label pattern expression in - Builder.pexp_constraint ~loc - { fn with pexp_attributes = expression.pexp_attributes } - type_constraint - | Pexp_fun (arg_label, _arg_expression, pattern, expr) -> - let function_name = get_function_name pattern.ppat_desc in - let new_fun_pattern = remove_type_constraint pattern in - Builder.pexp_fun ~loc arg_label None new_fun_pattern - (last_expr_to_raise_impossible ~loc function_name expr) - | Pexp_let (rec_flag, value_bindings, expression) -> - let pexp_let = - Builder.pexp_let ~loc rec_flag - (List.map - (fun binding -> - browser_only_value_binding binding.pvb_pat binding.pvb_expr) - value_bindings) - expression - in - [%expr [%e pexp_let]] - | _ -> error_only_works_on ~loc) + | Native -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + replace_fun_body_with_raise_impossible ~loc payload.pexp_desc let expression_rule = Context_free.Rule.extension (Extension.V3.declare "browser_only" Extension.Context.expression - extractor expression_handler) + extractor_single_payload expression_handler) (* Generates a structure_item with a value binding with a pattern and an expression with all the alerts and warnings *) let make_vb_with_browser_only ~loc ?type_constraint pattern expression = @@ -203,7 +206,7 @@ module Browser_only = struct let%browser_only function."]) = ([%e expression] [@alert "-browser_only"])] - let extractor = + let extractor_vb = let open Ast_pattern in let extractor_in_let = pstr_value __ (value_binding ~pat:__ ~expr:__ ^:: nil) @@ -218,50 +221,103 @@ module Browser_only = struct | Nonrecursive -> [%stri let [%p pattern] = [%e expression]] in + let add_browser_only_alert expression = + match expression.pexp_desc with + | Pexp_constraint + ( { + pexp_desc = + Pexp_fun (arg_label, _arg_expression, fun_pattern, expr); + _; + }, + type_constraint ) -> + let original_function_name = get_function_name pattern.ppat_desc in + let new_fun_pattern = remove_type_constraint fun_pattern in + let fn = + Builder.pexp_fun ~loc arg_label None new_fun_pattern + (last_expr_to_raise_impossible ~loc original_function_name expr) + in + let item = { fn with pexp_attributes = expr.pexp_attributes } in + make_vb_with_browser_only ~loc ~type_constraint pattern item + | Pexp_fun (arg_label, _arg_expression, fun_pattern, expr) -> + let original_function_name = get_function_name pattern.ppat_desc in + let new_fun_pattern = remove_type_constraint fun_pattern in + let fn = + Builder.pexp_fun ~loc arg_label None new_fun_pattern + (last_expr_to_raise_impossible ~loc original_function_name expr) + in + let item = { fn with pexp_attributes = expr.pexp_attributes } in + make_vb_with_browser_only ~loc pattern item + | Pexp_ident { txt = _longident; loc } -> + let item = [%expr Obj.magic ()] in + make_vb_with_browser_only ~loc pattern item + | Pexp_newtype (name, expr) -> + let original_function_name = name.txt in + let item = + last_expr_to_raise_impossible ~loc original_function_name expr + in + make_vb_with_browser_only ~loc pattern item + | _expr -> do_nothing rec_flag + in + match !mode with (* When it's -js, keep item as it is *) | Js -> do_nothing rec_flag - | Native -> ( - match expression.pexp_desc with - | Pexp_constraint - ( { - pexp_desc = - Pexp_fun (arg_label, _arg_expression, fun_pattern, expr); - _; - }, - type_constraint ) -> - let original_function_name = get_function_name pattern.ppat_desc in - let new_fun_pattern = remove_type_constraint fun_pattern in - let fn = - Builder.pexp_fun ~loc arg_label None new_fun_pattern - (last_expr_to_raise_impossible ~loc original_function_name expr) - in - let item = { fn with pexp_attributes = expr.pexp_attributes } in - make_vb_with_browser_only ~loc ~type_constraint pattern item - | Pexp_fun (arg_label, _arg_expression, fun_pattern, expr) -> - let original_function_name = get_function_name pattern.ppat_desc in - let new_fun_pattern = remove_type_constraint fun_pattern in - let fn = - Builder.pexp_fun ~loc arg_label None new_fun_pattern - (last_expr_to_raise_impossible ~loc original_function_name expr) - in - let item = { fn with pexp_attributes = expr.pexp_attributes } in - make_vb_with_browser_only ~loc pattern item - | Pexp_ident { txt = _longident; loc } -> - let item = [%expr Obj.magic ()] in - make_vb_with_browser_only ~loc pattern item - | Pexp_newtype (name, expr) -> - let original_function_name = name.txt in - let item = - last_expr_to_raise_impossible ~loc original_function_name expr - in - make_vb_with_browser_only ~loc pattern item - | _expr -> do_nothing rec_flag) + | Native -> add_browser_only_alert expression let structure_item_rule = Context_free.Rule.extension (Extension.V3.declare "browser_only" Extension.Context.structure_item - extractor structure_item_handler) + extractor_vb structure_item_handler) + + let has_browser_only_attribute expr = + match expr.pexp_desc with + | Pexp_extension ({ txt = "browser_only" }, _) -> true + | _ -> false + + let use_effect (expr : expression) = + let add_browser_only_extension expr = + match expr.pexp_desc with + | Pexp_apply (_, [ (Nolabel, effect_body) ]) + when has_browser_only_attribute effect_body -> + None + | Pexp_apply (apply_expr, [ (Nolabel, effect_body); _ ]) + | Pexp_apply (apply_expr, [ (Nolabel, effect_body) ]) -> + let loc = expr.pexp_loc in + let new_effect_body = [%expr [%browser_only [%e effect_body]]] in + let new_effect_fun = + Builder.pexp_apply ~loc apply_expr [ (Nolabel, new_effect_body) ] + in + Some new_effect_fun + | _ -> None + in + match !mode with + (* When it's -js, keep item as it is *) + | Js -> None + | Native -> add_browser_only_extension expr + + let use_effects = + [ + (* useEffect *) + Context_free.Rule.special_function "React.useEffect" use_effect; + Context_free.Rule.special_function "React.useEffect0" use_effect; + Context_free.Rule.special_function "React.useEffect1" use_effect; + Context_free.Rule.special_function "React.useEffect2" use_effect; + Context_free.Rule.special_function "React.useEffect3" use_effect; + Context_free.Rule.special_function "React.useEffect4" use_effect; + Context_free.Rule.special_function "React.useEffect5" use_effect; + Context_free.Rule.special_function "React.useEffect6" use_effect; + Context_free.Rule.special_function "React.useEffect7" use_effect; + (* useLayoutEffect *) + Context_free.Rule.special_function "React.useLayoutEffect" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect0" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect1" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect2" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect3" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect4" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect5" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect6" use_effect; + Context_free.Rule.special_function "React.useLayoutEffect7" use_effect; + ] end module Preprocess = struct @@ -454,12 +510,14 @@ let () = Driver.add_arg "-js" (Unit (fun () -> mode := Js)) ~doc:"preprocess for js build"; - Driver.V2.register_transformation browser_ppx - ~rules: - [ - Browser_only.expression_rule; - Browser_only.structure_item_rule; - Platform.rule; - ] + let rules = + [ + Browser_only.expression_rule; + Browser_only.structure_item_rule; + Platform.rule; + ] + @ Browser_only.use_effects + in + Driver.V2.register_transformation browser_ppx ~rules ~preprocess_impl:Preprocess.preprocess_impl ~preprocess_intf:Preprocess.preprocess_intf diff --git a/packages/browser-ppx/tests/use_effect.t b/packages/browser-ppx/tests/use_effect.t new file mode 100644 index 000000000..c842cb897 --- /dev/null +++ b/packages/browser-ppx/tests/use_effect.t @@ -0,0 +1,76 @@ + $ cat > input.re << EOF + > [@react.component] + > let make = () => { + > let (state, dispatch) = React.useReducer(reducer, initialState); + > + > React.useEffect0(() => { + > dispatch @@ UsersRequestStarted; + > None; + > }); + > + >
; + > }; + > EOF + + $ refmt --parse re --print ml input.re > input.ml + +With -js flag everything keeps as it is + + $ ./standalone.exe -impl input.ml -js | ocamlformat - --enable-outside-detected-project --impl + let make () = + let state, dispatch = React.useReducer reducer initialState in + React.useEffect0 (fun () -> + dispatch @@ UsersRequestStarted; + None); + div ~children:[] () [@JSX] + [@@react.component] + +Without -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr + + $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl + let make () = + let state, dispatch = React.useReducer reducer initialState in + React.useEffect0 (fun () -> + Runtime.fail_impossible_action_in_ssr ""); + div ~children:[] () [@JSX] + [@@react.component] + + $ cat > input.re << EOF + > [@react.component] + > let make = () => { + > React.useEffect2( + > () => { + > if (uiState == Submitted) { + > dispatch @@ + > CurrentPasswordUpdated( + > switch (currentPassword) { + > | WithValue(value) when value == "" => Empty + > | _ => currentPassword + > }, + > ); + > + > switch (currentPassword, newPassword) { + > | (WithValue(currentPassword), Valid(newPassword)) when currentPassword != "" => + > passwordReset({oldPassword: currentPassword, newPassword}, dispatch, onConfirmed) + > | _ => dispatch @@ SubmitTriggered(Idle) + > }; + > }; + > None; + > }, + > (uiState, newPassword), + > ); + > + >
; + > }; + > EOF + + $ refmt --parse re --print ml input.re > input.ml + +Without -js flag, we add the browser_only transformation and browser_only applies the transformation to fail_impossible_action_in_ssr + + $ ./standalone.exe -impl input.ml | ocamlformat - --enable-outside-detected-project --impl + let make () = + React.useEffect2 (fun () -> + Runtime.fail_impossible_action_in_ssr ""); + div ~children:[] () [@JSX] + [@@react.component] diff --git a/packages/melange.js/test.ml b/packages/melange.js/test.ml index bcd89c72d..da033e0e4 100644 --- a/packages/melange.js/test.ml +++ b/packages/melange.js/test.ml @@ -248,6 +248,11 @@ let string_tests = assert_string (Js.String.replaceByRe "david" ~regexp:[%re "/d/"] ~replacement:"x") "xavid"); + (* test "replaceByRe with references ($n)" (fun () -> + assert_string + (Js.String.replaceByRe "david" ~regexp:[%re "/d(.*?)d/g"] + ~replacement:"$1") + "avi"); *) test "replaceByRe with global" (fun () -> assert_string (Js.String.replaceByRe "vowels be gone" ~regexp:[%re "/[aeiou]/g"] diff --git a/packages/melange.ppx/double_hash.ml b/packages/melange.ppx/double_hash.ml index 8ef0ba4fc..71a625927 100644 --- a/packages/melange.ppx/double_hash.ml +++ b/packages/melange.ppx/double_hash.ml @@ -5,7 +5,12 @@ let expander e = let loc = e.pexp_loc in match e.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Lident "##"; _ }; pexp_loc_stack = _ }, + ( { + pexp_desc = Pexp_ident { txt = Lident "##"; _ }; + pexp_loc_stack = _; + pexp_loc = _; + pexp_attributes = _; + }, [ (Nolabel, objectArg); (Nolabel, methodArg) ] ) -> ( match methodArg with | { pexp_desc = Pexp_ident { txt = Lident li; _ }; _ } -> diff --git a/packages/melange.ppx/pipe_first.ml b/packages/melange.ppx/pipe_first.ml index a0aa3dbef..b522e5902 100644 --- a/packages/melange.ppx/pipe_first.ml +++ b/packages/melange.ppx/pipe_first.ml @@ -8,7 +8,12 @@ let expander e = let loc = e.pexp_loc in match e.pexp_desc with | Pexp_apply - ( { pexp_desc = Pexp_ident { txt = Lident "|."; _ }; pexp_loc_stack }, + ( { + pexp_desc = Pexp_ident { txt = Lident "|."; _ }; + pexp_loc_stack; + pexp_loc = _; + pexp_attributes = _; + }, [ (Nolabel, arg); (Nolabel, fn) ] ) -> ( let fn = Option.value ~default:fn (expander' fn) in let arg = Option.value ~default:arg (expander' arg) in @@ -33,6 +38,7 @@ let expander e = pexp_desc = Pexp_construct (lident, None); pexp_loc; pexp_loc_stack; + pexp_attributes = _; } -> Some {