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