diff --git a/jscomp/bsb/bsb_config_parse.ml b/jscomp/bsb/bsb_config_parse.ml index a2bf36a53c..ba747d6078 100644 --- a/jscomp/bsb/bsb_config_parse.ml +++ b/jscomp/bsb/bsb_config_parse.ml @@ -281,7 +281,9 @@ let interpret_json Some (Filename.quote (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_2_exe) ) | "3" -> - Bsb_exception.errorf ~loc "JSX version 3 is deprecated, please downgrade to 1.x for version 3" + reason_react_jsx := + Some (Filename.quote + (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_3_exe) ) | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo end | Some x -> Bsb_exception.config_error x diff --git a/lib/4.02.3/bsb.ml b/lib/4.02.3/bsb.ml index 4b059b2654..24c0108b8f 100644 --- a/lib/4.02.3/bsb.ml +++ b/lib/4.02.3/bsb.ml @@ -11878,7 +11878,9 @@ let interpret_json Some (Filename.quote (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_2_exe) ) | "3" -> - Bsb_exception.errorf ~loc "JSX version 3 is deprecated, please downgrade to 1.x for version 3" + reason_react_jsx := + Some (Filename.quote + (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_3_exe) ) | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo end | Some x -> Bsb_exception.config_error x diff --git a/lib/4.02.3/reactjs_jsx_ppx_v2.ml b/lib/4.02.3/reactjs_jsx_ppx_v2.ml index 9f2aee0cca..35d51c3019 100644 --- a/lib/4.02.3/reactjs_jsx_ppx_v2.ml +++ b/lib/4.02.3/reactjs_jsx_ppx_v2.ml @@ -10,8 +10,9 @@ *) (* - The actual transform: + 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|])`. @@ -25,30 +26,42 @@ transform `[@JSX] [foo]` into `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` -*) -(* - This file's shared between the Reason repo and the BuckleScript repo. In - Reason, it's in src. In BuckleScript, it's in jscomp/bin. We periodically - copy this file from Reason (the source of truth) to BuckleScript, then - uncomment the #if #else #end cppo macros you see in the file. That's because - BuckleScript's on OCaml 4.02 while Reason's on 4.04; so the #if macros - surround the pieces of code that are different between the two compilers. - - When you modify this file, please make sure you're not dragging in too many - things. You don't necessarily have to test the file on both Reason and - BuckleScript; ping @chenglou and a few others and we'll keep them synced up by - patching the right parts, through the power of types(tm) -*) + 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|])` +*) +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l let nolabel = "" let labelled str = str +let optional str = "?" ^ str +let isOptional str = str <> "" && str.[0] = '?' +let isLabelled str = str <> "" && not (isOptional str) +let getLabel str = if (isOptional str) then (String.sub str 1 ((String.length str) - 1)) else str + let argIsKeyRef = function | (("key" | "ref"), _) | (("?key" | "?ref"), _) -> true | _ -> false let constantString ~loc str = Ast_helper.Exp.constant ~loc (Asttypes.Const_string (str, None)) - +let safeTypeFromValue valueStr = +let valueStr = getLabel valueStr in +match String.sub valueStr 0 1 with +| "_" -> "T" ^ valueStr +| _ -> valueStr open Ast_helper open Ast_mapper @@ -56,7 +69,31 @@ open Asttypes open Parsetree open Longident +type 'a children = | ListLiteral of 'a | Exact of 'a +type componentConfig = { + propsName: string; +} + (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin + match accum with + | [singleElement] -> Exact singleElement + | accum -> ListLiteral (List.rev accum |> Exp.array ~loc) + end + | {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 @@ -76,27 +113,297 @@ let transformChildrenIfList ~loc ~mapper theList = let extractChildren ?(removeLastPositionUnit=false) ~loc propsAndChildren = let rec allButLast_ lst acc = match lst with | [] -> [] - | ("", {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc | ("", _)::rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") - | arg::rest -> allButLast_ rest (arg::acc) in let allButLast lst = allButLast_ lst [] |> List.rev in - match (List.partition (fun (label, expr) -> label = labelled "children") propsAndChildren) with + 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) - | ([(label, childrenExpr)], props) -> + | ([(_, childrenExpr)], props) -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | (moreThanOneChild, props) -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") + | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") + +(* 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 + +(* Filter the [@react.component] attribute and immutably replace them on the binding *) +let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes} + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | {pvb_pat = { + ppat_desc = Ppat_var {txt} + }} -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + +(* 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)) + +(* 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 + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelLocType (label, _, _, _, loc, type_) = (label, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc: Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | fileName -> fileName + in + let fileName = try + Filename.chop_extension (Filename.basename fileName) + with | Invalid_argument _-> fileName in + let fileName = String.capitalize fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | ("", nestedModules, "make") -> nestedModules + | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules) + | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules) + | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules)) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, loc, type_)::tl -> + recursivelyMakeNamedArgsForExternal tl (Typ.arrow + ~loc + label + (match (label, type_) with + | (label, None) when isOptional label -> { + ptyp_loc = loc; + ptyp_attributes = []; + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + }]); + } + | (label, None) when isLabelled label -> { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*","option"))}, _)} as type_)) when isOptional label -> + type_ + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])})) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (label, Some (type_)) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (_, Some type_) -> type_ + | (_, None) -> raise (Invalid_argument "This should never happen..") + ) + args) + | [] -> args + +(* 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 = loc}, PStr [])]; + pval_loc = loc; +} + +(* 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) + } + +(* 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) + } + +(* Build an AST node for the props name when converted to a Js.t inside the function signature *) +let makePropsName ~loc name = + { + ppat_desc = Ppat_var {txt = name; loc}; + ppat_loc = loc; + ppat_attributes = []; + } + +(* Build an AST node representing a "closed" Js.t object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc ( + Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{ + ptyp_desc = Ptyp_object(namedTypeList, Closed); + ptyp_loc = loc; + ptyp_attributes = []; + }]) + ) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal + fnName + loc + (List.map pluckLabelLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) (* TODO: some line number might still be wrong *) let jsxMapper () = let jsxVersion = ref None in - let transformUppercaseCall modulePath mapper loc attrs callExpression callArguments = + 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 in let capped = String.uppercase first in first = capped 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) + ])) + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let (children, nonChildrenProps) = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({txt = Lident "[]"}, None) + } -> "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> raise (Invalid_argument "A spread as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + in + let args = match nonChildrenProps with + | [_justTheUnitArgumentAtEnd] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] + | nonEmptyProps -> + let propsCall = + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let transformUppercaseCall modulePath mapper loc attrs _ callArguments = let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in let childrenExpr = transformChildrenIfList ~loc ~mapper children in @@ -123,15 +430,11 @@ let jsxMapper () = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - Pexp_construct ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _ }) - | Pexp_construct ({txt = Lident "[]"; loc}, None); - pexp_attributes + Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({txt = Lident "[]"}, None) } -> "createElement" (* [@JSX] div(~children=[|a|]), coming from
...[|a|]
*) - | { - pexp_desc = (Pexp_array _); - pexp_attributes - } -> + | { pexp_desc = (Pexp_array _) } -> raise (Invalid_argument "A spread + an array literal as a DOM element's \ children would cancel each other out, and thus don't make sense written \ together. You can simply remove the spread and the array literal.") @@ -141,7 +444,7 @@ let jsxMapper () = } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") -> raise (Invalid_argument "A spread + a JSX literal as a DOM element's \ children don't make sense written together. You can simply remove the spread.") - | notAList -> "createElementVariadic" + | _ -> "createElementVariadic" in let args = match nonChildrenProps with | [_justTheUnitArgumentAtEnd] -> @@ -175,6 +478,307 @@ let jsxMapper () = args in + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun ("key", _, _, _) + | Pexp_fun ("?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 ("ref", _, _, _) + | Pexp_fun ("?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 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, None, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) -> + (expression.pexp_desc, list, None) + | Pexp_fun (nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) -> + (expression.pexp_desc, list, Some txt) + | innerExpression -> (innerExpression, list, None) + in + + + let argToType types (name, _default, _noLabelName, _alias, loc, type_) = match (type_, name) with + | (Some type_, name) when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + | (None, name) when isOptional name -> + (getLabel name, [], { + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + 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 + in + + let argToConcreteType types (name, loc, type_) = match name with + | name when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + (* return value *) + | _ -> types + in + + let nestedModules = ref([]) in + let transformComponentDefinition mapper structure returnStructures = match structure with + (* external *) + | ({ + pstr_loc; + pstr_desc = Pstr_primitive ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as pstr_desc) + } 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 ("", _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, loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = makePropsExternal fnName pstr_loc (( + optional "key", + pstr_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + pstr with pstr_desc = Pstr_primitive { + pstr_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + (* let component = ... *) + | { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + valueBindings + ) + } -> + let mapBinding binding = if (hasAttrOnBinding binding) then + let fnName = getFnName binding in + let modifiedBinding binding = + let expression = binding.pvb_expr in + let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in + let rec spelunkForFunExpression expression = (match expression with + (* let make = (~prop) => ... *) + | { + pexp_desc = Pexp_fun _ + } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression) + (* let make = {let foo = bar in (~prop) => ...} *) + | { + pexp_desc = Pexp_let (recursive, vbs, returnExpression) + } -> + (* here's where we spelunk! *) + let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in + ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = Pexp_apply (wrapperExpression, [(nolabel, innerFunctionExpression)]) + } -> + let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in + ((fun expressionDesc -> { + expression with pexp_desc = + Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)]) + }), + realReturnExpression + ) + | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).") + ) in + let (wrapExpression, expression) = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, expression) + in + let (bindingWrapper, expression) = modifiedBinding binding in + let reactComponentAttribute = try + Some(List.find hasAttr binding.pvb_attributes) + with | Not_found -> None in + let payload = match reactComponentAttribute with + (* TODO: in some cases this is a better loc than pstr_loc *) + | Some (_loc, payload) -> Some payload + | None -> None in + let props = getPropsAttr payload in + (* do stuff here! *) + let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in + let namedArgListWithKeyAndRef = (optional("key"), None, None, "key", pstr_loc, None) :: namedArgList in + let namedArgListWithKeyAndRef = match forwardRef with + | Some(_) -> (optional("ref"), None, None, "ref", pstr_loc, None) :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let externalDecl = makeExternalDecl fnName pstr_loc namedArgListWithKeyAndRef namedTypeList in + let makeLet innerExpression (label, default, _, alias, loc, _type) = + let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in + let expression = (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 expression = match (label, default) with + | (label, Some default) when isOptional label -> Exp.match_ expression [ + Exp.case + (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc}))) + (Exp.ident ~loc {txt = (Lident labelString); loc}); + Exp.case + (Pat.construct {loc; txt=Lident "None"} None) + default + ] + | _ -> expression in + let letExpression = Vb.mk + (Pat.var ~loc {txt = alias; loc}) + expression in + Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in + let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in + let innerExpressionWithRef = match (forwardRef) with + | Some txt -> + {innerExpression with pexp_desc = Pexp_fun (nolabel, None, { + ppat_desc = Ppat_var { txt; loc = pstr_loc }; + ppat_loc = pstr_loc; + ppat_attributes = []; + }, innerExpression)} + | None -> innerExpression + in + let fullExpression = (Pexp_fun ( + nolabel, + None, + { + ppat_desc = Ppat_constraint ( + makePropsName ~loc:pstr_loc props.propsName, + makePropsType ~loc:pstr_loc namedTypeList + ); + ppat_loc = pstr_loc; + ppat_attributes = []; + }, + innerExpressionWithRef + )) in + let fileName = filenameFromLoc pstr_loc in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let fullExpression = match (fullModuleName) with + | ("") -> fullExpression + | (txt) -> Pexp_let ( + Nonrecursive, + [Vb.mk + ~loc:pstr_loc + (Pat.var ~loc:pstr_loc {loc = pstr_loc; txt}) + (Exp.mk ~loc:pstr_loc fullExpression) + ], + (Exp.ident ~loc:pstr_loc {loc = pstr_loc; txt = Lident txt}) + ) + in + let newBinding = bindingWrapper fullExpression in + (Some externalDecl, newBinding) + else + (None, binding) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding) (externs, bindings) = + let externs = match extern with + | Some extern -> extern :: externs + | None -> externs in + (externs, binding :: bindings) + in + let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in + externs @ { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + bindings + ) + } :: returnStructures + | structure -> structure :: returnStructures in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] 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 ("", _type, rest) -> + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_)::types) + | _ -> (fullType, types)) + in + let (innerType, propTypes) = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = makePropsExternalSig fnName psig_loc (( + optional "key", + psig_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + psig with psig_desc = Psig_value { + psig_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + | signature -> signature :: returnSignatures in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] in + + let transformJsxCall mapper callExpression callArguments attrs = (match callExpression.pexp_desc with | Pexp_ident caller -> @@ -187,13 +791,18 @@ let jsxMapper () = (match !jsxVersion with | None | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2")) + | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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} -> - transformLowercaseCall mapper loc attrs callArguments id + (match !jsxVersion with + | None + | Some 2 -> transformLowercaseCall mapper loc attrs callArguments id + | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 3")) | {txt = Ldot (_, anythingNotCreateElementOrMake)} -> raise ( @@ -210,12 +819,15 @@ let jsxMapper () = Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!" ) ) - | anythingElseThanIdent -> + | _ -> raise ( Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name." ) ) in + let signature = + (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in + let structure = (fun mapper structure -> match structure with (* @@ -245,26 +857,27 @@ let jsxMapper () = (* no file-level jsx config found *) | ([], _) -> default_mapper.structure mapper structure (* {jsx: 2} *) - | ((_, {pexp_desc = Pexp_constant (Const_int version)})::rest, recordFieldsWithoutJsx) -> begin (match version with | 2 -> jsxVersion := Some 2 - | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2")); - + | 3 -> jsxVersion := Some 3 + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3")); match recordFieldsWithoutJsx with (* record empty now, remove the whole bs.config attribute *) - | [] -> default_mapper.structure mapper restOfStructure + | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure | fields -> default_mapper.structure mapper ({ pstr_loc; pstr_desc = Pstr_attribute ( bsConfigLabel, PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}] ) - }::restOfStructure) + }::(reactComponentTransform mapper restOfStructure)) end - | (_, recordFieldsWithoutJsx) -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") + end + | structures -> begin + default_mapper.structure mapper @@ reactComponentTransform mapper structures end - | _ -> default_mapper.structure mapper structure ) in let expr = @@ -283,7 +896,7 @@ let jsxMapper () = (* 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}, Some {pexp_desc = Pexp_tuple _}) | Pexp_construct ({txt = Lident "[]"; loc}, None); pexp_attributes } as listItems -> @@ -311,10 +924,86 @@ let jsxMapper () = (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e) in + let module_binding = + (fun 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 + ) in - { default_mapper with structure; expr } - - - + { default_mapper with structure; expr; signature; module_binding; } + + +(* #if BS_COMPILER_IN_BROWSER then + +module Js = struct + module Unsafe = struct + type any + external inject : 'a -> any = "%identity" + external get : 'a -> 'b -> 'c = "caml_js_get" + external set : 'a -> 'b -> 'c -> unit = "caml_js_set" + external pure_js_expr : string -> 'a = "caml_pure_js_expr" + let global = pure_js_expr "joo_global_object" + external obj : (string * any) array -> 'a = "caml_js_object" + end + type (-'a, +'b) meth_callback + type 'a callback = (unit, 'a) meth_callback + external wrap_meth_callback : ('a -> 'b) -> ('a, 'b) meth_callback = "caml_js_wrap_meth_callback" + type + 'a t + type js_string + external string : string -> js_string t = "caml_js_from_string" + external to_string : js_string t -> string = "caml_js_to_string" +end + +(* keep in sync with jscomp/core/jsoo_main.ml `let implementation` *) +let rewrite code = + let mapper = jsxMapper () in + Location.input_name := "//toplevel//"; + try + let lexer = Lexing.from_string code in + let pstr = Parse.implementation lexer in + let pstr = mapper.structure mapper pstr in + let buffer = Buffer.create 1000 in + Pprintast.structure Format.str_formatter pstr; + let ocaml_code = Format.flush_str_formatter () in + Js.Unsafe.(obj [| "ocaml_code", inject @@ Js.string ocaml_code |]) + with e -> + match Location.error_of_exn e with + | Some error -> + Location.report_error Format.err_formatter error; + let (file, line, startchar) = Location.get_pos_info error.loc.loc_start in + let (file, endline, endchar) = Location.get_pos_info error.loc.loc_end in + Js.Unsafe.(obj + [| + "ppx_error_msg", inject @@ Js.string (Printf.sprintf "Line %d, %d: %s" line startchar error.msg); + "row", inject (line - 1); + "column", inject startchar; + "endRow", inject (endline - 1); + "endColumn", inject endchar; + "text", inject @@ Js.string error.msg; + "type", inject @@ Js.string "error"; + |] + ) + | None -> + Js.Unsafe.(obj [| + "js_error_msg" , inject @@ Js.string (Printexc.to_string e) + |]) + +let export (field : string) v = + Js.Unsafe.set (Js.Unsafe.global) field v + +let make_ppx name = + export name + (Js.Unsafe.(obj + [|"rewrite", + inject @@ + Js.wrap_meth_callback + (fun _ code -> rewrite (Js.to_string code)); + |])) + +let () = make_ppx "jsxv2" *) + +(* #else *) let () = Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) - +(* #end *) \ No newline at end of file diff --git a/lib/4.02.3/reactjs_jsx_ppx_v3.ml b/lib/4.02.3/reactjs_jsx_ppx_v3.ml new file mode 100644 index 0000000000..5adb89478e --- /dev/null +++ b/lib/4.02.3/reactjs_jsx_ppx_v3.ml @@ -0,0 +1,1009 @@ +(* + This is the file 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 BuckleScript'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|])` +*) + +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l +let nolabel = "" +let labelled str = str +let optional str = "?" ^ str +let isOptional str = str <> "" && str.[0] = '?' +let isLabelled str = str <> "" && not (isOptional str) +let getLabel str = if (isOptional str) then (String.sub str 1 ((String.length str) - 1)) else str + +let argIsKeyRef = function + | (("key" | "ref"), _) | (("?key" | "?ref"), _) -> true + | _ -> false +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Asttypes.Const_string (str, None)) +let safeTypeFromValue valueStr = +let valueStr = getLabel valueStr in +match String.sub valueStr 0 1 with +| "_" -> "T" ^ valueStr +| _ -> valueStr + +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +type 'a children = | ListLiteral of 'a | Exact of 'a +type componentConfig = { + propsName: string; +} + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin + match accum with + | [singleElement] -> Exact singleElement + | accum -> ListLiteral (List.rev accum |> Exp.array ~loc) + end + | {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)} -> + List.rev accum |> Exp.array ~loc + | {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 + | [] -> [] + | ("", {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc + | ("", _)::rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") + | arg::rest -> allButLast_ rest (arg::acc) + in + let allButLast lst = allButLast_ lst [] |> List.rev 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") + +(* 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 + +(* Filter the [@react.component] attribute and immutably replace them on the binding *) +let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes} + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | {pvb_pat = { + ppat_desc = Ppat_var {txt} + }} -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + +(* 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)) + +(* 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 + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelLocType (label, _, _, _, loc, type_) = (label, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc: Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | fileName -> fileName + in + let fileName = try + Filename.chop_extension (Filename.basename fileName) + with | Invalid_argument _-> fileName in + let fileName = String.capitalize fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | ("", nestedModules, "make") -> nestedModules + | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules) + | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules) + | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules)) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, loc, type_)::tl -> + recursivelyMakeNamedArgsForExternal tl (Typ.arrow + ~loc + label + (match (label, type_) with + | (label, None) when isOptional label -> { + ptyp_loc = loc; + ptyp_attributes = []; + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + }]); + } + | (label, None) when isLabelled label -> { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*","option"))}, _)} as type_)) when isOptional label -> + type_ + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])})) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (label, Some (type_)) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (_, Some type_) -> type_ + | (_, None) -> raise (Invalid_argument "This should never happen..") + ) + args) + | [] -> args + +(* 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 = loc}, PStr [])]; + pval_loc = loc; +} + +(* 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) + } + +(* 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) + } + +(* Build an AST node for the props name when converted to a Js.t inside the function signature *) +let makePropsName ~loc name = + { + ppat_desc = Ppat_var {txt = name; loc}; + ppat_loc = loc; + ppat_attributes = []; + } + +(* Build an AST node representing a "closed" Js.t object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc ( + Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{ + ptyp_desc = Ptyp_object(namedTypeList, Closed); + ptyp_loc = loc; + ptyp_attributes = []; + }]) + ) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal + fnName + loc + (List.map pluckLabelLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + +(* 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 in let capped = String.uppercase first in first = capped 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) + ])) + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let (children, nonChildrenProps) = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({txt = Lident "[]"}, None) + } -> "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> raise (Invalid_argument "A spread as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + in + let args = match nonChildrenProps with + | [_justTheUnitArgumentAtEnd] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] + | nonEmptyProps -> + let propsCall = + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let transformUppercaseCall modulePath mapper loc attrs _ callArguments = + let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in + let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in + let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *) + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")}) + (argsKeyRef @ [(nolabel, e)]) in + Exp.apply + ~loc + ~attrs + (* Foo.make *) + (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")}) + args + |> wrapWithReasonReactElement in + + let transformLowercaseCall 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) + } -> "createElement" + (* [@JSX] div(~children=[|a|]), coming from
...[|a|]
*) + | { pexp_desc = (Pexp_array _) } -> + raise (Invalid_argument "A spread + an array literal as a DOM element's \ + children would cancel each other out, and thus don't make sense written \ + together. You can simply remove the spread and the array literal.") + (* [@JSX] div(~children=
), coming from
...
*) + | { + pexp_attributes + } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") -> + raise (Invalid_argument "A spread + a JSX literal as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + | _ -> "createElementVariadic" + 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", "props")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun ("key", _, _, _) + | Pexp_fun ("?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 ("ref", _, _, _) + | Pexp_fun ("?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 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, None, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) -> + (expression.pexp_desc, list, None) + | Pexp_fun (nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) -> + (expression.pexp_desc, list, Some txt) + | innerExpression -> (innerExpression, list, None) + in + + + let argToType types (name, _default, _noLabelName, _alias, loc, type_) = match (type_, name) with + | (Some type_, name) when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + | (None, name) when isOptional name -> + (getLabel name, [], { + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + 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 + in + + let argToConcreteType types (name, loc, type_) = match name with + | name when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + (* return value *) + | _ -> types + in + + let nestedModules = ref([]) in + let transformComponentDefinition mapper structure returnStructures = match structure with + (* external *) + | ({ + pstr_loc; + pstr_desc = Pstr_primitive ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as pstr_desc) + } 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 ("", _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, loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = makePropsExternal fnName pstr_loc (( + optional "key", + pstr_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + pstr with pstr_desc = Pstr_primitive { + pstr_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + (* let component = ... *) + | { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + valueBindings + ) + } -> + let mapBinding binding = if (hasAttrOnBinding binding) then + let fnName = getFnName binding in + let modifiedBinding binding = + let expression = binding.pvb_expr in + let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in + let rec spelunkForFunExpression expression = (match expression with + (* let make = (~prop) => ... *) + | { + pexp_desc = Pexp_fun _ + } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression) + (* let make = {let foo = bar in (~prop) => ...} *) + | { + pexp_desc = Pexp_let (recursive, vbs, returnExpression) + } -> + (* here's where we spelunk! *) + let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in + ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = Pexp_apply (wrapperExpression, [(nolabel, innerFunctionExpression)]) + } -> + let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in + ((fun expressionDesc -> { + expression with pexp_desc = + Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)]) + }), + realReturnExpression + ) + | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).") + ) in + let (wrapExpression, expression) = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, expression) + in + let (bindingWrapper, expression) = modifiedBinding binding in + let reactComponentAttribute = try + Some(List.find hasAttr binding.pvb_attributes) + with | Not_found -> None in + let payload = match reactComponentAttribute with + (* TODO: in some cases this is a better loc than pstr_loc *) + | Some (_loc, payload) -> Some payload + | None -> None in + let props = getPropsAttr payload in + (* do stuff here! *) + let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in + let namedArgListWithKeyAndRef = (optional("key"), None, None, "key", pstr_loc, None) :: namedArgList in + let namedArgListWithKeyAndRef = match forwardRef with + | Some(_) -> (optional("ref"), None, None, "ref", pstr_loc, None) :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let externalDecl = makeExternalDecl fnName pstr_loc namedArgListWithKeyAndRef namedTypeList in + let makeLet innerExpression (label, default, _, alias, loc, _type) = + let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in + let expression = (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 expression = match (label, default) with + | (label, Some default) when isOptional label -> Exp.match_ expression [ + Exp.case + (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc}))) + (Exp.ident ~loc {txt = (Lident labelString); loc}); + Exp.case + (Pat.construct {loc; txt=Lident "None"} None) + default + ] + | _ -> expression in + let letExpression = Vb.mk + (Pat.var ~loc {txt = alias; loc}) + expression in + Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in + let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in + let innerExpressionWithRef = match (forwardRef) with + | Some txt -> + {innerExpression with pexp_desc = Pexp_fun (nolabel, None, { + ppat_desc = Ppat_var { txt; loc = pstr_loc }; + ppat_loc = pstr_loc; + ppat_attributes = []; + }, innerExpression)} + | None -> innerExpression + in + let fullExpression = (Pexp_fun ( + nolabel, + None, + { + ppat_desc = Ppat_constraint ( + makePropsName ~loc:pstr_loc props.propsName, + makePropsType ~loc:pstr_loc namedTypeList + ); + ppat_loc = pstr_loc; + ppat_attributes = []; + }, + innerExpressionWithRef + )) in + let fileName = filenameFromLoc pstr_loc in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let fullExpression = match (fullModuleName) with + | ("") -> fullExpression + | (txt) -> Pexp_let ( + Nonrecursive, + [Vb.mk + ~loc:pstr_loc + (Pat.var ~loc:pstr_loc {loc = pstr_loc; txt}) + (Exp.mk ~loc:pstr_loc fullExpression) + ], + (Exp.ident ~loc:pstr_loc {loc = pstr_loc; txt = Lident txt}) + ) + in + let newBinding = bindingWrapper fullExpression in + (Some externalDecl, newBinding) + else + (None, binding) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding) (externs, bindings) = + let externs = match extern with + | Some extern -> extern :: externs + | None -> externs in + (externs, binding :: bindings) + in + let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in + externs @ { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + bindings + ) + } :: returnStructures + | structure -> structure :: returnStructures in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] 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 ("", _type, rest) -> + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_)::types) + | _ -> (fullType, types)) + in + let (innerType, propTypes) = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = makePropsExternalSig fnName psig_loc (( + optional "key", + psig_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + psig with psig_desc = Psig_value { + psig_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + | signature -> signature :: returnSignatures in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] in + + + let transformJsxCall mapper callExpression callArguments attrs = + (match callExpression.pexp_desc with + | Pexp_ident caller -> + (match caller with + | {txt = Lident "createElement"} -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> + (match !jsxVersion with + | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments + | None + | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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 + | Some 2 -> transformLowercaseCall mapper loc attrs callArguments id + | None + | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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." + ) + ) in + + let signature = + (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in + + let structure = + (fun mapper structure -> match structure with + (* + match against [@bs.config {foo, jsx: ...}] at the file-level. This + indicates which version of JSX we're using. This code stays here because + we used to have 2 versions of JSX PPX (and likely will again in the + future when JSX PPX changes). So the architecture for switching between + JSX behavior stayed here. To create a new JSX ppx, copy paste this + entire file and change the relevant parts. + + Description of architecture: in bucklescript's bsconfig.json, you can + specify a project-wide JSX version. You can also specify a file-level + JSX version. This degree of freedom allows a person to convert a project + one file at time onto the new JSX, when it was released. It also enabled + a project to depend on a third-party which is still using an old version + of JSX + *) + | { + pstr_loc; + pstr_desc = Pstr_attribute ( + ({txt = "bs.config"} as bsConfigLabel), + PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord] + ) + }::restOfStructure -> begin + let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in + match (jsxField, recordFieldsWithoutJsx) with + (* no file-level jsx config found *) + | ([], _) -> default_mapper.structure mapper structure + (* {jsx: 2} *) + | ((_, {pexp_desc = Pexp_constant (Const_int version)})::rest, recordFieldsWithoutJsx) -> begin + (match version with + | 2 -> jsxVersion := Some 2 + | 3 -> jsxVersion := Some 3 + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3")); + match recordFieldsWithoutJsx with + (* record empty now, remove the whole bs.config attribute *) + | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure + | fields -> default_mapper.structure mapper ({ + pstr_loc; + pstr_desc = Pstr_attribute ( + bsConfigLabel, + PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}] + ) + }::(reactComponentTransform mapper restOfStructure)) + end + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") + end + | structures -> begin + default_mapper.structure mapper @@ reactComponentTransform mapper structures + end + ) in + + let expr = + (fun 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 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) in + + let module_binding = + (fun 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 + ) in + + { default_mapper with structure; expr; signature; module_binding; } + + +(* #if BS_COMPILER_IN_BROWSER then + +module Js = struct + module Unsafe = struct + type any + external inject : 'a -> any = "%identity" + external get : 'a -> 'b -> 'c = "caml_js_get" + external set : 'a -> 'b -> 'c -> unit = "caml_js_set" + external pure_js_expr : string -> 'a = "caml_pure_js_expr" + let global = pure_js_expr "joo_global_object" + external obj : (string * any) array -> 'a = "caml_js_object" + end + type (-'a, +'b) meth_callback + type 'a callback = (unit, 'a) meth_callback + external wrap_meth_callback : ('a -> 'b) -> ('a, 'b) meth_callback = "caml_js_wrap_meth_callback" + type + 'a t + type js_string + external string : string -> js_string t = "caml_js_from_string" + external to_string : js_string t -> string = "caml_js_to_string" +end + +(* keep in sync with jscomp/core/jsoo_main.ml `let implementation` *) +let rewrite code = + let mapper = jsxMapper () in + Location.input_name := "//toplevel//"; + try + let lexer = Lexing.from_string code in + let pstr = Parse.implementation lexer in + let pstr = mapper.structure mapper pstr in + let buffer = Buffer.create 1000 in + Pprintast.structure Format.str_formatter pstr; + let ocaml_code = Format.flush_str_formatter () in + Js.Unsafe.(obj [| "ocaml_code", inject @@ Js.string ocaml_code |]) + with e -> + match Location.error_of_exn e with + | Some error -> + Location.report_error Format.err_formatter error; + let (file, line, startchar) = Location.get_pos_info error.loc.loc_start in + let (file, endline, endchar) = Location.get_pos_info error.loc.loc_end in + Js.Unsafe.(obj + [| + "ppx_error_msg", inject @@ Js.string (Printf.sprintf "Line %d, %d: %s" line startchar error.msg); + "row", inject (line - 1); + "column", inject startchar; + "endRow", inject (endline - 1); + "endColumn", inject endchar; + "text", inject @@ Js.string error.msg; + "type", inject @@ Js.string "error"; + |] + ) + | None -> + Js.Unsafe.(obj [| + "js_error_msg" , inject @@ Js.string (Printexc.to_string e) + |]) + +let export (field : string) v = + Js.Unsafe.set (Js.Unsafe.global) field v + +let make_ppx name = + export name + (Js.Unsafe.(obj + [|"rewrite", + inject @@ + Js.wrap_meth_callback + (fun _ code -> rewrite (Js.to_string code)); + |])) + +let () = make_ppx "jsxv2" *) + +(* #else *) +let () = Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) +(* #end *) \ No newline at end of file diff --git a/lib/4.02.3/reactjs_jsx_ppx_v3.mli b/lib/4.02.3/reactjs_jsx_ppx_v3.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/lib/4.02.3/unstable/bsb_native.ml b/lib/4.02.3/unstable/bsb_native.ml index 4b059b2654..24c0108b8f 100644 --- a/lib/4.02.3/unstable/bsb_native.ml +++ b/lib/4.02.3/unstable/bsb_native.ml @@ -11878,7 +11878,9 @@ let interpret_json Some (Filename.quote (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_2_exe) ) | "3" -> - Bsb_exception.errorf ~loc "JSX version 3 is deprecated, please downgrade to 1.x for version 3" + reason_react_jsx := + Some (Filename.quote + (Filename.concat bsc_dir Literals.reactjs_jsx_ppx_3_exe) ) | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo end | Some x -> Bsb_exception.config_error x diff --git a/lib/4.06.1/reactjs_jsx_ppx_v2.ml b/lib/4.06.1/reactjs_jsx_ppx_v2.ml index e69de29bb2..ed782cc8e8 100644 --- a/lib/4.06.1/reactjs_jsx_ppx_v2.ml +++ b/lib/4.06.1/reactjs_jsx_ppx_v2.ml @@ -0,0 +1,1021 @@ +(* + This is the file 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 BuckleScript'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|])` +*) + +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l +let nolabel = Nolabel +let labelled str = Labelled str +let optional str = Optional str +let isOptional str = match str with +| Optional _ -> true +| _ -> false +let isLabelled str = match str with +| Labelled _ -> true +| _ -> false +let getLabel str = match str with +| Optional str | Labelled str -> str +| Nolabel -> "" + +let argIsKeyRef = function + | (Labelled ("key" | "ref"), _) | (Optional ("key" | "ref"), _) -> true + | _ -> false +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) +let safeTypeFromValue valueStr = +let valueStr = getLabel valueStr in +match String.sub valueStr 0 1 with +| "_" -> "T" ^ valueStr +| _ -> valueStr + +type 'a children = | ListLiteral of 'a | Exact of 'a +type componentConfig = { + propsName: string; +} + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin + match accum with + | [singleElement] -> Exact singleElement + | accum -> ListLiteral (List.rev accum |> Exp.array ~loc) + end + | {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)} -> + List.rev accum |> Exp.array ~loc + | {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) + in + let allButLast lst = allButLast_ lst [] |> List.rev 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") + +(* 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 + +(* Filter the [@react.component] attribute and immutably replace them on the binding *) +let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes} + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | {pvb_pat = { + ppat_desc = Ppat_var {txt} + }} -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + +(* 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)) + +(* 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 + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelLocType (label, _, _, _, loc, type_) = (label, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc: Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | fileName -> fileName + in + let fileName = try + Filename.chop_extension (Filename.basename fileName) + with | Invalid_argument _-> fileName in + let fileName = String.capitalize_ascii fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | ("", nestedModules, "make") -> nestedModules + | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules) + | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules) + | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules)) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, loc, type_)::tl -> + recursivelyMakeNamedArgsForExternal tl (Typ.arrow + ~loc + label + (match (label, type_) with + | (label, None) when isOptional label -> { + ptyp_loc = loc; + ptyp_attributes = []; + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + }]); + } + | (label, None) when isLabelled label -> { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*","option"))}, _)} as type_)) when isOptional label -> + type_ + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])})) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (label, Some (type_)) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (_, Some type_) -> type_ + | (_, None) -> raise (Invalid_argument "This should never happen..") + ) + args) + | [] -> args + +(* 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 = loc}, PStr [])]; + pval_loc = loc; +} + +(* 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) + } + +(* 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) + } + +(* Build an AST node for the props name when converted to a Js.t 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" Js.t object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc ( + Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{ + ptyp_desc = Ptyp_object( + List.map (makeObjectField loc) namedTypeList, + Closed + ); + ptyp_loc = loc; + ptyp_attributes = []; + }]) + ) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal + fnName + loc + (List.map pluckLabelLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + +(* 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 in let capped = String.uppercase_ascii first in first = capped 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) + ])) + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let (children, nonChildrenProps) = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({txt = Lident "[]"}, None) + } -> "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> raise (Invalid_argument "A spread as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + in + let args = match nonChildrenProps with + | [_justTheUnitArgumentAtEnd] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] + | nonEmptyProps -> + let propsCall = + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let transformUppercaseCall modulePath mapper loc attrs _ callArguments = + let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in + let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in + let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *) + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")}) + (argsKeyRef @ [(nolabel, e)]) in + Exp.apply + ~loc + ~attrs + (* Foo.make *) + (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")}) + args + |> wrapWithReasonReactElement in + + let transformLowercaseCall 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) + } -> "createElement" + (* [@JSX] div(~children=[|a|]), coming from
...[|a|]
*) + | { pexp_desc = (Pexp_array _) } -> + raise (Invalid_argument "A spread + an array literal as a DOM element's \ + children would cancel each other out, and thus don't make sense written \ + together. You can simply remove the spread and the array literal.") + (* [@JSX] div(~children=
), coming from
...
*) + | { + pexp_attributes + } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") -> + raise (Invalid_argument "A spread + a JSX literal as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + | _ -> "createElementVariadic" + 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", "props")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun (Labelled "key", _, _, _) + | Pexp_fun (Optional "key", _, _, _) -> raise (Invalid_argument "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its parent!") + | Pexp_fun (Labelled "ref", _, _, _) + | Pexp_fun (Optional "ref", _, _, _) -> raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") + | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> + let 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, None, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) -> + (expression.pexp_desc, list, None) + | Pexp_fun (nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) -> + (expression.pexp_desc, list, Some txt) + | innerExpression -> (innerExpression, list, None) + in + + + let argToType types (name, _default, _noLabelName, _alias, loc, type_) = match (type_, name) with + | (Some type_, name) when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + | (None, name) when isOptional name -> + (getLabel name, [], { + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + 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 + in + + let argToConcreteType types (name, loc, type_) = match name with + | name when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + (* return value *) + | _ -> types + in + + let nestedModules = ref([]) in + let transformComponentDefinition mapper structure returnStructures = match structure with + (* external *) + | ({ + pstr_loc; + pstr_desc = Pstr_primitive ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as pstr_desc) + } 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, loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = makePropsExternal fnName pstr_loc (( + optional "key", + pstr_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + pstr with pstr_desc = Pstr_primitive { + pstr_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + (* let component = ... *) + | { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + valueBindings + ) + } -> + let mapBinding binding = if (hasAttrOnBinding binding) then + let fnName = getFnName binding in + let modifiedBinding binding = + let expression = binding.pvb_expr in + let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in + let rec spelunkForFunExpression expression = (match expression with + (* let make = (~prop) => ... *) + | { + pexp_desc = Pexp_fun _ + } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression) + (* let make = {let foo = bar in (~prop) => ...} *) + | { + pexp_desc = Pexp_let (recursive, vbs, returnExpression) + } -> + (* here's where we spelunk! *) + let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in + ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = Pexp_apply (wrapperExpression, [(nolabel, innerFunctionExpression)]) + } -> + let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in + ((fun expressionDesc -> { + expression with pexp_desc = + Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)]) + }), + realReturnExpression + ) + | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).") + ) in + let (wrapExpression, expression) = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, expression) + in + let (bindingWrapper, expression) = modifiedBinding binding in + let reactComponentAttribute = try + Some(List.find hasAttr binding.pvb_attributes) + with | Not_found -> None in + let payload = match reactComponentAttribute with + (* TODO: in some cases this is a better loc than pstr_loc *) + | Some (_loc, payload) -> Some payload + | None -> None in + let props = getPropsAttr payload in + (* do stuff here! *) + let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in + let namedArgListWithKeyAndRef = (optional("key"), None, None, "key", pstr_loc, None) :: namedArgList in + let namedArgListWithKeyAndRef = match forwardRef with + | Some(_) -> (optional("ref"), None, None, "ref", pstr_loc, None) :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let externalDecl = makeExternalDecl fnName pstr_loc namedArgListWithKeyAndRef namedTypeList in + let makeLet innerExpression (label, default, _, alias, loc, _type) = + let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in + let expression = (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 expression = match (label, default) with + | (label, Some default) when isOptional label -> Exp.match_ expression [ + Exp.case + (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc}))) + (Exp.ident ~loc {txt = (Lident labelString); loc}); + Exp.case + (Pat.construct {loc; txt=Lident "None"} None) + default + ] + | _ -> expression in + let letExpression = Vb.mk + (Pat.var ~loc {txt = alias; loc}) + expression in + Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in + let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in + let innerExpressionWithRef = match (forwardRef) with + | Some txt -> + {innerExpression with pexp_desc = Pexp_fun (nolabel, None, { + ppat_desc = Ppat_var { txt; loc = pstr_loc }; + ppat_loc = pstr_loc; + ppat_attributes = []; + }, innerExpression)} + | None -> innerExpression + in + let fullExpression = (Pexp_fun ( + nolabel, + None, + { + ppat_desc = Ppat_constraint ( + makePropsName ~loc:pstr_loc props.propsName, + makePropsType ~loc:pstr_loc namedTypeList + ); + ppat_loc = pstr_loc; + ppat_attributes = []; + }, + innerExpressionWithRef + )) in + let fileName = filenameFromLoc pstr_loc in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let fullExpression = match (fullModuleName) with + | ("") -> fullExpression + | (txt) -> Pexp_let ( + Nonrecursive, + [Vb.mk + ~loc:pstr_loc + (Pat.var ~loc:pstr_loc {loc = pstr_loc; txt}) + (Exp.mk ~loc:pstr_loc fullExpression) + ], + (Exp.ident ~loc:pstr_loc {loc = pstr_loc; txt = Lident txt}) + ) + in + let newBinding = bindingWrapper fullExpression in + (Some externalDecl, newBinding) + else + (None, binding) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding) (externs, bindings) = + let externs = match extern with + | Some extern -> extern :: externs + | None -> externs in + (externs, binding :: bindings) + in + let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in + externs @ { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + bindings + ) + } :: returnStructures + | structure -> structure :: returnStructures in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] in + + let transformComponentSignature mapper signature returnSignatures = match signature with + | ({ + psig_loc; + psig_desc = Psig_value ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as psig_desc) + } as psig) -> + (match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + (match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_)::types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_)::types) + | _ -> (fullType, types)) + in + let (innerType, propTypes) = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = makePropsExternalSig fnName psig_loc (( + optional "key", + psig_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + psig with psig_desc = Psig_value { + psig_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + | signature -> signature :: returnSignatures in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] in + + + let transformJsxCall mapper callExpression callArguments attrs = + (match callExpression.pexp_desc with + | Pexp_ident caller -> + (match caller with + | {txt = Lident "createElement"} -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> + (match !jsxVersion with + | None + | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments + | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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 2 -> transformLowercaseCall mapper loc attrs callArguments id + | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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." + ) + ) in + + let signature = + (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in + + let structure = + (fun mapper structure -> match structure with + (* + match against [@bs.config {foo, jsx: ...}] at the file-level. This + indicates which version of JSX we're using. This code stays here because + we used to have 2 versions of JSX PPX (and likely will again in the + future when JSX PPX changes). So the architecture for switching between + JSX behavior stayed here. To create a new JSX ppx, copy paste this + entire file and change the relevant parts. + + Description of architecture: in bucklescript's bsconfig.json, you can + specify a project-wide JSX version. You can also specify a file-level + JSX version. This degree of freedom allows a person to convert a project + one file at time onto the new JSX, when it was released. It also enabled + a project to depend on a third-party which is still using an old version + of JSX + *) + | { + pstr_loc; + pstr_desc = Pstr_attribute ( + ({txt = "bs.config"} as bsConfigLabel), + PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord] + ) + }::restOfStructure -> begin + let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in + match (jsxField, recordFieldsWithoutJsx) with + (* no file-level jsx config found *) + | ([], _) -> default_mapper.structure mapper structure + (* {jsx: 2} *) + | ((_, {pexp_desc = Pexp_constant (Pconst_integer (version, None)})::rest, recordFieldsWithoutJsx) -> begin + (match version with + | 2 -> jsxVersion := Some 2 + | 3 -> jsxVersion := Some 3 + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3")); + match recordFieldsWithoutJsx with + (* record empty now, remove the whole bs.config attribute *) + | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure + | fields -> default_mapper.structure mapper ({ + pstr_loc; + pstr_desc = Pstr_attribute ( + bsConfigLabel, + PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}] + ) + }::(reactComponentTransform mapper restOfStructure)) + end + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") + end + | structures -> begin + default_mapper.structure mapper @@ reactComponentTransform mapper structures + end + ) in + + let expr = + (fun 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 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) in + + let module_binding = + (fun 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 + ) in + + { default_mapper with structure; expr; signature; module_binding; } + + +(* #if BS_COMPILER_IN_BROWSER then + +module Js = struct + module Unsafe = struct + type any + external inject : 'a -> any = "%identity" + external get : 'a -> 'b -> 'c = "caml_js_get" + external set : 'a -> 'b -> 'c -> unit = "caml_js_set" + external pure_js_expr : string -> 'a = "caml_pure_js_expr" + let global = pure_js_expr "joo_global_object" + external obj : (string * any) array -> 'a = "caml_js_object" + end + type (-'a, +'b) meth_callback + type 'a callback = (unit, 'a) meth_callback + external wrap_meth_callback : ('a -> 'b) -> ('a, 'b) meth_callback = "caml_js_wrap_meth_callback" + type + 'a t + type js_string + external string : string -> js_string t = "caml_js_from_string" + external to_string : js_string t -> string = "caml_js_to_string" +end + +(* keep in sync with jscomp/core/jsoo_main.ml `let implementation` *) +let rewrite code = + let mapper = jsxMapper () in + Location.input_name := "//toplevel//"; + try + let lexer = Lexing.from_string code in + let pstr = Parse.implementation lexer in + let pstr = mapper.structure mapper pstr in + let buffer = Buffer.create 1000 in + Pprintast.structure Format.str_formatter pstr; + let ocaml_code = Format.flush_str_formatter () in + Js.Unsafe.(obj [| "ocaml_code", inject @@ Js.string ocaml_code |]) + with e -> + match Location.error_of_exn e with + | Some error -> + Location.report_error Format.err_formatter error; + let (file, line, startchar) = Location.get_pos_info error.loc.loc_start in + let (file, endline, endchar) = Location.get_pos_info error.loc.loc_end in + Js.Unsafe.(obj + [| + "ppx_error_msg", inject @@ Js.string (Printf.sprintf "Line %d, %d: %s" line startchar error.msg); + "row", inject (line - 1); + "column", inject startchar; + "endRow", inject (endline - 1); + "endColumn", inject endchar; + "text", inject @@ Js.string error.msg; + "type", inject @@ Js.string "error"; + |] + ) + | None -> + Js.Unsafe.(obj [| + "js_error_msg" , inject @@ Js.string (Printexc.to_string e) + |]) + +let export (field : string) v = + Js.Unsafe.set (Js.Unsafe.global) field v + +let make_ppx name = + export name + (Js.Unsafe.(obj + [|"rewrite", + inject @@ + Js.wrap_meth_callback + (fun _ code -> rewrite (Js.to_string code)); + |])) + +let () = make_ppx "jsxv2" *) + +(* #else *) +let () = Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) +(* #end *) diff --git a/lib/4.06.1/reactjs_jsx_ppx_v3.ml b/lib/4.06.1/reactjs_jsx_ppx_v3.ml new file mode 100644 index 0000000000..af2fdceae5 --- /dev/null +++ b/lib/4.06.1/reactjs_jsx_ppx_v3.ml @@ -0,0 +1,1021 @@ +(* + This is the file 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 BuckleScript'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|])` +*) + +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l +let nolabel = Nolabel +let labelled str = Labelled str +let optional str = Optional str +let isOptional str = match str with +| Optional _ -> true +| _ -> false +let isLabelled str = match str with +| Labelled _ -> true +| _ -> false +let getLabel str = match str with +| Optional str | Labelled str -> str +| Nolabel -> "" + +let argIsKeyRef = function + | (Labelled ("key" | "ref"), _) | (Optional ("key" | "ref"), _) -> true + | _ -> false +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) +let safeTypeFromValue valueStr = +let valueStr = getLabel valueStr in +match String.sub valueStr 0 1 with +| "_" -> "T" ^ valueStr +| _ -> valueStr + +type 'a children = | ListLiteral of 'a | Exact of 'a +type componentConfig = { + propsName: string; +} + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> begin + match accum with + | [singleElement] -> Exact singleElement + | accum -> ListLiteral (List.rev accum |> Exp.array ~loc) + end + | {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)} -> + List.rev accum |> Exp.array ~loc + | {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) + in + let allButLast lst = allButLast_ lst [] |> List.rev 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") + +(* 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 + +(* Filter the [@react.component] attribute and immutably replace them on the binding *) +let filterAttrOnBinding binding = {binding with pvb_attributes = List.filter otherAttrsPure binding.pvb_attributes} + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | {pvb_pat = { + ppat_desc = Ppat_var {txt} + }} -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + +(* 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)) + +(* 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 + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelLocType (label, _, _, _, loc, type_) = (label, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc: Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | fileName -> fileName + in + let fileName = try + Filename.chop_extension (Filename.basename fileName) + with | Invalid_argument _-> fileName in + let fileName = String.capitalize_ascii fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | ("", nestedModules, "make") -> nestedModules + | ("", nestedModules, fnName) -> List.rev (fnName :: nestedModules) + | (fileName, nestedModules, "make") -> fileName :: (List.rev nestedModules) + | (fileName, nestedModules, fnName) -> fileName :: (List.rev (fnName :: nestedModules)) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, loc, type_)::tl -> + recursivelyMakeNamedArgsForExternal tl (Typ.arrow + ~loc + label + (match (label, type_) with + | (label, None) when isOptional label -> { + ptyp_loc = loc; + ptyp_attributes = []; + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + }]); + } + | (label, None) when isLabelled label -> { + ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_loc = loc; + ptyp_attributes = []; + } + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Ldot (Lident "*predef*","option"))}, _)} as type_)) when isOptional label -> + type_ + | (label, Some ({ptyp_desc = Ptyp_constr ({txt=(Lident "option")}, [type_])})) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (label, Some (type_)) when isOptional label -> { + type_ with + ptyp_desc = Ptyp_constr ({loc=type_.ptyp_loc; txt=(Ldot (Lident "*predef*","option"))}, [type_]); + } + | (_, Some type_) -> type_ + | (_, None) -> raise (Invalid_argument "This should never happen..") + ) + args) + | [] -> args + +(* 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 = loc}, PStr [])]; + pval_loc = loc; +} + +(* 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) + } + +(* 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) + } + +(* Build an AST node for the props name when converted to a Js.t 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" Js.t object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc ( + Ptyp_constr({txt= Ldot (Lident("Js"), "t"); loc}, [{ + ptyp_desc = Ptyp_object( + List.map (makeObjectField loc) namedTypeList, + Closed + ); + ptyp_loc = loc; + ptyp_attributes = []; + }]) + ) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal + fnName + loc + (List.map pluckLabelLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + +(* 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 in let capped = String.uppercase_ascii first in first = capped 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) + ])) + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let (children, nonChildrenProps) = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({txt = Lident "[]"}, None) + } -> "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> raise (Invalid_argument "A spread as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + in + let args = match nonChildrenProps with + | [_justTheUnitArgumentAtEnd] -> + [ + (* "div" *) + (nolabel, componentNameExpr); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] + | nonEmptyProps -> + let propsCall = + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let transformUppercaseCall modulePath mapper loc attrs _ callArguments = + let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in + let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in + let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *) + Exp.apply + ~loc + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")}) + (argsKeyRef @ [(nolabel, e)]) in + Exp.apply + ~loc + ~attrs + (* Foo.make *) + (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")}) + args + |> wrapWithReasonReactElement in + + let transformLowercaseCall 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) + } -> "createElement" + (* [@JSX] div(~children=[|a|]), coming from
...[|a|]
*) + | { pexp_desc = (Pexp_array _) } -> + raise (Invalid_argument "A spread + an array literal as a DOM element's \ + children would cancel each other out, and thus don't make sense written \ + together. You can simply remove the spread and the array literal.") + (* [@JSX] div(~children=
), coming from
...
*) + | { + pexp_attributes + } when pexp_attributes |> List.exists (fun (attribute, _) -> attribute.txt = "JSX") -> + raise (Invalid_argument "A spread + a JSX literal as a DOM element's \ + children don't make sense written together. You can simply remove the spread.") + | _ -> "createElementVariadic" + 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", "props")}) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr) + ] in + Exp.apply + ~loc + (* throw away the [@JSX] attribute and keep the others, if any *) + ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + args + in + + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun (Labelled "key", _, _, _) + | Pexp_fun (Optional "key", _, _, _) -> raise (Invalid_argument "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its parent!") + | Pexp_fun (Labelled "ref", _, _, _) + | Pexp_fun (Optional "ref", _, _, _) -> raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") + | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> + let 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, None, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (nolabel, _, { ppat_desc = (Ppat_construct ({txt = Lident "()"}, _) | Ppat_any)}, expression) -> + (expression.pexp_desc, list, None) + | Pexp_fun (nolabel, _, { ppat_desc = Ppat_var ({txt})}, expression) -> + (expression.pexp_desc, list, Some txt) + | innerExpression -> (innerExpression, list, None) + in + + + let argToType types (name, _default, _noLabelName, _alias, loc, type_) = match (type_, name) with + | (Some type_, name) when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + | (None, name) when isOptional name -> + (getLabel name, [], { + ptyp_desc = Ptyp_constr ({loc; txt=(Ldot (Lident "*predef*","option"))}, [{ + 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 + in + + let argToConcreteType types (name, loc, type_) = match name with + | name when isLabelled name || isOptional name -> + (getLabel name, [], type_) :: types + (* return value *) + | _ -> types + in + + let nestedModules = ref([]) in + let transformComponentDefinition mapper structure returnStructures = match structure with + (* external *) + | ({ + pstr_loc; + pstr_desc = Pstr_primitive ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as pstr_desc) + } 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, loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = makePropsExternal fnName pstr_loc (( + optional "key", + pstr_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = pstr_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + pstr with pstr_desc = Pstr_primitive { + pstr_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + (* let component = ... *) + | { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + valueBindings + ) + } -> + let mapBinding binding = if (hasAttrOnBinding binding) then + let fnName = getFnName binding in + let modifiedBinding binding = + let expression = binding.pvb_expr in + let wrapExpressionWithBinding expressionFn expression = {(filterAttrOnBinding binding) with pvb_expr = expressionFn expression} in + let rec spelunkForFunExpression expression = (match expression with + (* let make = (~prop) => ... *) + | { + pexp_desc = Pexp_fun _ + } -> ((fun expressionDesc -> {expression with pexp_desc = expressionDesc}), expression) + (* let make = {let foo = bar in (~prop) => ...} *) + | { + pexp_desc = Pexp_let (recursive, vbs, returnExpression) + } -> + (* here's where we spelunk! *) + let (wrapExpression, realReturnExpression) = spelunkForFunExpression returnExpression in + ((fun expressionDesc -> {expression with pexp_desc = Pexp_let (recursive, vbs, wrapExpression expressionDesc)}), realReturnExpression) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = Pexp_apply (wrapperExpression, [(nolabel, innerFunctionExpression)]) + } -> + let (wrapExpression, realReturnExpression) = spelunkForFunExpression innerFunctionExpression in + ((fun expressionDesc -> { + expression with pexp_desc = + Pexp_apply (wrapperExpression, [(nolabel, wrapExpression expressionDesc)]) + }), + realReturnExpression + ) + | _ -> raise (Invalid_argument "react.component calls can only be on function definitions or component wrappers (forwardRef, memo).") + ) in + let (wrapExpression, expression) = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, expression) + in + let (bindingWrapper, expression) = modifiedBinding binding in + let reactComponentAttribute = try + Some(List.find hasAttr binding.pvb_attributes) + with | Not_found -> None in + let payload = match reactComponentAttribute with + (* TODO: in some cases this is a better loc than pstr_loc *) + | Some (_loc, payload) -> Some payload + | None -> None in + let props = getPropsAttr payload in + (* do stuff here! *) + let (innerFunctionExpression, namedArgList, forwardRef) = recursivelyTransformNamedArgsForMake mapper expression [] in + let namedArgListWithKeyAndRef = (optional("key"), None, None, "key", pstr_loc, None) :: namedArgList in + let namedArgListWithKeyAndRef = match forwardRef with + | Some(_) -> (optional("ref"), None, None, "ref", pstr_loc, None) :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let externalDecl = makeExternalDecl fnName pstr_loc namedArgListWithKeyAndRef namedTypeList in + let makeLet innerExpression (label, default, _, alias, loc, _type) = + let labelString = (match label with | label when isOptional label || isLabelled label -> getLabel label | _ -> raise (Invalid_argument "This should never happen")) in + let expression = (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 expression = match (label, default) with + | (label, Some default) when isOptional label -> Exp.match_ expression [ + Exp.case + (Pat.construct {loc; txt=Lident "Some"} (Some (Pat.var ~loc {txt = labelString; loc}))) + (Exp.ident ~loc {txt = (Lident labelString); loc}); + Exp.case + (Pat.construct {loc; txt=Lident "None"} None) + default + ] + | _ -> expression in + let letExpression = Vb.mk + (Pat.var ~loc {txt = alias; loc}) + expression in + Exp.let_ ~loc Nonrecursive [letExpression] innerExpression in + let innerExpression = List.fold_left makeLet (Exp.mk innerFunctionExpression) namedArgList in + let innerExpressionWithRef = match (forwardRef) with + | Some txt -> + {innerExpression with pexp_desc = Pexp_fun (nolabel, None, { + ppat_desc = Ppat_var { txt; loc = pstr_loc }; + ppat_loc = pstr_loc; + ppat_attributes = []; + }, innerExpression)} + | None -> innerExpression + in + let fullExpression = (Pexp_fun ( + nolabel, + None, + { + ppat_desc = Ppat_constraint ( + makePropsName ~loc:pstr_loc props.propsName, + makePropsType ~loc:pstr_loc namedTypeList + ); + ppat_loc = pstr_loc; + ppat_attributes = []; + }, + innerExpressionWithRef + )) in + let fileName = filenameFromLoc pstr_loc in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let fullExpression = match (fullModuleName) with + | ("") -> fullExpression + | (txt) -> Pexp_let ( + Nonrecursive, + [Vb.mk + ~loc:pstr_loc + (Pat.var ~loc:pstr_loc {loc = pstr_loc; txt}) + (Exp.mk ~loc:pstr_loc fullExpression) + ], + (Exp.ident ~loc:pstr_loc {loc = pstr_loc; txt = Lident txt}) + ) + in + let newBinding = bindingWrapper fullExpression in + (Some externalDecl, newBinding) + else + (None, binding) + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding) (externs, bindings) = + let externs = match extern with + | Some extern -> extern :: externs + | None -> externs in + (externs, binding :: bindings) + in + let (externs, bindings) = List.fold_right otherStructures structuresAndBinding ([], []) in + externs @ { + pstr_loc; + pstr_desc = Pstr_value ( + recFlag, + bindings + ) + } :: returnStructures + | structure -> structure :: returnStructures in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] in + + let transformComponentSignature mapper signature returnSignatures = match signature with + | ({ + psig_loc; + psig_desc = Psig_value ({ + pval_name = { txt = fnName }; + pval_attributes; + pval_type; + } as psig_desc) + } as psig) -> + (match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [_] -> + let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + (match ptyp_desc with + | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) when isOptional name || isLabelled name -> + getPropTypes ((name, ptyp_loc, type_)::types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> + getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_)::types) + | _ -> (fullType, types)) + in + let (innerType, propTypes) = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = makePropsExternalSig fnName psig_loc (( + optional "key", + psig_loc, + None + ) :: List.map pluckLabelAndLoc propTypes) retPropsType in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = Ptyp_constr ( + {loc = psig_loc; txt = Ldot ((Lident "React"), "componentLike")}, + [retPropsType; innerType] + ) in + let newStructure = { + psig with psig_desc = Psig_value { + psig_desc with pval_type = { + pval_type with ptyp_desc = newExternalType; + }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + } + } in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time")) + | signature -> signature :: returnSignatures in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] in + + + let transformJsxCall mapper callExpression callArguments attrs = + (match callExpression.pexp_desc with + | Pexp_ident caller -> + (match caller with + | {txt = Lident "createElement"} -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> + (match !jsxVersion with + | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments + | None + | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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 + | Some 2 -> transformLowercaseCall mapper loc attrs callArguments id + | None + | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2 or 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." + ) + ) in + + let signature = + (fun mapper signature -> default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature) in + + let structure = + (fun mapper structure -> match structure with + (* + match against [@bs.config {foo, jsx: ...}] at the file-level. This + indicates which version of JSX we're using. This code stays here because + we used to have 2 versions of JSX PPX (and likely will again in the + future when JSX PPX changes). So the architecture for switching between + JSX behavior stayed here. To create a new JSX ppx, copy paste this + entire file and change the relevant parts. + + Description of architecture: in bucklescript's bsconfig.json, you can + specify a project-wide JSX version. You can also specify a file-level + JSX version. This degree of freedom allows a person to convert a project + one file at time onto the new JSX, when it was released. It also enabled + a project to depend on a third-party which is still using an old version + of JSX + *) + | { + pstr_loc; + pstr_desc = Pstr_attribute ( + ({txt = "bs.config"} as bsConfigLabel), + PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord] + ) + }::restOfStructure -> begin + let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in + match (jsxField, recordFieldsWithoutJsx) with + (* no file-level jsx config found *) + | ([], _) -> default_mapper.structure mapper structure + (* {jsx: 2} *) + | ((_, {pexp_desc = Pexp_constant (Pconst_integer (version, None)})::rest, recordFieldsWithoutJsx) -> begin + (match version with + | 2 -> jsxVersion := Some 2 + | 3 -> jsxVersion := Some 3 + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2 or 3")); + match recordFieldsWithoutJsx with + (* record empty now, remove the whole bs.config attribute *) + | [] -> default_mapper.structure mapper @@ reactComponentTransform mapper restOfStructure + | fields -> default_mapper.structure mapper ({ + pstr_loc; + pstr_desc = Pstr_attribute ( + bsConfigLabel, + PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}] + ) + }::(reactComponentTransform mapper restOfStructure)) + end + | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") + end + | structures -> begin + default_mapper.structure mapper @@ reactComponentTransform mapper structures + end + ) in + + let expr = + (fun 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 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) in + + let module_binding = + (fun 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 + ) in + + { default_mapper with structure; expr; signature; module_binding; } + + +(* #if BS_COMPILER_IN_BROWSER then + +module Js = struct + module Unsafe = struct + type any + external inject : 'a -> any = "%identity" + external get : 'a -> 'b -> 'c = "caml_js_get" + external set : 'a -> 'b -> 'c -> unit = "caml_js_set" + external pure_js_expr : string -> 'a = "caml_pure_js_expr" + let global = pure_js_expr "joo_global_object" + external obj : (string * any) array -> 'a = "caml_js_object" + end + type (-'a, +'b) meth_callback + type 'a callback = (unit, 'a) meth_callback + external wrap_meth_callback : ('a -> 'b) -> ('a, 'b) meth_callback = "caml_js_wrap_meth_callback" + type + 'a t + type js_string + external string : string -> js_string t = "caml_js_from_string" + external to_string : js_string t -> string = "caml_js_to_string" +end + +(* keep in sync with jscomp/core/jsoo_main.ml `let implementation` *) +let rewrite code = + let mapper = jsxMapper () in + Location.input_name := "//toplevel//"; + try + let lexer = Lexing.from_string code in + let pstr = Parse.implementation lexer in + let pstr = mapper.structure mapper pstr in + let buffer = Buffer.create 1000 in + Pprintast.structure Format.str_formatter pstr; + let ocaml_code = Format.flush_str_formatter () in + Js.Unsafe.(obj [| "ocaml_code", inject @@ Js.string ocaml_code |]) + with e -> + match Location.error_of_exn e with + | Some error -> + Location.report_error Format.err_formatter error; + let (file, line, startchar) = Location.get_pos_info error.loc.loc_start in + let (file, endline, endchar) = Location.get_pos_info error.loc.loc_end in + Js.Unsafe.(obj + [| + "ppx_error_msg", inject @@ Js.string (Printf.sprintf "Line %d, %d: %s" line startchar error.msg); + "row", inject (line - 1); + "column", inject startchar; + "endRow", inject (endline - 1); + "endColumn", inject endchar; + "text", inject @@ Js.string error.msg; + "type", inject @@ Js.string "error"; + |] + ) + | None -> + Js.Unsafe.(obj [| + "js_error_msg" , inject @@ Js.string (Printexc.to_string e) + |]) + +let export (field : string) v = + Js.Unsafe.set (Js.Unsafe.global) field v + +let make_ppx name = + export name + (Js.Unsafe.(obj + [|"rewrite", + inject @@ + Js.wrap_meth_callback + (fun _ code -> rewrite (Js.to_string code)); + |])) + +let () = make_ppx "jsxv2" *) + +(* #else *) +let () = Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) +(* #end *) diff --git a/lib/4.06.1/reactjs_jsx_ppx_v3.mli b/lib/4.06.1/reactjs_jsx_ppx_v3.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/lib/body.ninja b/lib/body.ninja index 308c23e87c..4c4209c02f 100644 --- a/lib/body.ninja +++ b/lib/body.ninja @@ -20,5 +20,6 @@ build refmt$ext: cc $INCL/refmt_main3.mli $INCL/refmt_main3.ml flags = $flags -w -40-30 -no-alias-deps -I +compiler-libs ocamlcommon.cmxa build reactjs_jsx_ppx_2$ext: cc $INCL/reactjs_jsx_ppx_v2.mli $INCL/reactjs_jsx_ppx_v2.ml flags = $flags -w -40-30 -no-alias-deps -I +compiler-libs ocamlcommon.cmxa +build reactjs_jsx_ppx_3$ext: cc $INCL/reactjs_jsx_ppx_v3.mli $INCL/reactjs_jsx_ppx_v3.ml + flags = $flags -w -40-30 -no-alias-deps -I +compiler-libs ocamlcommon.cmxa build bsc$ext: cc $INCL/whole_compiler.mli $INCL/whole_compiler.ml - diff --git a/scripts/prepublish.js b/scripts/prepublish.js index 22acaa5b01..a1d6cebbc7 100644 --- a/scripts/prepublish.js +++ b/scripts/prepublish.js @@ -26,7 +26,7 @@ function verifyIsCleanWorkTree() { } function checkWinBinary(){ - var assocs = ['bsppx', 'bsb', 'bsb_helper', 'refmt', 'reactjs_jsx_ppx_2','bsc'].map(x=>{ + var assocs = ['bsppx', 'bsb', 'bsb_helper', 'refmt', 'reactjs_jsx_ppx_2', 'reactjs_jsx_ppx_3', 'bsc'].map(x=>{ return [x, { win32 : false, darwin : false}] })