From 552c05c0e31b96a3f5f2e4987bf90c217606aeec Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Thu, 9 Jun 2022 02:03:51 +0900 Subject: [PATCH 01/35] react ppx v4 and parsing spread props --- cli/reactjs_jsx_ppx_v3.ml | 426 +++++++++++++++++++++---------------- cli/reactjs_jsx_ppx_v3.mli | 12 +- src/res_core.ml | 23 ++ src/res_grammar.ml | 2 +- 4 files changed, 278 insertions(+), 185 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index b0f060f6..ea67582e 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -285,50 +285,139 @@ let rec recursivelyMakeNamedArgsForExternal list 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] +(* List.filter_map in 4.08.0 *) +let filterMap f = + let rec aux accu = function + | [] -> List.rev accu + | x :: l -> ( + match f x with + | None -> aux accu l + | Some v -> aux (v :: accu) l) + in + aux [] -(* 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 record from props and spread props if exists *) +let recordFromProps {pexp_loc} 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 fields = + props + |> List.map (fun (arg_label, ({pexp_loc} as expr)) -> + (* In case filed label is "key" only then change expression to option *) + if getLabel arg_label = "key" then + ( {txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, + Exp.construct + {txt = Longident.parse "Some"; loc = pexp_loc} + (Some expr) ) + else + ({txt = Longident.parse (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; pexp_attributes = []} + | [spreadProps] -> + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc; + pexp_attributes = []; + } + | spreadProps :: _ -> + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc; + pexp_attributes = []; + } -(* 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] +(* make type params for type make<'id, 'name, ...> *) +let rec makePropsTypeParamsTvar namedTypeList = + namedTypeList + |> filterMap (fun (_, label, _, _) -> + if label <> "key" then Some (Typ.var label, Invariant) else None) + +(* TODO check ~foo=option<(int, int)>=? case futher *) +let extractOptionalCoreType = function + | {ptyp_desc = Ptyp_constr ({txt}, [coreType])} when txt = optionIdent -> + coreType + | t -> t + +let wrapCoreTypeOption ({ptyp_loc} as coreType) = + Typ.constr {txt = Lident "option"; loc = ptyp_loc} [coreType] + +(* make type params for make fn arguments *) +(* let make = ({id, name, children}: make<'id, 'name, 'children>) *) +let rec makePropsTypeParams namedTypeList = + namedTypeList + |> filterMap (fun (_isOptional, label, _, _interiorType) -> + if label = "key" then None else Some (Typ.var label)) + +(* make type params for make sig arguments *) +(* let make: React.componentLike>, React.element> *) +let rec makePropsTypeParamsSig namedTypeList = + namedTypeList + |> filterMap (fun (isOptional, label, _, interiorType) -> + if label = "key" then None + else if isOptional then Some (extractOptionalCoreType interiorType) + else Some interiorType) + +(* @obj type make<'id, 'name, ...> = { id: 'id, name: 'name, ... } *) +let makePropsRecordType fnName loc namedTypeList = + let labelDeclList = + namedTypeList + |> List.map (fun (isOptional, label, _, interiorType) -> + Type.field ~loc {txt = label; loc} + (if label = "key" then interiorType + else if isOptional then wrapCoreTypeOption (Typ.var label) + else Typ.var label)) + in + (* 'id, 'className, ... *) + let params = makePropsTypeParamsTvar namedTypeList in + Str.type_ Nonrecursive + [ + Type.mk ~loc + ~attrs:[({txt = "bs.obj"; loc}, PStr [])] + ~params {txt = fnName; loc} ~kind:(Ptype_record labelDeclList); + ] + +(* @obj type props = { id: option, key: ... } *) +let makePropsRecordTypeSig fnName loc namedTypeList = + let labelDeclList = + namedTypeList + |> List.map (fun (isOptional, label, _, interiorType) -> + Type.field ~loc {txt = label; loc} + (if label = "key" then interiorType + else if isOptional then wrapCoreTypeOption (Typ.var label) + else Typ.var label)) + in + let params = makePropsTypeParamsTvar namedTypeList in + Sig.type_ Nonrecursive + [ + Type.mk ~loc + ~attrs:[({txt = "bs.obj"; loc}, PStr [])] + ~params {txt = fnName; loc} ~kind:(Ptype_record labelDeclList); + ] (* 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_) = +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 *) @@ -336,13 +425,6 @@ 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 = @@ -358,7 +440,8 @@ let newtypeToVar newtype type_ = let jsxMapper () = let jsxVersion = ref None in - let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = + let transformUppercaseCall3 modulePath mapper loc attrs callExpression + callArguments = let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in @@ -372,18 +455,19 @@ 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; - [ - ( labelled "children", - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); - ]) - @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] + @ + 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")} ); + ] in + let record = recordFromProps callExpression args in let isCap str = let first = String.sub str 0 1 [@@raises Invalid_argument] in let capped = String.uppercase_ascii first in @@ -397,39 +481,26 @@ 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 - in + let props = record 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)] + (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); - ] + (Exp.ident ~loc {txt = ident; loc}) + [(nolabel, props); (nolabel, children)] [@@raises Invalid_argument] in - let transformLowercaseCall3 mapper loc attrs callArguments id = + let transformLowercaseCall3 mapper loc attrs _callExpression callArguments id + = let children, nonChildrenProps = extractChildren ~loc callArguments in + (* keep the v3 *) + (* let record = recordFromProps callExpression nonChildrenProps in *) let componentNameExpr = constantString ~loc id in let childrenExpr = transformChildrenIfList ~loc ~mapper children in let createElementCall = @@ -468,7 +539,7 @@ let jsxMapper () = [ (* "div" *) (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (* ReactDOMRe.domProps(~className=blabla, ~foo=bar, ()) *) (labelled "props", propsCall); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr); @@ -569,7 +640,8 @@ let jsxMapper () = match (type_, name, default) with | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ when isOptional name -> - ( getLabel name, + ( true, + getLabel name, [], { type_ with @@ -578,7 +650,8 @@ let jsxMapper () = } ) :: types | Some type_, name, Some _default -> - ( getLabel name, + ( false, + getLabel name, [], { ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); @@ -586,9 +659,10 @@ let jsxMapper () = ptyp_attributes = []; } ) :: 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 = @@ -606,7 +680,8 @@ let jsxMapper () = } ) :: types | None, name, _ when isLabelled name -> - ( getLabel name, + ( false, + getLabel name, [], { ptyp_desc = Ptyp_var (safeTypeFromValue name); @@ -620,9 +695,9 @@ let jsxMapper () = let argToConcreteType types (name, loc, type_) = match name with - | name when isLabelled name -> (getLabel name, [], type_) :: types + | name when isLabelled name -> (false, getLabel name, [], type_) :: types | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) + (true, getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) :: types | _ -> types in @@ -654,15 +729,15 @@ 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 (* default *), loc, Some type_) + let retPropsType = + Typ.constr ~loc:pstr_loc + (Location.mkloc (Longident.parse fnName) pstr_loc) + (makePropsTypeParams namedTypeList) 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 + (* @obj type make = { ... } *) + let propsRecordType = + makePropsRecordType fnName pstr_loc + ((true, "key", [], keyType pstr_loc) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -682,7 +757,7 @@ let jsxMapper () = }; } in - externalPropsDecl :: newStructure :: returnStructures + propsRecordType :: newStructure :: returnStructures | _ -> raise (Invalid_argument @@ -875,27 +950,6 @@ let jsxMapper () = (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 -> @@ -930,30 +984,20 @@ let jsxMapper () = 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)) + (fun (a, b, c, typ) -> + (a, b, c, newtypeToVar newtype.txt typ)) args) namedTypeList newtypes in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes + (* @obj type make = { ... } *) + let propsRecordType = + makePropsRecordType fnName pstr_loc + ((true, "key", [], keyType pstr_loc) :: namedTypeList) in let innerExpressionArgs = List.map pluckArg namedArgListWithKeyAndRefForNew @@ -1017,53 +1061,79 @@ let jsxMapper () = ] (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) in - let bindings, newBinding = + let rec returnedExpression labels ({pexp_desc} as expr) = + match pexp_desc with + | Pexp_fun + ( _arg_label, + _default, + { + ppat_desc = + Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; + }, + expr ) -> + (labels, expr) + | Pexp_fun (arg_label, _default, _pattern, expr) -> + returnedExpression + ({txt = getLabel arg_label; loc = pstr_loc} :: labels) + expr + | _ -> (labels, expr) + in + let labels, expression = returnedExpression [] expression in + let patterns = + labels + |> List.map (fun {txt} -> + ( {txt = Longident.parse txt; loc = pstr_loc}, + Pat.var {txt; loc = pstr_loc} )) + in + let pattern = + if List.length patterns = 0 then Pat.any () + else Pat.record (List.rev patterns) Closed + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ pattern + (Typ.constr ~loc + {txt = Longident.parse @@ fnName; loc} + (makePropsTypeParams namedTypeList))) + expression + in + (* let make = ({id, name, ...}: make<'id, 'name, ...>) => { ... } *) + let bindings = 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 ) + [ + 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})); + ] | Nonrecursive -> - ( [{binding with pvb_expr = expression; pvb_attributes = []}], - Some (bindingWrapper fullExpression) ) + [{binding with pvb_expr = expression; pvb_attributes = []}] in - (Some externalDecl, bindings, newBinding) - else (None, [binding], None) + (Some propsRecordType, bindings) + else (None, [binding]) [@@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 - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let otherStructures (type_, binding) (types, bindings) = + let types = + match type_ with + | Some type_ -> type_ :: types + | None -> types in - (externs, binding @ bindings, newBindings) + (types, binding @ bindings) in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) + let types, bindings = + 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] @@ -1099,15 +1169,14 @@ 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 (Longident.parse fnName) psig_loc) + (makePropsTypeParamsSig 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 fnName psig_loc + ((true, "key", [], keyType psig_loc) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -1127,7 +1196,7 @@ let jsxMapper () = }; } in - externalPropsDecl :: newStructure :: returnSignatures + propsRecordType :: newStructure :: returnSignatures | _ -> raise (Invalid_argument @@ -1163,7 +1232,8 @@ let jsxMapper () = | {loc; txt = Lident id} -> ( match !jsxVersion with | None | Some 3 -> - transformLowercaseCall3 mapper loc attrs callArguments id + transformLowercaseCall3 mapper loc attrs callExpression callArguments + id | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) | {txt = Ldot (_, anythingNotCreateElementOrMake)} -> raise diff --git a/cli/reactjs_jsx_ppx_v3.mli b/cli/reactjs_jsx_ppx_v3.mli index da60a051..f240cc4f 100644 --- a/cli/reactjs_jsx_ppx_v3.mli +++ b/cli/reactjs_jsx_ppx_v3.mli @@ -22,14 +22,14 @@ 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 `[@JSX] div(~props1=a, ~props2=b, ~spreadProps=props3 ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ~props=({...props3, props1: a, 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, ()))` + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into + `React.createElement(Foo.make, Foo.makeProps({...baz, 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|])` + `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into + `React.createElementVariadic(Foo.make, Foo.makeProps({...baz, foo: bar, children: React.null}), [|foo, bar|])` transform `[@JSX] [foo]` into `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` *) diff --git a/src/res_core.ml b/src/res_core.ml index 8ab33fa5..f2d477d2 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -2566,6 +2566,7 @@ and parseJsxFragment p = * | ?lident * | lident = jsx_expr * | lident = ?jsx_expr + * | {...jsx_expr} *) and parseJsxProp p = match p.Parser.token with @@ -2604,6 +2605,28 @@ and parseJsxProp p = if optional then Asttypes.Optional name else Asttypes.Labelled name in Some (label, attrExpr)) + (* {...props} *) + | Lbrace -> ( + Parser.next p; + match p.Parser.token with + | DotDotDot -> ( + Parser.next p; + let loc = mkLoc p.Parser.startPos p.prevEndPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + {e with pexp_attributes = propLocAttr :: e.pexp_attributes} + in + (* using label "spreadProps" to distinguish from others *) + let label = Asttypes.Labelled "spreadProps" in + match p.Parser.token with + | Rbrace -> + Parser.next p; + Some (label, attrExpr) + | _ -> None) + | _ -> None) | _ -> None and parseJsxProps p = diff --git a/src/res_grammar.ml b/src/res_grammar.ml index e2d982df..4c9cb942 100644 --- a/src/res_grammar.ml +++ b/src/res_grammar.ml @@ -158,7 +158,7 @@ let isExprStart = function | _ -> false let isJsxAttributeStart = function - | Token.Lident _ | Question -> true + | Token.Lident _ | Question | Lbrace -> true | _ -> false let isStructureItemStart = function From aaf02aea3d0a1d7a4870f0d8d4fc36ecab803cad Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Thu, 9 Jun 2022 11:39:04 +0900 Subject: [PATCH 02/35] change the empty record to "_" for jsx upper case --- cli/reactjs_jsx_ppx_v3.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index ea67582e..a5049029 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -481,7 +481,14 @@ let jsxMapper () = Ldot (fullPath, "make") | modulePath -> modulePath in - let props = record in + let isEmptyRecord { pexp_desc } = + match pexp_desc with + | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | _ -> false + in + (* check if record which goes to Foo.make({ ... } as record) empty or not + if empty then change it to "_" *) + let props = if isEmptyRecord record then Exp.ident { loc; txt = Lident "_"} else record in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with From 2a1477fc299e5bc88a940508b00a1847537a6fb8 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Thu, 9 Jun 2022 14:55:29 +0900 Subject: [PATCH 03/35] change empty record to {key: None} for jsx upper case --- cli/reactjs_jsx_ppx_v3.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index a5049029..daef9ac3 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -34,6 +34,10 @@ let optionIdent = Lident "option" let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) +let recordWithKey ~loc = Exp.record ~loc + [({loc; txt = Lident "key"}, Exp.construct {loc; txt = Lident "None"} None)] + None + let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in match String.sub valueStr 0 1 with @@ -487,8 +491,10 @@ let jsxMapper () = | _ -> false in (* check if record which goes to Foo.make({ ... } as record) empty or not - if empty then change it to "_" *) - let props = if isEmptyRecord record then Exp.ident { loc; txt = Lident "_"} else record in + if empty then change it to {key: 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 recordWithKey ~loc else record in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with From 4e41a577075f17f445a0bf71be29ba1dc84d0ecf Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 10 Jun 2022 00:16:43 +0900 Subject: [PATCH 04/35] polishing the loc of react ppx --- cli/reactjs_jsx_ppx_v3.ml | 51 ++++++++++++++++++--------------------- 1 file changed, 24 insertions(+), 27 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index daef9ac3..929e1112 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -34,9 +34,10 @@ let optionIdent = Lident "option" let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) -let recordWithKey ~loc = Exp.record ~loc - [({loc; txt = Lident "key"}, Exp.construct {loc; txt = Lident "None"} None)] - None +let recordWithKey ~loc = + Exp.record ~loc + [({loc; txt = Lident "key"}, Exp.construct {loc; txt = Lident "None"} None)] + None let safeTypeFromValue valueStr = let valueStr = getLabel valueStr in @@ -485,14 +486,14 @@ let jsxMapper () = Ldot (fullPath, "make") | modulePath -> modulePath in - let isEmptyRecord { pexp_desc } = + let isEmptyRecord {pexp_desc} = match pexp_desc with | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true | _ -> false in (* check if record which goes to Foo.make({ ... } as record) empty or not - if empty then change it to {key: None} only for upper case jsx - This would be redundant regarding PR progress https://github.com/rescript-lang/syntax/pull/299 + if empty then change it to {key: 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 recordWithKey ~loc else record in (* handle key, ref, children *) @@ -996,7 +997,6 @@ let jsxMapper () = ] ) in let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in let externalTypes = (* translate newtypes to type variables *) List.fold_left @@ -1009,21 +1009,23 @@ let jsxMapper () = in (* @obj type make = { ... } *) let propsRecordType = - makePropsRecordType fnName pstr_loc - ((true, "key", [], keyType pstr_loc) :: namedTypeList) + makePropsRecordType fnName emptyLoc + ((true, "key", [], keyType emptyLoc) :: namedTypeList) in let innerExpressionArgs = List.map pluckArg namedArgListWithKeyAndRefForNew @ if hasUnit then - [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] + [ + (Nolabel, Exp.construct {loc = emptyLoc; txt = Lident "()"} None); + ] else [] in let innerExpression = Exp.apply (Exp.ident { - loc; + loc = emptyLoc; txt = Lident (match recFlag with @@ -1074,7 +1076,7 @@ let jsxMapper () = ] (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) in - let rec returnedExpression labels ({pexp_desc} as expr) = + let rec returnedExpression patterns ({pexp_desc} as expr) = match pexp_desc with | Pexp_fun ( _arg_label, @@ -1084,29 +1086,24 @@ let jsxMapper () = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; }, expr ) -> - (labels, expr) - | Pexp_fun (arg_label, _default, _pattern, expr) -> + (patterns, expr) + | Pexp_fun (arg_label, _default, ({ppat_loc} as pattern), expr) -> returnedExpression - ({txt = getLabel arg_label; loc = pstr_loc} :: labels) + (({loc = ppat_loc; txt = Lident (getLabel arg_label)}, pattern) + :: patterns) expr - | _ -> (labels, expr) - in - let labels, expression = returnedExpression [] expression in - let patterns = - labels - |> List.map (fun {txt} -> - ( {txt = Longident.parse txt; loc = pstr_loc}, - Pat.var {txt; loc = pstr_loc} )) + | _ -> (patterns, expr) in + let patternsWithLid, expression = returnedExpression [] expression in let pattern = - if List.length patterns = 0 then Pat.any () - else Pat.record (List.rev patterns) Closed + if List.length patternsWithLid = 0 then Pat.any () + else Pat.record (List.rev patternsWithLid) Closed in let expression = Exp.fun_ Nolabel None (Pat.constraint_ pattern - (Typ.constr ~loc - {txt = Longident.parse @@ fnName; loc} + (Typ.constr ~loc:emptyLoc + {txt = Longident.parse @@ fnName; loc = emptyLoc} (makePropsTypeParams namedTypeList))) expression in From 945e911edfa0e1a1865c9ef977e3995815b093e4 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 10 Jun 2022 14:58:00 +0900 Subject: [PATCH 05/35] implicit option type of @obj record update --- cli/reactjs_jsx_ppx_v3.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 929e1112..262a1d04 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -324,10 +324,7 @@ let recordFromProps {pexp_loc} callArguments = |> List.map (fun (arg_label, ({pexp_loc} as expr)) -> (* In case filed label is "key" only then change expression to option *) if getLabel arg_label = "key" then - ( {txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, - Exp.construct - {txt = Longident.parse "Some"; loc = pexp_loc} - (Some expr) ) + ({txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, expr) else ({txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, expr)) in From 2ce3b67389a1609a54cd7a56216739a36729bc04 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 10 Jun 2022 17:48:33 +0900 Subject: [PATCH 06/35] add match vbs for optional arg with default value --- cli/reactjs_jsx_ppx_v3.ml | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 262a1d04..23f6da89 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -704,6 +704,13 @@ let jsxMapper () = [@@raises Invalid_argument] in + let argWithDefaultValue (name, default, _, _, _, _) = + match default with + | Some default when isOptional name -> Some (getLabel name, default) + | _ -> None + [@@raises Invalid_argument] + in + let argToConcreteType types (name, loc, type_) = match name with | name when isLabelled name -> (false, getLabel name, [], type_) :: types @@ -994,6 +1001,26 @@ let jsxMapper () = ] ) in let namedTypeList = List.fold_left argToType [] namedArgList in + let namedArgWithDefaultValueList = + filterMap 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 let externalTypes = (* translate newtypes to type variables *) List.fold_left @@ -1102,7 +1129,8 @@ let jsxMapper () = (Typ.constr ~loc:emptyLoc {txt = Longident.parse @@ fnName; loc = emptyLoc} (makePropsTypeParams namedTypeList))) - expression + (if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression) in (* let make = ({id, name, ...}: make<'id, 'name, ...>) => { ... } *) let bindings = From 896688dbb83e9627d9938ac80fc61c0384cfbf65 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 11 Jun 2022 01:32:51 +0900 Subject: [PATCH 07/35] add @optional record declarations --- cli/reactjs_jsx_ppx_v3.ml | 78 +++++++++++++++++++++------------------ 1 file changed, 42 insertions(+), 36 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 23f6da89..57a823c3 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -31,10 +31,12 @@ let getLabel str = let optionIdent = Lident "option" +let optionalAttr = [({txt = "optional"; loc = Location.none}, PStr [])] + let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) -let recordWithKey ~loc = +let recordWithOnlyKey ~loc = Exp.record ~loc [({loc; txt = Lident "key"}, Exp.construct {loc; txt = Lident "None"} None)] None @@ -46,9 +48,7 @@ let safeTypeFromValue valueStr = | _ -> valueStr [@@raises Invalid_argument] -let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} - [Typ.constr ~loc {loc; txt = Lident "string"} []] +let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} [] type 'a children = ListLiteral of 'a | Exact of 'a @@ -323,10 +323,10 @@ let recordFromProps {pexp_loc} callArguments = props |> List.map (fun (arg_label, ({pexp_loc} as expr)) -> (* In case filed label is "key" only then change expression to option *) - if getLabel arg_label = "key" then - ({txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, expr) - else - ({txt = Longident.parse (getLabel arg_label); loc = pexp_loc}, expr)) + 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) @@ -378,41 +378,45 @@ let rec makePropsTypeParamsSig namedTypeList = else if isOptional then Some (extractOptionalCoreType interiorType) else Some interiorType) -(* @obj type make<'id, 'name, ...> = { id: 'id, name: 'name, ... } *) -let makePropsRecordType fnName loc namedTypeList = +(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) +let makePropsRecordType propsName loc namedTypeList = let labelDeclList = namedTypeList - |> List.map (fun (isOptional, label, _, interiorType) -> - Type.field ~loc {txt = label; loc} - (if label = "key" then interiorType - else if isOptional then wrapCoreTypeOption (Typ.var label) - else Typ.var label)) + |> List.map (fun (isOptional, label, _, _interiorType) -> + if label = "key" then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (keyType Location.none) + else if isOptional then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (Typ.var label) + else Type.field ~loc {txt = label; loc} (Typ.var label)) in (* 'id, 'className, ... *) let params = makePropsTypeParamsTvar namedTypeList in Str.type_ Nonrecursive [ - Type.mk ~loc - ~attrs:[({txt = "bs.obj"; loc}, PStr [])] - ~params {txt = fnName; loc} ~kind:(Ptype_record labelDeclList); + Type.mk ~loc ~params {txt = propsName; loc} + ~kind:(Ptype_record labelDeclList); ] -(* @obj type props = { id: option, key: ... } *) -let makePropsRecordTypeSig fnName loc namedTypeList = +(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) +let makePropsRecordTypeSig propsName loc namedTypeList = let labelDeclList = namedTypeList - |> List.map (fun (isOptional, label, _, interiorType) -> - Type.field ~loc {txt = label; loc} - (if label = "key" then interiorType - else if isOptional then wrapCoreTypeOption (Typ.var label) - else Typ.var label)) + |> List.map (fun (isOptional, label, _, _interiorType) -> + if label = "key" then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (keyType Location.none) + else if isOptional then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (Typ.var label) + else Type.field ~loc {txt = label; loc} (Typ.var label)) in let params = makePropsTypeParamsTvar namedTypeList in Sig.type_ Nonrecursive [ - Type.mk ~loc - ~attrs:[({txt = "bs.obj"; loc}, PStr [])] - ~params {txt = fnName; loc} ~kind:(Ptype_record labelDeclList); + Type.mk ~loc ~params {txt = propsName; loc} + ~kind:(Ptype_record labelDeclList); ] (* Build an AST node for the props name when converted to an object inside the function signature *) @@ -492,7 +496,9 @@ let jsxMapper () = if empty then change it to {key: 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 recordWithKey ~loc else record in + let props = + if isEmptyRecord record then recordWithOnlyKey ~loc else record + in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) match !childrenArg with @@ -749,12 +755,12 @@ let jsxMapper () = let namedTypeList = List.fold_left argToConcreteType [] propTypes in let retPropsType = Typ.constr ~loc:pstr_loc - (Location.mkloc (Longident.parse fnName) pstr_loc) + (Location.mkloc (Lident fnName) pstr_loc) (makePropsTypeParams namedTypeList) in (* @obj type make = { ... } *) let propsRecordType = - makePropsRecordType fnName pstr_loc + makePropsRecordType "props" Location.none ((true, "key", [], keyType pstr_loc) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) @@ -1033,7 +1039,7 @@ let jsxMapper () = in (* @obj type make = { ... } *) let propsRecordType = - makePropsRecordType fnName emptyLoc + makePropsRecordType "props" emptyLoc ((true, "key", [], keyType emptyLoc) :: namedTypeList) in let innerExpressionArgs = @@ -1127,7 +1133,7 @@ let jsxMapper () = Exp.fun_ Nolabel None (Pat.constraint_ pattern (Typ.constr ~loc:emptyLoc - {txt = Longident.parse @@ fnName; loc = emptyLoc} + {txt = Lident "props"; loc = emptyLoc} (makePropsTypeParams namedTypeList))) (if List.length vbMatchList = 0 then expression else Exp.let_ Nonrecursive vbMatchList expression) @@ -1206,12 +1212,12 @@ let jsxMapper () = let namedTypeList = List.fold_left argToConcreteType [] propTypes in let retPropsType = Typ.constr - (Location.mkloc (Longident.parse fnName) psig_loc) + (Location.mkloc (Lident "props") psig_loc) (makePropsTypeParamsSig namedTypeList) in let propsRecordType = - makePropsRecordTypeSig fnName psig_loc - ((true, "key", [], keyType psig_loc) :: namedTypeList) + makePropsRecordTypeSig "props" Location.none + ((true, "key", [], keyType Location.none) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = From a1b48cf9b8eda4dbbe52ea1b79dc81c3a7fd5fe7 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 11 Jun 2022 03:19:18 +0900 Subject: [PATCH 08/35] fix missing pattern --- cli/reactjs_jsx_ppx_v3.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 57a823c3..f63d599e 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -755,10 +755,10 @@ let jsxMapper () = let namedTypeList = List.fold_left argToConcreteType [] propTypes in let retPropsType = Typ.constr ~loc:pstr_loc - (Location.mkloc (Lident fnName) pstr_loc) + (Location.mkloc (Lident "props") pstr_loc) (makePropsTypeParams namedTypeList) in - (* @obj type make = { ... } *) + (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *) let propsRecordType = makePropsRecordType "props" Location.none ((true, "key", [], keyType pstr_loc) :: namedTypeList) @@ -1117,9 +1117,10 @@ let jsxMapper () = }, expr ) -> (patterns, expr) - | Pexp_fun (arg_label, _default, ({ppat_loc} as pattern), expr) -> + | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> returnedExpression - (({loc = ppat_loc; txt = Lident (getLabel arg_label)}, pattern) + (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, + Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) :: patterns) expr | _ -> (patterns, expr) @@ -1189,10 +1190,7 @@ let jsxMapper () = match signature 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 From 167a79db8f2ff20131f16dd7f3b9af5d55cce6ae Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 11 Jun 2022 17:46:52 +0900 Subject: [PATCH 09/35] clean up codes and comments --- cli/reactjs_jsx_ppx_v3.ml | 81 +++++--------------------------------- cli/reactjs_jsx_ppx_v3.mli | 20 ++++++++-- 2 files changed, 25 insertions(+), 76 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index f63d599e..8fb5b94b 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -12,8 +12,6 @@ let nolabel = Nolabel let labelled str = Labelled str -let optional str = Optional str - let isOptional str = match str with | Optional _ -> true @@ -201,10 +199,6 @@ let getPropsAttr payload = | _ -> 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 = @@ -239,57 +233,6 @@ let makeModuleName fileName nestedModules fnName = 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] - (* List.filter_map in 4.08.0 *) let filterMap f = let rec aux accu = function @@ -347,31 +290,27 @@ let recordFromProps {pexp_loc} callArguments = pexp_attributes = []; } -(* make type params for type make<'id, 'name, ...> *) -let rec makePropsTypeParamsTvar namedTypeList = +(* make type params for type props<'id, 'name, ...> *) +let makePropsTypeParamsTvar namedTypeList = namedTypeList |> filterMap (fun (_, label, _, _) -> if label <> "key" then Some (Typ.var label, Invariant) else None) -(* TODO check ~foo=option<(int, int)>=? case futher *) let extractOptionalCoreType = function | {ptyp_desc = Ptyp_constr ({txt}, [coreType])} when txt = optionIdent -> coreType | t -> t -let wrapCoreTypeOption ({ptyp_loc} as coreType) = - Typ.constr {txt = Lident "option"; loc = ptyp_loc} [coreType] - (* make type params for make fn arguments *) -(* let make = ({id, name, children}: make<'id, 'name, 'children>) *) -let rec makePropsTypeParams namedTypeList = +(* let make = ({id, name, children}: props<'id, 'name, 'children>) *) +let makePropsTypeParams namedTypeList = namedTypeList |> filterMap (fun (_isOptional, label, _, _interiorType) -> if label = "key" then None else Some (Typ.var label)) (* make type params for make sig arguments *) -(* let make: React.componentLike>, React.element> *) -let rec makePropsTypeParamsSig namedTypeList = +(* let make: React.componentLike>, React.element> *) +let makePropsTypeParamsSig namedTypeList = namedTypeList |> filterMap (fun (isOptional, label, _, interiorType) -> if label = "key" then None @@ -733,9 +672,7 @@ let jsxMapper () = | { 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 @@ -1037,7 +974,7 @@ let jsxMapper () = args) namedTypeList newtypes in - (* @obj type make = { ... } *) + (* type props = { ... } *) let propsRecordType = makePropsRecordType "props" emptyLoc ((true, "key", [], keyType emptyLoc) :: namedTypeList) @@ -1139,7 +1076,7 @@ let jsxMapper () = (if List.length vbMatchList = 0 then expression else Exp.let_ Nonrecursive vbMatchList expression) in - (* let make = ({id, name, ...}: make<'id, 'name, ...>) => { ... } *) + (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) let bindings = match recFlag with | Recursive -> diff --git a/cli/reactjs_jsx_ppx_v3.mli b/cli/reactjs_jsx_ppx_v3.mli index f240cc4f..db2dbcad 100644 --- a/cli/reactjs_jsx_ppx_v3.mli +++ b/cli/reactjs_jsx_ppx_v3.mli @@ -22,18 +22,30 @@ 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|])` + + v4: transform `[@JSX] div(~props1=a, ~props2=b, ~spreadProps=props3 ~children=[foo, bar], ())` into - `ReactDOMRe.createDOMElementVariadic("div", ~props=({...props3, props1: a, props2: b}), [|foo, bar|])`. + `ReactDOMRe.createDOMElementVariadic("div", ~props=ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. transform the upper-cased case `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into - `React.createElement(Foo.make, Foo.makeProps({...baz, key: a, ref: b, foo: bar}))` + `Foo.make({...baz, key: a, ref: b, foo: bar})` transform the upper-cased case `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into - `React.createElementVariadic(Foo.make, Foo.makeProps({...baz, foo: bar, children: React.null}), [|foo, bar|])` + Foo.make({...baz, foo: bar, children: React.null}), [|foo, bar|])` transform `[@JSX] [foo]` into `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` *) val rewrite_implementation : Parsetree.structure -> Parsetree.structure -val rewrite_signature : Parsetree.signature -> Parsetree.signature +val rewrite_signature : Parsetree.signature -> Parsetree.signature \ No newline at end of file From ba4b9c2c9dc137e6631d248b24952fad5f9d2534 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sun, 12 Jun 2022 00:10:43 +0900 Subject: [PATCH 10/35] support React.forwardRef --- cli/reactjs_jsx_ppx_v3.ml | 55 ++++++++++++++++++++++++++++++++------- 1 file changed, 45 insertions(+), 10 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 8fb5b94b..eb618170 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -48,6 +48,15 @@ let safeTypeFromValue valueStr = let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} [] +let refType loc = + Typ.constr ~loc + {loc; txt = Ldot (Lident "React", "ref")} + [ + Typ.constr ~loc + {loc; txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")} + [Typ.constr ~loc {loc; txt = Ldot (Lident "Dom", "element")} []]; + ] + type 'a children = ListLiteral of 'a | Exact of 'a type componentConfig = {propsName: string} @@ -294,7 +303,8 @@ let recordFromProps {pexp_loc} callArguments = let makePropsTypeParamsTvar namedTypeList = namedTypeList |> filterMap (fun (_, label, _, _) -> - if label <> "key" then Some (Typ.var label, Invariant) else None) + if label = "key" || label = "ref" then None + else Some (Typ.var label, Invariant)) let extractOptionalCoreType = function | {ptyp_desc = Ptyp_constr ({txt}, [coreType])} when txt = optionIdent -> @@ -306,14 +316,14 @@ let extractOptionalCoreType = function let makePropsTypeParams namedTypeList = namedTypeList |> filterMap (fun (_isOptional, label, _, _interiorType) -> - if label = "key" then None else Some (Typ.var label)) + if label = "key" || label = "ref" then None else Some (Typ.var label)) (* make type params for make sig arguments *) (* let make: React.componentLike>, React.element> *) let makePropsTypeParamsSig namedTypeList = namedTypeList |> filterMap (fun (isOptional, label, _, interiorType) -> - if label = "key" then None + if label = "key" || label = "ref" then None else if isOptional then Some (extractOptionalCoreType interiorType) else Some interiorType) @@ -325,6 +335,9 @@ let makePropsRecordType propsName loc namedTypeList = if label = "key" then Type.field ~loc ~attrs:optionalAttr {txt = label; loc} (keyType Location.none) + else if label = "ref" then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (refType Location.none) else if isOptional then Type.field ~loc ~attrs:optionalAttr {txt = label; loc} (Typ.var label) @@ -698,7 +711,9 @@ let jsxMapper () = (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *) let propsRecordType = makePropsRecordType "props" Location.none - ((true, "key", [], keyType pstr_loc) :: namedTypeList) + ((true, "key", [], keyType pstr_loc) + :: (true, "ref", [], refType pstr_loc) + :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -944,6 +959,9 @@ let jsxMapper () = ] ) in let namedTypeList = List.fold_left argToType [] namedArgList in + let vbIgnoreUnusedRef = + Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) + in let namedArgWithDefaultValueList = filterMap argWithDefaultValue namedArgList in @@ -977,7 +995,9 @@ let jsxMapper () = (* type props = { ... } *) let propsRecordType = makePropsRecordType "props" emptyLoc - ((true, "key", [], keyType emptyLoc) :: namedTypeList) + ((true, "key", [], keyType emptyLoc) + :: (true, "ref", [], refType pstr_loc) + :: namedTypeList) in let innerExpressionArgs = List.map pluckArg namedArgListWithKeyAndRefForNew @@ -1064,8 +1084,22 @@ let jsxMapper () = in let patternsWithLid, expression = returnedExpression [] expression in let pattern = - if List.length patternsWithLid = 0 then Pat.any () - else Pat.record (List.rev patternsWithLid) Closed + Pat.record + (List.rev patternsWithLid + @ [ + ( Location.mknoloc (Lident "ref"), + Pat.var (Location.mknoloc "ref") ); + ]) + Closed + in + (* add patttern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression + in + (* add let _ = ref to ignore unused warning *) + let expression = + Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression in let expression = Exp.fun_ Nolabel None @@ -1073,8 +1107,7 @@ let jsxMapper () = (Typ.constr ~loc:emptyLoc {txt = Lident "props"; loc = emptyLoc} (makePropsTypeParams namedTypeList))) - (if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression) + expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) let bindings = @@ -1152,7 +1185,9 @@ let jsxMapper () = in let propsRecordType = makePropsRecordTypeSig "props" Location.none - ((true, "key", [], keyType Location.none) :: namedTypeList) + ((true, "key", [], keyType Location.none) + :: (true, "ref", [], refType Location.none) + :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = From bb11ee2f3819d903f1adb5df82d03aff7f473d4e Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sun, 12 Jun 2022 12:29:30 +0900 Subject: [PATCH 11/35] replace filterMap with std lib --- cli/reactjs_jsx_ppx_v3.ml | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index eb618170..aa61e9a6 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -242,17 +242,6 @@ let makeModuleName fileName nestedModules fnName = constructor and a props external *) -(* List.filter_map in 4.08.0 *) -let filterMap f = - let rec aux accu = function - | [] -> List.rev accu - | x :: l -> ( - match f x with - | None -> aux accu l - | Some v -> aux (v :: accu) l) - in - aux [] - (* make record from props and spread props if exists *) let recordFromProps {pexp_loc} callArguments = let rec removeLastPositionUnitAux props acc = @@ -302,7 +291,7 @@ let recordFromProps {pexp_loc} callArguments = (* make type params for type props<'id, 'name, ...> *) let makePropsTypeParamsTvar namedTypeList = namedTypeList - |> filterMap (fun (_, label, _, _) -> + |> List.filter_map (fun (_, label, _, _) -> if label = "key" || label = "ref" then None else Some (Typ.var label, Invariant)) @@ -315,14 +304,14 @@ let extractOptionalCoreType = function (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) let makePropsTypeParams namedTypeList = namedTypeList - |> filterMap (fun (_isOptional, label, _, _interiorType) -> + |> List.filter_map (fun (_isOptional, label, _, _interiorType) -> if label = "key" || label = "ref" then None else Some (Typ.var label)) (* make type params for make sig arguments *) (* let make: React.componentLike>, React.element> *) let makePropsTypeParamsSig namedTypeList = namedTypeList - |> filterMap (fun (isOptional, label, _, interiorType) -> + |> List.filter_map (fun (isOptional, label, _, interiorType) -> if label = "key" || label = "ref" then None else if isOptional then Some (extractOptionalCoreType interiorType) else Some interiorType) @@ -963,7 +952,7 @@ let jsxMapper () = Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) in let namedArgWithDefaultValueList = - filterMap argWithDefaultValue namedArgList + List.filter_map argWithDefaultValue namedArgList in let vbMatch (label, default) = Vb.mk From ac6fddc55cb36540222df1736dd3d5b398f54222 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 12 Jun 2022 07:29:46 +0200 Subject: [PATCH 12/35] Add JSX V4 spec. --- cli/JSXV4.md | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 cli/JSXV4.md diff --git a/cli/JSXV4.md b/cli/JSXV4.md new file mode 100644 index 00000000..9824d6ed --- /dev/null +++ b/cli/JSXV4.md @@ -0,0 +1,81 @@ +**Abbreviation** +Tha placement of `@react.component` is an abbreviation as described below. + +***Normal Case*** + +```rescript +@react.component +let make = (~x, ~y, ~z) => body + +// is an abbreviation for + +let make = @react.component (~x, ~y, ~z) => body +``` + +***Forward Ref*** + +```rescript +@react.component +let make = React.forwardRef((~x, ~y, ref) => body) + +// is an abbreviation for + +let make = React.forwardRef({ + let fn = + @react.component (~x, ~y, ~ref=?) => { + let ref = ref->Js.Nullable.fromOption + body + } + (props, ref) => fn({...props, ref: {ref->Js.Nullable.toOption}}) +}) +``` + +**Conversion** +Conversion applies to an arrow function definition where all the arguments are labelled. +It produces a type definition and a new function. + +***Definition*** + +```rescript +@react.component (~x, ~y=3+x, ?z) => body + +// is converted to + +type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z, @optional key: string} + +(props: props<_>) => { + let x = props.x + let y = switch props.y { | None => 3+x | Some (y) => y } + let z = props.z + React.createElement(body: React.element, props) +} +``` + +***Application*** + +```rescript + +// is converted to +Comp.make({x}) + + +// is converted to +Comp.make({x, y:7, ~optional z}) + + +// is converted to +Comp.make({x, key: "7"}) +``` + +***Interface*** + +```rescript +@react.component +let make: (~x: int, ~y: int=?, ~z: int=?) => React.element + +// is converted to + +type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z} + +let make: (props) => React.element +``` From 2a3ddac56394527bb052210f3f64fe57d0ec88be Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 12 Jun 2022 19:54:10 +0200 Subject: [PATCH 13/35] typo --- cli/JSXV4.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index 9824d6ed..04459d28 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -60,7 +60,7 @@ Comp.make({x}) // is converted to -Comp.make({x, y:7, ~optional z}) +Comp.make({x, y:7, @optional z}) // is converted to From 2b742f14f94e5ad33f88d567b072110a03dd22be Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 00:57:06 +0200 Subject: [PATCH 14/35] JSX spec: move createElement to application. Following https://forum.rescript-lang.org/t/jsx-v4-next-rescript-react-0-10-x/3431/10 --- cli/JSXV4.md | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index 04459d28..d7797ddb 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -1,7 +1,7 @@ **Abbreviation** Tha placement of `@react.component` is an abbreviation as described below. -***Normal Case*** +**_Normal Case_** ```rescript @react.component @@ -12,7 +12,7 @@ let make = (~x, ~y, ~z) => body let make = @react.component (~x, ~y, ~z) => body ``` -***Forward Ref*** +**_Forward Ref_** ```rescript @react.component @@ -34,7 +34,7 @@ let make = React.forwardRef({ Conversion applies to an arrow function definition where all the arguments are labelled. It produces a type definition and a new function. -***Definition*** +**_Definition_** ```rescript @react.component (~x, ~y=3+x, ?z) => body @@ -43,31 +43,32 @@ It produces a type definition and a new function. type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z, @optional key: string} -(props: props<_>) => { - let x = props.x - let y = switch props.y { | None => 3+x | Some (y) => y } - let z = props.z - React.createElement(body: React.element, props) +({x, y, z}: props<_>) => { + let y = switch props.y { + | None => 3 + x + | Some(y) => y + } + body } ``` -***Application*** +**_Application_** ```rescript // is converted to -Comp.make({x}) +React.createElement(Comp.make, {x}) // is converted to -Comp.make({x, y:7, @optional z}) +React.createElement(Comp.make, {x, y:7, @optional z}) // is converted to -Comp.make({x, key: "7"}) +React.createElement(Comp.make, {x, key: "7"}) ``` -***Interface*** +**_Interface_** ```rescript @react.component From 7f541baa7e5374dad68d73a5f796f8e042f1a4e8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 01:11:14 +0200 Subject: [PATCH 15/35] spec: comment on name --- cli/JSXV4.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index d7797ddb..d109efc8 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -80,3 +80,8 @@ type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z} let make: (props) => React.element ``` + +**_Component_Name_** + +Use the V3 convention for names, and make sure the generated +function has the name of the enclosing module/file. \ No newline at end of file From 6ec656cf05440e0b7ecd12ad1aaa6ac1e1c1620b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 01:13:28 +0200 Subject: [PATCH 16/35] spec: clean up file --- cli/JSXV4.md | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index d109efc8..b273f916 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -1,7 +1,8 @@ **Abbreviation** -Tha placement of `@react.component` is an abbreviation as described below. -**_Normal Case_** +The placement of `@react.component` is an abbreviation as described below. + +**Normal Case** ```rescript @react.component @@ -12,7 +13,7 @@ let make = (~x, ~y, ~z) => body let make = @react.component (~x, ~y, ~z) => body ``` -**_Forward Ref_** +**Forward Ref** ```rescript @react.component @@ -31,10 +32,11 @@ let make = React.forwardRef({ ``` **Conversion** + Conversion applies to an arrow function definition where all the arguments are labelled. It produces a type definition and a new function. -**_Definition_** +**Definition** ```rescript @react.component (~x, ~y=3+x, ?z) => body @@ -52,7 +54,7 @@ type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z, @optional key } ``` -**_Application_** +**Application** ```rescript @@ -68,7 +70,7 @@ React.createElement(Comp.make, {x, y:7, @optional z}) React.createElement(Comp.make, {x, key: "7"}) ``` -**_Interface_** +**Interface** ```rescript @react.component @@ -81,7 +83,7 @@ type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z} let make: (props) => React.element ``` -**_Component_Name_** +**Component Name** Use the V3 convention for names, and make sure the generated -function has the name of the enclosing module/file. \ No newline at end of file +function has the name of the enclosing module/file. From 2abb690982a30a8bab1e74262d7fec3da908a75b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 01:14:28 +0200 Subject: [PATCH 17/35] external --- cli/JSXV4.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index b273f916..ca42d166 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -70,7 +70,7 @@ React.createElement(Comp.make, {x, y:7, @optional z}) React.createElement(Comp.make, {x, key: "7"}) ``` -**Interface** +**Interface And External** ```rescript @react.component @@ -83,6 +83,8 @@ type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z} let make: (props) => React.element ``` +Since an external is a function declaration, it follows the same rule. + **Component Name** Use the V3 convention for names, and make sure the generated From 47a6cb0ae05f48e6c07ddd4f5f22ebd79b5e121b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 01:16:26 +0200 Subject: [PATCH 18/35] Be consistent with interface only show how to transform the arrow function. --- cli/JSXV4.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index ca42d166..a204bec2 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -73,8 +73,7 @@ React.createElement(Comp.make, {x, key: "7"}) **Interface And External** ```rescript -@react.component -let make: (~x: int, ~y: int=?, ~z: int=?) => React.element +@react.component (~x: int, ~y: int=?, ~z: int=?) => React.element // is converted to From a97c9ae5a1463146d3aa20b1e0f9004ac014398d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 01:17:33 +0200 Subject: [PATCH 19/35] Update JSXV4.md --- cli/JSXV4.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index a204bec2..8d335278 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -79,7 +79,7 @@ React.createElement(Comp.make, {x, key: "7"}) type props<'x, 'y, 'z> = {x: 'x, @optional y: 'y, @optional z: 'z} -let make: (props) => React.element +props => React.element ``` Since an external is a function declaration, it follows the same rule. From 4e80d695de06ec59992b8b41fd2509203bf0861b Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Mon, 13 Jun 2022 11:00:58 +0900 Subject: [PATCH 20/35] restore React.createElement in application site --- cli/reactjs_jsx_ppx_v3.ml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index aa61e9a6..233007de 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -445,12 +445,17 @@ let jsxMapper () = match !childrenArg with | None -> Exp.apply ~loc ~attrs - (Exp.ident ~loc {txt = ident; loc}) - [(nolabel, props)] + (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 {txt = ident; loc}) - [(nolabel, props); (nolabel, children)] + (Exp.ident ~loc + {loc; txt = Ldot (Lident "React", "createElementVariadic")}) + [ + (nolabel, Exp.ident ~loc {txt = ident; loc}); + (nolabel, props); + (nolabel, children); + ] [@@raises Invalid_argument] in From e7af22f478e679454d5b5a3f6594f25524f4f1a3 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Mon, 13 Jun 2022 11:24:21 +0900 Subject: [PATCH 21/35] spec: react fragment --- cli/JSXV4.md | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index 8d335278..a258d76e 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -88,3 +88,21 @@ Since an external is a function declaration, it follows the same rule. Use the V3 convention for names, and make sure the generated function has the name of the enclosing module/file. + +**Fragment** + +```rescript +@react.component +let make = () => <> component + +// is converted to + +let make = () => { + ReactDOMRe.createElement( + ReasonReact.fragment, + [ + component + ] + ) +} +``` From c7412fcb09cde78ca0e1836ef71408f8e3ee01f5 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 13 Jun 2022 04:51:59 +0200 Subject: [PATCH 22/35] spec: tweak fragment. --- cli/JSXV4.md | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/cli/JSXV4.md b/cli/JSXV4.md index a258d76e..2d463c53 100644 --- a/cli/JSXV4.md +++ b/cli/JSXV4.md @@ -92,17 +92,9 @@ function has the name of the enclosing module/file. **Fragment** ```rescript -@react.component -let make = () => <> component +<> comp1 comp2 comp3 // is converted to -let make = () => { - ReactDOMRe.createElement( - ReasonReact.fragment, - [ - component - ] - ) -} +ReactDOMRe.createElement(ReasonReact.fragment, [comp1, comp2, comp3]) ``` From 139e23aa86d9f0af0878eed07e5e467d509d0523 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Mon, 13 Jun 2022 15:38:06 +0900 Subject: [PATCH 23/35] make react component name capitalized --- cli/reactjs_jsx_ppx_v3.ml | 233 ++++++++------------------------------ 1 file changed, 49 insertions(+), 184 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 233007de..e6e53a81 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -36,7 +36,11 @@ let constantString ~loc str = let recordWithOnlyKey ~loc = Exp.record ~loc - [({loc; txt = Lident "key"}, Exp.construct {loc; txt = Lident "None"} None)] + (* {key: @optional None} *) + [ + ( {loc; txt = Lident "key"}, + Exp.construct ~attrs:optionalAttr {loc; txt = Lident "None"} None ); + ] None let safeTypeFromValue valueStr = @@ -59,8 +63,6 @@ let refType loc = 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 = @@ -169,45 +171,6 @@ let makeNewBinding binding expression newName = 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] - (* 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 = @@ -360,29 +323,6 @@ let makePropsRecordTypeSig propsName loc namedTypeList = ~kind:(Ptype_record labelDeclList); ] -(* 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)) - -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 () = let jsxVersion = ref None in @@ -903,55 +843,13 @@ let jsxMapper () = 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 + let bindingWrapper, _hasUnit, expression = modifiedBinding binding in (* do stuff here! *) - let namedArgList, newtypes, forwardRef = + let namedArgList, _newtypes, _forwardRef = recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] [] 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 vbIgnoreUnusedRef = Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) @@ -976,16 +874,6 @@ let jsxMapper () = ]) in let vbMatchList = List.map vbMatch namedArgWithDefaultValueList in - let externalTypes = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, c, typ) -> - (a, b, c, newtypeToVar newtype.txt typ)) - args) - namedTypeList newtypes - in (* type props = { ... } *) let propsRecordType = makePropsRecordType "props" emptyLoc @@ -993,57 +881,22 @@ let jsxMapper () = :: (true, "ref", [], refType pstr_loc) :: namedTypeList) in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ - if hasUnit then - [ - (Nolabel, Exp.construct {loc = emptyLoc; txt = Lident "()"} None); - ] - else [] - in let innerExpression = Exp.apply - (Exp.ident - { - loc = emptyLoc; - 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 + (Exp.ident (Location.mknoloc @@ Lident "make")) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] in let fullExpression = + (* React component name should start with uppercase letter *) + (* let make = { let \"App" = props => make(props); \"App" } *) Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef + (match namedTypeList with + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()])) + innerExpression in let fullExpression = match fullModuleName with @@ -1104,42 +957,54 @@ let jsxMapper () = expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let bindings = + 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})); - ] + ( [ + 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 = []}] + ( [{binding with pvb_expr = expression; pvb_attributes = []}], + Some (bindingWrapper fullExpression) ) in - (Some propsRecordType, bindings) - else (None, [binding]) + (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 (type_, binding) (types, bindings) = + let otherStructures (type_, binding, newBinding) + (types, bindings, newBindings) = let types = match type_ with | Some type_ -> type_ :: types | None -> types in - (types, binding @ bindings) + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings + in + (types, binding @ bindings, newBindings) in - let types, bindings = - List.fold_right otherStructures structuresAndBinding ([], []) + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) in 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] From c9750410d22691c97749dfe73a40be210ffc2c92 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Mon, 13 Jun 2022 16:28:44 +0900 Subject: [PATCH 24/35] test: add test files --- tests/ppx/react/expected/commentAtTop.res.txt | 15 +++++-- .../expected/externalWithCustomName.res.txt | 13 +++--- tests/ppx/react/expected/innerModule.res.txt | 42 ++++++++++++------- tests/ppx/react/expected/newtype.res.txt | 25 +++++------ tests/ppx/react/expected/topLevel.res.txt | 20 +++++---- .../ppx/react/expected/typeConstraint.res.txt | 17 +++++--- 6 files changed, 83 insertions(+), 49 deletions(-) diff --git a/tests/ppx/react/expected/commentAtTop.res.txt b/tests/ppx/react/expected/commentAtTop.res.txt index 89dd8093..4f8fb5b4 100644 --- a/tests/ppx/react/expected/commentAtTop.res.txt +++ b/tests/ppx/react/expected/commentAtTop.res.txt @@ -1,10 +1,17 @@ -@obj external makeProps: (~msg: 'msg, ~key: string=?, unit) => {"msg": 'msg} = "" // test React JSX file +type props<'msg> = { // test React JSX file + @optional key: string, + @optional ref: React.ref>, + msg: 'msg, +} + +let make = ({msg, ref}: props<'msg>) => { + let _ = ref -let make = - (@warning("-16") ~msg) => { + { ReactDOMRe.createDOMElementVariadic("div", [{msg->React.string}]) } +} let make = { - let \"CommentAtTop" = (\"Props": {"msg": 'msg}) => make(~msg=\"Props"["msg"]) + let \"CommentAtTop" = (props: props<_>) => make(props) \"CommentAtTop" } diff --git a/tests/ppx/react/expected/externalWithCustomName.res.txt b/tests/ppx/react/expected/externalWithCustomName.res.txt index 083aeead..e279af9e 100644 --- a/tests/ppx/react/expected/externalWithCustomName.res.txt +++ b/tests/ppx/react/expected/externalWithCustomName.res.txt @@ -1,9 +1,12 @@ module Foo = { - @obj - external componentProps: (~a: int, ~b: string, ~key: string=?, unit) => {"a": int, "b": string} = - "" + type props<'a, 'b> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, + } @module("Foo") - external component: React.componentLike<{"a": int, "b": string}, React.element> = "component" + external component: React.componentLike, React.element> = "component" } -let t = React.createElement(Foo.component, Foo.componentProps(~a=1, ~b={"1"}, ())) +let t = React.createElement(Foo.component, {a: 1, b: "1"}) diff --git a/tests/ppx/react/expected/innerModule.res.txt b/tests/ppx/react/expected/innerModule.res.txt index 6c0e7369..5d502e1e 100644 --- a/tests/ppx/react/expected/innerModule.res.txt +++ b/tests/ppx/react/expected/innerModule.res.txt @@ -1,25 +1,35 @@ module Bar = { - @obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" - let make = - (@warning("-16") ~a, @warning("-16") ~b, _) => { - Js.log("This function should be named `InnerModule.react$Bar`") - ReactDOMRe.createDOMElementVariadic("div", []) - } + type props<'a, 'b> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, + } + let make = ({a, b, ref}: props<'a, 'b>) => { + let _ = ref + + Js.log("This function should be named `InnerModule.react$Bar`") + ReactDOMRe.createDOMElementVariadic("div", []) + } let make = { - let \"InnerModule$Bar" = (\"Props": {"a": 'a, "b": 'b}) => - make(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + let \"InnerModule$Bar" = (props: props<_>) => make(props) \"InnerModule$Bar" } - @obj external componentProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" + type props<'a, 'b> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, + } + + let component = ({a, b, ref}: props<'a, 'b>) => { + let _ = ref - let component = - (@warning("-16") ~a, @warning("-16") ~b, _) => { - Js.log("This function should be named `InnerModule.react$Bar$component`") - ReactDOMRe.createDOMElementVariadic("div", []) - } + Js.log("This function should be named `InnerModule.react$Bar$component`") + ReactDOMRe.createDOMElementVariadic("div", []) + } let component = { - let \"InnerModule$Bar$component" = (\"Props": {"a": 'a, "b": 'b}) => - component(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + let \"InnerModule$Bar$component" = (props: props<_>) => make(props) \"InnerModule$Bar$component" } } diff --git a/tests/ppx/react/expected/newtype.res.txt b/tests/ppx/react/expected/newtype.res.txt index ace5106c..6f45e7ad 100644 --- a/tests/ppx/react/expected/newtype.res.txt +++ b/tests/ppx/react/expected/newtype.res.txt @@ -1,15 +1,16 @@ -@obj -external makeProps: ( - ~a: '\"type-a", - ~b: array>, - ~c: 'a, - ~key: string=?, - unit, -) => {"a": '\"type-a", "b": array>, "c": 'a} = "" -let make = (type a, ~a: a, ~b: array>, ~c: 'a, _) => - ReactDOMRe.createDOMElementVariadic("div", []) +type props<'a, 'b, 'c> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, + c: 'c, +} +let make = ({ref}: props<'a, 'b, 'c>) => { + let _ = ref + (type a, ~a: a, ~b: array>, ~c: 'a, _) => + ReactDOMRe.createDOMElementVariadic("div", []) +} let make = { - let \"Newtype" = (\"Props": {"a": '\"type-a", "b": array>, "c": 'a}) => - make(~c=\"Props"["c"], ~b=\"Props"["b"], ~a=\"Props"["a"]) + let \"Newtype" = (props: props<_>) => make(props) \"Newtype" } diff --git a/tests/ppx/react/expected/topLevel.res.txt b/tests/ppx/react/expected/topLevel.res.txt index b14eee2a..96efc6f3 100644 --- a/tests/ppx/react/expected/topLevel.res.txt +++ b/tests/ppx/react/expected/topLevel.res.txt @@ -1,10 +1,16 @@ -@obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" -let make = - (@warning("-16") ~a, @warning("-16") ~b, _) => { - Js.log("This function should be named 'TopLevel.react'") - ReactDOMRe.createDOMElementVariadic("div", []) - } +type props<'a, 'b> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, +} +let make = ({a, b, ref}: props<'a, 'b>) => { + let _ = ref + + Js.log("This function should be named 'TopLevel.react'") + ReactDOMRe.createDOMElementVariadic("div", []) +} let make = { - let \"TopLevel" = (\"Props": {"a": 'a, "b": 'b}) => make(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + let \"TopLevel" = (props: props<_>) => make(props) \"TopLevel" } diff --git a/tests/ppx/react/expected/typeConstraint.res.txt b/tests/ppx/react/expected/typeConstraint.res.txt index 8940b164..452c8c45 100644 --- a/tests/ppx/react/expected/typeConstraint.res.txt +++ b/tests/ppx/react/expected/typeConstraint.res.txt @@ -1,8 +1,15 @@ -@obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" -let make: - type a. (~a: a, ~b: a, a) => React.element = - (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) +type props<'a, 'b> = { + @optional key: string, + @optional ref: React.ref>, + a: 'a, + b: 'b, +} +let make: 'a. (~a: 'a, ~b: 'a, 'a) => React.element = ({ref}: props<'a, 'b>) => { + let _ = ref + (type a): ((~a: a, ~b: a, a) => React.element) => + (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) +} let make = { - let \"TypeConstraint" = (\"Props": {"a": 'a, "b": 'b}) => make(~b=\"Props"["b"], ~a=\"Props"["a"]) + let \"TypeConstraint" = (props: props<_>) => make(props) \"TypeConstraint" } From 5a1dc6637518d4ccb424db0d9d2976d530a0d0fa Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Wed, 15 Jun 2022 16:15:02 +0900 Subject: [PATCH 25/35] fix ppx for forwardRef --- cli/reactjs_jsx_ppx_v3.ml | 106 +++++++++++++----- tests/ppx/react/expected/commentAtTop.res.txt | 7 +- .../expected/externalWithCustomName.res.txt | 2 +- tests/ppx/react/expected/innerModule.res.txt | 6 +- tests/ppx/react/expected/newtype.res.txt | 3 +- tests/ppx/react/expected/topLevel.res.txt | 3 +- .../ppx/react/expected/typeConstraint.res.txt | 3 +- 7 files changed, 92 insertions(+), 38 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index e6e53a81..f1fa4ec5 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -22,6 +22,10 @@ let isLabelled str = | Labelled _ -> true | _ -> false +let isForwardRef = function + | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | _ -> false + let getLabel str = match str with | Optional str | Labelled str -> str @@ -54,12 +58,8 @@ let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} [] let refType loc = Typ.constr ~loc - {loc; txt = Ldot (Lident "React", "ref")} - [ - Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")} - [Typ.constr ~loc {loc; txt = Ldot (Lident "Dom", "element")} []]; - ] + {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} + [] type 'a children = ListLiteral of 'a | Exact of 'a @@ -754,11 +754,12 @@ let jsxMapper () = pattern, ({pexp_desc = Pexp_fun _} as internalExpression) ); } -> - let wrap, hasUnit, exp = + let wrap, hasUnit, hasForwardRef, exp = spelunkForFunExpression internalExpression in ( wrap, hasUnit, + hasForwardRef, unerasableIgnoreExp { expression with @@ -777,7 +778,7 @@ let jsxMapper () = }, _internalExpression ); } -> - ((fun a -> a), true, expression) + ((fun a -> a), true, false, expression) (* let make = (~prop) => ... *) | { pexp_desc = @@ -787,14 +788,14 @@ let jsxMapper () = _pattern, _internalExpression ); } -> - ((fun a -> a), false, unerasableIgnoreExp expression) + ((fun a -> a), false, false, unerasableIgnoreExp expression) (* let make = (prop) => ... *) | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression); } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) + if !hasApplication then + ((fun a -> a), false, false, unerasableIgnoreExp expression) else Location.raise_errorf ~loc:pattern.ppat_loc "React: props need to be labelled arguments.\n\ @@ -805,11 +806,12 @@ let jsxMapper () = (* let make = {let foo = bar in (~prop) => ...} *) | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> (* here's where we spelunk! *) - let wrap, hasUnit, exp = + let wrap, hasUnit, hasForwardRef, exp = spelunkForFunExpression internalExpression in ( wrap, hasUnit, + hasForwardRef, {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} ) (* let make = React.forwardRef((~prop) => ...) *) @@ -818,32 +820,40 @@ let jsxMapper () = Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); } -> let () = hasApplication := true in - let _, hasUnit, exp = + let _, hasUnit, _, exp = spelunkForFunExpression internalExpression in + let hasForwardRef = isForwardRef wrapperExpression in ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), hasUnit, + hasForwardRef, exp ) | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); } -> - let wrap, hasUnit, exp = + let wrap, hasUnit, hasForwardRef, exp = spelunkForFunExpression internalExpression in ( wrap, hasUnit, + hasForwardRef, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp); } ) - | e -> ((fun a -> a), false, e) + | e -> ((fun a -> a), false, false, e) in - let wrapExpression, hasUnit, expression = + let wrapExpression, hasUnit, hasForwardRef, expression = spelunkForFunExpression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + ( wrapExpressionWithBinding wrapExpression, + hasUnit, + hasForwardRef, + expression ) + in + let bindingWrapper, _hasUnit, hasForwardRef, expression = + modifiedBinding binding in - let bindingWrapper, _hasUnit, expression = modifiedBinding binding in (* do stuff here! *) let namedArgList, _newtypes, _forwardRef = recursivelyTransformNamedArgsForMake mapper @@ -851,9 +861,20 @@ let jsxMapper () = [] [] in let namedTypeList = List.fold_left argToType [] namedArgList in + (* let _ = ref *) let vbIgnoreUnusedRef = Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) in + (* let ref = ref->Js.Nullable.fromOption *) + let vbRefFromOption = + Vb.mk + (Pat.var @@ Location.mknoloc "ref") + (Exp.apply + (Exp.ident + (Location.mknoloc + (Ldot (Ldot (Lident "Js", "Nullable"), "fromOption")))) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]) + in let namedArgWithDefaultValueList = List.filter_map argWithDefaultValue namedArgList in @@ -882,13 +903,37 @@ let jsxMapper () = :: namedTypeList) in let innerExpression = - Exp.apply - (Exp.ident (Location.mknoloc @@ Lident "make")) - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] + if hasForwardRef then + Exp.apply + (Exp.ident @@ Location.mknoloc @@ Lident "make") + [ + ( Nolabel, + Exp.record + [ + ( Location.mknoloc @@ Lident "ref", + Exp.apply ~attrs:optionalAttr + (Exp.ident + (Location.mknoloc + (Ldot + (Ldot (Lident "Js", "Nullable"), "toOption")))) + [ + ( Nolabel, + Exp.ident (Location.mknoloc @@ Lident "ref") ); + ] ); + ] + (Some (Exp.ident (Location.mknoloc @@ Lident "props"))) ); + ] + else + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident "make")) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] 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" @@ -896,7 +941,11 @@ let jsxMapper () = Pat.constraint_ (Pat.var @@ Location.mknoloc "props") (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()])) - innerExpression + (if hasForwardRef then + Exp.fun_ nolabel None + (Pat.var @@ Location.mknoloc "ref") + innerExpression + else innerExpression) in let fullExpression = match fullModuleName with @@ -922,11 +971,13 @@ let jsxMapper () = expr ) -> (patterns, expr) | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) - :: patterns) - expr + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, + Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) + :: patterns) + expr + else returnedExpression patterns expr | _ -> (patterns, expr) in let patternsWithLid, expression = returnedExpression [] expression in @@ -948,6 +999,7 @@ let jsxMapper () = let expression = Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression in + let expression = Exp.let_ Nonrecursive [vbRefFromOption] expression in let expression = Exp.fun_ Nolabel None (Pat.constraint_ pattern diff --git a/tests/ppx/react/expected/commentAtTop.res.txt b/tests/ppx/react/expected/commentAtTop.res.txt index 4f8fb5b4..b9c3259b 100644 --- a/tests/ppx/react/expected/commentAtTop.res.txt +++ b/tests/ppx/react/expected/commentAtTop.res.txt @@ -1,10 +1,7 @@ -type props<'msg> = { // test React JSX file - @optional key: string, - @optional ref: React.ref>, - msg: 'msg, -} +type props<'msg> = {@optional key: string, @optional ref: ReactDOM.Ref.currentDomRef, msg: 'msg} // test React JSX file let make = ({msg, ref}: props<'msg>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref { diff --git a/tests/ppx/react/expected/externalWithCustomName.res.txt b/tests/ppx/react/expected/externalWithCustomName.res.txt index e279af9e..72e5974c 100644 --- a/tests/ppx/react/expected/externalWithCustomName.res.txt +++ b/tests/ppx/react/expected/externalWithCustomName.res.txt @@ -1,7 +1,7 @@ module Foo = { type props<'a, 'b> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, } diff --git a/tests/ppx/react/expected/innerModule.res.txt b/tests/ppx/react/expected/innerModule.res.txt index 5d502e1e..23145271 100644 --- a/tests/ppx/react/expected/innerModule.res.txt +++ b/tests/ppx/react/expected/innerModule.res.txt @@ -1,11 +1,12 @@ module Bar = { type props<'a, 'b> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, } let make = ({a, b, ref}: props<'a, 'b>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref Js.log("This function should be named `InnerModule.react$Bar`") @@ -17,12 +18,13 @@ module Bar = { } type props<'a, 'b> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, } let component = ({a, b, ref}: props<'a, 'b>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref Js.log("This function should be named `InnerModule.react$Bar$component`") diff --git a/tests/ppx/react/expected/newtype.res.txt b/tests/ppx/react/expected/newtype.res.txt index 6f45e7ad..91e0cc9d 100644 --- a/tests/ppx/react/expected/newtype.res.txt +++ b/tests/ppx/react/expected/newtype.res.txt @@ -1,11 +1,12 @@ type props<'a, 'b, 'c> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, c: 'c, } let make = ({ref}: props<'a, 'b, 'c>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref (type a, ~a: a, ~b: array>, ~c: 'a, _) => ReactDOMRe.createDOMElementVariadic("div", []) diff --git a/tests/ppx/react/expected/topLevel.res.txt b/tests/ppx/react/expected/topLevel.res.txt index 96efc6f3..8860b44d 100644 --- a/tests/ppx/react/expected/topLevel.res.txt +++ b/tests/ppx/react/expected/topLevel.res.txt @@ -1,10 +1,11 @@ type props<'a, 'b> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, } let make = ({a, b, ref}: props<'a, 'b>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref Js.log("This function should be named 'TopLevel.react'") diff --git a/tests/ppx/react/expected/typeConstraint.res.txt b/tests/ppx/react/expected/typeConstraint.res.txt index 452c8c45..b11ba87b 100644 --- a/tests/ppx/react/expected/typeConstraint.res.txt +++ b/tests/ppx/react/expected/typeConstraint.res.txt @@ -1,10 +1,11 @@ type props<'a, 'b> = { @optional key: string, - @optional ref: React.ref>, + @optional ref: ReactDOM.Ref.currentDomRef, a: 'a, b: 'b, } let make: 'a. (~a: 'a, ~b: 'a, 'a) => React.element = ({ref}: props<'a, 'b>) => { + let ref = Js.Nullable.fromOption(ref) let _ = ref (type a): ((~a: a, ~b: a, a) => React.element) => (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) From 9a2ddb0b59c82308665e4869525da536307a8604 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 17 Jun 2022 01:57:22 +0900 Subject: [PATCH 26/35] remove ref from props except forwardRef --- cli/reactjs_jsx_ppx_v3.ml | 49 +++++++++++-------- tests/ppx/react/expected/commentAtTop.res.txt | 11 ++--- .../expected/externalWithCustomName.res.txt | 7 +-- tests/ppx/react/expected/innerModule.res.txt | 24 ++------- tests/ppx/react/expected/newtype.res.txt | 16 ++---- tests/ppx/react/expected/topLevel.res.txt | 12 +---- .../ppx/react/expected/typeConstraint.res.txt | 16 ++---- 7 files changed, 46 insertions(+), 89 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index f1fa4ec5..8269d4bd 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -288,8 +288,9 @@ let makePropsRecordType propsName loc namedTypeList = Type.field ~loc ~attrs:optionalAttr {txt = label; loc} (keyType Location.none) else if label = "ref" then - Type.field ~loc ~attrs:optionalAttr {txt = label; loc} - (refType Location.none) + Type.field ~loc + ~attrs:(if isOptional then optionalAttr else []) + {txt = label; loc} (refType Location.none) else if isOptional then Type.field ~loc ~attrs:optionalAttr {txt = label; loc} (Typ.var label) @@ -645,9 +646,7 @@ let jsxMapper () = (* type props<'id, 'name> = { @optional key: string, @optional id: 'id, ... } *) let propsRecordType = makePropsRecordType "props" Location.none - ((true, "key", [], keyType pstr_loc) - :: (true, "ref", [], refType pstr_loc) - :: namedTypeList) + ((true, "key", [], keyType pstr_loc) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = @@ -898,9 +897,10 @@ let jsxMapper () = (* type props = { ... } *) let propsRecordType = makePropsRecordType "props" emptyLoc - ((true, "key", [], keyType emptyLoc) - :: (true, "ref", [], refType pstr_loc) - :: namedTypeList) + (((true, "key", [], keyType emptyLoc) :: namedTypeList) + @ + if hasForwardRef then [(true, "ref", [], refType pstr_loc)] + else []) in let innerExpression = if hasForwardRef then @@ -981,14 +981,20 @@ let jsxMapper () = | _ -> (patterns, expr) in let patternsWithLid, expression = returnedExpression [] expression in + let patternsWithLid = + List.rev patternsWithLid + @ + if hasForwardRef then + [ + ( Location.mknoloc (Lident "ref"), + Pat.var (Location.mknoloc "ref") ); + ] + else [] + in let pattern = - Pat.record - (List.rev patternsWithLid - @ [ - ( Location.mknoloc (Lident "ref"), - Pat.var (Location.mknoloc "ref") ); - ]) - Closed + match patternsWithLid with + | [] -> Pat.any () + | _ -> Pat.record patternsWithLid Closed in (* add patttern matching for optional prop value *) let expression = @@ -997,9 +1003,14 @@ let jsxMapper () = in (* add let _ = ref to ignore unused warning *) let expression = - Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression + match hasForwardRef with + | true -> + let expression = + Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression + in + Exp.let_ Nonrecursive [vbRefFromOption] expression + | false -> expression in - let expression = Exp.let_ Nonrecursive [vbRefFromOption] expression in let expression = Exp.fun_ Nolabel None (Pat.constraint_ pattern @@ -1096,9 +1107,7 @@ let jsxMapper () = in let propsRecordType = makePropsRecordTypeSig "props" Location.none - ((true, "key", [], keyType Location.none) - :: (true, "ref", [], refType Location.none) - :: namedTypeList) + ((true, "key", [], keyType Location.none) :: namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = diff --git a/tests/ppx/react/expected/commentAtTop.res.txt b/tests/ppx/react/expected/commentAtTop.res.txt index b9c3259b..1d536ca4 100644 --- a/tests/ppx/react/expected/commentAtTop.res.txt +++ b/tests/ppx/react/expected/commentAtTop.res.txt @@ -1,12 +1,7 @@ -type props<'msg> = {@optional key: string, @optional ref: ReactDOM.Ref.currentDomRef, msg: 'msg} // test React JSX file +type props<'msg> = {@optional key: string, msg: 'msg} // test React JSX file -let make = ({msg, ref}: props<'msg>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref - - { - ReactDOMRe.createDOMElementVariadic("div", [{msg->React.string}]) - } +let make = ({msg}: props<'msg>) => { + ReactDOMRe.createDOMElementVariadic("div", [{msg->React.string}]) } let make = { let \"CommentAtTop" = (props: props<_>) => make(props) diff --git a/tests/ppx/react/expected/externalWithCustomName.res.txt b/tests/ppx/react/expected/externalWithCustomName.res.txt index 72e5974c..d7d06db7 100644 --- a/tests/ppx/react/expected/externalWithCustomName.res.txt +++ b/tests/ppx/react/expected/externalWithCustomName.res.txt @@ -1,10 +1,5 @@ module Foo = { - type props<'a, 'b> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, - } + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} @module("Foo") external component: React.componentLike, React.element> = "component" } diff --git a/tests/ppx/react/expected/innerModule.res.txt b/tests/ppx/react/expected/innerModule.res.txt index 23145271..a849bc72 100644 --- a/tests/ppx/react/expected/innerModule.res.txt +++ b/tests/ppx/react/expected/innerModule.res.txt @@ -1,14 +1,6 @@ module Bar = { - type props<'a, 'b> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, - } - let make = ({a, b, ref}: props<'a, 'b>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref - + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} + let make = ({a, b}: props<'a, 'b>) => { Js.log("This function should be named `InnerModule.react$Bar`") ReactDOMRe.createDOMElementVariadic("div", []) } @@ -16,17 +8,9 @@ module Bar = { let \"InnerModule$Bar" = (props: props<_>) => make(props) \"InnerModule$Bar" } - type props<'a, 'b> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, - } - - let component = ({a, b, ref}: props<'a, 'b>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} + let component = ({a, b}: props<'a, 'b>) => { Js.log("This function should be named `InnerModule.react$Bar$component`") ReactDOMRe.createDOMElementVariadic("div", []) } diff --git a/tests/ppx/react/expected/newtype.res.txt b/tests/ppx/react/expected/newtype.res.txt index 91e0cc9d..10bd9031 100644 --- a/tests/ppx/react/expected/newtype.res.txt +++ b/tests/ppx/react/expected/newtype.res.txt @@ -1,16 +1,6 @@ -type props<'a, 'b, 'c> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, - c: 'c, -} -let make = ({ref}: props<'a, 'b, 'c>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref - (type a, ~a: a, ~b: array>, ~c: 'a, _) => - ReactDOMRe.createDOMElementVariadic("div", []) -} +type props<'a, 'b, 'c> = {@optional key: string, a: 'a, b: 'b, c: 'c} +let make = (_: props<'a, 'b, 'c>, type a, ~a: a, ~b: array>, ~c: 'a, _) => + ReactDOMRe.createDOMElementVariadic("div", []) let make = { let \"Newtype" = (props: props<_>) => make(props) \"Newtype" diff --git a/tests/ppx/react/expected/topLevel.res.txt b/tests/ppx/react/expected/topLevel.res.txt index 8860b44d..7694fd43 100644 --- a/tests/ppx/react/expected/topLevel.res.txt +++ b/tests/ppx/react/expected/topLevel.res.txt @@ -1,13 +1,5 @@ -type props<'a, 'b> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, -} -let make = ({a, b, ref}: props<'a, 'b>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref - +type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} +let make = ({a, b}: props<'a, 'b>) => { Js.log("This function should be named 'TopLevel.react'") ReactDOMRe.createDOMElementVariadic("div", []) } diff --git a/tests/ppx/react/expected/typeConstraint.res.txt b/tests/ppx/react/expected/typeConstraint.res.txt index b11ba87b..339cf97c 100644 --- a/tests/ppx/react/expected/typeConstraint.res.txt +++ b/tests/ppx/react/expected/typeConstraint.res.txt @@ -1,15 +1,7 @@ -type props<'a, 'b> = { - @optional key: string, - @optional ref: ReactDOM.Ref.currentDomRef, - a: 'a, - b: 'b, -} -let make: 'a. (~a: 'a, ~b: 'a, 'a) => React.element = ({ref}: props<'a, 'b>) => { - let ref = Js.Nullable.fromOption(ref) - let _ = ref - (type a): ((~a: a, ~b: a, a) => React.element) => - (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) -} +type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} +let make: 'a. (~a: 'a, ~b: 'a, 'a) => React.element = (_: props<'a, 'b>, type a): ( + (~a: a, ~b: a, a) => React.element +) => (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) let make = { let \"TypeConstraint" = (props: props<_>) => make(props) \"TypeConstraint" From 5aa2382b682b1df89ebfd4e95c02d6065d161c6b Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 17 Jun 2022 01:57:43 +0900 Subject: [PATCH 27/35] add test for forwardRef --- tests/ppx/react/expected/forwardRef.res.txt | 53 +++++++++++++++++++++ tests/ppx/react/forwardRef.res | 20 ++++++++ 2 files changed, 73 insertions(+) create mode 100644 tests/ppx/react/expected/forwardRef.res.txt create mode 100644 tests/ppx/react/forwardRef.res diff --git a/tests/ppx/react/expected/forwardRef.res.txt b/tests/ppx/react/expected/forwardRef.res.txt new file mode 100644 index 00000000..da4ca0fa --- /dev/null +++ b/tests/ppx/react/expected/forwardRef.res.txt @@ -0,0 +1,53 @@ +module FancyInput = { + type props<'className, 'children> = { + @optional key: string, + @optional className: 'className, + children: 'children, + @optional ref: ReactDOM.Ref.currentDomRef, + } + let make = ({className, children, ref}: props<'className, 'children>) => { + let ref = Js.Nullable.fromOption(ref) + let _ = ref + + ReactDOMRe.createDOMElementVariadic( + "div", + [ + ReactDOMRe.createDOMElementVariadic( + "input", + ~props=ReactDOMRe.domProps( + ~type_="text", + ~className?, + ~ref=?{Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef)}, + (), + ), + [], + ), + children, + ], + ) + } + let make = React.forwardRef({ + let \"ForwardRef$FancyInput" = (props: props<_>, ref) => + make({...props, ref: @optional Js.Nullable.toOption(ref)}) + \"ForwardRef$FancyInput" + }) +} +type props = {@optional key: string} + +let make = (_: props) => { + let input = React.useRef(Js.Nullable.null) + + ReactDOMRe.createDOMElementVariadic( + "div", + [ + React.createElement( + FancyInput.make, + {ref: input, children: {React.string("Click to focus")}}, + ), + ], + ) +} +let make = { + let \"ForwardRef" = props => make(props) + \"ForwardRef" +} diff --git a/tests/ppx/react/forwardRef.res b/tests/ppx/react/forwardRef.res new file mode 100644 index 00000000..a34d1ea9 --- /dev/null +++ b/tests/ppx/react/forwardRef.res @@ -0,0 +1,20 @@ +module FancyInput = { + @react.component + let make = React.forwardRef((~className=?, ~children, ref) => +
+ Belt.Option.map(ReactDOM.Ref.domRef)} + /> + children +
+ ) +} + +@react.component +let make = () => { + let input = React.useRef(Js.Nullable.null) + +
{React.string("Click to focus")}
+} From 3c213965eb52bd30c1ad4d553e74268e4cc5852c Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 17 Jun 2022 02:25:29 +0900 Subject: [PATCH 28/35] format --- cli/reactjs_jsx_ppx_v3.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 8269d4bd..2e2f37f0 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -375,7 +375,7 @@ let jsxMapper () = | _ -> false in (* check if record which goes to Foo.make({ ... } as record) empty or not - if empty then change it to {key: None} only for upper case jsx + 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 = From 2e4025d53b84a3c73f37d7ec8e856c354910e323 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Fri, 17 Jun 2022 17:17:32 +0900 Subject: [PATCH 29/35] remove uneccessary adding @optional attr from extracting props type --- cli/reactjs_jsx_ppx_v3.ml | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 2e2f37f0..95dd2940 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -258,11 +258,6 @@ let makePropsTypeParamsTvar namedTypeList = if label = "key" || label = "ref" then None else Some (Typ.var label, Invariant)) -let extractOptionalCoreType = function - | {ptyp_desc = Ptyp_constr ({txt}, [coreType])} when txt = optionIdent -> - coreType - | t -> t - (* make type params for make fn arguments *) (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) let makePropsTypeParams namedTypeList = @@ -274,10 +269,8 @@ let makePropsTypeParams namedTypeList = (* let make: React.componentLike>, React.element> *) let makePropsTypeParamsSig namedTypeList = namedTypeList - |> List.filter_map (fun (isOptional, label, _, interiorType) -> - if label = "key" || label = "ref" then None - else if isOptional then Some (extractOptionalCoreType interiorType) - else Some interiorType) + |> List.filter_map (fun (_isOptional, label, _, interiorType) -> + if label = "key" || label = "ref" then None else Some interiorType) (* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) let makePropsRecordType propsName loc namedTypeList = @@ -604,12 +597,10 @@ let jsxMapper () = [@@raises Invalid_argument] in - let argToConcreteType types (name, loc, type_) = + let argToConcreteType types (name, _loc, type_) = match name with | name when isLabelled name -> (false, getLabel name, [], type_) :: types - | name when isOptional name -> - (true, getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) - :: types + | name when isOptional name -> (true, getLabel name, [], type_) :: types | _ -> types in From 5216cced711358eeddd06d2d8c06ad1d0c0cbfb0 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 18 Jun 2022 00:47:27 +0900 Subject: [PATCH 30/35] indent by relocating every fn from jsxMapper --- cli/reactjs_jsx_ppx_v3.ml | 1772 ++++++++++++++++++------------------- 1 file changed, 877 insertions(+), 895 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 95dd2940..d89e694b 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -317,953 +317,935 @@ let makePropsRecordTypeSig propsName loc namedTypeList = ~kind:(Ptype_record labelDeclList); ] -(* TODO: some line number might still be wrong *) -let jsxMapper () = - let jsxVersion = ref None in - - let transformUppercaseCall3 modulePath mapper loc attrs callExpression - 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")} ); - ] - in - let record = recordFromProps callExpression args 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 isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - 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 - (* 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] +let transformUppercaseCall3 modulePath mapper loc attrs callExpression + callArguments = + let children, argsWithLabels = + extractChildren ~loc ~removeLastPositionUnit:true callArguments in - - let transformLowercaseCall3 mapper loc attrs _callExpression callArguments id - = - let children, nonChildrenProps = extractChildren ~loc callArguments in - (* keep the v3 *) - (* let record = recordFromProps callExpression nonChildrenProps 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.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 + 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")} ); + ] + in + let record = recordFromProps callExpression args 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 isEmptyRecord {pexp_desc} = + match pexp_desc with + | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | _ -> false + 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 + (* 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] - 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", _, _, _) -> +let transformLowercaseCall3 mapper loc attrs _callExpression callArguments id = + let children, nonChildrenProps = extractChildren ~loc callArguments in + (* keep the v3 *) + (* let record = recordFromProps callExpression nonChildrenProps 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 - "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] + "A spread as a DOM element's children don't make sense written \ + together. You can simply remove the spread.") 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 -> - ( true, - getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types - | Some type_, name, Some _default -> - ( false, - getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | Some type_, name, _ -> (false, getLabel name, [], type_) :: types - | None, name, _ when isOptional 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 = []; - } ) - :: types - | None, name, _ when isLabelled name -> - ( false, - getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | _ -> types - [@@raises Invalid_argument] + 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] - let argWithDefaultValue (name, default, _, _, _, _) = - match default with - | Some default when isOptional name -> Some (getLabel name, default) - | _ -> None - [@@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 - let argToConcreteType types (name, _loc, type_) = - match name with - | name when isLabelled name -> (false, getLabel name, [], type_) :: types - | name when isOptional name -> (true, getLabel name, [], type_) :: types - | _ -> types - 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] - let nestedModules = ref [] in - let transformComponentDefinition mapper structure returnStructures = - match structure with - (* external *) - | { - pstr_loc; - pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); - } as pstr -> ( - match List.filter hasAttr pval_attributes with - | [] -> structure :: returnStructures - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let 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 = +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 -> + ( true, + getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); + } ) + :: types + | Some type_, name, Some _default -> + ( false, + getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | Some type_, name, _ -> (false, getLabel name, [], type_) :: types + | None, name, _ when isOptional name -> + ( true, + getLabel name, + [], + { + ptyp_desc = Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive + ( {loc; txt = optionIdent}, + [ { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; }; + ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | None, name, _ when isLabelled name -> + ( false, + getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | _ -> types + [@@raises Invalid_argument] + +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 -> (false, getLabel name, [], type_) :: types + | name when isOptional name -> (true, getLabel name, [], type_) :: types + | _ -> types + +let transformComponentDefinition nestedModules mapper structure returnStructures + = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = + Pstr_primitive ({pval_attributes; pval_type} as value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let 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 :: returnStructures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one time") + ) + (* let component = ... *) + | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; + pvb_loc = emptyLoc; } in - propsRecordType :: newStructure :: returnStructures - | _ -> - raise - (Invalid_argument - "Only one react.component call can exist on a component at one \ - time")) - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = + 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 = { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; + exp with + pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes; } 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, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - hasForwardRef, - 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, false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if !hasApplication then - ((fun a -> a), false, 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, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - 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 _, hasUnit, _, exp = - spelunkForFunExpression internalExpression - in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - hasForwardRef, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - hasForwardRef, + (* 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, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + hasForwardRef, + unerasableIgnoreExp { expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); + pexp_desc = Pexp_fun (label, default, pattern, exp); } ) - | e -> ((fun a -> a), false, false, e) - in - let wrapExpression, hasUnit, hasForwardRef, expression = - spelunkForFunExpression expression - in - ( wrapExpressionWithBinding wrapExpression, - hasUnit, - hasForwardRef, - expression ) - in - let bindingWrapper, _hasUnit, hasForwardRef, expression = - modifiedBinding binding - in - (* do stuff here! *) - let namedArgList, _newtypes, _forwardRef = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] - in - let namedTypeList = List.fold_left argToType [] namedArgList in - (* let _ = ref *) - let vbIgnoreUnusedRef = - Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) - in - (* let ref = ref->Js.Nullable.fromOption *) - let vbRefFromOption = - Vb.mk - (Pat.var @@ Location.mknoloc "ref") - (Exp.apply - (Exp.ident - (Location.mknoloc - (Ldot (Ldot (Lident "Js", "Nullable"), "fromOption")))) - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]) - 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) :: namedTypeList) - @ - if hasForwardRef then [(true, "ref", [], refType pstr_loc)] - else []) - in - let innerExpression = - if hasForwardRef then - Exp.apply - (Exp.ident @@ Location.mknoloc @@ Lident "make") - [ - ( Nolabel, - Exp.record - [ - ( Location.mknoloc @@ Lident "ref", - Exp.apply ~attrs:optionalAttr - (Exp.ident - (Location.mknoloc - (Ldot - (Ldot (Lident "Js", "Nullable"), "toOption")))) - [ - ( Nolabel, - Exp.ident (Location.mknoloc @@ Lident "ref") ); - ] ); - ] - (Some (Exp.ident (Location.mknoloc @@ Lident "props"))) ); - ] - else - Exp.apply - (Exp.ident (Location.mknoloc @@ Lident "make")) - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - 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 - 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}) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { + ppat_desc = + Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; + }, + _internalExpression ); + } -> + ((fun a -> a), true, false, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if !hasApplication then + ((fun a -> a), false, 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, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + 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 _, hasUnit, _, exp = + spelunkForFunExpression internalExpression + in + let hasForwardRef = isForwardRef wrapperExpression in + ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), + hasUnit, + hasForwardRef, + exp ) + | { + pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + hasForwardRef, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, false, e) in - let rec returnedExpression patterns ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_fun - ( _arg_label, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - expr ) -> - (patterns, expr) - | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) - :: patterns) - expr - else returnedExpression patterns expr - | _ -> (patterns, expr) + let wrapExpression, hasUnit, hasForwardRef, expression = + spelunkForFunExpression expression in - let patternsWithLid, expression = returnedExpression [] expression in - let patternsWithLid = - List.rev patternsWithLid + ( wrapExpressionWithBinding wrapExpression, + hasUnit, + hasForwardRef, + expression ) + in + let bindingWrapper, _hasUnit, hasForwardRef, expression = + modifiedBinding binding + in + (* do stuff here! *) + let namedArgList, _newtypes, _forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedTypeList = List.fold_left argToType [] namedArgList in + (* let _ = ref *) + let vbIgnoreUnusedRef = + Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) + in + (* let ref = ref->Js.Nullable.fromOption *) + let vbRefFromOption = + Vb.mk + (Pat.var @@ Location.mknoloc "ref") + (Exp.apply + (Exp.ident + (Location.mknoloc + (Ldot (Ldot (Lident "Js", "Nullable"), "fromOption")))) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]) + 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) :: namedTypeList) @ - if hasForwardRef then + if hasForwardRef then [(true, "ref", [], refType pstr_loc)] else [] + ) + in + let innerExpression = + if hasForwardRef then + Exp.apply + (Exp.ident @@ Location.mknoloc @@ Lident "make") [ - ( Location.mknoloc (Lident "ref"), - Pat.var (Location.mknoloc "ref") ); + ( Nolabel, + Exp.record + [ + ( Location.mknoloc @@ Lident "ref", + Exp.apply ~attrs:optionalAttr + (Exp.ident + (Location.mknoloc + (Ldot + (Ldot (Lident "Js", "Nullable"), "toOption")))) + [ + ( Nolabel, + Exp.ident (Location.mknoloc @@ Lident "ref") ); + ] ); + ] + (Some (Exp.ident (Location.mknoloc @@ Lident "props"))) ); ] - else [] - in - let pattern = - match patternsWithLid with - | [] -> Pat.any () - | _ -> Pat.record patternsWithLid Closed - in - (* add patttern matching for optional prop value *) - let expression = - if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression - in - (* add let _ = ref to ignore unused warning *) - let expression = - match hasForwardRef with - | true -> - let expression = - Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression - in - Exp.let_ Nonrecursive [vbRefFromOption] expression - | false -> expression - in - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ pattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (makePropsTypeParams 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_attributes = []}], - 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 (type_, binding, newBinding) - (types, bindings, newBindings) = - let types = - match type_ with - | Some type_ -> type_ :: types - | None -> types + else + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident "make")) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + 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 - (types, binding @ bindings, newBindings) - in - let types, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - 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 [] - [@@raises Invalid_argument] - in - - let transformComponentSignature _mapper signature returnSignatures = - match signature with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter hasAttr pval_attributes with - | [] -> signature :: returnSignatures - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) + 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 innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (makePropsTypeParamsSig namedTypeList) + let rec returnedExpression patterns ({pexp_desc} as expr) = + match pexp_desc with + | Pexp_fun + ( _arg_label, + _default, + {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + expr ) -> + (patterns, expr) + | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, + Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) + :: patterns) + expr + else returnedExpression patterns expr + | _ -> (patterns, expr) in - let propsRecordType = - makePropsRecordTypeSig "props" Location.none - ((true, "key", [], keyType Location.none) :: namedTypeList) + let patternsWithLid, expression = returnedExpression [] expression in + let patternsWithLid = + List.rev patternsWithLid + @ + if hasForwardRef then + [ + (Location.mknoloc (Lident "ref"), Pat.var (Location.mknoloc "ref")); + ] + else [] 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] ) + let pattern = + match patternsWithLid with + | [] -> Pat.any () + | _ -> Pat.record patternsWithLid Closed 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; - }; - } + (* add patttern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression in - propsRecordType :: newStructure :: returnSignatures - | _ -> - raise - (Invalid_argument - "Only one react.component call can exist on a component at one \ - time")) - | signature -> signature :: returnSignatures - [@@raises Invalid_argument] - in + (* add let _ = ref to ignore unused warning *) + let expression = + match hasForwardRef with + | true -> + let expression = + Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression + in + Exp.let_ Nonrecursive [vbRefFromOption] expression + | false -> expression + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ pattern + (Typ.constr ~loc:emptyLoc + {txt = Lident "props"; loc = emptyLoc} + (makePropsTypeParams 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_attributes = []}], + 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 (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 + (types, binding @ bindings, newBindings) + in + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + 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] - let reactComponentSignatureTransform mapper signatures = - List.fold_right (transformComponentSignature mapper) signatures [] - [@@raises Invalid_argument] - in +let reactComponentTransform nestedModules mapper structures = + List.fold_right + (transformComponentDefinition nestedModules mapper) + structures [] + [@@raises Invalid_argument] - let transformJsxCall mapper callExpression callArguments attrs = - match callExpression.pexp_desc with - | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"} -> - raise - (Invalid_argument - "JSX: `createElement` should be preceeded by a module name.") - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match !jsxVersion with - | None | Some 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> ( - match !jsxVersion with - | None | Some 3 -> - transformLowercaseCall3 mapper loc attrs callExpression callArguments - id - | Some _ -> 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!")) +let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { + psig_loc; + psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); + } as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (makePropsTypeParamsSig namedTypeList) + in + let propsRecordType = + makePropsRecordTypeSig "props" Location.none + ((true, "key", [], keyType Location.none) :: namedTypeList) + 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 + propsRecordType :: newStructure :: returnSignatures | _ -> raise (Invalid_argument - "JSX: `createElement` should be preceeded by a simple, direct \ - module name.") - [@@raises Invalid_argument] - in + "Only one react.component call can exist on a component at one time") + ) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] - let signature mapper signature = - default_mapper.signature mapper - @@ reactComponentSignatureTransform mapper signature - [@@raises Invalid_argument] - in +let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] - let structure mapper structure = - match structure with - | structures -> - default_mapper.structure mapper - @@ reactComponentTransform mapper structures - [@@raises Invalid_argument] - in +let transformJsxCall jsxVersion mapper callExpression callArguments attrs = + match callExpression.pexp_desc with + | Pexp_ident caller -> ( + match caller with + | {txt = Lident "createElement"} -> + raise + (Invalid_argument + "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( + match !jsxVersion with + | None | Some 3 -> + transformUppercaseCall3 modulePath mapper loc attrs callExpression + callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | {loc; txt = Lident id} -> ( + match !jsxVersion with + | None | Some 3 -> + transformLowercaseCall3 mapper loc attrs callExpression callArguments id + | Some _ -> 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] + +let signature mapper signature = + default_mapper.signature mapper + @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + +let structure nestedModules mapper structure = + match structure with + | structures -> + default_mapper.structure mapper + @@ reactComponentTransform nestedModules mapper structures + [@@raises Invalid_argument] - 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 +let expr jsxVersion 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 jsxVersion 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 - 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 + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ + (* "div" *) + (nolabel, fragment); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] 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 + 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] - 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 +let module_binding nestedModules 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] + +(* TODO: some line number might still be wrong *) +let jsxMapper nestedModules = + let jsxVersion = ref None in + let structure = structure nestedModules in + let module_binding = module_binding nestedModules in + let expr = expr jsxVersion in {default_mapper with structure; expr; signature; module_binding} [@@raises Invalid_argument, Failure] let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = - let mapper = jsxMapper () in + let nestedModules = ref [] in + let mapper = jsxMapper nestedModules in mapper.structure mapper code [@@raises Invalid_argument, Failure] let rewrite_signature (code : Parsetree.signature) : Parsetree.signature = - let mapper = jsxMapper () in + let nestedModules = ref [] in + let mapper = jsxMapper nestedModules in mapper.signature mapper code [@@raises Invalid_argument, Failure] From 34f9cf8ca2f08d938f22e1dfa76302ede7d3345f Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 18 Jun 2022 11:16:38 +0900 Subject: [PATCH 31/35] remove unused jsxVersion * jsx version check is conducted in compiler config side --- cli/reactjs_jsx_ppx_v3.ml | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index d89e694b..6ddfc800 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -1111,7 +1111,7 @@ let reactComponentSignatureTransform mapper signatures = List.fold_right (transformComponentSignature mapper) signatures [] [@@raises Invalid_argument] -let transformJsxCall jsxVersion mapper callExpression callArguments attrs = +let transformJsxCall mapper callExpression callArguments attrs = match callExpression.pexp_desc with | Pexp_ident caller -> ( match caller with @@ -1120,20 +1120,14 @@ let transformJsxCall jsxVersion mapper callExpression callArguments attrs = (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 modulePath mapper loc attrs callExpression + 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 callExpression callArguments id - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + | {loc; txt = Lident id} -> + transformLowercaseCall3 mapper loc attrs callExpression callArguments id | {txt = Ldot (_, anythingNotCreateElementOrMake)} -> raise (Invalid_argument @@ -1165,7 +1159,7 @@ let structure nestedModules mapper structure = @@ reactComponentTransform nestedModules mapper structures [@@raises Invalid_argument] -let expr jsxVersion mapper expression = +let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} @@ -1179,8 +1173,7 @@ let expr jsxVersion mapper expression = (* no JSX attribute *) | [], _ -> default_mapper.expr mapper expression | _, nonJSXAttributes -> - transformJsxCall jsxVersion mapper callExpression callArguments - nonJSXAttributes) + transformJsxCall mapper callExpression callArguments nonJSXAttributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = @@ -1231,10 +1224,8 @@ let module_binding nestedModules mapper module_binding = (* TODO: some line number might still be wrong *) let jsxMapper nestedModules = - let jsxVersion = ref None in let structure = structure nestedModules in let module_binding = module_binding nestedModules in - let expr = expr jsxVersion in {default_mapper with structure; expr; signature; module_binding} [@@raises Invalid_argument, Failure] From 256eaac09f8ee784d646cc4a3a53b19069ac8df4 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sun, 19 Jun 2022 11:47:50 +0900 Subject: [PATCH 32/35] add new line --- cli/reactjs_jsx_ppx_v3.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cli/reactjs_jsx_ppx_v3.mli b/cli/reactjs_jsx_ppx_v3.mli index db2dbcad..f43e8344 100644 --- a/cli/reactjs_jsx_ppx_v3.mli +++ b/cli/reactjs_jsx_ppx_v3.mli @@ -48,4 +48,4 @@ val rewrite_implementation : Parsetree.structure -> Parsetree.structure -val rewrite_signature : Parsetree.signature -> Parsetree.signature \ No newline at end of file +val rewrite_signature : Parsetree.signature -> Parsetree.signature From 007b17b42c13f32bb030e2a354befa2e01d3c0a1 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sun, 19 Jun 2022 12:54:28 +0900 Subject: [PATCH 33/35] update jsx ppx comment --- cli/reactjs_jsx_ppx_v3.mli | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/cli/reactjs_jsx_ppx_v3.mli b/cli/reactjs_jsx_ppx_v3.mli index f43e8344..9a4e1f77 100644 --- a/cli/reactjs_jsx_ppx_v3.mli +++ b/cli/reactjs_jsx_ppx_v3.mli @@ -38,14 +38,30 @@ `ReactDOMRe.createDOMElementVariadic("div", ~props=ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. transform the upper-cased case `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into - `Foo.make({...baz, key: a, ref: b, foo: bar})` + `React.createElement(Foo.make, {...baz, key: a, ref: b, foo: bar})` transform the upper-cased case `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into - Foo.make({...baz, foo: bar, children: React.null}), [|foo, bar|])` + `React.createElement(Foo.make, {...baz, foo: bar, children: React.null}), [|foo, bar|])` transform `[@JSX] [foo]` into `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` *) +(* + New JSX transform with React v17 + + if has key + `jsxKeyed("div", { ... }, "key") or jsxsKeyed("div", { ... }, "key")` + + upper case + child X -> `jsx(Foo.make, { ... })` + child -> `jsx(Foo.make, { ... , children: ... })` + children O -> `jsxs(Foo.make, { ..., children: [ ... ]})` + + lower case + child X -> `jsx("div", { ... })` + child O -> `jsx("div", { ..., children: ... })` + children O -> `jsxs("div", { ..., children: [ ... ]})` +*) val rewrite_implementation : Parsetree.structure -> Parsetree.structure val rewrite_signature : Parsetree.signature -> Parsetree.signature From 0bacbe331c34b21ff96cd791a40761a90def8313 Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 25 Jun 2022 01:13:55 +0900 Subject: [PATCH 34/35] rename v3 -> v4, restore v3, add cli args --- cli/reactjs_jsx_ppx_v3.ml | 2025 ++++++++++++++++++------------------ cli/reactjs_jsx_ppx_v3.mli | 28 - cli/reactjs_jsx_ppx_v4.ml | 1287 +++++++++++++++++++++++ cli/reactjs_jsx_ppx_v4.mli | 68 ++ cli/res_cli.ml | 27 +- 5 files changed, 2405 insertions(+), 1030 deletions(-) create mode 100644 cli/reactjs_jsx_ppx_v4.ml create mode 100644 cli/reactjs_jsx_ppx_v4.mli diff --git a/cli/reactjs_jsx_ppx_v3.ml b/cli/reactjs_jsx_ppx_v3.ml index 6ddfc800..b0f060f6 100644 --- a/cli/reactjs_jsx_ppx_v3.ml +++ b/cli/reactjs_jsx_ppx_v3.ml @@ -12,6 +12,8 @@ let nolabel = Nolabel let labelled str = Labelled str +let optional str = Optional str + let isOptional str = match str with | Optional _ -> true @@ -22,10 +24,6 @@ let isLabelled str = | Labelled _ -> true | _ -> false -let isForwardRef = function - | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true - | _ -> false - let getLabel str = match str with | Optional str | Labelled str -> str @@ -33,20 +31,9 @@ let getLabel str = let optionIdent = Lident "option" -let optionalAttr = [({txt = "optional"; loc = Location.none}, PStr [])] - let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) -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 @@ -54,15 +41,14 @@ let safeTypeFromValue valueStr = | _ -> valueStr [@@raises Invalid_argument] -let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} [] - -let refType loc = - Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} - [] +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 = @@ -171,6 +157,49 @@ let makeNewBinding binding expression newName = 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 = @@ -205,1038 +234,1044 @@ let makeModuleName fileName nestedModules fnName = constructor and a props external *) -(* make record from props and spread props if exists *) -let recordFromProps {pexp_loc} 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 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; pexp_attributes = []} - | [spreadProps] -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc; - pexp_attributes = []; - } - | spreadProps :: _ -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc; - pexp_attributes = []; - } +(* 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 type params for type props<'id, 'name, ...> *) -let makePropsTypeParamsTvar namedTypeList = - namedTypeList - |> List.filter_map (fun (_, label, _, _) -> - if label = "key" || label = "ref" then None - else Some (Typ.var label, Invariant)) +(* 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 makePropsTypeParams namedTypeList = - namedTypeList - |> List.filter_map (fun (_isOptional, label, _, _interiorType) -> - if label = "key" || label = "ref" then None else Some (Typ.var 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] -(* make type params for make sig arguments *) -(* let make: React.componentLike>, React.element> *) -let makePropsTypeParamsSig namedTypeList = - namedTypeList - |> List.filter_map (fun (_isOptional, label, _, interiorType) -> - if label = "key" || label = "ref" then None else Some interiorType) +(* 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] -(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) -let makePropsRecordType propsName loc namedTypeList = - let labelDeclList = - namedTypeList - |> List.map (fun (isOptional, label, _, _interiorType) -> - if label = "key" then - Type.field ~loc ~attrs:optionalAttr {txt = label; loc} - (keyType Location.none) - else if label = "ref" then - Type.field ~loc - ~attrs:(if isOptional then optionalAttr else []) - {txt = label; loc} (refType Location.none) - else if isOptional then - Type.field ~loc ~attrs:optionalAttr {txt = label; loc} - (Typ.var label) - else Type.field ~loc {txt = label; loc} (Typ.var label)) - in - (* 'id, 'className, ... *) - let params = makePropsTypeParamsTvar namedTypeList in - Str.type_ Nonrecursive - [ - Type.mk ~loc ~params {txt = propsName; loc} - ~kind:(Ptype_record labelDeclList); - ] +(* 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 = []} -(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) -let makePropsRecordTypeSig propsName loc namedTypeList = - let labelDeclList = - namedTypeList - |> List.map (fun (isOptional, label, _, _interiorType) -> - if label = "key" then - Type.field ~loc ~attrs:optionalAttr {txt = label; loc} - (keyType Location.none) - else if isOptional then - Type.field ~loc ~attrs:optionalAttr {txt = label; loc} - (Typ.var label) - else Type.field ~loc {txt = label; loc} (Typ.var label)) - in - let params = makePropsTypeParamsTvar namedTypeList in - Sig.type_ Nonrecursive - [ - Type.mk ~loc ~params {txt = propsName; loc} - ~kind:(Ptype_record labelDeclList); - ] +let makeObjectField loc (str, attrs, type_) = + Otag ({loc; txt = str}, attrs, type_) -let transformUppercaseCall3 modulePath mapper loc attrs callExpression - 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")} ); - ] +(* 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 record = recordFromProps callExpression args in - let isCap str = - let first = String.sub str 0 1 [@@raises Invalid_argument] in - let capped = String.uppercase_ascii first in - first = capped + let mapper = {Ast_mapper.default_mapper with typ} in + mapper.typ mapper type_ + +(* TODO: some line number might still be wrong *) +let jsxMapper () = + let jsxVersion = ref None in + + 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 ident = - match modulePath with - | Lident _ -> Ldot (modulePath, "make") - | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") - | modulePath -> modulePath - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - 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 - (* 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 + + 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 "React", "createElementVariadic")}) - [ - (nolabel, Exp.ident ~loc {txt = ident; loc}); - (nolabel, props); - (nolabel, children); - ] - [@@raises Invalid_argument] + {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + [@@raises Invalid_argument] + in -let transformLowercaseCall3 mapper loc attrs _callExpression callArguments id = - let children, nonChildrenProps = extractChildren ~loc callArguments in - (* keep the v3 *) - (* let record = recordFromProps callExpression nonChildrenProps 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)
*) - | _ -> + 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 - "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))) + "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 - [ - (* "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] -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 - 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, - _, + 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, + [], { - 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] + 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 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 -> - ( true, - getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types - | Some type_, name, Some _default -> - ( false, - getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | Some type_, name, _ -> (false, getLabel name, [], type_) :: types - | None, name, _ when isOptional name -> - ( true, - getLabel name, - [], - { - ptyp_desc = + let nestedModules = ref [] in + let transformComponentDefinition mapper structure returnStructures = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = + Pstr_primitive + ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = + (label, None (* default *), loc, Some type_) + in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) + :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr - ( {loc; txt = optionIdent}, - [ + ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, + [retPropsType; innerType] ) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; + value_description with + pval_type = {pval_type with ptyp_desc = newExternalType}; + pval_attributes = List.filter otherAttrsPure pval_attributes; }; - ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | None, name, _ when isLabelled name -> - ( false, - getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | _ -> types - [@@raises Invalid_argument] - -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 -> (false, getLabel name, [], type_) :: types - | name when isOptional name -> (true, getLabel name, [], type_) :: types - | _ -> types - -let transformComponentDefinition nestedModules mapper structure returnStructures - = - match structure with - (* external *) - | { - pstr_loc; - pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); - } as pstr -> ( - match List.filter hasAttr pval_attributes with - | [] -> structure :: returnStructures - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let 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 :: returnStructures - | _ -> - raise - (Invalid_argument - "Only one react.component call can exist on a component at one time") - ) - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if hasAttrOnBinding binding then - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; } in - let fnName = getFnName binding.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 = + externalPropsDecl :: newStructure :: returnStructures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one \ + time")) + (* let component = ... *) + | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = { - 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, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - hasForwardRef, - unerasableIgnoreExp + 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_fun (label, default, pattern, exp); + pexp_desc = Pexp_sequence (wrapperExpression, exp); } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), true, false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if !hasApplication then - ((fun a -> a), false, 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, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - 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 _, hasUnit, _, exp = - spelunkForFunExpression internalExpression - in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - hasForwardRef, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - hasForwardRef, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, false, e) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression + in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) in - let wrapExpression, hasUnit, hasForwardRef, expression = - spelunkForFunExpression expression + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try Some (List.find hasAttr binding.pvb_attributes) + with Not_found -> None in - ( wrapExpressionWithBinding wrapExpression, - hasUnit, - hasForwardRef, - expression ) - in - let bindingWrapper, _hasUnit, hasForwardRef, expression = - modifiedBinding binding - in - (* do stuff here! *) - let namedArgList, _newtypes, _forwardRef = - recursivelyTransformNamedArgsForMake mapper - (modifiedBindingOld binding) - [] [] - in - let namedTypeList = List.fold_left argToType [] namedArgList in - (* let _ = ref *) - let vbIgnoreUnusedRef = - Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) - in - (* let ref = ref->Js.Nullable.fromOption *) - let vbRefFromOption = - Vb.mk - (Pat.var @@ Location.mknoloc "ref") - (Exp.apply - (Exp.ident - (Location.mknoloc - (Ldot (Ldot (Lident "Js", "Nullable"), "fromOption")))) - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]) - 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) :: namedTypeList) + 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 hasForwardRef then [(true, "ref", [], refType pstr_loc)] else [] - ) - in - let innerExpression = - if hasForwardRef then - Exp.apply - (Exp.ident @@ Location.mknoloc @@ Lident "make") - [ - ( Nolabel, - Exp.record - [ - ( Location.mknoloc @@ Lident "ref", - Exp.apply ~attrs:optionalAttr - (Exp.ident - (Location.mknoloc - (Ldot - (Ldot (Lident "Js", "Nullable"), "toOption")))) - [ - ( Nolabel, - Exp.ident (Location.mknoloc @@ Lident "ref") ); - ] ); - ] - (Some (Exp.ident (Location.mknoloc @@ Lident "props"))) ); - ] - else + if hasUnit then + [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] + else [] + in + let innerExpression = Exp.apply - (Exp.ident (Location.mknoloc @@ Lident "make")) - [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - 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 - 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 rec returnedExpression patterns ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_fun - ( _arg_label, - _default, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, - expr ) -> - (patterns, expr) - | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) - :: patterns) - expr - else returnedExpression patterns expr - | _ -> (patterns, expr) + (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) + 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 patternsWithLid, expression = returnedExpression [] expression in - let patternsWithLid = - List.rev patternsWithLid - @ - if hasForwardRef then - [ - (Location.mknoloc (Lident "ref"), Pat.var (Location.mknoloc "ref")); - ] - else [] + let newBindings = + match newBinding with + | Some newBinding -> newBinding :: newBindings + | None -> newBindings in - let pattern = - match patternsWithLid with - | [] -> Pat.any () - | _ -> Pat.record patternsWithLid Closed + (externs, binding @ bindings, newBindings) + in + let externs, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + externs + @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] + @ (match newBindings with + | [] -> [] + | newBindings -> + [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) + @ returnStructures + | structure -> structure :: returnStructures + [@@raises Invalid_argument] + in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] + [@@raises Invalid_argument] + in + + let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { + psig_loc; + psig_desc = + Psig_value + ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + psig_desc); + } as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) in - (* add patttern matching for optional prop value *) - let expression = - if List.length vbMatchList = 0 then expression - else Exp.let_ Nonrecursive vbMatchList expression + 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 - (* add let _ = ref to ignore unused warning *) - let expression = - match hasForwardRef with - | true -> - let expression = - Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression - in - Exp.let_ Nonrecursive [vbRefFromOption] expression - | false -> expression + 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 - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ pattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (makePropsTypeParams namedTypeList))) - expression + (* 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 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_attributes = []}], - Some (bindingWrapper fullExpression) ) + 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 - (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 (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 - (types, binding @ bindings, newBindings) - in - let types, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - 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] + externalPropsDecl :: newStructure :: returnSignatures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one \ + time")) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] + in -let reactComponentTransform nestedModules mapper structures = - List.fold_right - (transformComponentDefinition nestedModules mapper) - structures [] - [@@raises Invalid_argument] + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] + in -let transformComponentSignature _mapper signature returnSignatures = - match signature with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter hasAttr pval_attributes with - | [] -> signature :: returnSignatures - | [_] -> - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (makePropsTypeParamsSig namedTypeList) - in - let propsRecordType = - makePropsRecordTypeSig "props" Location.none - ((true, "key", [], keyType Location.none) :: namedTypeList) - 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 - propsRecordType :: newStructure :: returnSignatures + let transformJsxCall mapper callExpression callArguments attrs = + match callExpression.pexp_desc with + | Pexp_ident caller -> ( + match caller with + | {txt = Lident "createElement"} -> + raise + (Invalid_argument + "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( + match !jsxVersion with + | None | Some 3 -> + transformUppercaseCall3 modulePath mapper loc attrs callExpression + callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | {loc; txt = Lident id} -> ( + match !jsxVersion with + | None | Some 3 -> + transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3")) + | {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 - "Only one react.component call can exist on a component at one time") - ) - | signature -> signature :: returnSignatures - [@@raises Invalid_argument] - -let reactComponentSignatureTransform mapper signatures = - List.fold_right (transformComponentSignature mapper) signatures [] - [@@raises Invalid_argument] - -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"))} -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - 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} -> - transformLowercaseCall3 mapper loc attrs callExpression callArguments id - | {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] + "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] + let signature mapper signature = + default_mapper.signature mapper + @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + in -let structure nestedModules mapper structure = - match structure with - | structures -> - default_mapper.structure mapper - @@ reactComponentTransform nestedModules mapper structures - [@@raises Invalid_argument] + let structure mapper structure = + match structure with + | structures -> + default_mapper.structure mapper + @@ reactComponentTransform mapper structures + [@@raises Invalid_argument] + in -let expr mapper expression = - match expression with - (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (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")} + 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 - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] + 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 - 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] - -let module_binding nestedModules 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] + 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 -(* TODO: some line number might still be wrong *) -let jsxMapper nestedModules = - let structure = structure nestedModules in - let module_binding = module_binding nestedModules 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 {default_mapper with structure; expr; signature; module_binding} [@@raises Invalid_argument, Failure] let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = - let nestedModules = ref [] in - let mapper = jsxMapper nestedModules in + let mapper = jsxMapper () in mapper.structure mapper code [@@raises Invalid_argument, Failure] let rewrite_signature (code : Parsetree.signature) : Parsetree.signature = - let nestedModules = ref [] in - let mapper = jsxMapper nestedModules in + let mapper = jsxMapper () in mapper.signature mapper code [@@raises Invalid_argument, Failure] diff --git a/cli/reactjs_jsx_ppx_v3.mli b/cli/reactjs_jsx_ppx_v3.mli index 9a4e1f77..da60a051 100644 --- a/cli/reactjs_jsx_ppx_v3.mli +++ b/cli/reactjs_jsx_ppx_v3.mli @@ -32,36 +32,8 @@ `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])` transform `[@JSX] [foo]` into `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` - - v4: - transform `[@JSX] div(~props1=a, ~props2=b, ~spreadProps=props3 ~children=[foo, bar], ())` into - `ReactDOMRe.createDOMElementVariadic("div", ~props=ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. - transform the upper-cased case - `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into - `React.createElement(Foo.make, {...baz, key: a, ref: b, foo: bar})` - transform the upper-cased case - `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into - `React.createElement(Foo.make, {...baz, foo: bar, children: React.null}), [|foo, bar|])` - transform `[@JSX] [foo]` into - `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` *) -(* - New JSX transform with React v17 - - if has key - `jsxKeyed("div", { ... }, "key") or jsxsKeyed("div", { ... }, "key")` - - upper case - child X -> `jsx(Foo.make, { ... })` - child -> `jsx(Foo.make, { ... , children: ... })` - children O -> `jsxs(Foo.make, { ..., children: [ ... ]})` - - lower case - child X -> `jsx("div", { ... })` - child O -> `jsx("div", { ..., children: ... })` - children O -> `jsxs("div", { ..., children: [ ... ]})` -*) val rewrite_implementation : Parsetree.structure -> Parsetree.structure val rewrite_signature : Parsetree.signature -> Parsetree.signature diff --git a/cli/reactjs_jsx_ppx_v4.ml b/cli/reactjs_jsx_ppx_v4.ml new file mode 100644 index 00000000..9a14615c --- /dev/null +++ b/cli/reactjs_jsx_ppx_v4.ml @@ -0,0 +1,1287 @@ +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l + +let nolabel = Nolabel + +let labelled str = Labelled str + +let isOptional str = + match str with + | Optional _ -> true + | _ -> false + +let isLabelled str = + match str with + | Labelled _ -> true + | _ -> false + +let isForwardRef = function + | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | _ -> false + +let getLabel str = + match str with + | Optional str | Labelled str -> str + | Nolabel -> "" + +let optionIdent = Lident "option" + +let optionalAttr = [({txt = "optional"; loc = Location.none}, PStr [])] + +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] + +let keyType loc = Typ.constr ~loc {loc; txt = Lident "string"} [] + +let refType loc = + Typ.constr ~loc + {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} + [] + +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 [] + +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 look up the [@react.component] attribute *) +let hasAttr (loc, _) = loc.txt = "react.component" + +(* Helper method to filter out any attribute that isn't [@react.component] *) +let otherAttrsPure (loc, _) = loc.txt <> "react.component" + +(* Iterate over the attributes and try to find the [@react.component] attribute *) +let hasAttrOnBinding {pvb_attributes} = find_opt hasAttr pvb_attributes <> None + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let 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 + +(* + 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 +*) + +(* make record from props and spread props if exists *) +let recordFromProps ?(removeKey = false) {pexp_loc} 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; pexp_attributes = []} + | [spreadProps] -> + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc; + pexp_attributes = []; + } + | spreadProps :: _ -> + { + pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_loc; + pexp_attributes = []; + } + +(* make type params for type props<'id, 'name, ...> *) +let makePropsTypeParamsTvar namedTypeList = + namedTypeList + |> List.filter_map (fun (_, label, _, _) -> + if label = "key" || label = "ref" then None + else Some (Typ.var label, Invariant)) + +(* make type params for make fn arguments *) +(* let make = ({id, name, children}: props<'id, 'name, 'children>) *) +let makePropsTypeParams namedTypeList = + namedTypeList + |> List.filter_map (fun (_isOptional, label, _, _interiorType) -> + if label = "key" || label = "ref" then None else Some (Typ.var label)) + +(* make type params for make sig arguments *) +(* let make: React.componentLike>, React.element> *) +let makePropsTypeParamsSig namedTypeList = + namedTypeList + |> List.filter_map (fun (_isOptional, label, _, interiorType) -> + if label = "key" || label = "ref" then None else Some interiorType) + +(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) +let makePropsRecordType propsName loc namedTypeList = + let labelDeclList = + namedTypeList + |> List.map (fun (isOptional, label, _, _interiorType) -> + if label = "key" then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (keyType Location.none) + else if label = "ref" then + Type.field ~loc + ~attrs:(if isOptional then optionalAttr else []) + {txt = label; loc} (refType Location.none) + else if isOptional then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (Typ.var label) + else Type.field ~loc {txt = label; loc} (Typ.var label)) + in + (* 'id, 'className, ... *) + let params = makePropsTypeParamsTvar namedTypeList in + Str.type_ Nonrecursive + [ + Type.mk ~loc ~params {txt = propsName; loc} + ~kind:(Ptype_record labelDeclList); + ] + +(* type props<'id, 'name, ...> = { @optional key: string, @optional id: 'id, ... } *) +let makePropsRecordTypeSig propsName loc namedTypeList = + let labelDeclList = + namedTypeList + |> List.map (fun (isOptional, label, _, _interiorType) -> + if label = "key" then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (keyType Location.none) + else if isOptional then + Type.field ~loc ~attrs:optionalAttr {txt = label; loc} + (Typ.var label) + else Type.field ~loc {txt = label; loc} (Typ.var label)) + in + let params = makePropsTypeParamsTvar namedTypeList in + Sig.type_ Nonrecursive + [ + Type.mk ~loc ~params {txt = propsName; loc} + ~kind:(Ptype_record labelDeclList); + ] + +let transformUppercaseCall3 jsxRuntime modulePath mapper loc attrs + callExpression 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; + match jsxRuntime with + | "automatic" -> [(labelled "children", expression)] + | _ -> + [ + ( labelled "children", + Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); + ]) + 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 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 jsxRuntime with + (* The new jsx transform *) + | "automatic" -> + let record = recordFromProps ~removeKey:true callExpression 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 "React", "jsxKeyed")}, + [(nolabel, keyExpr)] ) + | None, [] -> + (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")}, []) + | Some _, (_, keyExpr) :: _ -> + ( Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxsKeyed")}, + [(nolabel, keyExpr)] ) + | Some _, [] -> + (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")}, []) + in + Exp.apply ~loc ~attrs jsxExpr + ([(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] @ key) + | _ -> ( + let record = recordFromProps callExpression 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 ~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] + +let transformLowercaseCall3 _jsxRuntime mapper loc attrs _callExpression + callArguments id = + let children, nonChildrenProps = extractChildren ~loc callArguments in + (* keep the v3 *) + (* let record = recordFromProps callExpression nonChildrenProps 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.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] + +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] + +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 -> + ( true, + getLabel name, + [], + { + type_ with + ptyp_desc = + Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); + } ) + :: types + | Some type_, name, Some _default -> + ( false, + getLabel name, + [], + { + ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | Some type_, name, _ -> (false, getLabel name, [], type_) :: types + | None, name, _ when isOptional 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 = []; + } ) + :: types + | None, name, _ when isLabelled name -> + ( false, + getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | _ -> types + [@@raises Invalid_argument] + +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 -> (false, getLabel name, [], type_) :: types + | name when isOptional name -> (true, getLabel name, [], type_) :: types + | _ -> types + +let transformComponentDefinition nestedModules mapper structure returnStructures + = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = + Pstr_primitive ({pval_attributes; pval_type} as value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isLabelled name || isOptional name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let 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 :: returnStructures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one time") + ) + (* let component = ... *) + | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; + pvb_loc = emptyLoc; + } + in + let fnName = getFnName binding.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, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + hasForwardRef, + 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, false, expression) + (* let make = (~prop) => ... *) + | { + pexp_desc = + Pexp_fun + ( (Labelled _ | Optional _), + _default, + _pattern, + _internalExpression ); + } -> + ((fun a -> a), false, false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { + pexp_desc = + Pexp_fun (_nolabel, _default, pattern, _internalExpression); + } -> + if !hasApplication then + ((fun a -> a), false, 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, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + 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 _, hasUnit, _, exp = + spelunkForFunExpression internalExpression + in + let hasForwardRef = isForwardRef wrapperExpression in + ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), + hasUnit, + hasForwardRef, + exp ) + | { + pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); + } -> + let wrap, hasUnit, hasForwardRef, exp = + spelunkForFunExpression internalExpression + in + ( wrap, + hasUnit, + hasForwardRef, + { + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, false, e) + in + let wrapExpression, hasUnit, hasForwardRef, expression = + spelunkForFunExpression expression + in + ( wrapExpressionWithBinding wrapExpression, + hasUnit, + hasForwardRef, + expression ) + in + let bindingWrapper, _hasUnit, hasForwardRef, expression = + modifiedBinding binding + in + (* do stuff here! *) + let namedArgList, _newtypes, _forwardRef = + recursivelyTransformNamedArgsForMake mapper + (modifiedBindingOld binding) + [] [] + in + let namedTypeList = List.fold_left argToType [] namedArgList in + (* let _ = ref *) + let vbIgnoreUnusedRef = + Vb.mk (Pat.any ()) (Exp.ident (Location.mknoloc (Lident "ref"))) + in + (* let ref = ref->Js.Nullable.fromOption *) + let vbRefFromOption = + Vb.mk + (Pat.var @@ Location.mknoloc "ref") + (Exp.apply + (Exp.ident + (Location.mknoloc + (Ldot (Ldot (Lident "Js", "Nullable"), "fromOption")))) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))]) + 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) :: namedTypeList) + @ + if hasForwardRef then [(true, "ref", [], refType pstr_loc)] else [] + ) + in + let innerExpression = + if hasForwardRef then + Exp.apply + (Exp.ident @@ Location.mknoloc @@ Lident "make") + [ + ( Nolabel, + Exp.record + [ + ( Location.mknoloc @@ Lident "ref", + Exp.apply ~attrs:optionalAttr + (Exp.ident + (Location.mknoloc + (Ldot + (Ldot (Lident "Js", "Nullable"), "toOption")))) + [ + ( Nolabel, + Exp.ident (Location.mknoloc @@ Lident "ref") ); + ] ); + ] + (Some (Exp.ident (Location.mknoloc @@ Lident "props"))) ); + ] + else + Exp.apply + (Exp.ident (Location.mknoloc @@ Lident "make")) + [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] + 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 + 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 rec returnedExpression patterns ({pexp_desc} as expr) = + match pexp_desc with + | Pexp_fun + ( _arg_label, + _default, + {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, + expr ) -> + (patterns, expr) + | Pexp_fun (arg_label, _default, {ppat_loc}, expr) -> + if isLabelled arg_label || isOptional arg_label then + returnedExpression + (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, + Pat.var {txt = getLabel arg_label; loc = ppat_loc} ) + :: patterns) + expr + else returnedExpression patterns expr + | _ -> (patterns, expr) + in + let patternsWithLid, expression = returnedExpression [] expression in + let patternsWithLid = + List.rev patternsWithLid + @ + if hasForwardRef then + [ + (Location.mknoloc (Lident "ref"), Pat.var (Location.mknoloc "ref")); + ] + else [] + in + let pattern = + match patternsWithLid with + | [] -> Pat.any () + | _ -> Pat.record patternsWithLid Closed + in + (* add patttern matching for optional prop value *) + let expression = + if List.length vbMatchList = 0 then expression + else Exp.let_ Nonrecursive vbMatchList expression + in + (* add let _ = ref to ignore unused warning *) + let expression = + match hasForwardRef with + | true -> + let expression = + Exp.let_ Nonrecursive [vbIgnoreUnusedRef] expression + in + Exp.let_ Nonrecursive [vbRefFromOption] expression + | false -> expression + in + let expression = + Exp.fun_ Nolabel None + (Pat.constraint_ pattern + (Typ.constr ~loc:emptyLoc + {txt = Lident "props"; loc = emptyLoc} + (makePropsTypeParams 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_attributes = []}], + 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 (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 + (types, binding @ bindings, newBindings) + in + let types, bindings, newBindings = + List.fold_right otherStructures structuresAndBinding ([], [], []) + in + 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] + +let reactComponentTransform nestedModules mapper structures = + List.fold_right + (transformComponentDefinition nestedModules mapper) + structures [] + [@@raises Invalid_argument] + +let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { + psig_loc; + psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); + } as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) + when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) + when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let retPropsType = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (makePropsTypeParamsSig namedTypeList) + in + let propsRecordType = + makePropsRecordTypeSig "props" Location.none + ((true, "key", [], keyType Location.none) :: namedTypeList) + 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 + propsRecordType :: newStructure :: returnSignatures + | _ -> + raise + (Invalid_argument + "Only one react.component call can exist on a component at one time") + ) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] + +let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] + +let transformJsxCall jsxRuntime 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"))} -> + transformUppercaseCall3 jsxRuntime modulePath mapper loc attrs + callExpression 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} -> + transformLowercaseCall3 jsxRuntime mapper loc attrs callExpression + callArguments id + | {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] + +let signature mapper signature = + default_mapper.signature mapper + @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + +let structure nestedModules mapper structure = + match structure with + | structures -> + default_mapper.structure mapper + @@ reactComponentTransform nestedModules mapper structures + [@@raises Invalid_argument] + +let expr jsxRuntime 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 jsxRuntime 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] + +let module_binding nestedModules 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] + +(* TODO: some line number might still be wrong *) +let jsxMapper jsxRuntime nestedModules = + let structure = structure nestedModules in + let module_binding = module_binding nestedModules in + let expr = expr jsxRuntime in + {default_mapper with structure; expr; signature; module_binding} + [@@raises Invalid_argument, Failure] + +let rewrite_implementation jsxRuntime (code : Parsetree.structure) : + Parsetree.structure = + let nestedModules = ref [] in + let mapper = jsxMapper jsxRuntime nestedModules in + mapper.structure mapper code + [@@raises Invalid_argument, Failure] + +let rewrite_signature jsxRuntime (code : Parsetree.signature) : + Parsetree.signature = + let nestedModules = ref [] in + let mapper = jsxMapper jsxRuntime nestedModules in + mapper.signature mapper code + [@@raises Invalid_argument, Failure] diff --git a/cli/reactjs_jsx_ppx_v4.mli b/cli/reactjs_jsx_ppx_v4.mli new file mode 100644 index 00000000..0c4d1c7e --- /dev/null +++ b/cli/reactjs_jsx_ppx_v4.mli @@ -0,0 +1,68 @@ +(* + This is the module that handles turning Reason JSX' agnostic function call into + a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx + facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- + points-in-ocaml/ + You wouldn't use this file directly; it's used by ReScript's + bsconfig.json. Specifically, there's a field called `react-jsx` inside the + field `reason`, which enables this ppx through some internal call in bsb +*) + +(* + There are two different transforms that can be selected in this file (v2 and v3): + v2: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo, + bar|])`. + transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into + `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` + v3: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))` + transform the upper-cased case + `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into + `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` + + v4: + transform `[@JSX] div(~props1=a, ~props2=b, ~spreadProps=props3 ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ~props=ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into + `React.createElement(Foo.make, {...baz, key: a, ref: b, foo: bar})` + transform the upper-cased case + `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into + `React.createElement(Foo.make, {...baz, foo: bar, children: React.null}), [|foo, bar|])` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` +*) + +(* + New JSX transform with React v17 + + if has key + `jsxKeyed("div", { ... }, "key") or jsxsKeyed("div", { ... }, "key")` + + upper case + child X -> `jsx(Foo.make, { ... })` + child -> `jsx(Foo.make, { ... , children: ... })` + children O -> `jsxs(Foo.make, { ..., children: [ ... ]})` + + lower case + child X -> `jsx("div", { ... })` + child O -> `jsx("div", { ..., children: ... })` + children O -> `jsxs("div", { ..., children: [ ... ]})` +*) +val rewrite_implementation : + string -> Parsetree.structure -> Parsetree.structure + +val rewrite_signature : string -> Parsetree.signature -> Parsetree.signature diff --git a/cli/res_cli.ml b/cli/res_cli.ml index a11bf162..66b0270d 100644 --- a/cli/res_cli.ml +++ b/cli/res_cli.ml @@ -163,6 +163,7 @@ module ResClflags : sig val file : string ref val interface : bool ref val ppx : string ref + val jsxRuntime : string ref val typechecker : bool ref val parse : unit -> unit @@ -174,6 +175,7 @@ end = struct let origin = ref "" let interface = ref false let ppx = ref "" + let jsxRuntime = ref "automatic" let file = ref "" let typechecker = ref false @@ -203,8 +205,12 @@ end = struct "Parse as interface" ); ( "-ppx", Arg.String (fun txt -> ppx := txt), - "Apply a specific built-in ppx before parsing, none or jsx. Default: \ - none" ); + "Apply a specific built-in ppx before parsing, none or jsx3, jsx4. \ + Default: none" ); + ( "-jsx-runtime", + Arg.String (fun txt -> jsxRuntime := txt), + "Specify the jsx runtime for React, classic or automatic. Default: \ + automatic" ); ( "-typechecker", Arg.Unit (fun () -> typechecker := true), "Parses the ast as it would be passed to the typechecker and not the \ @@ -218,8 +224,8 @@ module CliArgProcessor = struct type backend = Parser : 'diagnostics Res_driver.parsingEngine -> backend [@@unboxed] - let processFile ~isInterface ~width ~recover ~origin ~target ~ppx ~typechecker - filename = + let processFile ~isInterface ~width ~recover ~origin ~target ~ppx ~jsxRuntime + ~typechecker filename = let len = String.length filename in let processInterface = isInterface @@ -277,7 +283,10 @@ module CliArgProcessor = struct else let parsetree = match ppx with - | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree + | "jsx3" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree + | "jsx4" -> + Reactjs_jsx_ppx_v4.rewrite_signature jsxRuntime + parseResult.parsetree | _ -> parseResult.parsetree in printEngine.printInterface ~width ~filename @@ -294,8 +303,11 @@ module CliArgProcessor = struct else let parsetree = match ppx with - | "jsx" -> + | "jsx3" -> Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree + | "jsx4" -> + Reactjs_jsx_ppx_v4.rewrite_implementation jsxRuntime + parseResult.parsetree | _ -> parseResult.parsetree in printEngine.printImplementation ~width ~filename @@ -309,4 +321,5 @@ let[@raises exit] () = CliArgProcessor.processFile ~isInterface:!ResClflags.interface ~width:!ResClflags.width ~recover:!ResClflags.recover ~target:!ResClflags.print ~origin:!ResClflags.origin ~ppx:!ResClflags.ppx - ~typechecker:!ResClflags.typechecker !ResClflags.file) + ~jsxRuntime:!ResClflags.jsxRuntime ~typechecker:!ResClflags.typechecker + !ResClflags.file) From 033762926ab36a82f04a2fd987fac13658b71dac Mon Sep 17 00:00:00 2001 From: Woonki Moon Date: Sat, 25 Jun 2022 01:15:24 +0900 Subject: [PATCH 35/35] add tests for v3 and v4 respectively --- scripts/test.sh | 19 ++++++- .../react/expected/commentAtTop.res_v3.txt | 10 ++++ ...p.res.txt => commentAtTop.res_v4_auto.txt} | 0 .../expected/commentAtTop.res_v4_cls.txt | 9 +++ .../externalWithCustomName.res_v3.txt | 9 +++ .../externalWithCustomName.res_v4_auto.txt | 7 +++ ... => externalWithCustomName.res_v4_cls.txt} | 0 .../ppx/react/expected/forwardRef.res_v3.txt | 56 +++++++++++++++++++ .../react/expected/forwardRef.res_v4_auto.txt | 48 ++++++++++++++++ ...dRef.res.txt => forwardRef.res_v4_cls.txt} | 0 .../ppx/react/expected/innerModule.res_v3.txt | 25 +++++++++ ...le.res.txt => innerModule.res_v4_auto.txt} | 0 .../react/expected/innerModule.res_v4_cls.txt | 21 +++++++ tests/ppx/react/expected/newtype.res_v3.txt | 15 +++++ ...ewtype.res.txt => newtype.res_v4_auto.txt} | 0 .../ppx/react/expected/newtype.res_v4_cls.txt | 7 +++ tests/ppx/react/expected/topLevel.res_v3.txt | 10 ++++ ...Level.res.txt => topLevel.res_v4_auto.txt} | 0 .../react/expected/topLevel.res_v4_cls.txt | 9 +++ .../react/expected/typeConstraint.res_v3.txt | 8 +++ ...res.txt => typeConstraint.res_v4_auto.txt} | 0 .../expected/typeConstraint.res_v4_cls.txt | 8 +++ 22 files changed, 259 insertions(+), 2 deletions(-) create mode 100644 tests/ppx/react/expected/commentAtTop.res_v3.txt rename tests/ppx/react/expected/{commentAtTop.res.txt => commentAtTop.res_v4_auto.txt} (100%) create mode 100644 tests/ppx/react/expected/commentAtTop.res_v4_cls.txt create mode 100644 tests/ppx/react/expected/externalWithCustomName.res_v3.txt create mode 100644 tests/ppx/react/expected/externalWithCustomName.res_v4_auto.txt rename tests/ppx/react/expected/{externalWithCustomName.res.txt => externalWithCustomName.res_v4_cls.txt} (100%) create mode 100644 tests/ppx/react/expected/forwardRef.res_v3.txt create mode 100644 tests/ppx/react/expected/forwardRef.res_v4_auto.txt rename tests/ppx/react/expected/{forwardRef.res.txt => forwardRef.res_v4_cls.txt} (100%) create mode 100644 tests/ppx/react/expected/innerModule.res_v3.txt rename tests/ppx/react/expected/{innerModule.res.txt => innerModule.res_v4_auto.txt} (100%) create mode 100644 tests/ppx/react/expected/innerModule.res_v4_cls.txt create mode 100644 tests/ppx/react/expected/newtype.res_v3.txt rename tests/ppx/react/expected/{newtype.res.txt => newtype.res_v4_auto.txt} (100%) create mode 100644 tests/ppx/react/expected/newtype.res_v4_cls.txt create mode 100644 tests/ppx/react/expected/topLevel.res_v3.txt rename tests/ppx/react/expected/{topLevel.res.txt => topLevel.res_v4_auto.txt} (100%) create mode 100644 tests/ppx/react/expected/topLevel.res_v4_cls.txt create mode 100644 tests/ppx/react/expected/typeConstraint.res_v3.txt rename tests/ppx/react/expected/{typeConstraint.res.txt => typeConstraint.res_v4_auto.txt} (100%) create mode 100644 tests/ppx/react/expected/typeConstraint.res_v4_cls.txt diff --git a/scripts/test.sh b/scripts/test.sh index a55cd638..d836f2e9 100755 --- a/scripts/test.sh +++ b/scripts/test.sh @@ -8,6 +8,9 @@ function exp { echo "$(dirname $1)/expected/$(basename $1).txt" } +function exp2 { + echo "$(dirname $1)/expected/$(basename $1)$2.txt" +} taskCount=0 function maybeWait { @@ -35,10 +38,22 @@ while read file; do rescript $file &> $(exp $file) & maybeWait done temp/files.txt +while read file; do + rescript -ppx jsx3 $file &> $(exp2 $file "_v3") & maybeWait +done temp/files.txt +while read file; do + rescript -ppx jsx4 -jsx-runtime classic $file &> $(exp2 $file "_v4_cls") & maybeWait +done temp/files.txt while read file; do - rescript -ppx jsx $file &> $(exp $file) & maybeWait + rescript -ppx jsx4 -jsx-runtime automatic $file &> $(exp2 $file "_v4_auto") & maybeWait done {"msg": 'msg} = "" // test React JSX file + +let make = + (@warning("-16") ~msg) => { + ReactDOMRe.createDOMElementVariadic("div", [{msg->React.string}]) + } +let make = { + let \"CommentAtTop" = (\"Props": {"msg": 'msg}) => make(~msg=\"Props"["msg"]) + \"CommentAtTop" +} diff --git a/tests/ppx/react/expected/commentAtTop.res.txt b/tests/ppx/react/expected/commentAtTop.res_v4_auto.txt similarity index 100% rename from tests/ppx/react/expected/commentAtTop.res.txt rename to tests/ppx/react/expected/commentAtTop.res_v4_auto.txt diff --git a/tests/ppx/react/expected/commentAtTop.res_v4_cls.txt b/tests/ppx/react/expected/commentAtTop.res_v4_cls.txt new file mode 100644 index 00000000..1d536ca4 --- /dev/null +++ b/tests/ppx/react/expected/commentAtTop.res_v4_cls.txt @@ -0,0 +1,9 @@ +type props<'msg> = {@optional key: string, msg: 'msg} // test React JSX file + +let make = ({msg}: props<'msg>) => { + ReactDOMRe.createDOMElementVariadic("div", [{msg->React.string}]) +} +let make = { + let \"CommentAtTop" = (props: props<_>) => make(props) + \"CommentAtTop" +} diff --git a/tests/ppx/react/expected/externalWithCustomName.res_v3.txt b/tests/ppx/react/expected/externalWithCustomName.res_v3.txt new file mode 100644 index 00000000..083aeead --- /dev/null +++ b/tests/ppx/react/expected/externalWithCustomName.res_v3.txt @@ -0,0 +1,9 @@ +module Foo = { + @obj + external componentProps: (~a: int, ~b: string, ~key: string=?, unit) => {"a": int, "b": string} = + "" + @module("Foo") + external component: React.componentLike<{"a": int, "b": string}, React.element> = "component" +} + +let t = React.createElement(Foo.component, Foo.componentProps(~a=1, ~b={"1"}, ())) diff --git a/tests/ppx/react/expected/externalWithCustomName.res_v4_auto.txt b/tests/ppx/react/expected/externalWithCustomName.res_v4_auto.txt new file mode 100644 index 00000000..0f56d93f --- /dev/null +++ b/tests/ppx/react/expected/externalWithCustomName.res_v4_auto.txt @@ -0,0 +1,7 @@ +module Foo = { + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} + @module("Foo") + external component: React.componentLike, React.element> = "component" +} + +let t = React.jsx(Foo.component, {a: 1, b: "1"}) diff --git a/tests/ppx/react/expected/externalWithCustomName.res.txt b/tests/ppx/react/expected/externalWithCustomName.res_v4_cls.txt similarity index 100% rename from tests/ppx/react/expected/externalWithCustomName.res.txt rename to tests/ppx/react/expected/externalWithCustomName.res_v4_cls.txt diff --git a/tests/ppx/react/expected/forwardRef.res_v3.txt b/tests/ppx/react/expected/forwardRef.res_v3.txt new file mode 100644 index 00000000..7ad6177f --- /dev/null +++ b/tests/ppx/react/expected/forwardRef.res_v3.txt @@ -0,0 +1,56 @@ +module FancyInput = { + @obj + external makeProps: ( + ~className: 'className=?, + ~children: 'children, + ~key: string=?, + ~ref: 'ref=?, + unit, + ) => {"className": option<'className>, "children": 'children} = "" + let make = + (@warning("-16") ~className=?, @warning("-16") ~children) => + @warning("-16") + ref => + ReactDOMRe.createDOMElementVariadic( + "div", + [ + ReactDOMRe.createDOMElementVariadic( + "input", + ~props=ReactDOMRe.domProps( + ~type_="text", + ~className?, + ~ref=?{Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef)}, + (), + ), + [], + ), + children, + ], + ) + let make = React.forwardRef({ + let \"ForwardRef$FancyInput" = ( + \"Props": {"className": option<'className>, "children": 'children}, + ref, + ) => make(~children=\"Props"["children"], ~className=?\"Props"["className"], ref) + \"ForwardRef$FancyInput" + }) +} +@obj external makeProps: (~key: string=?, unit) => {.} = "" + +let make = () => { + let input = React.useRef(Js.Nullable.null) + + ReactDOMRe.createDOMElementVariadic( + "div", + [ + React.createElement( + FancyInput.make, + FancyInput.makeProps(~ref=input, ~children={React.string("Click to focus")}, ()), + ), + ], + ) +} +let make = { + let \"ForwardRef" = (\"Props": {.}) => make() + \"ForwardRef" +} diff --git a/tests/ppx/react/expected/forwardRef.res_v4_auto.txt b/tests/ppx/react/expected/forwardRef.res_v4_auto.txt new file mode 100644 index 00000000..d29dfe86 --- /dev/null +++ b/tests/ppx/react/expected/forwardRef.res_v4_auto.txt @@ -0,0 +1,48 @@ +module FancyInput = { + type props<'className, 'children> = { + @optional key: string, + @optional className: 'className, + children: 'children, + @optional ref: ReactDOM.Ref.currentDomRef, + } + let make = ({className, children, ref}: props<'className, 'children>) => { + let ref = Js.Nullable.fromOption(ref) + let _ = ref + + ReactDOMRe.createDOMElementVariadic( + "div", + [ + ReactDOMRe.createDOMElementVariadic( + "input", + ~props=ReactDOMRe.domProps( + ~type_="text", + ~className?, + ~ref=?{Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef)}, + (), + ), + [], + ), + children, + ], + ) + } + let make = React.forwardRef({ + let \"ForwardRef$FancyInput" = (props: props<_>, ref) => + make({...props, ref: @optional Js.Nullable.toOption(ref)}) + \"ForwardRef$FancyInput" + }) +} +type props = {@optional key: string} + +let make = (_: props) => { + let input = React.useRef(Js.Nullable.null) + + ReactDOMRe.createDOMElementVariadic( + "div", + [React.jsx(FancyInput.make, {ref: input, children: {React.string("Click to focus")}})], + ) +} +let make = { + let \"ForwardRef" = props => make(props) + \"ForwardRef" +} diff --git a/tests/ppx/react/expected/forwardRef.res.txt b/tests/ppx/react/expected/forwardRef.res_v4_cls.txt similarity index 100% rename from tests/ppx/react/expected/forwardRef.res.txt rename to tests/ppx/react/expected/forwardRef.res_v4_cls.txt diff --git a/tests/ppx/react/expected/innerModule.res_v3.txt b/tests/ppx/react/expected/innerModule.res_v3.txt new file mode 100644 index 00000000..6c0e7369 --- /dev/null +++ b/tests/ppx/react/expected/innerModule.res_v3.txt @@ -0,0 +1,25 @@ +module Bar = { + @obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" + let make = + (@warning("-16") ~a, @warning("-16") ~b, _) => { + Js.log("This function should be named `InnerModule.react$Bar`") + ReactDOMRe.createDOMElementVariadic("div", []) + } + let make = { + let \"InnerModule$Bar" = (\"Props": {"a": 'a, "b": 'b}) => + make(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + \"InnerModule$Bar" + } + @obj external componentProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" + + let component = + (@warning("-16") ~a, @warning("-16") ~b, _) => { + Js.log("This function should be named `InnerModule.react$Bar$component`") + ReactDOMRe.createDOMElementVariadic("div", []) + } + let component = { + let \"InnerModule$Bar$component" = (\"Props": {"a": 'a, "b": 'b}) => + component(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + \"InnerModule$Bar$component" + } +} diff --git a/tests/ppx/react/expected/innerModule.res.txt b/tests/ppx/react/expected/innerModule.res_v4_auto.txt similarity index 100% rename from tests/ppx/react/expected/innerModule.res.txt rename to tests/ppx/react/expected/innerModule.res_v4_auto.txt diff --git a/tests/ppx/react/expected/innerModule.res_v4_cls.txt b/tests/ppx/react/expected/innerModule.res_v4_cls.txt new file mode 100644 index 00000000..a849bc72 --- /dev/null +++ b/tests/ppx/react/expected/innerModule.res_v4_cls.txt @@ -0,0 +1,21 @@ +module Bar = { + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} + let make = ({a, b}: props<'a, 'b>) => { + Js.log("This function should be named `InnerModule.react$Bar`") + ReactDOMRe.createDOMElementVariadic("div", []) + } + let make = { + let \"InnerModule$Bar" = (props: props<_>) => make(props) + \"InnerModule$Bar" + } + type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} + + let component = ({a, b}: props<'a, 'b>) => { + Js.log("This function should be named `InnerModule.react$Bar$component`") + ReactDOMRe.createDOMElementVariadic("div", []) + } + let component = { + let \"InnerModule$Bar$component" = (props: props<_>) => make(props) + \"InnerModule$Bar$component" + } +} diff --git a/tests/ppx/react/expected/newtype.res_v3.txt b/tests/ppx/react/expected/newtype.res_v3.txt new file mode 100644 index 00000000..ace5106c --- /dev/null +++ b/tests/ppx/react/expected/newtype.res_v3.txt @@ -0,0 +1,15 @@ +@obj +external makeProps: ( + ~a: '\"type-a", + ~b: array>, + ~c: 'a, + ~key: string=?, + unit, +) => {"a": '\"type-a", "b": array>, "c": 'a} = "" +let make = (type a, ~a: a, ~b: array>, ~c: 'a, _) => + ReactDOMRe.createDOMElementVariadic("div", []) +let make = { + let \"Newtype" = (\"Props": {"a": '\"type-a", "b": array>, "c": 'a}) => + make(~c=\"Props"["c"], ~b=\"Props"["b"], ~a=\"Props"["a"]) + \"Newtype" +} diff --git a/tests/ppx/react/expected/newtype.res.txt b/tests/ppx/react/expected/newtype.res_v4_auto.txt similarity index 100% rename from tests/ppx/react/expected/newtype.res.txt rename to tests/ppx/react/expected/newtype.res_v4_auto.txt diff --git a/tests/ppx/react/expected/newtype.res_v4_cls.txt b/tests/ppx/react/expected/newtype.res_v4_cls.txt new file mode 100644 index 00000000..10bd9031 --- /dev/null +++ b/tests/ppx/react/expected/newtype.res_v4_cls.txt @@ -0,0 +1,7 @@ +type props<'a, 'b, 'c> = {@optional key: string, a: 'a, b: 'b, c: 'c} +let make = (_: props<'a, 'b, 'c>, type a, ~a: a, ~b: array>, ~c: 'a, _) => + ReactDOMRe.createDOMElementVariadic("div", []) +let make = { + let \"Newtype" = (props: props<_>) => make(props) + \"Newtype" +} diff --git a/tests/ppx/react/expected/topLevel.res_v3.txt b/tests/ppx/react/expected/topLevel.res_v3.txt new file mode 100644 index 00000000..b14eee2a --- /dev/null +++ b/tests/ppx/react/expected/topLevel.res_v3.txt @@ -0,0 +1,10 @@ +@obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" +let make = + (@warning("-16") ~a, @warning("-16") ~b, _) => { + Js.log("This function should be named 'TopLevel.react'") + ReactDOMRe.createDOMElementVariadic("div", []) + } +let make = { + let \"TopLevel" = (\"Props": {"a": 'a, "b": 'b}) => make(~b=\"Props"["b"], ~a=\"Props"["a"], ()) + \"TopLevel" +} diff --git a/tests/ppx/react/expected/topLevel.res.txt b/tests/ppx/react/expected/topLevel.res_v4_auto.txt similarity index 100% rename from tests/ppx/react/expected/topLevel.res.txt rename to tests/ppx/react/expected/topLevel.res_v4_auto.txt diff --git a/tests/ppx/react/expected/topLevel.res_v4_cls.txt b/tests/ppx/react/expected/topLevel.res_v4_cls.txt new file mode 100644 index 00000000..7694fd43 --- /dev/null +++ b/tests/ppx/react/expected/topLevel.res_v4_cls.txt @@ -0,0 +1,9 @@ +type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} +let make = ({a, b}: props<'a, 'b>) => { + Js.log("This function should be named 'TopLevel.react'") + ReactDOMRe.createDOMElementVariadic("div", []) +} +let make = { + let \"TopLevel" = (props: props<_>) => make(props) + \"TopLevel" +} diff --git a/tests/ppx/react/expected/typeConstraint.res_v3.txt b/tests/ppx/react/expected/typeConstraint.res_v3.txt new file mode 100644 index 00000000..8940b164 --- /dev/null +++ b/tests/ppx/react/expected/typeConstraint.res_v3.txt @@ -0,0 +1,8 @@ +@obj external makeProps: (~a: 'a, ~b: 'b, ~key: string=?, unit) => {"a": 'a, "b": 'b} = "" +let make: + type a. (~a: a, ~b: a, a) => React.element = + (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) +let make = { + let \"TypeConstraint" = (\"Props": {"a": 'a, "b": 'b}) => make(~b=\"Props"["b"], ~a=\"Props"["a"]) + \"TypeConstraint" +} diff --git a/tests/ppx/react/expected/typeConstraint.res.txt b/tests/ppx/react/expected/typeConstraint.res_v4_auto.txt similarity index 100% rename from tests/ppx/react/expected/typeConstraint.res.txt rename to tests/ppx/react/expected/typeConstraint.res_v4_auto.txt diff --git a/tests/ppx/react/expected/typeConstraint.res_v4_cls.txt b/tests/ppx/react/expected/typeConstraint.res_v4_cls.txt new file mode 100644 index 00000000..339cf97c --- /dev/null +++ b/tests/ppx/react/expected/typeConstraint.res_v4_cls.txt @@ -0,0 +1,8 @@ +type props<'a, 'b> = {@optional key: string, a: 'a, b: 'b} +let make: 'a. (~a: 'a, ~b: 'a, 'a) => React.element = (_: props<'a, 'b>, type a): ( + (~a: a, ~b: a, a) => React.element +) => (~a, ~b, _) => ReactDOMRe.createDOMElementVariadic("div", []) +let make = { + let \"TypeConstraint" = (props: props<_>) => make(props) + \"TypeConstraint" +}