From db88952bb5f69a5e551cf142f02500f1c658d661 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sun, 6 Nov 2022 10:54:43 -0800 Subject: [PATCH] [melange]: remove dependency on rescript syntax (#411) * [melange]: remove dependency on rescript syntax * tweak dependency specification --- Changes.md | 4 + dune-project | 4 +- jscomp/common/js_config.cppo.ml | 2 - jscomp/common/js_config.mli | 1 - jscomp/core/dune | 4 +- jscomp/core/js_implementation.ml | 10 +- jscomp/core/js_implementation.mli | 12 +- jscomp/ext/ext_file_extensions.ml | 4 - jscomp/frontend/dune | 2 +- jscomp/frontend/ppx_entry.ml | 4 +- jscomp/main/dune | 1 - jscomp/main/melc.ml | 79 +- jscomp/main/melc_cli.ml | 48 +- jscomp/napkin/dune | 14 +- .../ppx_rescript_compat.ml | 0 .../ppx_rescript_compat.mli | 0 jscomp/napkin/res_driver.ml | 6 +- mel/bsb_ninja_file_groups.ml | 21 +- mel/mel_rule.ml | 6 + mel/mel_rule.mli | 1 + nix/default.nix | 9 +- ppx_rescript_compat/dune | 3 - reactjs_jsx_ppx/dune | 4 + reactjs_jsx_ppx/reactjs_jsx_ppx_v3.ml | 932 ++++++++++++++++++ reactjs_jsx_ppx/reactjs_jsx_ppx_v3.mli | 39 + 25 files changed, 1052 insertions(+), 158 deletions(-) rename {ppx_rescript_compat => jscomp/napkin/ppx_rescript_compat}/ppx_rescript_compat.ml (100%) rename {ppx_rescript_compat => jscomp/napkin/ppx_rescript_compat}/ppx_rescript_compat.mli (100%) delete mode 100644 ppx_rescript_compat/dune create mode 100644 reactjs_jsx_ppx/dune create mode 100644 reactjs_jsx_ppx/reactjs_jsx_ppx_v3.ml create mode 100644 reactjs_jsx_ppx/reactjs_jsx_ppx_v3.mli diff --git a/Changes.md b/Changes.md index f03b84d7a5..7277d0d7cb 100644 --- a/Changes.md +++ b/Changes.md @@ -14,6 +14,10 @@ Unreleased - [melange]: Remove dependency on `reason`. Reason syntax users should install` reason` from their preferred package manager instead, and Melange / Dune will find it in `$PATH` ([#409](https://github.com/melange-re/melange/pull/409)) +- [melange]: Remove dependency on `napkin` (the ReScript syntax parser). Users + that depend on libraries written in ReScript syntax should install the `mel` + package and Melange / Dune will find the `rescript_syntax` binary in `$PATH` + ([#411](https://github.com/melange-re/melange/pull/411)) 0.2.0 2022-10-24 -------------- diff --git a/dune-project b/dune-project index 1521646b0f..8194df3e6d 100644 --- a/dune-project +++ b/dune-project @@ -40,8 +40,6 @@ (>= "1.1.0")) (base64 (>= "3.1.0")) - (ocaml-migrate-parsetree - (>= "2.3.0")) (cppo :build) (ounit :with-test))) @@ -56,4 +54,6 @@ (>= "1.1.0")) (luv (>= "0.5.11")) + (ocaml-migrate-parsetree + (>= "2.3.0")) (ounit :with-test))) diff --git a/jscomp/common/js_config.cppo.ml b/jscomp/common/js_config.cppo.ml index 00e1be7f4f..0865d27ea4 100644 --- a/jscomp/common/js_config.cppo.ml +++ b/jscomp/common/js_config.cppo.ml @@ -113,8 +113,6 @@ let no_stdlib = ref false let no_export = ref false -let format = ref None - let as_ppx = ref false diff --git a/jscomp/common/js_config.mli b/jscomp/common/js_config.mli index e7533a5c9a..cc9e3a1992 100644 --- a/jscomp/common/js_config.mli +++ b/jscomp/common/js_config.mli @@ -75,7 +75,6 @@ val js_stdout : bool ref val all_module_aliases : bool ref val no_stdlib : bool ref val no_export : bool ref -val format : Ext_file_extensions.syntax_kind option ref val as_ppx : bool ref val customize_runtime : string option ref val as_pp : bool ref diff --git a/jscomp/core/dune b/jscomp/core/dune index 793c518e07..953bdffe3c 100644 --- a/jscomp/core/dune +++ b/jscomp/core/dune @@ -13,9 +13,7 @@ frontend melange-compiler-libs outcome_printer - js_parser - ppx_rescript_compat - napkin)) + js_parser)) (rule (targets js_fold.ml) diff --git a/jscomp/core/js_implementation.ml b/jscomp/core/js_implementation.ml index 05e6cfaca0..80f1db24cc 100644 --- a/jscomp/core/js_implementation.ml +++ b/jscomp/core/js_implementation.ml @@ -99,7 +99,7 @@ let after_parsing_sig ppf outputprefix ast = initial_env sg; process_with_gentype (outputprefix ^ ".cmti")) -let interface ~parser ~lang:_ ppf fname = +let interface ~parser ppf fname = Res_compmisc.init_path (); let sig_ = parser fname |> Ast_deriving_compat.signature in sig_ @@ -190,14 +190,10 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Lam_compile_main.lambda_as_module ~package_info js_program outputprefix); process_with_gentype (outputprefix ^ ".cmt") -let implementation ~parser ~lang ppf fname = +let implementation ~parser ppf fname = Res_compmisc.init_path (); - let str = parser fname |> Ast_deriving_compat.structure in - let str = - match lang with `rescript -> Ppx_rescript_compat.structure str | _ -> str - in - str + parser fname |> Ast_deriving_compat.structure |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml |> Ppx_entry.rewrite_implementation diff --git a/jscomp/core/js_implementation.mli b/jscomp/core/js_implementation.mli index 643c687c7d..b5f50588a4 100644 --- a/jscomp/core/js_implementation.mli +++ b/jscomp/core/js_implementation.mli @@ -25,11 +25,7 @@ (** High level compilation module *) val interface : - parser:(string -> Parsetree.signature) -> - lang:[ `ml | `rescript ] -> - Format.formatter -> - string -> - unit + parser:(string -> Parsetree.signature) -> Format.formatter -> string -> unit (** This module defines a function to compile the program directly into [js] given [filename] and [outputprefix], it will be useful if we don't care about bytecode output(generating js only). @@ -48,11 +44,7 @@ val interface_mliast : Format.formatter -> string -> unit *) val implementation : - parser:(string -> Parsetree.structure) -> - lang:[ `ml | `rescript ] -> - Format.formatter -> - string -> - unit + parser:(string -> Parsetree.structure) -> Format.formatter -> string -> unit (** [implementation ppf sourcefile outprefix] compiles to JS directly *) val implementation_mlast : Format.formatter -> string -> unit diff --git a/jscomp/ext/ext_file_extensions.ml b/jscomp/ext/ext_file_extensions.ml index b3fc1593aa..bc0e5bd7be 100644 --- a/jscomp/ext/ext_file_extensions.ml +++ b/jscomp/ext/ext_file_extensions.ml @@ -3,8 +3,6 @@ type syntax_kind = Ml | Res type valid_input = | Ml | Mli - | Res - | Resi | Intf_ast | Impl_ast | Mlmap @@ -25,7 +23,5 @@ let classify_input ext = | _ when ext = Literals.suffix_iast -> Intf_ast | _ when ext = Literals.suffix_mlmap -> Mlmap | _ when ext = Literals.suffix_cmi -> Cmi - | _ when ext = Literals.suffix_res -> Res - | _ when ext = Literals.suffix_resi -> Resi | _ when ext = Literals.suffix_cmj -> Cmj | _ -> Unknown diff --git a/jscomp/frontend/dune b/jscomp/frontend/dune index aeb8baf868..3724d799ec 100644 --- a/jscomp/frontend/dune +++ b/jscomp/frontend/dune @@ -12,4 +12,4 @@ melange-compiler-libs outcome_printer js_parser - napkin)) + reactjs_jsx_ppx_v3)) diff --git a/jscomp/frontend/ppx_entry.ml b/jscomp/frontend/ppx_entry.ml index 9a56c4e491..20a156ce29 100644 --- a/jscomp/frontend/ppx_entry.ml +++ b/jscomp/frontend/ppx_entry.ml @@ -29,7 +29,7 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = Ast_config.iter_on_bs_config_sigi ast; let ast = match !Js_config.jsx_version with - | 3 -> Napkin.Reactjs_jsx_ppx_v3.rewrite_signature ast + | 3 -> Reactjs_jsx_ppx_v3.rewrite_signature ast | _ -> ast (* react-jsx ppx relies on built-in ones like `##` *) in @@ -45,7 +45,7 @@ let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = Ast_config.iter_on_bs_config_stru ast; let ast = match !Js_config.jsx_version with - | 3 -> Napkin.Reactjs_jsx_ppx_v3.rewrite_implementation ast + | 3 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast | _ -> ast in if !Js_config.no_builtin_ppx then ast diff --git a/jscomp/main/dune b/jscomp/main/dune index ef3678e8b5..2894ba69c9 100644 --- a/jscomp/main/dune +++ b/jscomp/main/dune @@ -11,7 +11,6 @@ outcome_printer melange-compiler-libs core - napkin cmdliner) (modules melc melc_cli) (preprocessor_deps ../../package.json ../../bsconfig.json) diff --git a/jscomp/main/melc.ml b/jscomp/main/melc.ml index b1468c9e85..5b9c177644 100644 --- a/jscomp/main/melc.ml +++ b/jscomp/main/melc.ml @@ -46,25 +46,11 @@ let process_file sourcefile let sourcefile = set_abs_input_name sourcefile in Js_implementation.implementation ~parser:Pparse_driver.parse_implementation - ~lang:`ml ppf sourcefile | Mli -> let sourcefile = set_abs_input_name sourcefile in Js_implementation.interface ~parser:Pparse_driver.parse_interface - ~lang:`ml - ppf sourcefile - | Res -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.implementation - ~parser:Napkin.Res_driver.parse_implementation - ~lang:`rescript - ppf sourcefile - | Resi -> - let sourcefile = set_abs_input_name sourcefile in - Js_implementation.interface - ~parser:Napkin.Res_driver.parse_interface - ~lang:`rescript ppf sourcefile | Intf_ast -> @@ -89,63 +75,6 @@ let process_file sourcefile let ppf = Format.err_formatter -(* Error messages to standard error formatter *) -open struct - let handle_res_parse_result (parse_result : _ Napkin.Res_driver.parseResult) = - if parse_result.invalid then begin - Napkin.Res_diagnostics.printReport parse_result.diagnostics parse_result.source; - exit 1 - end -end - -let print_res_interface ~comments ast = - Napkin.Res_printer.printInterface ~width:100 ~comments ast - -let print_res_implementation ~comments ast = - Napkin.Res_printer.printImplementation ~width:100 ~comments ast - -(* TODO: support printing from AST too. *) -let format_file ~(kind: Ext_file_extensions.syntax_kind) input = - let ext = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) in - let impl_format_fn ~comments ast = - match kind, comments with - | Res, `Res comments -> - let ast = Napkin.Import.From_current.copy_structure ast in - output_string stdout (print_res_implementation ~comments ast) - | Res, `Re _ -> - let ast = Napkin.Import.From_current.copy_structure ast in - output_string stdout (print_res_implementation ~comments:[] ast) - | _ -> raise (Arg.Bad ("don't know what to do with " ^ input)) - in - let intf_format_fn ~comments ast = - match kind, comments with - | Res, `Res comments -> - let ast = Napkin.Import.From_current.copy_signature ast in - output_string stdout (print_res_interface ~comments ast) - | Res, `Re _ -> - let ast = Napkin.Import.From_current.copy_signature ast in - output_string stdout (print_res_interface ~comments:[] ast) - | _ -> raise (Arg.Bad ("don't know what to do with " ^ input)) - in - begin match ext with - | Res -> - let parse_result = - Napkin.Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename:input - in - handle_res_parse_result parse_result; - impl_format_fn - ~comments:(`Res parse_result.comments) - parse_result.parsetree - | Resi -> - let parse_result = - Napkin.Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename:input - in - intf_format_fn - ~comments:(`Res parse_result.comments) - parse_result.parsetree - | _ -> (raise (Arg.Bad ("don't know what to do with " ^ input))) - end - let anonymous ~(rev_args : string list) = if !Js_config.as_ppx then match rev_args with @@ -169,11 +98,7 @@ let anonymous ~(rev_args : string list) = end else match rev_args with - | [filename] -> - begin match !Js_config.format with - | Some syntax_kind -> `Ok (format_file ~kind:syntax_kind filename) - | None -> `Ok (process_file filename ppf) - end + | [filename] -> `Ok (process_file filename ppf) | [] -> `Ok () | _ -> `Error (false, "can not handle multiple files") @@ -278,7 +203,6 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret bs_no_builtin_ppx; bs_cross_module_opt; bs_diagnose; - format; where; verbose; keep_locs; @@ -395,7 +319,6 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret if bs_no_builtin_ppx then Js_config.no_builtin_ppx := bs_no_builtin_ppx; if bs_diagnose then Js_config.diagnose := bs_diagnose; - Ext_option.iter format (fun format -> Js_config.format := Some format); if where then print_standard_library (); if verbose then Clflags.verbose := verbose; Ext_option.iter keep_locs (fun keep_locs -> Clflags.keep_locs := keep_locs); diff --git a/jscomp/main/melc_cli.ml b/jscomp/main/melc_cli.ml index 094d8d792b..37ad56fe1c 100644 --- a/jscomp/main/melc_cli.ml +++ b/jscomp/main/melc_cli.ml @@ -59,7 +59,6 @@ type t = { bs_no_builtin_ppx : bool; bs_cross_module_opt : bool option; bs_diagnose : bool; - format : Ext_file_extensions.syntax_kind option; where : bool; verbose : bool; keep_locs : bool option; @@ -194,29 +193,6 @@ let bs_e = in Arg.(value & opt (some string) None & info [ "e" ] ~doc) -let format = - let ext_conv = - let parse ext : (Ext_file_extensions.syntax_kind, _) result = - match Ext_string.trim ext with - | "res" -> Ok Res - | "ml" -> Ok Ml - | x -> - Error - (`Msg - (Format.asprintf - "invalid option `%s` passed to -format, expected `re`, `res` \ - or `ml`" - x)) - in - let print fmt (ext : Ext_file_extensions.syntax_kind) = - let s = match ext with Ext_file_extensions.Res -> "res" | Ml -> "ml" in - Format.fprintf fmt "%s" s - in - Arg.conv ~docv:"ext" (parse, print) - in - let doc = "Format as Res syntax" in - Arg.(value & opt (some ext_conv) None & info [ "format" ] ~doc) - let where = let doc = "Print location of standard library and exit" in Arg.(value & flag & info [ "where" ] ~doc) @@ -510,8 +486,8 @@ let parse help include_dirs alerts warnings output_name bs_read_cmi ppx bs_g bs_package_name bs_ns as_ppx as_pp no_alias_deps bs_gentype unboxed_types bs_D bs_unsafe_empty_array nostdlib color bs_list_conditionals bs_eval bs_e bs_cmi_only bs_cmi bs_cmj bs_no_version_header - bs_no_builtin_ppx bs_cross_module_opt bs_diagnose format where verbose - keep_locs bs_no_check_div_by_zero bs_noassertfalse noassert bs_loc impl intf + bs_no_builtin_ppx bs_cross_module_opt bs_diagnose where verbose keep_locs + bs_no_check_div_by_zero bs_noassertfalse noassert bs_loc impl intf intf_suffix g opaque strict_sequence strict_formats dtypedtree dparsetree drawlambda dsource version pp absname bin_annot i nopervasives modules nolabels principal short_paths unsafe warn_help warn_error bs_stop_after_cmj @@ -552,7 +528,6 @@ let parse help include_dirs alerts warnings output_name bs_read_cmi ppx bs_no_builtin_ppx; bs_cross_module_opt; bs_diagnose; - format; where; verbose; keep_locs; @@ -600,16 +575,15 @@ let cmd = $ color $ bs_list_conditionals $ Internal.bs_eval $ bs_e $ Internal.bs_cmi_only $ Internal.bs_cmi $ Internal.bs_cmj $ Internal.bs_no_version_header $ Internal.bs_no_builtin_ppx - $ Internal.bs_cross_module_opt $ Internal.bs_diagnose $ format $ where - $ verbose $ keep_locs $ Internal.bs_no_check_div_by_zero - $ Internal.bs_noassertfalse $ Internal.noassert $ Internal.bs_loc - $ Internal.impl $ Internal.intf $ Internal.intf_suffix $ Internal.g - $ Internal.opaque $ Internal.strict_sequence $ Internal.strict_formats - $ Internal.dtypedtree $ Internal.dparsetree $ Internal.drawlambda - $ Internal.dsource $ version $ pp $ absname $ bin_annot $ i - $ Internal.nopervasives $ Internal.modules $ Internal.nolabels - $ Internal.principal $ Internal.short_paths $ unsafe $ warn_help - $ warn_error $ bs_stop_after_cmj $ Internal.runtime $ filenames + $ Internal.bs_cross_module_opt $ Internal.bs_diagnose $ where $ verbose + $ keep_locs $ Internal.bs_no_check_div_by_zero $ Internal.bs_noassertfalse + $ Internal.noassert $ Internal.bs_loc $ Internal.impl $ Internal.intf + $ Internal.intf_suffix $ Internal.g $ Internal.opaque + $ Internal.strict_sequence $ Internal.strict_formats $ Internal.dtypedtree + $ Internal.dparsetree $ Internal.drawlambda $ Internal.dsource $ version + $ pp $ absname $ bin_annot $ i $ Internal.nopervasives $ Internal.modules + $ Internal.nolabels $ Internal.principal $ Internal.short_paths $ unsafe + $ warn_help $ warn_error $ bs_stop_after_cmj $ Internal.runtime $ filenames $ Compat.bs_super_errors $ Compat.c) (* Different than Ext_cli_args because we need to normalize `-w -foo` to diff --git a/jscomp/napkin/dune b/jscomp/napkin/dune index ca6fec215d..c1c9e7acb2 100644 --- a/jscomp/napkin/dune +++ b/jscomp/napkin/dune @@ -1,5 +1,17 @@ +(include_subdirs unqualified) + (library (name napkin) (flags (:standard -w -9)) - (libraries ocaml-migrate-parsetree compiler-libs.common)) + (modules :standard \ res_cli) + (libraries frontend ocaml-migrate-parsetree compiler-libs.common)) + +(executable + (name res_cli) + (public_name rescript_syntax) + (package mel) + (modules res_cli) + (flags + (-open Napkin)) + (libraries napkin)) diff --git a/ppx_rescript_compat/ppx_rescript_compat.ml b/jscomp/napkin/ppx_rescript_compat/ppx_rescript_compat.ml similarity index 100% rename from ppx_rescript_compat/ppx_rescript_compat.ml rename to jscomp/napkin/ppx_rescript_compat/ppx_rescript_compat.ml diff --git a/ppx_rescript_compat/ppx_rescript_compat.mli b/jscomp/napkin/ppx_rescript_compat/ppx_rescript_compat.mli similarity index 100% rename from ppx_rescript_compat/ppx_rescript_compat.mli rename to jscomp/napkin/ppx_rescript_compat/ppx_rescript_compat.mli diff --git a/jscomp/napkin/res_driver.ml b/jscomp/napkin/res_driver.ml index 24642f7273..26cb38485d 100644 --- a/jscomp/napkin/res_driver.ml +++ b/jscomp/napkin/res_driver.ml @@ -46,7 +46,11 @@ let setup ~filename ~forPrinter () = let parsingEngine = { parseImplementation = begin fun ~forPrinter ~filename -> let engine = setup ~filename ~forPrinter () in - let structure = Res_core.parseImplementation engine |> To_current.copy_structure in + let structure = + Res_core.parseImplementation engine + |> To_current.copy_structure + |> Ppx_rescript_compat.structure + in let (invalid, diagnostics) = match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) | _ as diagnostics -> (true, diagnostics) diff --git a/mel/bsb_ninja_file_groups.ml b/mel/bsb_ninja_file_groups.ml index cea69d6992..60d891acaf 100644 --- a/mel/bsb_ninja_file_groups.ml +++ b/mel/bsb_ninja_file_groups.ml @@ -65,6 +65,8 @@ type suffixes = { impl : string; intf : string } let re_suffixes = { impl = Literals.suffix_re; intf = Literals.suffix_rei } let ml_suffixes = { impl = Literals.suffix_ml; intf = Literals.suffix_mli } let res_suffixes = { impl = Literals.suffix_res; intf = Literals.suffix_resi } +let reason_rule ?target:_ oc = Mel_rule.process_reason oc +let rescript_rule ?target:_ oc = Mel_rule.process_rescript oc let emit_module_build (package_specs : Bsb_package_specs.t) (is_dev : bool) oc ?gentype_config ~global_config ~bs_dependencies ~bs_dev_dependencies @@ -158,7 +160,6 @@ let emit_module_build (package_specs : Bsb_package_specs.t) (is_dev : bool) oc output_filename_sans_extension in let ast_rule ?target:_ oc = Mel_rule.ast global_config oc cur_dir in - let reason_rule ?target:_ oc = Mel_rule.process_reason oc in if which <> `intf then ( let input_impl = match module_info.syntax_kind with @@ -169,7 +170,14 @@ let emit_module_build (package_specs : Bsb_package_specs.t) (is_dev : bool) oc Bsb_ninja_targets.output_build oc ~outputs:[ ast_input_impl ] ~inputs:[ input_impl ] ~rule:reason_rule; ast_input_impl - | Different _ | Same (Ml | Res) -> input_impl + | Same Res | Different { impl = Res; _ } -> + let ast_input_impl = + input_impl ^ Literals.suffix_pp ^ Literals.suffix_ml + in + Bsb_ninja_targets.output_build oc ~outputs:[ ast_input_impl ] + ~inputs:[ input_impl ] ~rule:rescript_rule; + ast_input_impl + | Different _ | Same Ml -> input_impl in Bsb_ninja_targets.output_build oc @@ -214,7 +222,14 @@ let emit_module_build (package_specs : Bsb_package_specs.t) (is_dev : bool) oc Bsb_ninja_targets.output_build oc ~outputs:[ ast_input_intf ] ~inputs:[ input_intf ] ~rule:reason_rule; ast_input_intf - | Different _ | Same (Ml | Res) -> input_intf + | Same Res | Different { intf = Res; _ } -> + let ast_input_intf = + input_intf ^ Literals.suffix_pp ^ Literals.suffix_mli + in + Bsb_ninja_targets.output_build oc ~outputs:[ ast_input_intf ] + ~inputs:[ input_intf ] ~rule:rescript_rule; + ast_input_intf + | Different _ | Same Ml -> input_intf in Bsb_ninja_targets.output_build oc ~outputs:[ output_iast ] diff --git a/mel/mel_rule.ml b/mel/mel_rule.ml index 6340eb3080..5ba359c286 100644 --- a/mel/mel_rule.ml +++ b/mel/mel_rule.ml @@ -82,6 +82,12 @@ let cmj, cmj_dev = aux ~read_cmi:`yes let cmij, cmij_dev = aux ~read_cmi:`no let cmi, cmi_dev = aux ~read_cmi:`is_cmi +let process_rescript oc = + output_string oc + {|(action + (with-stdout-to %{targets} + (run rescript_syntax -print=binary %{inputs})))|} + let process_reason oc = output_string oc {|(action diff --git a/mel/mel_rule.mli b/mel/mel_rule.mli index e6df0c33f1..863f087748 100644 --- a/mel/mel_rule.mli +++ b/mel/mel_rule.mli @@ -77,6 +77,7 @@ val cmi_dev : unit val process_reason : out_channel -> unit +val process_rescript : out_channel -> unit val ast : Bsb_ninja_global_vars.t -> out_channel -> string -> unit val meldep : Bsb_ninja_global_vars.t -> out_channel -> string -> unit val meldep_dev : Bsb_ninja_global_vars.t -> out_channel -> string -> unit diff --git a/nix/default.nix b/nix/default.nix index 36f2cef235..9ac3dca1c5 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -22,7 +22,7 @@ rec { "lib" "test" "mel_workspace" - "ppx_rescript_compat" + "reactjs_jsx_ppx" "scripts" ]; exclude = [ "jscomp/test" ]; @@ -48,7 +48,6 @@ rec { melange-compiler-libs cmdliner base64 - ocaml-migrate-parsetree-2 ]; meta.mainProgram = "melc"; }; @@ -74,6 +73,11 @@ rec { "jscomp/bsb_helper" "jscomp/stubs" "jscomp/common" + "jscomp/frontend" + "reactjs_jsx_ppx" + "jscomp/napkin" + "jscomp/js_parser" + "jscomp/outcome_printer" "mel_workspace" ]; }; @@ -83,6 +87,7 @@ rec { melange cmdliner luv + ocaml-migrate-parsetree-2 ]; meta.mainProgram = "mel"; diff --git a/ppx_rescript_compat/dune b/ppx_rescript_compat/dune deleted file mode 100644 index 1139d12bd2..0000000000 --- a/ppx_rescript_compat/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name ppx_rescript_compat) - (libraries frontend)) diff --git a/reactjs_jsx_ppx/dune b/reactjs_jsx_ppx/dune new file mode 100644 index 0000000000..8fb9d29937 --- /dev/null +++ b/reactjs_jsx_ppx/dune @@ -0,0 +1,4 @@ +(library + (name reactjs_jsx_ppx_v3) + (flags :standard -w -9) + (libraries compiler-libs.common)) diff --git a/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.ml b/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.ml new file mode 100644 index 0000000000..f11047b057 --- /dev/null +++ b/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.ml @@ -0,0 +1,932 @@ +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let rec find_opt p = function [] -> None | x :: l -> if p x then Some x else find_opt p l + +let nolabel = Nolabel + +let labelled str = Labelled str + +let optional str = Optional str + +let isOptional str = match str with Optional _ -> true | _ -> false + +let isLabelled str = match str with Labelled _ -> true | _ -> false + +let getLabel str = match str with Optional str | Labelled str -> str | Nolabel -> "" + +let optionIdent = Lident "option" + +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, Location.none, None)) + +let safeTypeFromValue valueStr = + let valueStr = getLabel valueStr in + match String.sub valueStr 0 1 with "_" -> "T" ^ valueStr | _ -> valueStr + [@@raises Invalid_argument] + +let keyType loc = Typ.constr ~loc { loc; txt = optionIdent } [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] + +type 'a children = ListLiteral of 'a | Exact of 'a + +type componentConfig = { propsName : string } + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum)) ) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> Exact (mapper.expr mapper notAList) + in + transformChildren_ theList [] + +let transformChildrenIfList ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> mapper.expr mapper notAList + in + transformChildren_ theList [] + +let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = + let rec allButLast_ lst acc = + match lst with + | [] -> [] + | [ (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) + [@@raises Invalid_argument] + in + let allButLast lst = allButLast_ lst [] |> List.rev [@@raises Invalid_argument] in + match List.partition (fun (label, _) -> label = labelled "children") propsAndChildren with + | [], props -> + (* no children provided? Place a placeholder list *) + (Exp.construct ~loc { loc; txt = Lident "[]" } None, 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") + [@@raises Invalid_argument] + +let unerasableIgnore loc = + { attr_name = { loc; txt = "warning" }; + attr_payload = PStr [ Str.eval (Exp.constant (Pconst_string ("-16", Location.none, None))) ]; + attr_loc = loc; + } + +let merlinFocus = { + attr_name = { loc = Location.none; txt = "merlin.focus" }; + attr_payload = PStr []; + attr_loc = Location.none; +} + +(* Helper method to look up the [@react.component] attribute *) +let hasAttr {attr_name=loc; _} = loc.txt = "react.component" + +(* Helper method to filter out any attribute that isn't [@react.component] *) +let otherAttrsPure { attr_name = loc; _} = loc.txt <> "react.component" + +(* Iterate over the attributes and try to find the [@react.component] attribute *) +let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None + +(* 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 + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +let makeNewBinding binding expression newName = + match binding with + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +(* 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 txt)) + [@@raises Invalid_argument] + +(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) +let getPropsAttr payload = + let defaultProps = { propsName = "Props" } in + match payload with + | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _) } :: _rest)) -> + List.fold_left getPropsNameValue defaultProps 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.") + | _ -> defaultProps + [@@raises Invalid_argument] + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc : Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with "" -> !Location.input_name | fileName -> fileName in + let fileName = try Filename.chop_extension (Filename.basename fileName) with Invalid_argument _ -> fileName in + let fileName = String.capitalize_ascii fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = + match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | "", nestedModules, "make" -> nestedModules + | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) + | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules + | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, default, loc, interiorType) :: tl -> + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + ( match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, _ + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]) }, _ + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] } + (* ~foo *) + | label, None, _ -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc_stack = []; + ptyp_loc = loc; + ptyp_attributes = [] } + | _label, Some type_, _ -> type_ ) + args) + | [] -> args + [@@raises Invalid_argument] + +(* Build an AST node for the [@bs.obj] representing props for a component *) +let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = + let propsName = fnName ^ "Props" in + { + pval_name = { txt = propsName; loc }; + pval_type = + recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef + (Typ.arrow nolabel + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] } + propsType); + pval_prim = [ "" ]; + pval_attributes = [ { attr_name = { txt = "bs.obj"; loc }; attr_payload = PStr []; attr_loc = loc } ]; + pval_loc = loc; + } + [@@raises Invalid_argument] + +(* Build an AST node representing an `external` with the definition of the [@bs.obj] *) +let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = + { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the signature of the `external` definition *) +let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = + { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the props name when converted to an object inside the function signature *) +let makePropsName ~loc name = + { ppat_desc = Ppat_var { txt = name; loc }; + ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = [] } + +let makeObjectField loc (str, attrs, type_) = + { pof_desc = Otag ({ loc; txt = str }, type_); + pof_loc = loc; + pof_attributes = attrs; + } + +(* Build an AST node representing a "closed" object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc + (Ptyp_constr + ( { txt = Ldot (Lident "Js", "t"); loc }, + [ + { + ptyp_desc = Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = []; + }; + ] )) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal fnName loc + (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + [@@raises Invalid_argument] + +(* TODO: some line number might still be wrong *) +let jsxMapper () = + let jsxVersion = ref None in + + let transformUppercaseCall3 ~caller modulePath mapper loc attrs _ callArguments = + let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let argsForMake = argsWithLabels in + let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ ( match childrenExpr with + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] ) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] + in + let isCap str = + let first = String.sub str 0 1 [@@raises Invalid_argument] in + let capped = String.uppercase_ascii first in + first = capped + [@@raises Invalid_argument] + in + let ident = + match modulePath with + | Lident _ -> Ldot (modulePath, caller) + | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, caller) + | modulePath -> modulePath + in + let propsIdent = + match ident with + | Lident path -> Lident (path ^ "Props") + | Ldot (ident, path) -> Ldot (ident, path ^ "Props") + | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") + in + let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in + (* handle key, ref, children *) + (* React.createElement(Component.make, props, ...children) *) + match !childrenArg with + | None -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] + | Some children -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props); (nolabel, children) ] + [@@raises Invalid_argument] + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let children, nonChildrenProps = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> + raise + (Invalid_argument + "A spread as a DOM element's children don't make sense written together. You can simply remove the \ + spread.") + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + | nonEmptyProps -> + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) + args + [@@raises Invalid_argument] + in + + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> + raise + (Invalid_argument + "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its \ + parent!") + | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> + raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") + | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( + match ptyp_desc with + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "ReasonReact: optional argument annotations must have explicit `option`. Did you mean \ + `option(%s)=?`?" + currentType)) ) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in + + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) -> + (list, None) + | Pexp_fun + ( Nolabel, + _, + { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, + _expression ) -> + (list, Some txt) + | Pexp_fun (Nolabel, _, pattern, _expression) -> + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: react.component refs only support plain arguments and type annotations." + | _ -> (list, None) + [@@raises Invalid_argument] + in + + let argToType types (name, default, _noLabelName, _alias, loc, type_) = + match (type_, name, default) with + | Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, name, _ when isOptional name -> + ( getLabel name, + [], + { type_ with ptyp_desc = Ptyp_constr ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]) } ) + :: types + | Some type_, name, Some _default -> + ( getLabel name, + [], + { ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] } ) + :: types + | Some type_, name, _ -> (getLabel name, [], type_) :: types + | None, name, _ when isOptional name -> + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ { ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] } ] ); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = []; + } ) + :: types + | None, name, _ when isLabelled name -> + (getLabel name, [], { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_loc_stack = []; + ptyp_attributes = [] }) + :: types + | _ -> types + [@@raises Invalid_argument] + in + + let argToConcreteType types (name, loc, type_) = + match name with + | name when isLabelled name -> (getLabel name, [], type_) :: types + | name when isOptional name -> (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) :: types + | _ -> types + in + + let nestedModules = ref [] in + let transformComponentDefinition mapper structure returnStructures = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isLabelled name || isOptional name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in + let fnName = getFnName binding in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let modifiedBindingOld 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 *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } -> expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]) } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } -> + spelunkForFunExpression innerFunctionExpression + | _ -> + raise + (Invalid_argument + "react.component calls can only be on function definitions or component wrappers (forwardRef, \ + memo).") + [@@raises Invalid_argument] + in + spelunkForFunExpression expression + in + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { exp with pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + ( wrap, + hasUnit, + unerasableIgnoreExp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp) } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun ((Labelled _ | Optional _), _default, _pattern, _internalExpression) } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression) } -> + if hasApplication.contents then ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with React.forwardRef.\n\ + \ If your component doesn't have any props use () or _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_let (recursive, vbs, exp) }) + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (wrapperExpression, [ (Nolabel, internalExpression) ]) } -> + let () = hasApplication := true in + let _, hasUnit, exp = spelunkForFunExpression internalExpression in + ((fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), hasUnit, exp) + | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression) } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp) }) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try Some (List.find hasAttr binding.pvb_attributes) with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some { attr_name = loc; attr_payload = payload; _ } -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, forwardRef = + recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] + in + let namedArgListWithKeyAndRef = + (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc)) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with label when isOptional label || isLabelled label -> getLabel label | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + (nolabel, Exp.ident ~loc { txt = Lident props.propsName; loc }); + (nolabel, Exp.ident ~loc { txt = Lident labelString; loc }); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalDecl = makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { loc; txt = Lident (match recFlag with Recursive -> internalFnName | Nonrecursive -> fnName) }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { ppat_desc = Ppat_var { txt; loc = emptyLoc }; + ppat_loc = emptyLoc; + ppat_loc_stack = []; + ppat_attributes = [] }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc namedTypeList); + ppat_loc = emptyLoc; + ppat_loc_stack = []; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] + (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk (Pat.var { loc = emptyLoc; txt = fnName }) fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression)) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + [@@raises Invalid_argument] + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) = + let externs = match extern with Some extern -> extern :: externs | None -> externs in + let newBindings = + match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings + in + (externs, binding @ bindings, newBindings) + in + let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ ( match newBindings with + | [] -> [] + | newBindings -> [ { pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings) } ] ) + @ returnStructures + | structure -> structure :: returnStructures + [@@raises Invalid_argument] + in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] + [@@raises Invalid_argument] + in + + let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { psig_loc; psig_desc = Psig_value ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc) } + as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isOptional name || isLabelled name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] + in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] + in + + let transformJsxCall mapper callExpression callArguments attrs = + match callExpression.pexp_desc with + | Pexp_ident caller -> ( + match caller with + | { txt = Lident "createElement" } -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match !jsxVersion with + | None | Some 3 -> transformUppercaseCall3 ~caller:"make" modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match !jsxVersion with + | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + (* Foo.bar(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + (* Not only "createElement" or "make". See + https://github.com/reasonml/reason/pull/2541 *) + | { loc; txt = Ldot (modulePath, anythingNotCreateElementOrMake) } -> ( + match !jsxVersion with + | None | Some 3 -> transformUppercaseCall3 ~caller:anythingNotCreateElementOrMake modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + | { txt = Lapply _ } -> + (* don't think there's ever a case where this is reached *) + raise (Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!") ) + | _ -> raise (Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name.") + [@@raises Invalid_argument] + in + + let signature mapper signature = + default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + in + + let structure mapper structure = + match structure with structures -> default_mapper.structure mapper @@ reactComponentTransform mapper structures + [@@raises Invalid_argument] + in + + let expr mapper expression = + match expression with + (* Does the function application have the @JSX attribute? *) + | { pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes } -> ( + let jsxAttribute, nonJSXAttributes = + List.partition (fun {attr_name = attribute; _} -> attribute.txt = "JSX") pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> transformJsxCall mapper callExpression callArguments nonJSXAttributes ) + (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) + | { + pexp_desc = + ( Pexp_construct ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); + pexp_attributes; + } as listItems -> ( + let jsxAttribute, nonJSXAttributes = + List.partition (fun {attr_name = attribute; _} -> attribute.txt = "JSX") pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let fragment = Exp.ident ~loc { loc; txt = Ldot (Lident "ReasonReact", "fragment") } in + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ (* "div" *) (nolabel, fragment); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + in + Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) + args ) + (* Delegate to the default mapper, a deep identity traversal *) + | e -> default_mapper.expr mapper e + [@@raises Invalid_argument] + in + + let module_binding mapper module_binding = + (match module_binding.pmb_name.txt with + | None -> () + | Some name -> + nestedModules := name :: !nestedModules); + let mapped = default_mapper.module_binding mapper module_binding in + let _ = nestedModules := List.tl !nestedModules in + mapped + [@@raises Failure] + in + { default_mapper with structure; expr; signature; module_binding } + [@@raises Invalid_argument, Failure] + +let rewrite_implementation code : Parsetree.structure = + let mapper = jsxMapper () in + let str = mapper.structure mapper code in + str + [@@raises Invalid_argument, Failure] + +let rewrite_signature code : Parsetree.signature = + let mapper = jsxMapper () in + let sig_ = mapper.signature mapper code in + sig_ + [@@raises Invalid_argument, Failure] diff --git a/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.mli b/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.mli new file mode 100644 index 0000000000..da60a051c8 --- /dev/null +++ b/reactjs_jsx_ppx/reactjs_jsx_ppx_v3.mli @@ -0,0 +1,39 @@ +(* + This is the module that handles turning Reason JSX' agnostic function call into + a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx + facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- + points-in-ocaml/ + You wouldn't use this file directly; it's used by ReScript's + bsconfig.json. Specifically, there's a field called `react-jsx` inside the + field `reason`, which enables this ppx through some internal call in bsb +*) + +(* + There are two different transforms that can be selected in this file (v2 and v3): + v2: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo, + bar|])`. + transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into + `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` + v3: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))` + transform the upper-cased case + `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into + `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` +*) + +val rewrite_implementation : Parsetree.structure -> Parsetree.structure + +val rewrite_signature : Parsetree.signature -> Parsetree.signature