diff --git a/CHANGELOG.md b/CHANGELOG.md
index 8db6013b4b..f189ddb803 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -20,6 +20,9 @@
- Add support for for `async`/`await` https://github.com/rescript-lang/rescript-compiler/pull/5537
+- Initial support for JSX V4, still work in progress.
+ - :boom: when V4 is activated, at most one component is allowed for each module.
+
#### :nail_care: Polish
- Print patterns in warnings using rescript printer https://github.com/rescript-lang/rescript-compiler/pull/5492
diff --git a/jscomp/frontend/ppx_entry.ml b/jscomp/frontend/ppx_entry.ml
index bc54e87f16..89096be803 100644
--- a/jscomp/frontend/ppx_entry.ml
+++ b/jscomp/frontend/ppx_entry.ml
@@ -29,7 +29,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_signature ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_signature ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
(* react-jsx ppx relies on built-in ones like `##` *)
in
@@ -45,7 +47,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_implementation ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
in
if !Js_config.no_builtin_ppx then ast
diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml
index 1ae85cf636..ee556d74fa 100644
--- a/lib/4.06.1/unstable/js_compiler.ml
+++ b/lib/4.06.1/unstable/js_compiler.ml
@@ -271444,8 +271444,8 @@ let mapper : mapper =
end
-module Reactjs_jsx_ppx_v3 : sig
-#1 "reactjs_jsx_ppx_v3.mli"
+module Reactjs_jsx_ppx : sig
+#1 "reactjs_jsx_ppx.mli"
(*
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
@@ -271456,399 +271456,1666 @@ module Reactjs_jsx_ppx_v3 : sig
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 :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.structure ->
+ Parsetree.structure
+
+val rewrite_signature :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.signature ->
+ Parsetree.signature
+
+end = struct
+#1 "reactjs_jsx_ppx.ml"
+open Ast_helper
+open Ast_mapper
+open Asttypes
+open Parsetree
+open Longident
+
+type jsxConfig = {
+ mutable version: int;
+ mutable module_: string;
+ mutable mode: string;
+ mutable nestedModules: string list;
+ mutable hasReactComponent: bool;
+}
+
+let getPayloadFields payload =
+ match payload with
+ | PStr
+ ({
+ pstr_desc =
+ Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _);
+ }
+ :: _rest) ->
+ recordFields
+ | _ -> []
+
+type configKey = Int | String
+
+let getJsxConfigByKey ~key ~type_ recordFields =
+ let values =
+ List.filter_map
+ (fun ((lid, expr) : Longident.t Location.loc * expression) ->
+ match (type_, lid, expr) with
+ | ( Int,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_integer (value, None))} )
+ when k = key ->
+ Some value
+ | ( String,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_string (value, None))} )
+ when k = key ->
+ Some value
+ | _ -> None)
+ recordFields
+ in
+ match values with
+ | [] -> None
+ | [v] | v :: _ -> Some v
+
+let getInt ~key fields =
+ match fields |> getJsxConfigByKey ~key ~type_:Int with
+ | None -> None
+ | Some s -> int_of_string_opt s
+
+let getString ~key fields = fields |> getJsxConfigByKey ~key ~type_:String
+
+let updateConfig config payload =
+ let fields = getPayloadFields payload in
+ (match getInt ~key:"version" fields with
+ | None -> ()
+ | Some i -> config.version <- i);
+ (match getString ~key:"module" fields with
+ | None -> ()
+ | Some s -> config.module_ <- s);
+ match getString ~key:"mode" fields with
+ | None -> ()
+ | Some s -> config.mode <- s
+
+let isJsxConfigAttr ((loc, _) : attribute) = loc.txt = "jsxConfig"
+
+let processConfigAttribute attribute config =
+ if isJsxConfigAttr attribute then updateConfig config (snd attribute)
+
+(* Helper method to look up the [@react.component] attribute *)
+let hasAttr (loc, _) = loc.txt = "react.component"
+
+(* Iterate over the attributes and try to find the [@react.component] attribute *)
+let hasAttrOnBinding {pvb_attributes} =
+ List.find_opt hasAttr pvb_attributes <> None
+
+module V3 = struct
+ 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, 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 =
+ ( {loc; txt = "warning"},
+ PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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
*)
-val rewrite_implementation : Parsetree.structure -> Parsetree.structure
+ (* 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_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_attributes = [];
+ }
+ (* ~foo *)
+ | label, None, _ ->
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue label);
+ 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_attributes = [];
+ }
+ propsType);
+ pval_prim = [""];
+ pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
+ 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_attributes = [];
+ }
+
+ let makeObjectField loc (str, attrs, type_) =
+ Otag ({loc; txt = str}, attrs, type_)
+
+ (* Build an AST node representing a "closed" object representing a component's props *)
+ let makePropsType ~loc namedTypeList =
+ Typ.mk ~loc
+ (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
+
+ (* 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]
+
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let transformUppercaseCall3 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, "make")
+ | Ldot (_modulePath, value) as fullPath when isCap value ->
+ Ldot (fullPath, "make")
+ | 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 args newtypes =
+ 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
+ "React: 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_) :: args)
+ newtypes
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
+ _expression ) ->
+ (args, newtypes, None)
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {
+ ppat_desc =
+ ( Ppat_var {txt}
+ | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) );
+ },
+ _expression ) ->
+ (args, newtypes, Some txt)
+ | Pexp_fun (Nolabel, _, pattern, _expression) ->
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: react.component refs only support plain arguments and type \
+ annotations."
+ | Pexp_newtype (label, expression) ->
+ recursivelyTransformNamedArgsForMake mapper expression args
+ (label :: newtypes)
+ | Pexp_constraint (expression, _typ) ->
+ recursivelyTransformNamedArgsForMake mapper expression args newtypes
+ | _ -> (args, newtypes, 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_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_attributes = [];
+ };
+ ] );
+ ptyp_loc = loc;
+ ptyp_attributes = [];
+ } )
+ :: types
+ | None, name, _ when isLabelled name ->
+ ( getLabel name,
+ [],
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue name);
+ ptyp_loc = loc;
+ 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 transformStructureItem mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ 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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ "React: 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 (loc, payload) -> (loc.loc, Some payload)
+ | None -> (emptyLoc, None)
+ in
+ let props = getPropsAttr payload in
+ (* do stuff here! *)
+ let namedArgList, newtypes, 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 externalArgs =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, c, d, e, maybeTyp) ->
+ match maybeTyp with
+ | Some typ ->
+ (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
+ | None -> (a, b, c, d, e, None))
+ args)
+ namedArgListWithKeyAndRef newtypes
+ in
+ let externalTypes =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
+ args)
+ namedTypeList newtypes
+ in
+ let externalDecl =
+ makeExternalDecl fnName loc externalArgs externalTypes
+ 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_attributes = [];
+ },
+ innerExpression );
+ }
+ | None -> innerExpression
+ in
+ let fullExpression =
+ Exp.fun_ nolabel None
+ {
+ ppat_desc =
+ Ppat_constraint
+ ( makePropsName ~loc:emptyLoc props.propsName,
+ makePropsType ~loc:emptyLoc externalTypes );
+ ppat_loc = emptyLoc;
+ 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}],
+ 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)}]
+ )
+ | _ -> [item]
+ [@@raises Invalid_argument]
+ in
+
+ let transformSignatureItem _mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ raise
+ (Invalid_argument
+ "Only one react.component call can exist on a component at one \
+ time"))
+ | _ -> [item]
+ [@@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 config.version with
+ | 3 ->
+ transformUppercaseCall3 modulePath mapper loc attrs callExpression
+ callArguments
+ | _ -> 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 config.version with
+ | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
+ | _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
+ raise
+ (Invalid_argument
+ ("JSX: the JSX attribute should be attached to a \
+ `YourModuleName.createElement` or `YourModuleName.make` call. \
+ We saw `" ^ anythingNotCreateElementOrMake ^ "` instead"))
+ | {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
-val rewrite_signature : Parsetree.signature -> Parsetree.signature
+ 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 (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 (attribute, _) -> attribute.txt = "JSX")
+ pexp_attributes
+ in
+ match (jsxAttribute, nonJSXAttributes) with
+ (* no JSX attribute *)
+ | [], _ -> default_mapper.expr mapper expression
+ | _, nonJSXAttributes ->
+ let loc = {loc with loc_ghost = true} in
+ 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
-end = struct
-#1 "reactjs_jsx_ppx_v3.ml"
-open Ast_helper
-open Ast_mapper
-open Asttypes
-open Parsetree
-open Longident
+ let module_binding mapper module_binding =
+ let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let mapped = default_mapper.module_binding mapper module_binding in
+ let _ = nestedModules := List.tl !nestedModules in
+ mapped
+ [@@raises Failure]
+ in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
-let rec find_opt p = function
- | [] -> None
- | x :: l -> if p x then Some x else find_opt p l
+module V4 = struct
+ let nolabel = Nolabel
-let nolabel = Nolabel
+ let labelled str = Labelled str
-let labelled str = Labelled str
+ let isOptional str =
+ match str with
+ | Optional _ -> true
+ | _ -> false
-let optional str = Optional str
+ let isLabelled str =
+ match str with
+ | Labelled _ -> true
+ | _ -> false
-let isOptional str =
- match str with
- | Optional _ -> true
- | _ -> false
+ let isForwardRef = function
+ | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} ->
+ true
+ | _ -> false
-let isLabelled str =
- match str with
- | Labelled _ -> true
- | _ -> false
+ let getLabel str =
+ match str with
+ | Optional str | Labelled str -> str
+ | Nolabel -> ""
-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, 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 optionalAttr = [({txt = "ns.optional"; loc = Location.none}, PStr [])]
-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
+ let constantString ~loc str =
+ Ast_helper.Exp.constant ~loc (Pconst_string (str, None))
+
+ (* {} empty object in Js *)
+ let recordWithOnlyKey ~loc =
+ Exp.record ~loc
+ (* {key: @optional None} *)
+ [
+ ( {loc; txt = Lident "key"},
+ Exp.construct ~attrs:optionalAttr {loc; txt = Lident "None"} None );
+ ]
+ None
+
+ let safeTypeFromValue valueStr =
+ let valueStr = getLabel valueStr in
+ match String.sub valueStr 0 1 with
+ | "_" -> "T" ^ valueStr
+ | _ -> valueStr
[@@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 =
- ( {loc; txt = "warning"},
- PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+ let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} []
-let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+ let refType loc =
+ Typ.constr ~loc
+ {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")}
+ []
-(* Helper method to look up the [@react.component] attribute *)
-let hasAttr (loc, _) = loc.txt = "react.component"
+ type 'a children = ListLiteral of 'a | Exact of 'a
+
+ (* 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 []
-(* Helper method to filter out any attribute that isn't [@react.component] *)
-let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+ 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]
-(* Iterate over the attributes and try to find the [@react.component] attribute *)
-let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
-(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
-let rec getFnName binding =
- match binding with
- | {ppat_desc = Ppat_var {txt}} -> txt
- | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
- | _ ->
- raise (Invalid_argument "react.component calls cannot be destructured.")
- [@@raises Invalid_argument]
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
-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
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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 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
+
+ let raiseError ~loc msg = Location.raise_errorf ~loc msg
+
+ let raiseErrorMultipleReactComponent ~loc =
+ raiseError ~loc
+ "Only one component definition is allowed for each module. Move to a \
+ submodule or other file if necessary."
+ (*
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_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_attributes = [];
- }
- (* ~foo *)
- | label, None, _ ->
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue label);
- 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_attributes = [];
- }
- propsType);
- pval_prim = [""];
- pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
- pval_loc = loc;
- }
- [@@raises Invalid_argument]
+ (* make record from props and spread props if exists *)
+ let recordFromProps ?(removeKey = false) callArguments =
+ let rec removeLastPositionUnitAux props acc =
+ match props with
+ | [] -> acc
+ | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] ->
+ acc
+ | (Nolabel, _) :: _rest ->
+ raise
+ (Invalid_argument
+ "JSX: found non-labelled argument before the last position")
+ | prop :: rest -> removeLastPositionUnitAux rest (prop :: acc)
+ in
+ let props, propsToSpread =
+ removeLastPositionUnitAux callArguments []
+ |> List.rev
+ |> List.partition (fun (label, _) -> label <> labelled "spreadProps")
+ in
+ let props =
+ if removeKey then
+ props |> List.filter (fun (arg_label, _) -> "key" <> getLabel arg_label)
+ else props
+ in
+ let fields =
+ props
+ |> List.map (fun (arg_label, ({pexp_loc} as expr)) ->
+ (* In case filed label is "key" only then change expression to option *)
+ if isOptional arg_label then
+ ( {txt = Lident (getLabel arg_label); loc = pexp_loc},
+ {expr with pexp_attributes = optionalAttr} )
+ else ({txt = Lident (getLabel arg_label); loc = pexp_loc}, expr))
+ in
+ let spreadFields =
+ propsToSpread |> List.map (fun (_, expression) -> expression)
+ in
+ match spreadFields with
+ | [] ->
+ {
+ pexp_desc = Pexp_record (fields, None);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | [spreadProps] ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | spreadProps :: _ ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
-(* 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]
+ (* make type params for make fn arguments *)
+ (* let make = ({id, name, children}: props<'id, 'name, 'children>) *)
+ let makePropsTypeParamsTvar namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (_isOptional, label, _, _interiorType) ->
+ if label = "key" || label = "ref" then None
+ else Some (Typ.var @@ safeTypeFromValue (Labelled label)))
+
+ let stripOption coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} ->
+ List.nth_opt coreTypes 0
+ | _ -> Some coreType
+
+ (* make type params for make sig arguments and for external *)
+ (* let make: React.componentLike>, React.element> *)
+ (* external make: React.componentLike, React.element> = "default" *)
+ let makePropsTypeParams ?(stripExplicitOption = false) namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" || label = "ref" then None
+ (* Strip the explicit option type in implementation *)
+ (* let make = (~x: option=?) => ... *)
+ else if isOptional && stripExplicitOption then
+ stripOption interiorType
+ else Some interiorType)
+
+ let makeLabelDecls ~loc namedTypeList =
+ namedTypeList
+ |> List.map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc} interiorType
+ else if label = "ref" then
+ Type.field ~loc
+ ~attrs:(if isOptional then optionalAttr else [])
+ {txt = label; loc} interiorType
+ else if isOptional then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label)
+ else
+ Type.field ~loc {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label))
+
+ let makeTypeDecls propsName loc namedTypeList =
+ let labelDeclList = makeLabelDecls ~loc namedTypeList in
+ (* 'id, 'className, ... *)
+ let params =
+ makePropsTypeParamsTvar namedTypeList
+ |> List.map (fun coreType -> (coreType, Invariant))
+ in
+ [
+ Type.mk ~loc ~params {txt = propsName; loc}
+ ~kind:(Ptype_record labelDeclList);
+ ]
-(* 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_attributes = []}
-
-let makeObjectField loc (str, attrs, type_) =
- Otag ({loc; txt = str}, attrs, type_)
-
-(* Build an AST node representing a "closed" object representing a component's props *)
-let makePropsType ~loc namedTypeList =
- Typ.mk ~loc
- (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
-
-(* 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]
-
-let newtypeToVar newtype type_ =
- let var_desc = Ptyp_var ("type-" ^ newtype) in
- let typ (mapper : Ast_mapper.mapper) typ =
- match typ.ptyp_desc with
- | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
- {typ with ptyp_desc = var_desc}
- | _ -> Ast_mapper.default_mapper.typ mapper typ
- in
- let mapper = {Ast_mapper.default_mapper with typ} in
- mapper.typ mapper type_
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordType propsName loc namedTypeList =
+ Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
-(* TODO: some line number might still be wrong *)
-let jsxMapper () =
- let jsxVersion = ref None in
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordTypeSig propsName loc namedTypeList =
+ Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
- let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
+ let transformUppercaseCall3 ~config modulePath mapper loc attrs callArguments
+ =
let children, argsWithLabels =
extractChildren ~loc ~removeLastPositionUnit:true callArguments
in
@@ -271862,18 +273129,29 @@ let jsxMapper () =
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;
+ @
+ 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;
+ match config.mode with
+ | "automatic" ->
+ [
+ ( labelled "children",
+ Exp.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, 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
@@ -271887,94 +273165,190 @@ let jsxMapper () =
Ldot (fullPath, "make")
| 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
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
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);
- ]
+ match config.mode with
+ (* The new jsx transform *)
+ | "automatic" ->
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")},
+ [] )
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")},
+ [] )
+ in
+ Exp.apply ~attrs jsxExpr
+ ([(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)] @ key)
+ | _ -> (
+ let record = recordFromProps args in
+ (* check if record which goes to Foo.make({ ... } as record) empty or not
+ if empty then change it to {key: @optional None} only for upper case jsx
+ This would be redundant regarding PR progress https://github.com/rescript-lang/syntax/pull/299
+ *)
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ match !childrenArg with
+ | None ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "createElement")})
+ [(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)]
+ | Some children ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {
+ loc = Location.none;
+ txt = Ldot (Lident "React", "createElementVariadic");
+ })
+ [
+ (nolabel, Exp.ident {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 transformLowercaseCall3 ~config mapper loc attrs callArguments id =
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
+ match config.mode with
+ (* the new jsx transform *)
+ | "automatic" ->
+ let children, nonChildrenProps =
+ extractChildren ~removeLastPositionUnit:true ~loc callArguments
+ in
+ let argsForMake = nonChildrenProps 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.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, expression)] );
+ ]
+ in
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
+ in
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsx")}, [])
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxs")}, [])
+ in
+ Exp.apply ~loc ~attrs jsxExpr
+ ([(nolabel, componentNameExpr); (nolabel, props)] @ key)
+ | _ ->
+ let children, nonChildrenProps = extractChildren ~loc callArguments 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.domProps(~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 args newtypes =
+ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes
+ coreType =
let expr = mapper.expr mapper expr in
match expr.pexp_desc with
(* TODO: make this show up with a loc. *)
@@ -272026,562 +273400,566 @@ let jsxMapper () =
recursivelyTransformNamedArgsForMake mapper expression
((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args)
- newtypes
+ newtypes coreType
| Pexp_fun
( Nolabel,
_,
{ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
_expression ) ->
- (args, newtypes, None)
+ (args, newtypes, coreType)
| Pexp_fun
( Nolabel,
_,
{
ppat_desc =
- Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _);
+ Ppat_var _ | Ppat_constraint ({ppat_desc = Ppat_var _}, _);
},
_expression ) ->
- (args, newtypes, Some txt)
+ (args, newtypes, coreType)
| Pexp_fun (Nolabel, _, pattern, _expression) ->
Location.raise_errorf ~loc:pattern.ppat_loc
"React: react.component refs only support plain arguments and type \
annotations."
| Pexp_newtype (label, expression) ->
recursivelyTransformNamedArgsForMake mapper expression args
- (label :: newtypes)
- | Pexp_constraint (expression, _typ) ->
+ (label :: newtypes) coreType
+ | Pexp_constraint (expression, coreType) ->
recursivelyTransformNamedArgsForMake mapper expression args newtypes
- | _ -> (args, newtypes, None)
+ (Some coreType)
+ | _ -> (args, newtypes, coreType)
[@@raises Invalid_argument]
- in
- let argToType types (name, default, _noLabelName, _alias, loc, type_) =
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ let argToType ~newtypes ~(typeConstraints : core_type option) types
+ (name, default, _noLabelName, _alias, loc, type_) =
+ let rec getType name coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} ->
+ if name = arg then Some c1 else getType name c2
+ | _ -> None
+ in
+ let typeConst = Option.bind typeConstraints (getType name) in
+ let type_ =
+ List.fold_left
+ (fun type_ newtype ->
+ match (type_, typeConst) with
+ | _, Some typ | Some typ, None -> Some (newtypeToVar newtype.txt typ)
+ | _ -> None)
+ type_ newtypes
+ in
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_attributes = [];
- } )
+ | Some type_, name, _ when isOptional name ->
+ (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttr})
:: types
- | Some type_, name, _ -> (getLabel name, [], type_) :: types
+ | Some type_, name, _ -> (false, getLabel name, [], type_) :: types
| None, name, _ when isOptional name ->
- ( getLabel name,
+ ( true,
+ getLabel name,
[],
- {
- ptyp_desc =
- Ptyp_constr
- ( {loc; txt = optionIdent},
- [
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- };
- ] );
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
+ Typ.var ~loc ~attrs:optionalAttr (safeTypeFromValue name) )
:: types
| None, name, _ when isLabelled name ->
- ( getLabel name,
- [],
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
- :: types
+ (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types
| _ -> types
[@@raises Invalid_argument]
- in
- let argToConcreteType types (name, loc, type_) =
+ let argWithDefaultValue (name, default, _, _, _, _) =
+ match default with
+ | Some default when isOptional name -> Some (getLabel name, default)
+ | _ -> None
+ [@@raises Invalid_argument]
+
+ 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
+ | name when isLabelled name -> (false, getLabel name, [], type_) :: types
+ | name when isOptional name -> (true, getLabel name, [], type_) :: types
| _ -> types
- in
- let nestedModules = ref [] in
- let transformComponentDefinition mapper structure returnStructures =
- match structure with
+ let transformStructureItem ~config mapper item =
+ match item with
(* external *)
| {
pstr_loc;
pstr_desc =
- Pstr_primitive
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- value_description);
+ Pstr_primitive ({pval_attributes; pval_type} as value_description);
} as pstr -> (
match List.filter hasAttr pval_attributes with
- | [] -> structure :: returnStructures
+ | [] -> [item]
| [_] ->
- 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
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ 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 retPropsType =
+ Typ.constr ~loc:pstr_loc
+ (Location.mkloc (Lident "props") pstr_loc)
+ (makePropsTypeParams namedTypeList)
+ in
+ (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" Location.none
+ ((true, "key", [], keyType pstr_loc) :: namedTypeList)
+ 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
+ [propsRecordType; newStructure])
| _ ->
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)} ->
+ | {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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
- 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
- | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} ->
- 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 =
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ let bindingLoc = binding.pvb_loc in
+ let bindingPatLoc = binding.pvb_pat.ppat_loc in
+ let binding =
{
- exp with
- pexp_attributes =
- unerasableIgnore emptyLoc :: exp.pexp_attributes;
+ binding with
+ pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc};
+ pvb_loc = emptyLoc;
}
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
+ let fnName = getFnName binding.pvb_pat in
+ let internalFnName = fnName ^ "$Internal" in
+ let fullModuleName =
+ makeModuleName fileName config.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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ (* 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
{
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
- "React: 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)
+ (* let make = (()) => ... *)
+ (* let make = (_) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( Nolabel,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (~prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( (Labelled _ | Optional _),
+ _default,
+ _pattern,
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun (_nolabel, _default, pattern, _internalExpression);
+ } ->
+ if !hasApplication then ((fun a -> a), false, expression)
+ else
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {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 _, _, exp = spelunkForFunExpression internalExpression in
+ let hasForwardRef = isForwardRef wrapperExpression in
+ ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]),
+ hasForwardRef,
+ exp )
+ | {
+ pexp_desc =
+ Pexp_sequence (wrapperExpression, internalExpression);
+ } ->
+ let wrap, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {
+ expression with
+ pexp_desc = Pexp_sequence (wrapperExpression, exp);
+ } )
+ | e -> ((fun a -> a), false, e)
+ in
+ let wrapExpression, hasForwardRef, expression =
+ spelunkForFunExpression expression
+ in
+ ( wrapExpressionWithBinding wrapExpression,
+ hasForwardRef,
+ expression )
in
- let wrapExpression, hasUnit, expression =
- spelunkForFunExpression expression
+ let bindingWrapper, hasForwardRef, expression =
+ modifiedBinding binding
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 (loc, payload) -> (loc.loc, Some payload)
- | None -> (emptyLoc, None)
- in
- let props = getPropsAttr payload in
- (* do stuff here! *)
- let namedArgList, newtypes, 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
- | _ -> ""
+ (* do stuff here! *)
+ let namedArgList, newtypes, typeConstraints =
+ recursivelyTransformNamedArgsForMake mapper
+ (modifiedBindingOld binding)
+ [] [] None
+ in
+ let namedTypeList =
+ List.fold_left
+ (argToType ~newtypes ~typeConstraints)
+ [] namedArgList
+ in
+ let namedArgWithDefaultValueList =
+ List.filter_map argWithDefaultValue namedArgList
+ in
+ let vbMatch (label, default) =
+ Vb.mk
+ (Pat.var (Location.mknoloc label))
+ (Exp.match_
+ (Exp.ident {txt = Lident label; loc = Location.none})
+ [
+ Exp.case
+ (Pat.construct
+ (Location.mknoloc @@ Lident "Some")
+ (Some (Pat.var (Location.mknoloc label))))
+ (Exp.ident (Location.mknoloc @@ Lident label));
+ Exp.case
+ (Pat.construct (Location.mknoloc @@ Lident "None") None)
+ default;
+ ])
+ in
+ let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in
+ (* type props = { ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" emptyLoc
+ ([(true, "key", [], keyType emptyLoc)]
+ @ (if hasForwardRef then
+ [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
+ in
+ let innerExpression =
+ Exp.apply
+ (Exp.ident (Location.mknoloc @@ Lident "make"))
+ ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))]
+ @
+ match hasForwardRef with
+ | true ->
+ [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]
+ | false -> [])
+ in
+ let fullExpression =
+ (* React component name should start with uppercase letter *)
+ (* let make = { let \"App" = props => make(props); \"App" } *)
+ (* let make = React.forwardRef({
+ let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))})
+ })*)
+ Exp.fun_ nolabel None
+ (match namedTypeList with
+ | [] -> Pat.var @@ Location.mknoloc "props"
+ | _ ->
+ Pat.constraint_
+ (Pat.var @@ Location.mknoloc "props")
+ (Typ.constr
+ (Location.mknoloc @@ Lident "props")
+ [Typ.any ()]))
+ (if hasForwardRef then
+ Exp.fun_ nolabel None
+ (Pat.var @@ Location.mknoloc "ref")
+ innerExpression
+ else innerExpression)
in
- ( label,
- match labelString with
- | "" -> Exp.ident ~loc {txt = Lident alias; loc}
- | labelString ->
- Exp.apply ~loc
- (Exp.ident ~loc {txt = Lident "##"; loc})
+ let fullExpression =
+ match fullModuleName with
+ | "" -> fullExpression
+ | txt ->
+ Exp.let_ Nonrecursive
[
- (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 externalArgs =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, c, d, e, maybeTyp) ->
- match maybeTyp with
- | Some typ ->
- (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
- | None -> (a, b, c, d, e, None))
- args)
- namedArgListWithKeyAndRef newtypes
- in
- let externalTypes =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
- args)
- namedTypeList newtypes
- in
- let externalDecl =
- makeExternalDecl fnName loc externalArgs externalTypes
- 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_attributes = [];
- },
- innerExpression );
- }
- | None -> innerExpression
- in
- let fullExpression =
- Exp.fun_ nolabel None
- {
- ppat_desc =
- Ppat_constraint
- ( makePropsName ~loc:emptyLoc props.propsName,
- makePropsType ~loc:emptyLoc externalTypes );
- ppat_loc = emptyLoc;
- 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)
+ Vb.mk ~loc:emptyLoc
+ (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt})
+ fullExpression;
+ ]
+ (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt})
+ in
+ let rec returnedExpression patternsWithLabel patternsWithNolabel
+ ({pexp_desc} as expr) =
+ match pexp_desc with
+ | Pexp_newtype (_, expr) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_constraint (expr, _) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_fun
+ ( _arg_label,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ expr ) ->
+ (patternsWithLabel, patternsWithNolabel, expr)
+ | Pexp_fun (arg_label, _default, {ppat_loc; ppat_desc}, expr) -> (
+ if isLabelled arg_label || isOptional arg_label then
+ returnedExpression
+ (( {loc = ppat_loc; txt = Lident (getLabel arg_label)},
+ Pat.var
+ ~attrs:
+ (if isOptional arg_label then optionalAttr else [])
+ {txt = getLabel arg_label; loc = ppat_loc} )
+ :: patternsWithLabel)
+ patternsWithNolabel expr
+ else
+ (* Special case of nolabel arg "ref" in forwardRef fn *)
+ (* let make = React.forwardRef(ref => body) *)
+ match ppat_desc with
+ | Ppat_var {txt} ->
+ returnedExpression patternsWithLabel
+ (( {loc = ppat_loc; txt = Lident txt},
+ Pat.var ~attrs:optionalAttr {txt; loc = ppat_loc} )
+ :: patternsWithNolabel)
+ expr
+ | _ ->
+ returnedExpression patternsWithLabel patternsWithNolabel
+ expr)
+ | _ -> (patternsWithLabel, patternsWithNolabel, expr)
+ in
+ let patternsWithLabel, patternsWithNolabel, expression =
+ returnedExpression [] [] expression
+ in
+ let pattern =
+ match patternsWithLabel with
+ | [] -> Pat.any ()
+ | _ -> Pat.record (List.rev patternsWithLabel) Open
+ in
+ (* add pattern matching for optional prop value *)
+ let expression =
+ if List.length vbMatchList = 0 then expression
+ else Exp.let_ Nonrecursive vbMatchList expression
+ in
+ let expression =
+ List.fold_left
+ (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr)
+ expression patternsWithNolabel
+ in
+ let expression =
+ Exp.fun_ Nolabel None
+ (Pat.constraint_ pattern
+ (Typ.constr ~loc:emptyLoc
+ {txt = Lident "props"; loc = emptyLoc}
+ (makePropsTypeParams ~stripExplicitOption:true
+ namedTypeList)))
+ expression
+ in
+ (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *)
+ 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_pat = Pat.var {txt = fnName; loc = Location.none};
+ };
+ ],
+ Some (bindingWrapper fullExpression) )
+ in
+ (Some propsRecordType, bindings, newBinding))
else (None, [binding], None)
[@@raises Invalid_argument]
in
+ (* END of mapBinding fn *)
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
+ let otherStructures (type_, binding, newBinding)
+ (types, bindings, newBindings) =
+ let types =
+ match type_ with
+ | Some type_ -> type_ :: types
+ | None -> types
in
let newBindings =
match newBinding with
| Some newBinding -> newBinding :: newBindings
| None -> newBindings
in
- (externs, binding @ bindings, newBindings)
+ (types, binding @ bindings, newBindings)
in
- let externs, bindings, newBindings =
+ let types, bindings, newBindings =
List.fold_right otherStructures structuresAndBinding ([], [], [])
in
- externs
+ types
@ [{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 []
+ @
+ match newBindings with
+ | [] -> []
+ | newBindings ->
+ [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}])
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformComponentSignature _mapper signature returnSignatures =
- match signature with
+ let transformSignatureItem ~config _mapper item =
+ match item with
| {
psig_loc;
- psig_desc =
- Psig_value
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- psig_desc);
+ psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc);
} as psig -> (
match List.filter hasAttr pval_attributes with
- | [] -> signature :: returnSignatures
+ | [] -> [item]
| [_] ->
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:psig_loc
+ else config.hasReactComponent <- true;
+ let hasForwardRef = ref false in
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
+ ( Nolabel,
+ {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)},
+ rest ) ->
+ getPropTypes types rest
+ | Ptyp_arrow (Nolabel, _type, rest) ->
+ hasForwardRef := true;
+ getPropTypes types rest
| Ptyp_arrow (name, type_, returnValue)
when isOptional name || isLabelled name ->
(returnValue, (name, returnValue.ptyp_loc, type_) :: types)
@@ -272589,15 +273967,18 @@ let jsxMapper () =
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_)
+ let retPropsType =
+ Typ.constr
+ (Location.mkloc (Lident "props") psig_loc)
+ (makePropsTypeParams namedTypeList)
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
+ let propsRecordType =
+ makePropsRecordTypeSig "props" Location.none
+ ([(true, "key", [], keyType Location.none)]
+ (* If there is Nolabel arg, regard the type as ref in forwardRef *)
+ @ (if !hasForwardRef then [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
in
(* can't be an arrow because it will defensively uncurry *)
let newExternalType =
@@ -272617,22 +273998,16 @@ let jsxMapper () =
};
}
in
- externalPropsDecl :: newStructure :: returnSignatures
+ [propsRecordType; newStructure]
| _ ->
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 []
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformJsxCall mapper callExpression callArguments attrs =
+ let transformJsxCall ~config mapper callExpression callArguments attrs =
match callExpression.pexp_desc with
| Pexp_ident caller -> (
match caller with
@@ -272641,20 +274016,14 @@ let jsxMapper () =
(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 modulePath mapper loc attrs callExpression
- callArguments
- | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} ->
+ transformUppercaseCall3 ~config modulePath mapper loc attrs
+ callArguments
(* 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"))
+ | {loc; txt = Lident id} ->
+ transformLowercaseCall3 ~config mapper loc attrs callArguments id
| {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
raise
(Invalid_argument
@@ -272673,23 +274042,8 @@ let jsxMapper () =
"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 =
+ let expr ~config mapper expression =
match expression with
(* Does the function application have the @JSX attribute? *)
| {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes}
@@ -272703,7 +274057,8 @@ let jsxMapper () =
(* no JSX attribute *)
| [], _ -> default_mapper.expr mapper expression
| _, nonJSXAttributes ->
- transformJsxCall mapper callExpression callArguments nonJSXAttributes)
+ transformJsxCall ~config mapper callExpression callArguments
+ nonJSXAttributes)
(* is it a list with jsx attribute? Reason <>foo> desugars to [@JSX][foo]*)
| {
pexp_desc =
@@ -272723,46 +274078,177 @@ let jsxMapper () =
| _, nonJSXAttributes ->
let loc = {loc with loc_ghost = true} in
let fragment =
- Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")}
+ match config.mode with
+ | "automatic" ->
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")}
+ | "classic" | _ ->
+ 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);
+ (match config.mode with
+ | "automatic" ->
+ ( nolabel,
+ Exp.record
+ [
+ ( Location.mknoloc @@ Lident "children",
+ match childrenExpr with
+ | {pexp_desc = Pexp_array children} -> (
+ match children with
+ | [] -> recordWithOnlyKey ~loc:Location.none
+ | [child] -> child
+ | _ -> childrenExpr)
+ | _ -> childrenExpr );
+ ]
+ None )
+ | "classic" | _ -> (nolabel, childrenExpr));
]
in
+ let countOfChildren = function
+ | {pexp_desc = Pexp_array children} -> List.length children
+ | _ -> 0
+ 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")})
+ (match config.mode with
+ | "automatic" ->
+ if countOfChildren childrenExpr > 1 then
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")}
+ else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")}
+ | "classic" | _ ->
+ 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 =
- let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let module_binding ~config mapper module_binding =
+ config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules;
let mapped = default_mapper.module_binding mapper module_binding in
- let _ = nestedModules := List.tl !nestedModules in
+ config.nestedModules <- List.tl config.nestedModules;
mapped
[@@raises Failure]
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let expr = expr ~config in
+ let module_binding = module_binding ~config in
+ let transformStructureItem = transformStructureItem ~config in
+ let transformSignatureItem = transformSignatureItem ~config in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
+
+let getMapper ~config =
+ let expr3, module_binding3, transformSignatureItem3, transformStructureItem3 =
+ V3.jsxMapper ~config
in
- {default_mapper with structure; expr; signature; module_binding}
- [@@raises Invalid_argument, Failure]
+ let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 =
+ V4.jsxMapper ~config
+ in
+
+ let expr mapper e =
+ match config.version with
+ | 3 -> expr3 mapper e
+ | 4 -> expr4 mapper e
+ | _ -> default_mapper.expr mapper e
+ in
+ let module_binding mapper mb =
+ match config.version with
+ | 3 -> module_binding3 mapper mb
+ | 4 -> module_binding4 mapper mb
+ | _ -> default_mapper.module_binding mapper mb
+ in
+ let saveConfig () =
+ {
+ config with
+ version = config.version;
+ module_ = config.module_;
+ mode = config.mode;
+ hasReactComponent = config.hasReactComponent;
+ }
+ in
+ let restoreConfig oldConfig =
+ config.version <- oldConfig.version;
+ config.module_ <- oldConfig.module_;
+ config.mode <- oldConfig.mode;
+ config.hasReactComponent <- oldConfig.hasReactComponent
+ in
+ let signature mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.psig_desc with
+ | Psig_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.signature_item mapper item in
+ if config.version = 3 then transformSignatureItem3 mapper item
+ else if config.version = 4 then transformSignatureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+ let structure mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.pstr_desc with
+ | Pstr_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.structure_item mapper item in
+ if config.version = 3 then transformStructureItem3 mapper item
+ else if config.version = 4 then transformStructureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+
+ {default_mapper with expr; module_binding; signature; structure}
-let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure =
- let mapper = jsxMapper () in
+let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.structure) : Parsetree.structure =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.structure mapper code
[@@raises Invalid_argument, Failure]
-let rewrite_signature (code : Parsetree.signature) : Parsetree.signature =
- let mapper = jsxMapper () in
+let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.signature) : Parsetree.signature =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.signature mapper code
[@@raises Invalid_argument, Failure]
@@ -272801,7 +274287,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_signature ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_signature ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
(* react-jsx ppx relies on built-in ones like `##` *)
in
@@ -272817,7 +274305,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_implementation ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
in
if !Js_config.no_builtin_ppx then ast
diff --git a/lib/4.06.1/unstable/js_compiler.ml.d b/lib/4.06.1/unstable/js_compiler.ml.d
index 5e47c4889b..f217a1c001 100644
--- a/lib/4.06.1/unstable/js_compiler.ml.d
+++ b/lib/4.06.1/unstable/js_compiler.ml.d
@@ -565,8 +565,8 @@
../lib/4.06.1/unstable/js_compiler.ml: ./ml/typetexp.mli
../lib/4.06.1/unstable/js_compiler.ml: ./ml/untypeast.ml
../lib/4.06.1/unstable/js_compiler.ml: ./ml/untypeast.mli
-../lib/4.06.1/unstable/js_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.ml
-../lib/4.06.1/unstable/js_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.mli
+../lib/4.06.1/unstable/js_compiler.ml: ./napkin/reactjs_jsx_ppx.ml
+../lib/4.06.1/unstable/js_compiler.ml: ./napkin/reactjs_jsx_ppx.mli
../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_comment.ml
../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_comment.mli
../lib/4.06.1/unstable/js_compiler.ml: ./napkin/res_comments_table.ml
diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml
index f793198fb7..e20770653c 100644
--- a/lib/4.06.1/unstable/js_playground_compiler.ml
+++ b/lib/4.06.1/unstable/js_playground_compiler.ml
@@ -272907,8 +272907,8 @@ let mapper : mapper =
end
-module Reactjs_jsx_ppx_v3 : sig
-#1 "reactjs_jsx_ppx_v3.mli"
+module Reactjs_jsx_ppx : sig
+#1 "reactjs_jsx_ppx.mli"
(*
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
@@ -272919,399 +272919,1666 @@ module Reactjs_jsx_ppx_v3 : sig
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 :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.structure ->
+ Parsetree.structure
+
+val rewrite_signature :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.signature ->
+ Parsetree.signature
+
+end = struct
+#1 "reactjs_jsx_ppx.ml"
+open Ast_helper
+open Ast_mapper
+open Asttypes
+open Parsetree
+open Longident
+
+type jsxConfig = {
+ mutable version: int;
+ mutable module_: string;
+ mutable mode: string;
+ mutable nestedModules: string list;
+ mutable hasReactComponent: bool;
+}
+
+let getPayloadFields payload =
+ match payload with
+ | PStr
+ ({
+ pstr_desc =
+ Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _);
+ }
+ :: _rest) ->
+ recordFields
+ | _ -> []
+
+type configKey = Int | String
+
+let getJsxConfigByKey ~key ~type_ recordFields =
+ let values =
+ List.filter_map
+ (fun ((lid, expr) : Longident.t Location.loc * expression) ->
+ match (type_, lid, expr) with
+ | ( Int,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_integer (value, None))} )
+ when k = key ->
+ Some value
+ | ( String,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_string (value, None))} )
+ when k = key ->
+ Some value
+ | _ -> None)
+ recordFields
+ in
+ match values with
+ | [] -> None
+ | [v] | v :: _ -> Some v
+
+let getInt ~key fields =
+ match fields |> getJsxConfigByKey ~key ~type_:Int with
+ | None -> None
+ | Some s -> int_of_string_opt s
+
+let getString ~key fields = fields |> getJsxConfigByKey ~key ~type_:String
+
+let updateConfig config payload =
+ let fields = getPayloadFields payload in
+ (match getInt ~key:"version" fields with
+ | None -> ()
+ | Some i -> config.version <- i);
+ (match getString ~key:"module" fields with
+ | None -> ()
+ | Some s -> config.module_ <- s);
+ match getString ~key:"mode" fields with
+ | None -> ()
+ | Some s -> config.mode <- s
+
+let isJsxConfigAttr ((loc, _) : attribute) = loc.txt = "jsxConfig"
+
+let processConfigAttribute attribute config =
+ if isJsxConfigAttr attribute then updateConfig config (snd attribute)
+
+(* Helper method to look up the [@react.component] attribute *)
+let hasAttr (loc, _) = loc.txt = "react.component"
+
+(* Iterate over the attributes and try to find the [@react.component] attribute *)
+let hasAttrOnBinding {pvb_attributes} =
+ List.find_opt hasAttr pvb_attributes <> None
+
+module V3 = struct
+ 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, 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 =
+ ( {loc; txt = "warning"},
+ PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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
*)
-val rewrite_implementation : Parsetree.structure -> Parsetree.structure
+ (* 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_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_attributes = [];
+ }
+ (* ~foo *)
+ | label, None, _ ->
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue label);
+ 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_attributes = [];
+ }
+ propsType);
+ pval_prim = [""];
+ pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
+ 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_attributes = [];
+ }
+
+ let makeObjectField loc (str, attrs, type_) =
+ Otag ({loc; txt = str}, attrs, type_)
+
+ (* Build an AST node representing a "closed" object representing a component's props *)
+ let makePropsType ~loc namedTypeList =
+ Typ.mk ~loc
+ (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
+
+ (* 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]
+
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let transformUppercaseCall3 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, "make")
+ | Ldot (_modulePath, value) as fullPath when isCap value ->
+ Ldot (fullPath, "make")
+ | 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 args newtypes =
+ 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
+ "React: 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_) :: args)
+ newtypes
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
+ _expression ) ->
+ (args, newtypes, None)
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {
+ ppat_desc =
+ ( Ppat_var {txt}
+ | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) );
+ },
+ _expression ) ->
+ (args, newtypes, Some txt)
+ | Pexp_fun (Nolabel, _, pattern, _expression) ->
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: react.component refs only support plain arguments and type \
+ annotations."
+ | Pexp_newtype (label, expression) ->
+ recursivelyTransformNamedArgsForMake mapper expression args
+ (label :: newtypes)
+ | Pexp_constraint (expression, _typ) ->
+ recursivelyTransformNamedArgsForMake mapper expression args newtypes
+ | _ -> (args, newtypes, 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_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_attributes = [];
+ };
+ ] );
+ ptyp_loc = loc;
+ ptyp_attributes = [];
+ } )
+ :: types
+ | None, name, _ when isLabelled name ->
+ ( getLabel name,
+ [],
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue name);
+ ptyp_loc = loc;
+ 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 transformStructureItem mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ 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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ "React: 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 (loc, payload) -> (loc.loc, Some payload)
+ | None -> (emptyLoc, None)
+ in
+ let props = getPropsAttr payload in
+ (* do stuff here! *)
+ let namedArgList, newtypes, 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 externalArgs =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, c, d, e, maybeTyp) ->
+ match maybeTyp with
+ | Some typ ->
+ (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
+ | None -> (a, b, c, d, e, None))
+ args)
+ namedArgListWithKeyAndRef newtypes
+ in
+ let externalTypes =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
+ args)
+ namedTypeList newtypes
+ in
+ let externalDecl =
+ makeExternalDecl fnName loc externalArgs externalTypes
+ 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_attributes = [];
+ },
+ innerExpression );
+ }
+ | None -> innerExpression
+ in
+ let fullExpression =
+ Exp.fun_ nolabel None
+ {
+ ppat_desc =
+ Ppat_constraint
+ ( makePropsName ~loc:emptyLoc props.propsName,
+ makePropsType ~loc:emptyLoc externalTypes );
+ ppat_loc = emptyLoc;
+ 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}],
+ 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)}]
+ )
+ | _ -> [item]
+ [@@raises Invalid_argument]
+ in
+
+ let transformSignatureItem _mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ raise
+ (Invalid_argument
+ "Only one react.component call can exist on a component at one \
+ time"))
+ | _ -> [item]
+ [@@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 config.version with
+ | 3 ->
+ transformUppercaseCall3 modulePath mapper loc attrs callExpression
+ callArguments
+ | _ -> 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 config.version with
+ | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
+ | _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
+ raise
+ (Invalid_argument
+ ("JSX: the JSX attribute should be attached to a \
+ `YourModuleName.createElement` or `YourModuleName.make` call. \
+ We saw `" ^ anythingNotCreateElementOrMake ^ "` instead"))
+ | {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
-val rewrite_signature : Parsetree.signature -> Parsetree.signature
+ 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 (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 (attribute, _) -> attribute.txt = "JSX")
+ pexp_attributes
+ in
+ match (jsxAttribute, nonJSXAttributes) with
+ (* no JSX attribute *)
+ | [], _ -> default_mapper.expr mapper expression
+ | _, nonJSXAttributes ->
+ let loc = {loc with loc_ghost = true} in
+ 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
-end = struct
-#1 "reactjs_jsx_ppx_v3.ml"
-open Ast_helper
-open Ast_mapper
-open Asttypes
-open Parsetree
-open Longident
+ let module_binding mapper module_binding =
+ let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let mapped = default_mapper.module_binding mapper module_binding in
+ let _ = nestedModules := List.tl !nestedModules in
+ mapped
+ [@@raises Failure]
+ in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
-let rec find_opt p = function
- | [] -> None
- | x :: l -> if p x then Some x else find_opt p l
+module V4 = struct
+ let nolabel = Nolabel
-let nolabel = Nolabel
+ let labelled str = Labelled str
-let labelled str = Labelled str
+ let isOptional str =
+ match str with
+ | Optional _ -> true
+ | _ -> false
-let optional str = Optional str
+ let isLabelled str =
+ match str with
+ | Labelled _ -> true
+ | _ -> false
-let isOptional str =
- match str with
- | Optional _ -> true
- | _ -> false
+ let isForwardRef = function
+ | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} ->
+ true
+ | _ -> false
-let isLabelled str =
- match str with
- | Labelled _ -> true
- | _ -> false
+ let getLabel str =
+ match str with
+ | Optional str | Labelled str -> str
+ | Nolabel -> ""
-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, 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 optionalAttr = [({txt = "ns.optional"; loc = Location.none}, PStr [])]
-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
+ let constantString ~loc str =
+ Ast_helper.Exp.constant ~loc (Pconst_string (str, None))
+
+ (* {} empty object in Js *)
+ let recordWithOnlyKey ~loc =
+ Exp.record ~loc
+ (* {key: @optional None} *)
+ [
+ ( {loc; txt = Lident "key"},
+ Exp.construct ~attrs:optionalAttr {loc; txt = Lident "None"} None );
+ ]
+ None
+
+ let safeTypeFromValue valueStr =
+ let valueStr = getLabel valueStr in
+ match String.sub valueStr 0 1 with
+ | "_" -> "T" ^ valueStr
+ | _ -> valueStr
[@@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 =
- ( {loc; txt = "warning"},
- PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+ let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} []
-let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+ let refType loc =
+ Typ.constr ~loc
+ {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")}
+ []
-(* Helper method to look up the [@react.component] attribute *)
-let hasAttr (loc, _) = loc.txt = "react.component"
+ type 'a children = ListLiteral of 'a | Exact of 'a
+
+ (* 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 []
-(* Helper method to filter out any attribute that isn't [@react.component] *)
-let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+ 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]
-(* Iterate over the attributes and try to find the [@react.component] attribute *)
-let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
-(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
-let rec getFnName binding =
- match binding with
- | {ppat_desc = Ppat_var {txt}} -> txt
- | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
- | _ ->
- raise (Invalid_argument "react.component calls cannot be destructured.")
- [@@raises Invalid_argument]
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
-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
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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 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
+
+ let raiseError ~loc msg = Location.raise_errorf ~loc msg
+
+ let raiseErrorMultipleReactComponent ~loc =
+ raiseError ~loc
+ "Only one component definition is allowed for each module. Move to a \
+ submodule or other file if necessary."
+ (*
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_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_attributes = [];
- }
- (* ~foo *)
- | label, None, _ ->
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue label);
- ptyp_loc = loc;
- ptyp_attributes = [];
- }
- | _label, Some type_, _ -> type_)
- args)
- | [] -> args
- [@@raises Invalid_argument]
+ (* make record from props and spread props if exists *)
+ let recordFromProps ?(removeKey = false) callArguments =
+ let rec removeLastPositionUnitAux props acc =
+ match props with
+ | [] -> acc
+ | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] ->
+ acc
+ | (Nolabel, _) :: _rest ->
+ raise
+ (Invalid_argument
+ "JSX: found non-labelled argument before the last position")
+ | prop :: rest -> removeLastPositionUnitAux rest (prop :: acc)
+ in
+ let props, propsToSpread =
+ removeLastPositionUnitAux callArguments []
+ |> List.rev
+ |> List.partition (fun (label, _) -> label <> labelled "spreadProps")
+ in
+ let props =
+ if removeKey then
+ props |> List.filter (fun (arg_label, _) -> "key" <> getLabel arg_label)
+ else props
+ in
+ let fields =
+ props
+ |> List.map (fun (arg_label, ({pexp_loc} as expr)) ->
+ (* In case filed label is "key" only then change expression to option *)
+ if isOptional arg_label then
+ ( {txt = Lident (getLabel arg_label); loc = pexp_loc},
+ {expr with pexp_attributes = optionalAttr} )
+ else ({txt = Lident (getLabel arg_label); loc = pexp_loc}, expr))
+ in
+ let spreadFields =
+ propsToSpread |> List.map (fun (_, expression) -> expression)
+ in
+ match spreadFields with
+ | [] ->
+ {
+ pexp_desc = Pexp_record (fields, None);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | [spreadProps] ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | spreadProps :: _ ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
-(* 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_attributes = [];
- }
- propsType);
- pval_prim = [""];
- pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
- pval_loc = loc;
- }
- [@@raises Invalid_argument]
+ (* make type params for make fn arguments *)
+ (* let make = ({id, name, children}: props<'id, 'name, 'children>) *)
+ let makePropsTypeParamsTvar namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (_isOptional, label, _, _interiorType) ->
+ if label = "key" || label = "ref" then None
+ else Some (Typ.var @@ safeTypeFromValue (Labelled label)))
+
+ let stripOption coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} ->
+ List.nth_opt coreTypes 0
+ | _ -> Some coreType
+
+ (* make type params for make sig arguments and for external *)
+ (* let make: React.componentLike>, React.element> *)
+ (* external make: React.componentLike, React.element> = "default" *)
+ let makePropsTypeParams ?(stripExplicitOption = false) namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" || label = "ref" then None
+ (* Strip the explicit option type in implementation *)
+ (* let make = (~x: option=?) => ... *)
+ else if isOptional && stripExplicitOption then
+ stripOption interiorType
+ else Some interiorType)
+
+ let makeLabelDecls ~loc namedTypeList =
+ namedTypeList
+ |> List.map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc} interiorType
+ else if label = "ref" then
+ Type.field ~loc
+ ~attrs:(if isOptional then optionalAttr else [])
+ {txt = label; loc} interiorType
+ else if isOptional then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label)
+ else
+ Type.field ~loc {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label))
-(* 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]
+ let makeTypeDecls propsName loc namedTypeList =
+ let labelDeclList = makeLabelDecls ~loc namedTypeList in
+ (* 'id, 'className, ... *)
+ let params =
+ makePropsTypeParamsTvar namedTypeList
+ |> List.map (fun coreType -> (coreType, Invariant))
+ in
+ [
+ Type.mk ~loc ~params {txt = propsName; loc}
+ ~kind:(Ptype_record labelDeclList);
+ ]
-(* 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_attributes = []}
-
-let makeObjectField loc (str, attrs, type_) =
- Otag ({loc; txt = str}, attrs, type_)
-
-(* Build an AST node representing a "closed" object representing a component's props *)
-let makePropsType ~loc namedTypeList =
- Typ.mk ~loc
- (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
-
-(* 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]
-
-let newtypeToVar newtype type_ =
- let var_desc = Ptyp_var ("type-" ^ newtype) in
- let typ (mapper : Ast_mapper.mapper) typ =
- match typ.ptyp_desc with
- | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
- {typ with ptyp_desc = var_desc}
- | _ -> Ast_mapper.default_mapper.typ mapper typ
- in
- let mapper = {Ast_mapper.default_mapper with typ} in
- mapper.typ mapper type_
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordType propsName loc namedTypeList =
+ Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
-(* TODO: some line number might still be wrong *)
-let jsxMapper () =
- let jsxVersion = ref None in
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordTypeSig propsName loc namedTypeList =
+ Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
- let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
+ let transformUppercaseCall3 ~config modulePath mapper loc attrs callArguments
+ =
let children, argsWithLabels =
extractChildren ~loc ~removeLastPositionUnit:true callArguments
in
@@ -273325,18 +274592,29 @@ let jsxMapper () =
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;
+ @
+ 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;
+ match config.mode with
+ | "automatic" ->
+ [
+ ( labelled "children",
+ Exp.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, 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
@@ -273350,94 +274628,190 @@ let jsxMapper () =
Ldot (fullPath, "make")
| 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
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
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);
- ]
+ match config.mode with
+ (* The new jsx transform *)
+ | "automatic" ->
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")},
+ [] )
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")},
+ [] )
+ in
+ Exp.apply ~attrs jsxExpr
+ ([(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)] @ key)
+ | _ -> (
+ let record = recordFromProps args in
+ (* check if record which goes to Foo.make({ ... } as record) empty or not
+ if empty then change it to {key: @optional None} only for upper case jsx
+ This would be redundant regarding PR progress https://github.com/rescript-lang/syntax/pull/299
+ *)
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ match !childrenArg with
+ | None ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "createElement")})
+ [(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)]
+ | Some children ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {
+ loc = Location.none;
+ txt = Ldot (Lident "React", "createElementVariadic");
+ })
+ [
+ (nolabel, Exp.ident {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 transformLowercaseCall3 ~config mapper loc attrs callArguments id =
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
+ match config.mode with
+ (* the new jsx transform *)
+ | "automatic" ->
+ let children, nonChildrenProps =
+ extractChildren ~removeLastPositionUnit:true ~loc callArguments
+ in
+ let argsForMake = nonChildrenProps 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.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, expression)] );
+ ]
+ in
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
+ in
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsx")}, [])
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxs")}, [])
+ in
+ Exp.apply ~loc ~attrs jsxExpr
+ ([(nolabel, componentNameExpr); (nolabel, props)] @ key)
+ | _ ->
+ let children, nonChildrenProps = extractChildren ~loc callArguments 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.domProps(~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 args newtypes =
+ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes
+ coreType =
let expr = mapper.expr mapper expr in
match expr.pexp_desc with
(* TODO: make this show up with a loc. *)
@@ -273489,562 +274863,566 @@ let jsxMapper () =
recursivelyTransformNamedArgsForMake mapper expression
((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args)
- newtypes
+ newtypes coreType
| Pexp_fun
( Nolabel,
_,
{ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
_expression ) ->
- (args, newtypes, None)
+ (args, newtypes, coreType)
| Pexp_fun
( Nolabel,
_,
{
ppat_desc =
- Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _);
+ Ppat_var _ | Ppat_constraint ({ppat_desc = Ppat_var _}, _);
},
_expression ) ->
- (args, newtypes, Some txt)
+ (args, newtypes, coreType)
| Pexp_fun (Nolabel, _, pattern, _expression) ->
Location.raise_errorf ~loc:pattern.ppat_loc
"React: react.component refs only support plain arguments and type \
annotations."
| Pexp_newtype (label, expression) ->
recursivelyTransformNamedArgsForMake mapper expression args
- (label :: newtypes)
- | Pexp_constraint (expression, _typ) ->
+ (label :: newtypes) coreType
+ | Pexp_constraint (expression, coreType) ->
recursivelyTransformNamedArgsForMake mapper expression args newtypes
- | _ -> (args, newtypes, None)
+ (Some coreType)
+ | _ -> (args, newtypes, coreType)
[@@raises Invalid_argument]
- in
- let argToType types (name, default, _noLabelName, _alias, loc, type_) =
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ let argToType ~newtypes ~(typeConstraints : core_type option) types
+ (name, default, _noLabelName, _alias, loc, type_) =
+ let rec getType name coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} ->
+ if name = arg then Some c1 else getType name c2
+ | _ -> None
+ in
+ let typeConst = Option.bind typeConstraints (getType name) in
+ let type_ =
+ List.fold_left
+ (fun type_ newtype ->
+ match (type_, typeConst) with
+ | _, Some typ | Some typ, None -> Some (newtypeToVar newtype.txt typ)
+ | _ -> None)
+ type_ newtypes
+ in
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_attributes = [];
- } )
+ | Some type_, name, _ when isOptional name ->
+ (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttr})
:: types
- | Some type_, name, _ -> (getLabel name, [], type_) :: types
+ | Some type_, name, _ -> (false, getLabel name, [], type_) :: types
| None, name, _ when isOptional name ->
- ( getLabel name,
+ ( true,
+ getLabel name,
[],
- {
- ptyp_desc =
- Ptyp_constr
- ( {loc; txt = optionIdent},
- [
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- };
- ] );
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
+ Typ.var ~loc ~attrs:optionalAttr (safeTypeFromValue name) )
:: types
| None, name, _ when isLabelled name ->
- ( getLabel name,
- [],
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
- :: types
+ (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types
| _ -> types
[@@raises Invalid_argument]
- in
- let argToConcreteType types (name, loc, type_) =
+ let argWithDefaultValue (name, default, _, _, _, _) =
+ match default with
+ | Some default when isOptional name -> Some (getLabel name, default)
+ | _ -> None
+ [@@raises Invalid_argument]
+
+ 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
+ | name when isLabelled name -> (false, getLabel name, [], type_) :: types
+ | name when isOptional name -> (true, getLabel name, [], type_) :: types
| _ -> types
- in
- let nestedModules = ref [] in
- let transformComponentDefinition mapper structure returnStructures =
- match structure with
+ let transformStructureItem ~config mapper item =
+ match item with
(* external *)
| {
pstr_loc;
pstr_desc =
- Pstr_primitive
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- value_description);
+ Pstr_primitive ({pval_attributes; pval_type} as value_description);
} as pstr -> (
match List.filter hasAttr pval_attributes with
- | [] -> structure :: returnStructures
+ | [] -> [item]
| [_] ->
- 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
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ 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 retPropsType =
+ Typ.constr ~loc:pstr_loc
+ (Location.mkloc (Lident "props") pstr_loc)
+ (makePropsTypeParams namedTypeList)
+ in
+ (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" Location.none
+ ((true, "key", [], keyType pstr_loc) :: namedTypeList)
+ 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
+ [propsRecordType; newStructure])
| _ ->
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)} ->
+ | {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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
- 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
- | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} ->
- 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 =
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ let bindingLoc = binding.pvb_loc in
+ let bindingPatLoc = binding.pvb_pat.ppat_loc in
+ let binding =
{
- exp with
- pexp_attributes =
- unerasableIgnore emptyLoc :: exp.pexp_attributes;
+ binding with
+ pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc};
+ pvb_loc = emptyLoc;
}
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
+ let fnName = getFnName binding.pvb_pat in
+ let internalFnName = fnName ^ "$Internal" in
+ let fullModuleName =
+ makeModuleName fileName config.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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ (* 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
{
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
- "React: 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)
+ (* let make = (()) => ... *)
+ (* let make = (_) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( Nolabel,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (~prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( (Labelled _ | Optional _),
+ _default,
+ _pattern,
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun (_nolabel, _default, pattern, _internalExpression);
+ } ->
+ if !hasApplication then ((fun a -> a), false, expression)
+ else
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {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 _, _, exp = spelunkForFunExpression internalExpression in
+ let hasForwardRef = isForwardRef wrapperExpression in
+ ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]),
+ hasForwardRef,
+ exp )
+ | {
+ pexp_desc =
+ Pexp_sequence (wrapperExpression, internalExpression);
+ } ->
+ let wrap, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {
+ expression with
+ pexp_desc = Pexp_sequence (wrapperExpression, exp);
+ } )
+ | e -> ((fun a -> a), false, e)
+ in
+ let wrapExpression, hasForwardRef, expression =
+ spelunkForFunExpression expression
+ in
+ ( wrapExpressionWithBinding wrapExpression,
+ hasForwardRef,
+ expression )
in
- let wrapExpression, hasUnit, expression =
- spelunkForFunExpression expression
+ let bindingWrapper, hasForwardRef, expression =
+ modifiedBinding binding
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 (loc, payload) -> (loc.loc, Some payload)
- | None -> (emptyLoc, None)
- in
- let props = getPropsAttr payload in
- (* do stuff here! *)
- let namedArgList, newtypes, 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
- | _ -> ""
+ (* do stuff here! *)
+ let namedArgList, newtypes, typeConstraints =
+ recursivelyTransformNamedArgsForMake mapper
+ (modifiedBindingOld binding)
+ [] [] None
+ in
+ let namedTypeList =
+ List.fold_left
+ (argToType ~newtypes ~typeConstraints)
+ [] namedArgList
+ in
+ let namedArgWithDefaultValueList =
+ List.filter_map argWithDefaultValue namedArgList
+ in
+ let vbMatch (label, default) =
+ Vb.mk
+ (Pat.var (Location.mknoloc label))
+ (Exp.match_
+ (Exp.ident {txt = Lident label; loc = Location.none})
+ [
+ Exp.case
+ (Pat.construct
+ (Location.mknoloc @@ Lident "Some")
+ (Some (Pat.var (Location.mknoloc label))))
+ (Exp.ident (Location.mknoloc @@ Lident label));
+ Exp.case
+ (Pat.construct (Location.mknoloc @@ Lident "None") None)
+ default;
+ ])
+ in
+ let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in
+ (* type props = { ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" emptyLoc
+ ([(true, "key", [], keyType emptyLoc)]
+ @ (if hasForwardRef then
+ [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
+ in
+ let innerExpression =
+ Exp.apply
+ (Exp.ident (Location.mknoloc @@ Lident "make"))
+ ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))]
+ @
+ match hasForwardRef with
+ | true ->
+ [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]
+ | false -> [])
+ in
+ let fullExpression =
+ (* React component name should start with uppercase letter *)
+ (* let make = { let \"App" = props => make(props); \"App" } *)
+ (* let make = React.forwardRef({
+ let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))})
+ })*)
+ Exp.fun_ nolabel None
+ (match namedTypeList with
+ | [] -> Pat.var @@ Location.mknoloc "props"
+ | _ ->
+ Pat.constraint_
+ (Pat.var @@ Location.mknoloc "props")
+ (Typ.constr
+ (Location.mknoloc @@ Lident "props")
+ [Typ.any ()]))
+ (if hasForwardRef then
+ Exp.fun_ nolabel None
+ (Pat.var @@ Location.mknoloc "ref")
+ innerExpression
+ else innerExpression)
in
- ( label,
- match labelString with
- | "" -> Exp.ident ~loc {txt = Lident alias; loc}
- | labelString ->
- Exp.apply ~loc
- (Exp.ident ~loc {txt = Lident "##"; loc})
+ let fullExpression =
+ match fullModuleName with
+ | "" -> fullExpression
+ | txt ->
+ Exp.let_ Nonrecursive
[
- (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 externalArgs =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, c, d, e, maybeTyp) ->
- match maybeTyp with
- | Some typ ->
- (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
- | None -> (a, b, c, d, e, None))
- args)
- namedArgListWithKeyAndRef newtypes
- in
- let externalTypes =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
- args)
- namedTypeList newtypes
- in
- let externalDecl =
- makeExternalDecl fnName loc externalArgs externalTypes
- 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_attributes = [];
- },
- innerExpression );
- }
- | None -> innerExpression
- in
- let fullExpression =
- Exp.fun_ nolabel None
- {
- ppat_desc =
- Ppat_constraint
- ( makePropsName ~loc:emptyLoc props.propsName,
- makePropsType ~loc:emptyLoc externalTypes );
- ppat_loc = emptyLoc;
- 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)
+ Vb.mk ~loc:emptyLoc
+ (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt})
+ fullExpression;
+ ]
+ (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt})
+ in
+ let rec returnedExpression patternsWithLabel patternsWithNolabel
+ ({pexp_desc} as expr) =
+ match pexp_desc with
+ | Pexp_newtype (_, expr) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_constraint (expr, _) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_fun
+ ( _arg_label,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ expr ) ->
+ (patternsWithLabel, patternsWithNolabel, expr)
+ | Pexp_fun (arg_label, _default, {ppat_loc; ppat_desc}, expr) -> (
+ if isLabelled arg_label || isOptional arg_label then
+ returnedExpression
+ (( {loc = ppat_loc; txt = Lident (getLabel arg_label)},
+ Pat.var
+ ~attrs:
+ (if isOptional arg_label then optionalAttr else [])
+ {txt = getLabel arg_label; loc = ppat_loc} )
+ :: patternsWithLabel)
+ patternsWithNolabel expr
+ else
+ (* Special case of nolabel arg "ref" in forwardRef fn *)
+ (* let make = React.forwardRef(ref => body) *)
+ match ppat_desc with
+ | Ppat_var {txt} ->
+ returnedExpression patternsWithLabel
+ (( {loc = ppat_loc; txt = Lident txt},
+ Pat.var ~attrs:optionalAttr {txt; loc = ppat_loc} )
+ :: patternsWithNolabel)
+ expr
+ | _ ->
+ returnedExpression patternsWithLabel patternsWithNolabel
+ expr)
+ | _ -> (patternsWithLabel, patternsWithNolabel, expr)
+ in
+ let patternsWithLabel, patternsWithNolabel, expression =
+ returnedExpression [] [] expression
+ in
+ let pattern =
+ match patternsWithLabel with
+ | [] -> Pat.any ()
+ | _ -> Pat.record (List.rev patternsWithLabel) Open
+ in
+ (* add pattern matching for optional prop value *)
+ let expression =
+ if List.length vbMatchList = 0 then expression
+ else Exp.let_ Nonrecursive vbMatchList expression
+ in
+ let expression =
+ List.fold_left
+ (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr)
+ expression patternsWithNolabel
+ in
+ let expression =
+ Exp.fun_ Nolabel None
+ (Pat.constraint_ pattern
+ (Typ.constr ~loc:emptyLoc
+ {txt = Lident "props"; loc = emptyLoc}
+ (makePropsTypeParams ~stripExplicitOption:true
+ namedTypeList)))
+ expression
+ in
+ (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *)
+ 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_pat = Pat.var {txt = fnName; loc = Location.none};
+ };
+ ],
+ Some (bindingWrapper fullExpression) )
+ in
+ (Some propsRecordType, bindings, newBinding))
else (None, [binding], None)
[@@raises Invalid_argument]
in
+ (* END of mapBinding fn *)
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
+ let otherStructures (type_, binding, newBinding)
+ (types, bindings, newBindings) =
+ let types =
+ match type_ with
+ | Some type_ -> type_ :: types
+ | None -> types
in
let newBindings =
match newBinding with
| Some newBinding -> newBinding :: newBindings
| None -> newBindings
in
- (externs, binding @ bindings, newBindings)
+ (types, binding @ bindings, newBindings)
in
- let externs, bindings, newBindings =
+ let types, bindings, newBindings =
List.fold_right otherStructures structuresAndBinding ([], [], [])
in
- externs
+ types
@ [{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 []
+ @
+ match newBindings with
+ | [] -> []
+ | newBindings ->
+ [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}])
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformComponentSignature _mapper signature returnSignatures =
- match signature with
+ let transformSignatureItem ~config _mapper item =
+ match item with
| {
psig_loc;
- psig_desc =
- Psig_value
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- psig_desc);
+ psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc);
} as psig -> (
match List.filter hasAttr pval_attributes with
- | [] -> signature :: returnSignatures
+ | [] -> [item]
| [_] ->
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:psig_loc
+ else config.hasReactComponent <- true;
+ let hasForwardRef = ref false in
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
+ ( Nolabel,
+ {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)},
+ rest ) ->
+ getPropTypes types rest
+ | Ptyp_arrow (Nolabel, _type, rest) ->
+ hasForwardRef := true;
+ getPropTypes types rest
| Ptyp_arrow (name, type_, returnValue)
when isOptional name || isLabelled name ->
(returnValue, (name, returnValue.ptyp_loc, type_) :: types)
@@ -274052,15 +275430,18 @@ let jsxMapper () =
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_)
+ let retPropsType =
+ Typ.constr
+ (Location.mkloc (Lident "props") psig_loc)
+ (makePropsTypeParams namedTypeList)
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
+ let propsRecordType =
+ makePropsRecordTypeSig "props" Location.none
+ ([(true, "key", [], keyType Location.none)]
+ (* If there is Nolabel arg, regard the type as ref in forwardRef *)
+ @ (if !hasForwardRef then [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
in
(* can't be an arrow because it will defensively uncurry *)
let newExternalType =
@@ -274080,22 +275461,16 @@ let jsxMapper () =
};
}
in
- externalPropsDecl :: newStructure :: returnSignatures
+ [propsRecordType; newStructure]
| _ ->
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 []
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformJsxCall mapper callExpression callArguments attrs =
+ let transformJsxCall ~config mapper callExpression callArguments attrs =
match callExpression.pexp_desc with
| Pexp_ident caller -> (
match caller with
@@ -274104,20 +275479,14 @@ let jsxMapper () =
(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 modulePath mapper loc attrs callExpression
- callArguments
- | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} ->
+ transformUppercaseCall3 ~config modulePath mapper loc attrs
+ callArguments
(* 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"))
+ | {loc; txt = Lident id} ->
+ transformLowercaseCall3 ~config mapper loc attrs callArguments id
| {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
raise
(Invalid_argument
@@ -274136,23 +275505,8 @@ let jsxMapper () =
"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 =
+ let expr ~config mapper expression =
match expression with
(* Does the function application have the @JSX attribute? *)
| {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes}
@@ -274166,7 +275520,8 @@ let jsxMapper () =
(* no JSX attribute *)
| [], _ -> default_mapper.expr mapper expression
| _, nonJSXAttributes ->
- transformJsxCall mapper callExpression callArguments nonJSXAttributes)
+ transformJsxCall ~config mapper callExpression callArguments
+ nonJSXAttributes)
(* is it a list with jsx attribute? Reason <>foo> desugars to [@JSX][foo]*)
| {
pexp_desc =
@@ -274186,46 +275541,177 @@ let jsxMapper () =
| _, nonJSXAttributes ->
let loc = {loc with loc_ghost = true} in
let fragment =
- Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")}
+ match config.mode with
+ | "automatic" ->
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")}
+ | "classic" | _ ->
+ 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);
+ (match config.mode with
+ | "automatic" ->
+ ( nolabel,
+ Exp.record
+ [
+ ( Location.mknoloc @@ Lident "children",
+ match childrenExpr with
+ | {pexp_desc = Pexp_array children} -> (
+ match children with
+ | [] -> recordWithOnlyKey ~loc:Location.none
+ | [child] -> child
+ | _ -> childrenExpr)
+ | _ -> childrenExpr );
+ ]
+ None )
+ | "classic" | _ -> (nolabel, childrenExpr));
]
in
+ let countOfChildren = function
+ | {pexp_desc = Pexp_array children} -> List.length children
+ | _ -> 0
+ 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")})
+ (match config.mode with
+ | "automatic" ->
+ if countOfChildren childrenExpr > 1 then
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")}
+ else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")}
+ | "classic" | _ ->
+ 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 =
- let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let module_binding ~config mapper module_binding =
+ config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules;
let mapped = default_mapper.module_binding mapper module_binding in
- let _ = nestedModules := List.tl !nestedModules in
+ config.nestedModules <- List.tl config.nestedModules;
mapped
[@@raises Failure]
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let expr = expr ~config in
+ let module_binding = module_binding ~config in
+ let transformStructureItem = transformStructureItem ~config in
+ let transformSignatureItem = transformSignatureItem ~config in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
+
+let getMapper ~config =
+ let expr3, module_binding3, transformSignatureItem3, transformStructureItem3 =
+ V3.jsxMapper ~config
in
- {default_mapper with structure; expr; signature; module_binding}
- [@@raises Invalid_argument, Failure]
+ let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 =
+ V4.jsxMapper ~config
+ in
+
+ let expr mapper e =
+ match config.version with
+ | 3 -> expr3 mapper e
+ | 4 -> expr4 mapper e
+ | _ -> default_mapper.expr mapper e
+ in
+ let module_binding mapper mb =
+ match config.version with
+ | 3 -> module_binding3 mapper mb
+ | 4 -> module_binding4 mapper mb
+ | _ -> default_mapper.module_binding mapper mb
+ in
+ let saveConfig () =
+ {
+ config with
+ version = config.version;
+ module_ = config.module_;
+ mode = config.mode;
+ hasReactComponent = config.hasReactComponent;
+ }
+ in
+ let restoreConfig oldConfig =
+ config.version <- oldConfig.version;
+ config.module_ <- oldConfig.module_;
+ config.mode <- oldConfig.mode;
+ config.hasReactComponent <- oldConfig.hasReactComponent
+ in
+ let signature mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.psig_desc with
+ | Psig_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.signature_item mapper item in
+ if config.version = 3 then transformSignatureItem3 mapper item
+ else if config.version = 4 then transformSignatureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+ let structure mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.pstr_desc with
+ | Pstr_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.structure_item mapper item in
+ if config.version = 3 then transformStructureItem3 mapper item
+ else if config.version = 4 then transformStructureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+
+ {default_mapper with expr; module_binding; signature; structure}
-let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure =
- let mapper = jsxMapper () in
+let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.structure) : Parsetree.structure =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.structure mapper code
[@@raises Invalid_argument, Failure]
-let rewrite_signature (code : Parsetree.signature) : Parsetree.signature =
- let mapper = jsxMapper () in
+let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.signature) : Parsetree.signature =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.signature mapper code
[@@raises Invalid_argument, Failure]
@@ -274264,7 +275750,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_signature ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_signature ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
(* react-jsx ppx relies on built-in ones like `##` *)
in
@@ -274280,7 +275768,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_implementation ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
in
if !Js_config.no_builtin_ppx then ast
diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml.d b/lib/4.06.1/unstable/js_playground_compiler.ml.d
index 2c110d07f8..5c7aac14e8 100644
--- a/lib/4.06.1/unstable/js_playground_compiler.ml.d
+++ b/lib/4.06.1/unstable/js_playground_compiler.ml.d
@@ -567,8 +567,8 @@
../lib/4.06.1/unstable/js_playground_compiler.ml: ./ml/typetexp.mli
../lib/4.06.1/unstable/js_playground_compiler.ml: ./ml/untypeast.ml
../lib/4.06.1/unstable/js_playground_compiler.ml: ./ml/untypeast.mli
-../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.ml
-../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.mli
+../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/reactjs_jsx_ppx.ml
+../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/reactjs_jsx_ppx.mli
../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_comment.ml
../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_comment.mli
../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_comments_table.ml
diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml
index 582d8cf70b..59351ff2db 100644
--- a/lib/4.06.1/whole_compiler.ml
+++ b/lib/4.06.1/whole_compiler.ml
@@ -283197,8 +283197,8 @@ let mapper : mapper =
end
-module Reactjs_jsx_ppx_v3 : sig
-#1 "reactjs_jsx_ppx_v3.mli"
+module Reactjs_jsx_ppx : sig
+#1 "reactjs_jsx_ppx.mli"
(*
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
@@ -283209,399 +283209,1666 @@ module Reactjs_jsx_ppx_v3 : sig
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 :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.structure ->
+ Parsetree.structure
+
+val rewrite_signature :
+ jsxVersion:int ->
+ jsxModule:string ->
+ jsxMode:string ->
+ Parsetree.signature ->
+ Parsetree.signature
+
+end = struct
+#1 "reactjs_jsx_ppx.ml"
+open Ast_helper
+open Ast_mapper
+open Asttypes
+open Parsetree
+open Longident
+
+type jsxConfig = {
+ mutable version: int;
+ mutable module_: string;
+ mutable mode: string;
+ mutable nestedModules: string list;
+ mutable hasReactComponent: bool;
+}
+
+let getPayloadFields payload =
+ match payload with
+ | PStr
+ ({
+ pstr_desc =
+ Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _);
+ }
+ :: _rest) ->
+ recordFields
+ | _ -> []
+
+type configKey = Int | String
+
+let getJsxConfigByKey ~key ~type_ recordFields =
+ let values =
+ List.filter_map
+ (fun ((lid, expr) : Longident.t Location.loc * expression) ->
+ match (type_, lid, expr) with
+ | ( Int,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_integer (value, None))} )
+ when k = key ->
+ Some value
+ | ( String,
+ {txt = Lident k},
+ {pexp_desc = Pexp_constant (Pconst_string (value, None))} )
+ when k = key ->
+ Some value
+ | _ -> None)
+ recordFields
+ in
+ match values with
+ | [] -> None
+ | [v] | v :: _ -> Some v
+
+let getInt ~key fields =
+ match fields |> getJsxConfigByKey ~key ~type_:Int with
+ | None -> None
+ | Some s -> int_of_string_opt s
+
+let getString ~key fields = fields |> getJsxConfigByKey ~key ~type_:String
+
+let updateConfig config payload =
+ let fields = getPayloadFields payload in
+ (match getInt ~key:"version" fields with
+ | None -> ()
+ | Some i -> config.version <- i);
+ (match getString ~key:"module" fields with
+ | None -> ()
+ | Some s -> config.module_ <- s);
+ match getString ~key:"mode" fields with
+ | None -> ()
+ | Some s -> config.mode <- s
+
+let isJsxConfigAttr ((loc, _) : attribute) = loc.txt = "jsxConfig"
+
+let processConfigAttribute attribute config =
+ if isJsxConfigAttr attribute then updateConfig config (snd attribute)
+
+(* Helper method to look up the [@react.component] attribute *)
+let hasAttr (loc, _) = loc.txt = "react.component"
+
+(* Iterate over the attributes and try to find the [@react.component] attribute *)
+let hasAttrOnBinding {pvb_attributes} =
+ List.find_opt hasAttr pvb_attributes <> None
+
+module V3 = struct
+ 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, 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 =
+ ( {loc; txt = "warning"},
+ PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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
*)
-val rewrite_implementation : Parsetree.structure -> Parsetree.structure
+ (* 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_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_attributes = [];
+ }
+ (* ~foo *)
+ | label, None, _ ->
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue label);
+ 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_attributes = [];
+ }
+ propsType);
+ pval_prim = [""];
+ pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
+ 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_attributes = [];
+ }
+
+ let makeObjectField loc (str, attrs, type_) =
+ Otag ({loc; txt = str}, attrs, type_)
+
+ (* Build an AST node representing a "closed" object representing a component's props *)
+ let makePropsType ~loc namedTypeList =
+ Typ.mk ~loc
+ (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
+
+ (* 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]
+
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let transformUppercaseCall3 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, "make")
+ | Ldot (_modulePath, value) as fullPath when isCap value ->
+ Ldot (fullPath, "make")
+ | 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 args newtypes =
+ 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
+ "React: 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_) :: args)
+ newtypes
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
+ _expression ) ->
+ (args, newtypes, None)
+ | Pexp_fun
+ ( Nolabel,
+ _,
+ {
+ ppat_desc =
+ ( Ppat_var {txt}
+ | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) );
+ },
+ _expression ) ->
+ (args, newtypes, Some txt)
+ | Pexp_fun (Nolabel, _, pattern, _expression) ->
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: react.component refs only support plain arguments and type \
+ annotations."
+ | Pexp_newtype (label, expression) ->
+ recursivelyTransformNamedArgsForMake mapper expression args
+ (label :: newtypes)
+ | Pexp_constraint (expression, _typ) ->
+ recursivelyTransformNamedArgsForMake mapper expression args newtypes
+ | _ -> (args, newtypes, 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_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_attributes = [];
+ };
+ ] );
+ ptyp_loc = loc;
+ ptyp_attributes = [];
+ } )
+ :: types
+ | None, name, _ when isLabelled name ->
+ ( getLabel name,
+ [],
+ {
+ ptyp_desc = Ptyp_var (safeTypeFromValue name);
+ ptyp_loc = loc;
+ 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 transformStructureItem mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ 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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ "React: 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 (loc, payload) -> (loc.loc, Some payload)
+ | None -> (emptyLoc, None)
+ in
+ let props = getPropsAttr payload in
+ (* do stuff here! *)
+ let namedArgList, newtypes, 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 externalArgs =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, c, d, e, maybeTyp) ->
+ match maybeTyp with
+ | Some typ ->
+ (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
+ | None -> (a, b, c, d, e, None))
+ args)
+ namedArgListWithKeyAndRef newtypes
+ in
+ let externalTypes =
+ (* translate newtypes to type variables *)
+ List.fold_left
+ (fun args newtype ->
+ List.map
+ (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
+ args)
+ namedTypeList newtypes
+ in
+ let externalDecl =
+ makeExternalDecl fnName loc externalArgs externalTypes
+ 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_attributes = [];
+ },
+ innerExpression );
+ }
+ | None -> innerExpression
+ in
+ let fullExpression =
+ Exp.fun_ nolabel None
+ {
+ ppat_desc =
+ Ppat_constraint
+ ( makePropsName ~loc:emptyLoc props.propsName,
+ makePropsType ~loc:emptyLoc externalTypes );
+ ppat_loc = emptyLoc;
+ 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}],
+ 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)}]
+ )
+ | _ -> [item]
+ [@@raises Invalid_argument]
+ in
+
+ let transformSignatureItem _mapper item =
+ match item 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
+ | [] -> [item]
+ | [_] ->
+ 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]
+ | _ ->
+ raise
+ (Invalid_argument
+ "Only one react.component call can exist on a component at one \
+ time"))
+ | _ -> [item]
+ [@@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 config.version with
+ | 3 ->
+ transformUppercaseCall3 modulePath mapper loc attrs callExpression
+ callArguments
+ | _ -> 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 config.version with
+ | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
+ | _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
+ raise
+ (Invalid_argument
+ ("JSX: the JSX attribute should be attached to a \
+ `YourModuleName.createElement` or `YourModuleName.make` call. \
+ We saw `" ^ anythingNotCreateElementOrMake ^ "` instead"))
+ | {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 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 (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 (attribute, _) -> attribute.txt = "JSX")
+ pexp_attributes
+ in
+ match (jsxAttribute, nonJSXAttributes) with
+ (* no JSX attribute *)
+ | [], _ -> default_mapper.expr mapper expression
+ | _, nonJSXAttributes ->
+ let loc = {loc with loc_ghost = true} in
+ 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 =
+ let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let mapped = default_mapper.module_binding mapper module_binding in
+ let _ = nestedModules := List.tl !nestedModules in
+ mapped
+ [@@raises Failure]
+ in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
-val rewrite_signature : Parsetree.signature -> Parsetree.signature
+module V4 = struct
+ let nolabel = Nolabel
-end = struct
-#1 "reactjs_jsx_ppx_v3.ml"
-open Ast_helper
-open Ast_mapper
-open Asttypes
-open Parsetree
-open Longident
+ let labelled str = Labelled str
-let rec find_opt p = function
- | [] -> None
- | x :: l -> if p x then Some x else find_opt p l
+ let isOptional str =
+ match str with
+ | Optional _ -> true
+ | _ -> false
-let nolabel = Nolabel
+ let isLabelled str =
+ match str with
+ | Labelled _ -> true
+ | _ -> false
-let labelled str = Labelled str
+ let isForwardRef = function
+ | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} ->
+ true
+ | _ -> false
-let optional str = Optional str
+ let getLabel str =
+ match str with
+ | Optional str | Labelled str -> str
+ | Nolabel -> ""
-let isOptional str =
- match str with
- | Optional _ -> true
- | _ -> false
+ let optionalAttr = [({txt = "ns.optional"; loc = Location.none}, PStr [])]
-let isLabelled str =
- match str with
- | Labelled _ -> true
- | _ -> false
+ let constantString ~loc str =
+ Ast_helper.Exp.constant ~loc (Pconst_string (str, None))
-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, 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 []
+ (* {} empty object in Js *)
+ let recordWithOnlyKey ~loc =
+ Exp.record ~loc
+ (* {key: @optional None} *)
+ [
+ ( {loc; txt = Lident "key"},
+ Exp.construct ~attrs:optionalAttr {loc; txt = Lident "None"} None );
+ ]
+ None
-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)
+ let safeTypeFromValue valueStr =
+ let valueStr = getLabel valueStr in
+ match String.sub valueStr 0 1 with
+ | "_" -> "T" ^ valueStr
+ | _ -> valueStr
[@@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 =
- ( {loc; txt = "warning"},
- PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] )
+ let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} []
-let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
+ let refType loc =
+ Typ.constr ~loc
+ {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")}
+ []
-(* Helper method to look up the [@react.component] attribute *)
-let hasAttr (loc, _) = loc.txt = "react.component"
+ type 'a children = ListLiteral of 'a | Exact of 'a
+
+ (* 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 []
-(* Helper method to filter out any attribute that isn't [@react.component] *)
-let otherAttrsPure (loc, _) = loc.txt <> "react.component"
+ 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]
-(* Iterate over the attributes and try to find the [@react.component] attribute *)
-let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None
+ let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr [])
-(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
-let rec getFnName binding =
- match binding with
- | {ppat_desc = Ppat_var {txt}} -> txt
- | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
- | _ ->
- raise (Invalid_argument "react.component calls cannot be destructured.")
- [@@raises Invalid_argument]
+ (* Helper method to filter out any attribute that isn't [@react.component] *)
+ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
-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
+ (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
+ let rec getFnName binding =
+ match binding with
+ | {ppat_desc = Ppat_var {txt}} -> txt
+ | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat
+ | _ ->
+ 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 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
+
+ let raiseError ~loc msg = Location.raise_errorf ~loc msg
+
+ let raiseErrorMultipleReactComponent ~loc =
+ raiseError ~loc
+ "Only one component definition is allowed for each module. Move to a \
+ submodule or other file if necessary."
+ (*
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_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_attributes = [];
- }
- (* ~foo *)
- | label, None, _ ->
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue label);
- ptyp_loc = loc;
- ptyp_attributes = [];
- }
- | _label, Some type_, _ -> type_)
- args)
- | [] -> args
- [@@raises Invalid_argument]
+ (* make record from props and spread props if exists *)
+ let recordFromProps ?(removeKey = false) callArguments =
+ let rec removeLastPositionUnitAux props acc =
+ match props with
+ | [] -> acc
+ | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] ->
+ acc
+ | (Nolabel, _) :: _rest ->
+ raise
+ (Invalid_argument
+ "JSX: found non-labelled argument before the last position")
+ | prop :: rest -> removeLastPositionUnitAux rest (prop :: acc)
+ in
+ let props, propsToSpread =
+ removeLastPositionUnitAux callArguments []
+ |> List.rev
+ |> List.partition (fun (label, _) -> label <> labelled "spreadProps")
+ in
+ let props =
+ if removeKey then
+ props |> List.filter (fun (arg_label, _) -> "key" <> getLabel arg_label)
+ else props
+ in
+ let fields =
+ props
+ |> List.map (fun (arg_label, ({pexp_loc} as expr)) ->
+ (* In case filed label is "key" only then change expression to option *)
+ if isOptional arg_label then
+ ( {txt = Lident (getLabel arg_label); loc = pexp_loc},
+ {expr with pexp_attributes = optionalAttr} )
+ else ({txt = Lident (getLabel arg_label); loc = pexp_loc}, expr))
+ in
+ let spreadFields =
+ propsToSpread |> List.map (fun (_, expression) -> expression)
+ in
+ match spreadFields with
+ | [] ->
+ {
+ pexp_desc = Pexp_record (fields, None);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | [spreadProps] ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
+ | spreadProps :: _ ->
+ {
+ pexp_desc = Pexp_record (fields, Some spreadProps);
+ pexp_loc = Location.none;
+ pexp_attributes = [];
+ }
-(* 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_attributes = [];
- }
- propsType);
- pval_prim = [""];
- pval_attributes = [({txt = "bs.obj"; loc}, PStr [])];
- pval_loc = loc;
- }
- [@@raises Invalid_argument]
+ (* make type params for make fn arguments *)
+ (* let make = ({id, name, children}: props<'id, 'name, 'children>) *)
+ let makePropsTypeParamsTvar namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (_isOptional, label, _, _interiorType) ->
+ if label = "key" || label = "ref" then None
+ else Some (Typ.var @@ safeTypeFromValue (Labelled label)))
+
+ let stripOption coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} ->
+ List.nth_opt coreTypes 0
+ | _ -> Some coreType
+
+ (* make type params for make sig arguments and for external *)
+ (* let make: React.componentLike>, React.element> *)
+ (* external make: React.componentLike, React.element> = "default" *)
+ let makePropsTypeParams ?(stripExplicitOption = false) namedTypeList =
+ namedTypeList
+ |> List.filter_map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" || label = "ref" then None
+ (* Strip the explicit option type in implementation *)
+ (* let make = (~x: option=?) => ... *)
+ else if isOptional && stripExplicitOption then
+ stripOption interiorType
+ else Some interiorType)
+
+ let makeLabelDecls ~loc namedTypeList =
+ namedTypeList
+ |> List.map (fun (isOptional, label, _, interiorType) ->
+ if label = "key" then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc} interiorType
+ else if label = "ref" then
+ Type.field ~loc
+ ~attrs:(if isOptional then optionalAttr else [])
+ {txt = label; loc} interiorType
+ else if isOptional then
+ Type.field ~loc ~attrs:optionalAttr {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label)
+ else
+ Type.field ~loc {txt = label; loc}
+ (Typ.var @@ safeTypeFromValue @@ Labelled label))
-(* 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]
+ let makeTypeDecls propsName loc namedTypeList =
+ let labelDeclList = makeLabelDecls ~loc namedTypeList in
+ (* 'id, 'className, ... *)
+ let params =
+ makePropsTypeParamsTvar namedTypeList
+ |> List.map (fun coreType -> (coreType, Invariant))
+ in
+ [
+ Type.mk ~loc ~params {txt = propsName; loc}
+ ~kind:(Ptype_record labelDeclList);
+ ]
-(* 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_attributes = []}
-
-let makeObjectField loc (str, attrs, type_) =
- Otag ({loc; txt = str}, attrs, type_)
-
-(* Build an AST node representing a "closed" object representing a component's props *)
-let makePropsType ~loc namedTypeList =
- Typ.mk ~loc
- (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
-
-(* 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]
-
-let newtypeToVar newtype type_ =
- let var_desc = Ptyp_var ("type-" ^ newtype) in
- let typ (mapper : Ast_mapper.mapper) typ =
- match typ.ptyp_desc with
- | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
- {typ with ptyp_desc = var_desc}
- | _ -> Ast_mapper.default_mapper.typ mapper typ
- in
- let mapper = {Ast_mapper.default_mapper with typ} in
- mapper.typ mapper type_
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordType propsName loc namedTypeList =
+ Str.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
-(* TODO: some line number might still be wrong *)
-let jsxMapper () =
- let jsxVersion = ref None in
+ (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *)
+ let makePropsRecordTypeSig propsName loc namedTypeList =
+ Sig.type_ Nonrecursive (makeTypeDecls propsName loc namedTypeList)
- let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
+ let transformUppercaseCall3 ~config modulePath mapper loc attrs callArguments
+ =
let children, argsWithLabels =
extractChildren ~loc ~removeLastPositionUnit:true callArguments
in
@@ -283615,18 +284882,29 @@ let jsxMapper () =
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;
+ @
+ 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;
+ match config.mode with
+ | "automatic" ->
+ [
+ ( labelled "children",
+ Exp.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, 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
@@ -283640,94 +284918,190 @@ let jsxMapper () =
Ldot (fullPath, "make")
| 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
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
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);
- ]
+ match config.mode with
+ (* The new jsx transform *)
+ | "automatic" ->
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")},
+ [] )
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")},
+ [] )
+ in
+ Exp.apply ~attrs jsxExpr
+ ([(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)] @ key)
+ | _ -> (
+ let record = recordFromProps args in
+ (* check if record which goes to Foo.make({ ... } as record) empty or not
+ if empty then change it to {key: @optional None} only for upper case jsx
+ This would be redundant regarding PR progress https://github.com/rescript-lang/syntax/pull/299
+ *)
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ match !childrenArg with
+ | None ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {loc = Location.none; txt = Ldot (Lident "React", "createElement")})
+ [(nolabel, Exp.ident {txt = ident; loc}); (nolabel, props)]
+ | Some children ->
+ Exp.apply ~attrs
+ (Exp.ident
+ {
+ loc = Location.none;
+ txt = Ldot (Lident "React", "createElementVariadic");
+ })
+ [
+ (nolabel, Exp.ident {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 transformLowercaseCall3 ~config mapper loc attrs callArguments id =
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
+ match config.mode with
+ (* the new jsx transform *)
+ | "automatic" ->
+ let children, nonChildrenProps =
+ extractChildren ~removeLastPositionUnit:true ~loc callArguments
+ in
+ let argsForMake = nonChildrenProps 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.apply
+ (Exp.ident
+ {txt = Ldot (Lident "React", "array"); loc = Location.none})
+ [(Nolabel, expression)] );
+ ]
+ in
+ let isEmptyRecord {pexp_desc} =
+ match pexp_desc with
+ | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true
+ | _ -> false
+ in
+ let record = recordFromProps ~removeKey:true args in
+ let props =
+ if isEmptyRecord record then recordWithOnlyKey ~loc else record
+ in
+ let keyProp =
+ args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label)
+ in
+ let jsxExpr, key =
+ match (!childrenArg, keyProp) with
+ | None, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxKeyed")},
+ [(nolabel, keyExpr)] )
+ | None, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsx")}, [])
+ | Some _, (_, keyExpr) :: _ ->
+ ( Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")},
+ [(nolabel, keyExpr)] )
+ | Some _, [] ->
+ (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOM", "jsxs")}, [])
+ in
+ Exp.apply ~loc ~attrs jsxExpr
+ ([(nolabel, componentNameExpr); (nolabel, props)] @ key)
+ | _ ->
+ let children, nonChildrenProps = extractChildren ~loc callArguments 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.domProps(~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 args newtypes =
+ let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes
+ coreType =
let expr = mapper.expr mapper expr in
match expr.pexp_desc with
(* TODO: make this show up with a loc. *)
@@ -283779,562 +285153,566 @@ let jsxMapper () =
recursivelyTransformNamedArgsForMake mapper expression
((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args)
- newtypes
+ newtypes coreType
| Pexp_fun
( Nolabel,
_,
{ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any},
_expression ) ->
- (args, newtypes, None)
+ (args, newtypes, coreType)
| Pexp_fun
( Nolabel,
_,
{
ppat_desc =
- Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _);
+ Ppat_var _ | Ppat_constraint ({ppat_desc = Ppat_var _}, _);
},
_expression ) ->
- (args, newtypes, Some txt)
+ (args, newtypes, coreType)
| Pexp_fun (Nolabel, _, pattern, _expression) ->
Location.raise_errorf ~loc:pattern.ppat_loc
"React: react.component refs only support plain arguments and type \
annotations."
| Pexp_newtype (label, expression) ->
recursivelyTransformNamedArgsForMake mapper expression args
- (label :: newtypes)
- | Pexp_constraint (expression, _typ) ->
+ (label :: newtypes) coreType
+ | Pexp_constraint (expression, coreType) ->
recursivelyTransformNamedArgsForMake mapper expression args newtypes
- | _ -> (args, newtypes, None)
+ (Some coreType)
+ | _ -> (args, newtypes, coreType)
[@@raises Invalid_argument]
- in
- let argToType types (name, default, _noLabelName, _alias, loc, type_) =
+ let newtypeToVar newtype type_ =
+ let var_desc = Ptyp_var ("type-" ^ newtype) in
+ let typ (mapper : Ast_mapper.mapper) typ =
+ match typ.ptyp_desc with
+ | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+ {typ with ptyp_desc = var_desc}
+ | _ -> Ast_mapper.default_mapper.typ mapper typ
+ in
+ let mapper = {Ast_mapper.default_mapper with typ} in
+ mapper.typ mapper type_
+
+ let argToType ~newtypes ~(typeConstraints : core_type option) types
+ (name, default, _noLabelName, _alias, loc, type_) =
+ let rec getType name coreType =
+ match coreType with
+ | {ptyp_desc = Ptyp_arrow (arg, c1, c2)} ->
+ if name = arg then Some c1 else getType name c2
+ | _ -> None
+ in
+ let typeConst = Option.bind typeConstraints (getType name) in
+ let type_ =
+ List.fold_left
+ (fun type_ newtype ->
+ match (type_, typeConst) with
+ | _, Some typ | Some typ, None -> Some (newtypeToVar newtype.txt typ)
+ | _ -> None)
+ type_ newtypes
+ in
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_attributes = [];
- } )
+ | Some type_, name, _ when isOptional name ->
+ (true, getLabel name, [], {type_ with ptyp_attributes = optionalAttr})
:: types
- | Some type_, name, _ -> (getLabel name, [], type_) :: types
+ | Some type_, name, _ -> (false, getLabel name, [], type_) :: types
| None, name, _ when isOptional name ->
- ( getLabel name,
+ ( true,
+ getLabel name,
[],
- {
- ptyp_desc =
- Ptyp_constr
- ( {loc; txt = optionIdent},
- [
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- };
- ] );
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
+ Typ.var ~loc ~attrs:optionalAttr (safeTypeFromValue name) )
:: types
| None, name, _ when isLabelled name ->
- ( getLabel name,
- [],
- {
- ptyp_desc = Ptyp_var (safeTypeFromValue name);
- ptyp_loc = loc;
- ptyp_attributes = [];
- } )
- :: types
+ (false, getLabel name, [], Typ.var ~loc (safeTypeFromValue name)) :: types
| _ -> types
[@@raises Invalid_argument]
- in
- let argToConcreteType types (name, loc, type_) =
+ let argWithDefaultValue (name, default, _, _, _, _) =
+ match default with
+ | Some default when isOptional name -> Some (getLabel name, default)
+ | _ -> None
+ [@@raises Invalid_argument]
+
+ 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
+ | name when isLabelled name -> (false, getLabel name, [], type_) :: types
+ | name when isOptional name -> (true, getLabel name, [], type_) :: types
| _ -> types
- in
- let nestedModules = ref [] in
- let transformComponentDefinition mapper structure returnStructures =
- match structure with
+ let transformStructureItem ~config mapper item =
+ match item with
(* external *)
| {
pstr_loc;
pstr_desc =
- Pstr_primitive
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- value_description);
+ Pstr_primitive ({pval_attributes; pval_type} as value_description);
} as pstr -> (
match List.filter hasAttr pval_attributes with
- | [] -> structure :: returnStructures
+ | [] -> [item]
| [_] ->
- 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
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ 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 retPropsType =
+ Typ.constr ~loc:pstr_loc
+ (Location.mkloc (Lident "props") pstr_loc)
+ (makePropsTypeParams namedTypeList)
+ in
+ (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" Location.none
+ ((true, "key", [], keyType pstr_loc) :: namedTypeList)
+ 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
+ [propsRecordType; newStructure])
| _ ->
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)} ->
+ | {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.pvb_pat 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 _} | {pexp_desc = Pexp_newtype _} ->
- 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
- | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} ->
- 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 =
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:pstr_loc
+ else (
+ config.hasReactComponent <- true;
+ let bindingLoc = binding.pvb_loc in
+ let bindingPatLoc = binding.pvb_pat.ppat_loc in
+ let binding =
{
- exp with
- pexp_attributes =
- unerasableIgnore emptyLoc :: exp.pexp_attributes;
+ binding with
+ pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc};
+ pvb_loc = emptyLoc;
}
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
+ let fnName = getFnName binding.pvb_pat in
+ let internalFnName = fnName ^ "$Internal" in
+ let fullModuleName =
+ makeModuleName fileName config.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 _} | {pexp_desc = Pexp_newtype _} ->
+ 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
+ | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)}
+ ->
+ 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
+ (* 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
{
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
- "React: 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)
+ (* let make = (()) => ... *)
+ (* let make = (_) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( Nolabel,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (~prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun
+ ( (Labelled _ | Optional _),
+ _default,
+ _pattern,
+ _internalExpression );
+ } ->
+ ((fun a -> a), false, expression)
+ (* let make = (prop) => ... *)
+ | {
+ pexp_desc =
+ Pexp_fun (_nolabel, _default, pattern, _internalExpression);
+ } ->
+ if !hasApplication then ((fun a -> a), false, expression)
+ else
+ Location.raise_errorf ~loc:pattern.ppat_loc
+ "React: 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, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {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 _, _, exp = spelunkForFunExpression internalExpression in
+ let hasForwardRef = isForwardRef wrapperExpression in
+ ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]),
+ hasForwardRef,
+ exp )
+ | {
+ pexp_desc =
+ Pexp_sequence (wrapperExpression, internalExpression);
+ } ->
+ let wrap, hasForwardRef, exp =
+ spelunkForFunExpression internalExpression
+ in
+ ( wrap,
+ hasForwardRef,
+ {
+ expression with
+ pexp_desc = Pexp_sequence (wrapperExpression, exp);
+ } )
+ | e -> ((fun a -> a), false, e)
+ in
+ let wrapExpression, hasForwardRef, expression =
+ spelunkForFunExpression expression
+ in
+ ( wrapExpressionWithBinding wrapExpression,
+ hasForwardRef,
+ expression )
in
- let wrapExpression, hasUnit, expression =
- spelunkForFunExpression expression
+ let bindingWrapper, hasForwardRef, expression =
+ modifiedBinding binding
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 (loc, payload) -> (loc.loc, Some payload)
- | None -> (emptyLoc, None)
- in
- let props = getPropsAttr payload in
- (* do stuff here! *)
- let namedArgList, newtypes, 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
- | _ -> ""
+ (* do stuff here! *)
+ let namedArgList, newtypes, typeConstraints =
+ recursivelyTransformNamedArgsForMake mapper
+ (modifiedBindingOld binding)
+ [] [] None
+ in
+ let namedTypeList =
+ List.fold_left
+ (argToType ~newtypes ~typeConstraints)
+ [] namedArgList
+ in
+ let namedArgWithDefaultValueList =
+ List.filter_map argWithDefaultValue namedArgList
+ in
+ let vbMatch (label, default) =
+ Vb.mk
+ (Pat.var (Location.mknoloc label))
+ (Exp.match_
+ (Exp.ident {txt = Lident label; loc = Location.none})
+ [
+ Exp.case
+ (Pat.construct
+ (Location.mknoloc @@ Lident "Some")
+ (Some (Pat.var (Location.mknoloc label))))
+ (Exp.ident (Location.mknoloc @@ Lident label));
+ Exp.case
+ (Pat.construct (Location.mknoloc @@ Lident "None") None)
+ default;
+ ])
+ in
+ let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in
+ (* type props = { ... } *)
+ let propsRecordType =
+ makePropsRecordType "props" emptyLoc
+ ([(true, "key", [], keyType emptyLoc)]
+ @ (if hasForwardRef then
+ [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
+ in
+ let innerExpression =
+ Exp.apply
+ (Exp.ident (Location.mknoloc @@ Lident "make"))
+ ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))]
+ @
+ match hasForwardRef with
+ | true ->
+ [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]
+ | false -> [])
in
- ( label,
- match labelString with
- | "" -> Exp.ident ~loc {txt = Lident alias; loc}
- | labelString ->
- Exp.apply ~loc
- (Exp.ident ~loc {txt = Lident "##"; loc})
+ let fullExpression =
+ (* React component name should start with uppercase letter *)
+ (* let make = { let \"App" = props => make(props); \"App" } *)
+ (* let make = React.forwardRef({
+ let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))})
+ })*)
+ Exp.fun_ nolabel None
+ (match namedTypeList with
+ | [] -> Pat.var @@ Location.mknoloc "props"
+ | _ ->
+ Pat.constraint_
+ (Pat.var @@ Location.mknoloc "props")
+ (Typ.constr
+ (Location.mknoloc @@ Lident "props")
+ [Typ.any ()]))
+ (if hasForwardRef then
+ Exp.fun_ nolabel None
+ (Pat.var @@ Location.mknoloc "ref")
+ innerExpression
+ else innerExpression)
+ in
+ let fullExpression =
+ match fullModuleName with
+ | "" -> fullExpression
+ | txt ->
+ Exp.let_ Nonrecursive
[
- (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 externalArgs =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, c, d, e, maybeTyp) ->
- match maybeTyp with
- | Some typ ->
- (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
- | None -> (a, b, c, d, e, None))
- args)
- namedArgListWithKeyAndRef newtypes
- in
- let externalTypes =
- (* translate newtypes to type variables *)
- List.fold_left
- (fun args newtype ->
- List.map
- (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ))
- args)
- namedTypeList newtypes
- in
- let externalDecl =
- makeExternalDecl fnName loc externalArgs externalTypes
- 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_attributes = [];
- },
- innerExpression );
- }
- | None -> innerExpression
- in
- let fullExpression =
- Exp.fun_ nolabel None
- {
- ppat_desc =
- Ppat_constraint
- ( makePropsName ~loc:emptyLoc props.propsName,
- makePropsType ~loc:emptyLoc externalTypes );
- ppat_loc = emptyLoc;
- 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)
+ Vb.mk ~loc:emptyLoc
+ (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt})
+ fullExpression;
+ ]
+ (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt})
+ in
+ let rec returnedExpression patternsWithLabel patternsWithNolabel
+ ({pexp_desc} as expr) =
+ match pexp_desc with
+ | Pexp_newtype (_, expr) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_constraint (expr, _) ->
+ returnedExpression patternsWithLabel patternsWithNolabel expr
+ | Pexp_fun
+ ( _arg_label,
+ _default,
+ {
+ ppat_desc =
+ Ppat_construct ({txt = Lident "()"}, _) | Ppat_any;
+ },
+ expr ) ->
+ (patternsWithLabel, patternsWithNolabel, expr)
+ | Pexp_fun (arg_label, _default, {ppat_loc; ppat_desc}, expr) -> (
+ if isLabelled arg_label || isOptional arg_label then
+ returnedExpression
+ (( {loc = ppat_loc; txt = Lident (getLabel arg_label)},
+ Pat.var
+ ~attrs:
+ (if isOptional arg_label then optionalAttr else [])
+ {txt = getLabel arg_label; loc = ppat_loc} )
+ :: patternsWithLabel)
+ patternsWithNolabel expr
+ else
+ (* Special case of nolabel arg "ref" in forwardRef fn *)
+ (* let make = React.forwardRef(ref => body) *)
+ match ppat_desc with
+ | Ppat_var {txt} ->
+ returnedExpression patternsWithLabel
+ (( {loc = ppat_loc; txt = Lident txt},
+ Pat.var ~attrs:optionalAttr {txt; loc = ppat_loc} )
+ :: patternsWithNolabel)
+ expr
+ | _ ->
+ returnedExpression patternsWithLabel patternsWithNolabel
+ expr)
+ | _ -> (patternsWithLabel, patternsWithNolabel, expr)
+ in
+ let patternsWithLabel, patternsWithNolabel, expression =
+ returnedExpression [] [] expression
+ in
+ let pattern =
+ match patternsWithLabel with
+ | [] -> Pat.any ()
+ | _ -> Pat.record (List.rev patternsWithLabel) Open
+ in
+ (* add pattern matching for optional prop value *)
+ let expression =
+ if List.length vbMatchList = 0 then expression
+ else Exp.let_ Nonrecursive vbMatchList expression
+ in
+ let expression =
+ List.fold_left
+ (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr)
+ expression patternsWithNolabel
+ in
+ let expression =
+ Exp.fun_ Nolabel None
+ (Pat.constraint_ pattern
+ (Typ.constr ~loc:emptyLoc
+ {txt = Lident "props"; loc = emptyLoc}
+ (makePropsTypeParams ~stripExplicitOption:true
+ namedTypeList)))
+ expression
+ in
+ (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *)
+ 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_pat = Pat.var {txt = fnName; loc = Location.none};
+ };
+ ],
+ Some (bindingWrapper fullExpression) )
+ in
+ (Some propsRecordType, bindings, newBinding))
else (None, [binding], None)
[@@raises Invalid_argument]
in
+ (* END of mapBinding fn *)
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
+ let otherStructures (type_, binding, newBinding)
+ (types, bindings, newBindings) =
+ let types =
+ match type_ with
+ | Some type_ -> type_ :: types
+ | None -> types
in
let newBindings =
match newBinding with
| Some newBinding -> newBinding :: newBindings
| None -> newBindings
in
- (externs, binding @ bindings, newBindings)
+ (types, binding @ bindings, newBindings)
in
- let externs, bindings, newBindings =
+ let types, bindings, newBindings =
List.fold_right otherStructures structuresAndBinding ([], [], [])
in
- externs
+ types
@ [{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 []
+ @
+ match newBindings with
+ | [] -> []
+ | newBindings ->
+ [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}])
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformComponentSignature _mapper signature returnSignatures =
- match signature with
+ let transformSignatureItem ~config _mapper item =
+ match item with
| {
psig_loc;
- psig_desc =
- Psig_value
- ({pval_name = {txt = fnName}; pval_attributes; pval_type} as
- psig_desc);
+ psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc);
} as psig -> (
match List.filter hasAttr pval_attributes with
- | [] -> signature :: returnSignatures
+ | [] -> [item]
| [_] ->
+ (* If there is another @react.component, throw error *)
+ if config.hasReactComponent then
+ raiseErrorMultipleReactComponent ~loc:psig_loc
+ else config.hasReactComponent <- true;
+ let hasForwardRef = ref false in
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
+ ( Nolabel,
+ {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)},
+ rest ) ->
+ getPropTypes types rest
+ | Ptyp_arrow (Nolabel, _type, rest) ->
+ hasForwardRef := true;
+ getPropTypes types rest
| Ptyp_arrow (name, type_, returnValue)
when isOptional name || isLabelled name ->
(returnValue, (name, returnValue.ptyp_loc, type_) :: types)
@@ -284342,15 +285720,18 @@ let jsxMapper () =
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_)
+ let retPropsType =
+ Typ.constr
+ (Location.mkloc (Lident "props") psig_loc)
+ (makePropsTypeParams namedTypeList)
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
+ let propsRecordType =
+ makePropsRecordTypeSig "props" Location.none
+ ([(true, "key", [], keyType Location.none)]
+ (* If there is Nolabel arg, regard the type as ref in forwardRef *)
+ @ (if !hasForwardRef then [(true, "ref", [], refType Location.none)]
+ else [])
+ @ namedTypeList)
in
(* can't be an arrow because it will defensively uncurry *)
let newExternalType =
@@ -284370,22 +285751,16 @@ let jsxMapper () =
};
}
in
- externalPropsDecl :: newStructure :: returnSignatures
+ [propsRecordType; newStructure]
| _ ->
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 []
+ | _ -> [item]
[@@raises Invalid_argument]
- in
- let transformJsxCall mapper callExpression callArguments attrs =
+ let transformJsxCall ~config mapper callExpression callArguments attrs =
match callExpression.pexp_desc with
| Pexp_ident caller -> (
match caller with
@@ -284394,20 +285769,14 @@ let jsxMapper () =
(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 modulePath mapper loc attrs callExpression
- callArguments
- | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3"))
+ | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} ->
+ transformUppercaseCall3 ~config modulePath mapper loc attrs
+ callArguments
(* 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"))
+ | {loc; txt = Lident id} ->
+ transformLowercaseCall3 ~config mapper loc attrs callArguments id
| {txt = Ldot (_, anythingNotCreateElementOrMake)} ->
raise
(Invalid_argument
@@ -284426,23 +285795,8 @@ let jsxMapper () =
"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 =
+ let expr ~config mapper expression =
match expression with
(* Does the function application have the @JSX attribute? *)
| {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes}
@@ -284456,7 +285810,8 @@ let jsxMapper () =
(* no JSX attribute *)
| [], _ -> default_mapper.expr mapper expression
| _, nonJSXAttributes ->
- transformJsxCall mapper callExpression callArguments nonJSXAttributes)
+ transformJsxCall ~config mapper callExpression callArguments
+ nonJSXAttributes)
(* is it a list with jsx attribute? Reason <>foo> desugars to [@JSX][foo]*)
| {
pexp_desc =
@@ -284476,46 +285831,177 @@ let jsxMapper () =
| _, nonJSXAttributes ->
let loc = {loc with loc_ghost = true} in
let fragment =
- Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")}
+ match config.mode with
+ | "automatic" ->
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")}
+ | "classic" | _ ->
+ 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);
+ (match config.mode with
+ | "automatic" ->
+ ( nolabel,
+ Exp.record
+ [
+ ( Location.mknoloc @@ Lident "children",
+ match childrenExpr with
+ | {pexp_desc = Pexp_array children} -> (
+ match children with
+ | [] -> recordWithOnlyKey ~loc:Location.none
+ | [child] -> child
+ | _ -> childrenExpr)
+ | _ -> childrenExpr );
+ ]
+ None )
+ | "classic" | _ -> (nolabel, childrenExpr));
]
in
+ let countOfChildren = function
+ | {pexp_desc = Pexp_array children} -> List.length children
+ | _ -> 0
+ 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")})
+ (match config.mode with
+ | "automatic" ->
+ if countOfChildren childrenExpr > 1 then
+ Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")}
+ else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")}
+ | "classic" | _ ->
+ 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 =
- let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in
+ let module_binding ~config mapper module_binding =
+ config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules;
let mapped = default_mapper.module_binding mapper module_binding in
- let _ = nestedModules := List.tl !nestedModules in
+ config.nestedModules <- List.tl config.nestedModules;
mapped
[@@raises Failure]
+
+ (* TODO: some line number might still be wrong *)
+ let jsxMapper ~config =
+ let expr = expr ~config in
+ let module_binding = module_binding ~config in
+ let transformStructureItem = transformStructureItem ~config in
+ let transformSignatureItem = transformSignatureItem ~config in
+ (expr, module_binding, transformSignatureItem, transformStructureItem)
+ [@@raises Invalid_argument, Failure]
+end
+
+let getMapper ~config =
+ let expr3, module_binding3, transformSignatureItem3, transformStructureItem3 =
+ V3.jsxMapper ~config
in
- {default_mapper with structure; expr; signature; module_binding}
- [@@raises Invalid_argument, Failure]
+ let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 =
+ V4.jsxMapper ~config
+ in
+
+ let expr mapper e =
+ match config.version with
+ | 3 -> expr3 mapper e
+ | 4 -> expr4 mapper e
+ | _ -> default_mapper.expr mapper e
+ in
+ let module_binding mapper mb =
+ match config.version with
+ | 3 -> module_binding3 mapper mb
+ | 4 -> module_binding4 mapper mb
+ | _ -> default_mapper.module_binding mapper mb
+ in
+ let saveConfig () =
+ {
+ config with
+ version = config.version;
+ module_ = config.module_;
+ mode = config.mode;
+ hasReactComponent = config.hasReactComponent;
+ }
+ in
+ let restoreConfig oldConfig =
+ config.version <- oldConfig.version;
+ config.module_ <- oldConfig.module_;
+ config.mode <- oldConfig.mode;
+ config.hasReactComponent <- oldConfig.hasReactComponent
+ in
+ let signature mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.psig_desc with
+ | Psig_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.signature_item mapper item in
+ if config.version = 3 then transformSignatureItem3 mapper item
+ else if config.version = 4 then transformSignatureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+ let structure mapper items =
+ let oldConfig = saveConfig () in
+ config.hasReactComponent <- false;
+ let result =
+ List.map
+ (fun item ->
+ (match item.pstr_desc with
+ | Pstr_attribute attr -> processConfigAttribute attr config
+ | _ -> ());
+ let item = default_mapper.structure_item mapper item in
+ if config.version = 3 then transformStructureItem3 mapper item
+ else if config.version = 4 then transformStructureItem4 mapper item
+ else [item])
+ items
+ |> List.flatten
+ in
+ restoreConfig oldConfig;
+ result
+ [@@raises Invalid_argument]
+ in
+
+ {default_mapper with expr; module_binding; signature; structure}
-let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure =
- let mapper = jsxMapper () in
+let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.structure) : Parsetree.structure =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.structure mapper code
[@@raises Invalid_argument, Failure]
-let rewrite_signature (code : Parsetree.signature) : Parsetree.signature =
- let mapper = jsxMapper () in
+let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode
+ (code : Parsetree.signature) : Parsetree.signature =
+ let config =
+ {
+ version = jsxVersion;
+ module_ = jsxModule;
+ mode = jsxMode;
+ nestedModules = [];
+ hasReactComponent = false;
+ }
+ in
+ let mapper = getMapper ~config in
mapper.signature mapper code
[@@raises Invalid_argument, Failure]
@@ -284554,7 +286040,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_signature ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_signature ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
(* react-jsx ppx relies on built-in ones like `##` *)
in
@@ -284570,7 +286058,9 @@ 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 -> Reactjs_jsx_ppx_v3.rewrite_implementation ast
+ | 3 ->
+ Reactjs_jsx_ppx.rewrite_implementation ~jsxVersion:3 ~jsxModule:""
+ ~jsxMode:"" ast
| _ -> ast
in
if !Js_config.no_builtin_ppx then ast
diff --git a/lib/4.06.1/whole_compiler.ml.d b/lib/4.06.1/whole_compiler.ml.d
index 93498b9cfa..3a40ea135b 100644
--- a/lib/4.06.1/whole_compiler.ml.d
+++ b/lib/4.06.1/whole_compiler.ml.d
@@ -632,8 +632,8 @@
../lib/4.06.1/whole_compiler.ml: ./ml/typetexp.mli
../lib/4.06.1/whole_compiler.ml: ./ml/untypeast.ml
../lib/4.06.1/whole_compiler.ml: ./ml/untypeast.mli
-../lib/4.06.1/whole_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.ml
-../lib/4.06.1/whole_compiler.ml: ./napkin/reactjs_jsx_ppx_v3.mli
+../lib/4.06.1/whole_compiler.ml: ./napkin/reactjs_jsx_ppx.ml
+../lib/4.06.1/whole_compiler.ml: ./napkin/reactjs_jsx_ppx.mli
../lib/4.06.1/whole_compiler.ml: ./napkin/res_ast_conversion.ml
../lib/4.06.1/whole_compiler.ml: ./napkin/res_ast_conversion.mli
../lib/4.06.1/whole_compiler.ml: ./napkin/res_comment.ml
diff --git a/syntax b/syntax
index 62ccbc1bc9..783c967a32 160000
--- a/syntax
+++ b/syntax
@@ -1 +1 @@
-Subproject commit 62ccbc1bc99c933514513094c0a3b0168aee5357
+Subproject commit 783c967a32587b96ca753b8dcdccf971e9bc1717