diff --git a/analysis/vendor/res_syntax/react_jsx_common.ml b/analysis/vendor/res_syntax/jsx_common.ml similarity index 88% rename from analysis/vendor/res_syntax/react_jsx_common.ml rename to analysis/vendor/res_syntax/jsx_common.ml index 51c471103..4281f0580 100644 --- a/analysis/vendor/res_syntax/react_jsx_common.ml +++ b/analysis/vendor/res_syntax/jsx_common.ml @@ -6,11 +6,14 @@ type jsxConfig = { mutable module_: string; mutable mode: string; mutable nestedModules: string list; - mutable hasReactComponent: bool; + mutable hasComponent: bool; } (* Helper method to look up the [@react.component] attribute *) -let hasAttr (loc, _) = loc.txt = "react.component" +let hasAttr (loc, _) = + match loc.txt with + | "react.component" | "jsx.component" -> true + | _ -> false (* Iterate over the attributes and try to find the [@react.component] attribute *) let hasAttrOnBinding {pvb_attributes} = @@ -20,7 +23,7 @@ let coreTypeOfAttrs attributes = List.find_map (fun ({txt}, payload) -> match (txt, payload) with - | "react.component", PTyp coreType -> Some coreType + | ("react.component" | "jsx.component"), PTyp coreType -> Some coreType | _ -> None) attributes @@ -37,7 +40,7 @@ let typVarsOfCoreType {ptyp_desc} = let raiseError ~loc msg = Location.raise_errorf ~loc msg -let raiseErrorMultipleReactComponent ~loc = +let raiseErrorMultipleComponent ~loc = raiseError ~loc "Only one component definition is allowed for each module. Move to a \ submodule or other file if necessary." diff --git a/analysis/vendor/res_syntax/reactjs_jsx_ppx.ml b/analysis/vendor/res_syntax/jsx_ppx.ml similarity index 88% rename from analysis/vendor/res_syntax/reactjs_jsx_ppx.ml rename to analysis/vendor/res_syntax/jsx_ppx.ml index f6449a6cc..e362a9c0a 100644 --- a/analysis/vendor/res_syntax/reactjs_jsx_ppx.ml +++ b/analysis/vendor/res_syntax/jsx_ppx.ml @@ -50,8 +50,8 @@ let updateConfig config payload = let fields = getPayloadFields payload in (match getInt ~key:"version" fields with | None -> () - | Some i -> config.React_jsx_common.version <- i); - (match getString ~key:"module" fields with + | Some i -> config.Jsx_common.version <- i); + (match getString ~key:"module_" fields with | None -> () | Some s -> config.module_ <- s); match getString ~key:"mode" fields with @@ -68,7 +68,7 @@ let getMapper ~config = Reactjs_jsx_v3.jsxMapper ~config in let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 = - Reactjs_jsx_v4.jsxMapper ~config + Jsx_v4.jsxMapper ~config in let expr mapper e = @@ -89,18 +89,18 @@ let getMapper ~config = version = config.version; module_ = config.module_; mode = config.mode; - hasReactComponent = config.hasReactComponent; + hasComponent = config.hasComponent; } in let restoreConfig oldConfig = - config.version <- oldConfig.React_jsx_common.version; + config.version <- oldConfig.Jsx_common.version; config.module_ <- oldConfig.module_; config.mode <- oldConfig.mode; - config.hasReactComponent <- oldConfig.hasReactComponent + config.hasComponent <- oldConfig.hasComponent in let signature mapper items = let oldConfig = saveConfig () in - config.hasReactComponent <- false; + config.hasComponent <- false; let result = List.map (fun item -> @@ -119,7 +119,7 @@ let getMapper ~config = in let structure mapper items = let oldConfig = saveConfig () in - config.hasReactComponent <- false; + config.hasComponent <- false; let result = List.map (fun item -> @@ -143,11 +143,11 @@ let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode (code : Parsetree.structure) : Parsetree.structure = let config = { - React_jsx_common.version = jsxVersion; + Jsx_common.version = jsxVersion; module_ = jsxModule; mode = jsxMode; nestedModules = []; - hasReactComponent = false; + hasComponent = false; } in let mapper = getMapper ~config in @@ -157,11 +157,11 @@ let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode (code : Parsetree.signature) : Parsetree.signature = let config = { - React_jsx_common.version = jsxVersion; + Jsx_common.version = jsxVersion; module_ = jsxModule; mode = jsxMode; nestedModules = []; - hasReactComponent = false; + hasComponent = false; } in let mapper = getMapper ~config in diff --git a/analysis/vendor/res_syntax/reactjs_jsx_ppx.mli b/analysis/vendor/res_syntax/jsx_ppx.mli similarity index 100% rename from analysis/vendor/res_syntax/reactjs_jsx_ppx.mli rename to analysis/vendor/res_syntax/jsx_ppx.mli diff --git a/analysis/vendor/res_syntax/reactjs_jsx_v4.ml b/analysis/vendor/res_syntax/jsx_v4.ml similarity index 90% rename from analysis/vendor/res_syntax/reactjs_jsx_v4.ml rename to analysis/vendor/res_syntax/jsx_v4.ml index 1801edd01..5246bbd31 100644 --- a/analysis/vendor/res_syntax/reactjs_jsx_v4.ml +++ b/analysis/vendor/res_syntax/jsx_v4.ml @@ -4,6 +4,8 @@ open Asttypes open Parsetree open Longident +let moduleAccessName config = String.capitalize_ascii config.Jsx_common.module_ + let nolabel = Nolabel let labelled str = Labelled str @@ -27,7 +29,7 @@ let getLabel str = | Optional str | Labelled str -> str | Nolabel -> "" -let optionalAttrs = [React_jsx_common.optionalAttr] +let optionalAttrs = [Jsx_common.optionalAttr] let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) @@ -93,7 +95,7 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in @@ -110,13 +112,16 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [(_, childrenExpr)], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: somehow there's more than one `children` label" let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) -let otherAttrsPure (loc, _) = loc.txt <> "react.component" +let otherAttrsPure (loc, _) = + match loc.txt with + | "react.component" | "jsx.component" -> false + | _ -> true (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) let rec getFnName binding = @@ -124,8 +129,8 @@ let rec getFnName binding = | {ppat_desc = Ppat_var {txt}} -> txt | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." + Jsx_common.raiseError ~loc:ppat_loc + "JSX component calls cannot be destructured." let makeNewBinding binding expression newName = match binding with @@ -138,8 +143,8 @@ let makeNewBinding binding expression newName = pvb_attributes = [merlinFocus]; } | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." + Jsx_common.raiseError ~loc:pvb_loc + "JSX component calls cannot be destructured." (* 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) = @@ -184,7 +189,7 @@ let recordFromProps ~loc ~removeKey callArguments = | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | ((Labelled txt, {pexp_loc}) as prop) :: rest | ((Optional txt, {pexp_loc}) as prop) :: rest -> @@ -192,7 +197,7 @@ let recordFromProps ~loc ~removeKey callArguments = match acc with | [] -> removeLastPositionUnitAux rest (prop :: acc) | _ -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "JSX: use {...p} {x: v} not {x: v} {...p} \n\ \ multiple spreads {...p} {...p} not allowed." else removeLastPositionUnitAux rest (prop :: acc) @@ -297,8 +302,7 @@ let makeLabelDecls namedTypeList = | hd :: tl -> if mem_label hd tl then let _, label, _, loc, _ = hd in - React_jsx_common.raiseError ~loc "JSX: found the duplicated prop `%s`" - label + Jsx_common.raiseError ~loc "JSX: found the duplicated prop `%s`" label else checkDuplicatedLabel tl in let () = namedTypeList |> List.rev |> checkDuplicatedLabel in @@ -374,13 +378,16 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc | ListLiteral expression -> ( (* this is a hack to support react components that introspect into their children *) childrenArg := Some expression; - match config.React_jsx_common.mode with + match config.Jsx_common.mode with | "automatic" -> [ ( labelled "children", Exp.apply (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) + { + txt = Ldot (Lident (moduleAccessName config), "array"); + loc = Location.none; + }) [(Nolabel, expression)] ); ] | _ -> @@ -424,16 +431,31 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc match (!childrenArg, keyProp) with | None, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxKeyed")}, + { + loc = Location.none; + txt = Ldot (Lident (moduleAccessName config), "jsxKeyed"); + }, [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsx")}, []) + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident (moduleAccessName config), "jsx"); + }, + [] ) | Some _, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "jsxsKeyed")}, + { + loc = Location.none; + txt = Ldot (Lident (moduleAccessName config), "jsxsKeyed"); + }, [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "jsxs")}, + ( Exp.ident + { + loc = Location.none; + txt = Ldot (Lident (moduleAccessName config), "jsxs"); + }, [] ) in Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr @@ -474,9 +496,15 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs callArguments id = let componentNameExpr = constantString ~loc:callExprLoc id in - match config.React_jsx_common.mode with + match config.Jsx_common.mode with (* the new jsx transform *) | "automatic" -> + let elementBinding = + match moduleAccessName config with + | "React" -> Lident "ReactDOM" + | generic -> Ldot (Lident generic, "DOM") + in + let children, nonChildrenProps = extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments in @@ -498,7 +526,7 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs Exp.apply ~attrs:optionalAttrs (Exp.ident { - txt = Ldot (Lident "ReactDOM", "someElement"); + txt = Ldot (elementBinding, "someElement"); loc = Location.none; }) [(Nolabel, children)] ); @@ -511,7 +539,10 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs ( labelled "children", Exp.apply (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) + { + txt = Ldot (Lident (moduleAccessName config), "array"); + loc = Location.none; + }) [(Nolabel, expression)] ); ] in @@ -531,17 +562,16 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs match (!childrenArg, keyProp) with | None, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxKeyed")}, + {loc = Location.none; txt = Ldot (elementBinding, "jsxKeyed")}, [key; (nolabel, unitExpr ~loc:Location.none)] ) | None, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsx")}, - [] ) + (Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsx")}, []) | Some _, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxsKeyed")}, + {loc = Location.none; txt = Ldot (elementBinding, "jsxsKeyed")}, [key; (nolabel, unitExpr ~loc:Location.none)] ) | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (Lident "ReactDOM", "jsxs")}, + ( Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsxs")}, [] ) in Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr @@ -562,7 +592,7 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "A spread as a DOM element's children don't make sense written \ together. You can simply remove the spread." in @@ -601,11 +631,11 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raiseError ~loc:expr.pexp_loc "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", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raiseError ~loc:expr.pexp_loc "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ instead." | Pexp_fun (arg, default, pattern, expression) @@ -628,7 +658,7 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = (Preprocessor (Printf.sprintf "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" + `option`. Did you mean `option<%s>=?`?" currentType))) | _ -> () in @@ -721,18 +751,18 @@ let argToConcreteType types (name, attrs, loc, type_) = let check_string_int_attribute_iter = let attribute _ ({txt; loc}, _) = if txt = "string" || txt = "int" then - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "@string and @int attributes not supported. See \ https://github.com/rescript-lang/rescript-compiler/issues/5724" in {Ast_iterator.default_iterator with attribute} -let checkMultipleReactComponents ~config ~loc = - (* If there is another @react.component, throw error *) - if config.React_jsx_common.hasReactComponent then - React_jsx_common.raiseErrorMultipleReactComponent ~loc - else config.hasReactComponent <- true +let checkMultipleComponents ~config ~loc = + (* If there is another component, throw error *) + if config.Jsx_common.hasComponent then + Jsx_common.raiseErrorMultipleComponent ~loc + else config.hasComponent <- true let modifiedBindingOld binding = let expression = binding.pvb_expr in @@ -757,9 +787,9 @@ let modifiedBindingOld binding = | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> spelunkForFunExpression innerFunctionExpression | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions or \ - component wrappers (forwardRef, memo)." + Jsx_common.raiseError ~loc:pexp_loc + "JSX component calls can only be on function definitions or component \ + wrappers (forwardRef, memo)." in spelunkForFunExpression expression @@ -882,15 +912,13 @@ let vbMatchExpr namedArgList expr = aux (List.rev namedArgList) let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = - if React_jsx_common.hasAttrOnBinding binding then ( - checkMultipleReactComponents ~config ~loc:pstr_loc; - let binding = React_jsx_common.removeArity binding in - let coreTypeOfAttr = - React_jsx_common.coreTypeOfAttrs binding.pvb_attributes - in + if Jsx_common.hasAttrOnBinding binding then ( + checkMultipleComponents ~config ~loc:pstr_loc; + let binding = Jsx_common.removeArity binding in + let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs binding.pvb_attributes in let typVarsOfCoreType = coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.map Jsx_common.typVarsOfCoreType |> Option.value ~default:[] in let bindingLoc = binding.pvb_loc in @@ -947,7 +975,7 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) in let innerExpression = - React_jsx_common.async_component ~async:isAsync innerExpression + Jsx_common.async_component ~async:isAsync innerExpression in let fullExpression = (* React component name should start with uppercase letter *) @@ -960,15 +988,16 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = | None -> makePropsPattern namedTypeList | Some _ -> makePropsPattern typVarsOfCoreType) (if hasForwardRef then - Exp.fun_ nolabel None - (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) + Exp.fun_ nolabel None + (Pat.var @@ Location.mknoloc "ref") + innerExpression + else innerExpression) in let fullExpression = if !Config.uncurried = Uncurried then fullExpression - |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc ~arity:1 + |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc + ~arity:(if hasForwardRef then 2 else 1) else fullExpression in let fullExpression = @@ -1128,17 +1157,17 @@ let transformStructureItem ~config item = pstr_desc = Pstr_primitive ({pval_attributes; pval_type} as value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.hasAttr pval_attributes with | [] -> [item] | [_] -> - checkMultipleReactComponents ~config ~loc:pstr_loc; + checkMultipleComponents ~config ~loc:pstr_loc; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; - let pval_type = React_jsx_common.extractUncurried pval_type in - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let pval_type = Jsx_common.extractUncurried pval_type in + let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in let typVarsOfCoreType = coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.map Jsx_common.typVarsOfCoreType |> Option.value ~default:[] in let rec getPropTypes types @@ -1174,7 +1203,10 @@ let transformStructureItem ~config item = (* can't be an arrow because it will defensively uncurry *) let newExternalType = Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, + ( { + loc = pstr_loc; + txt = Ldot (Lident (moduleAccessName config), "componentLike"); + }, [retPropsType; innerType] ) in let newStructure = @@ -1191,8 +1223,8 @@ let transformStructureItem ~config item = in [propsRecordType; newStructure] | _ -> - React_jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") + Jsx_common.raiseError ~loc:pstr_loc + "Only one JSX component call can exist on a component at one time") (* let component = ... *) | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( let fileName = filenameFromLoc pstr_loc in @@ -1231,18 +1263,18 @@ let transformSignatureItem ~config item = psig_loc; psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.hasAttr pval_attributes with | [] -> [item] | [_] -> - checkMultipleReactComponents ~config ~loc:psig_loc; - let pval_type = React_jsx_common.extractUncurried pval_type in + checkMultipleComponents ~config ~loc:psig_loc; + let pval_type = Jsx_common.extractUncurried pval_type in check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; let hasForwardRef = ref false in - let coreTypeOfAttr = React_jsx_common.coreTypeOfAttrs pval_attributes in + let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in let typVarsOfCoreType = coreTypeOfAttr - |> Option.map React_jsx_common.typVarsOfCoreType + |> Option.map Jsx_common.typVarsOfCoreType |> Option.value ~default:[] in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = @@ -1282,14 +1314,17 @@ let transformSignatureItem ~config item = psig_loc ((* If there is Nolabel arg, regard the type as ref in forwardRef *) (if !hasForwardRef then - [(true, "ref", [], Location.none, refType Location.none)] - else []) + [(true, "ref", [], Location.none, refType Location.none)] + else []) @ namedTypeList) in (* can't be an arrow because it will defensively uncurry *) let newExternalType = Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, + ( { + loc = psig_loc; + txt = Ldot (Lident (moduleAccessName config), "componentLike"); + }, [retPropsType; innerType] ) in let newStructure = @@ -1306,8 +1341,8 @@ let transformSignatureItem ~config item = in [propsRecordType; newStructure] | _ -> - React_jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") + Jsx_common.raiseError ~loc:psig_loc + "Only one JSX component call can exist on a component at one time") | _ -> [item] let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc @@ -1316,7 +1351,7 @@ let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc | Pexp_ident caller -> ( match caller with | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: `createElement` should be preceeded by a module name." (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> @@ -1329,18 +1364,18 @@ let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments id | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: the JSX attribute should be attached to a \ `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ `%s` instead" anythingNotCreateElementOrMake | {txt = Lapply _; loc} -> (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: encountered a weird case while processing the code. Please \ report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc + Jsx_common.raiseError ~loc:callExpression.pexp_loc "JSX: `createElement` should be preceeded by a simple, direct module \ name." @@ -1384,7 +1419,8 @@ let expr ~config mapper expression = let fragment = match config.mode with | "automatic" -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxFragment")} + Exp.ident ~loc + {loc; txt = Ldot (Lident (moduleAccessName config), "jsxFragment")} | "classic" | _ -> Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} in @@ -1392,10 +1428,13 @@ let expr ~config mapper expression = let recordOfChildren children = Exp.record [(Location.mknoloc (Lident "children"), children)] None in - let applyReactArray expr = + let applyJsxArray expr = Exp.apply (Exp.ident - {txt = Ldot (Lident "React", "array"); loc = Location.none}) + { + txt = Ldot (Lident (moduleAccessName config), "array"); + loc = Location.none; + }) [(Nolabel, expr)] in let countOfChildren = function @@ -1410,11 +1449,11 @@ let expr ~config mapper expression = | [child] -> recordOfChildren child | _ -> ( match config.mode with - | "automatic" -> recordOfChildren @@ applyReactArray childrenExpr + | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr | "classic" | _ -> emptyRecord ~loc:Location.none)) | _ -> ( match config.mode with - | "automatic" -> recordOfChildren @@ applyReactArray childrenExpr + | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr | "classic" | _ -> emptyRecord ~loc:Location.none) in let args = @@ -1433,8 +1472,11 @@ let expr ~config mapper expression = (match config.mode with | "automatic" -> if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsxs")} - else Exp.ident ~loc {loc; txt = Ldot (Lident "React", "jsx")} + Exp.ident ~loc + {loc; txt = Ldot (Lident (moduleAccessName config), "jsxs")} + else + Exp.ident ~loc + {loc; txt = Ldot (Lident (moduleAccessName config), "jsx")} | "classic" | _ -> if countOfChildren childrenExpr > 1 then Exp.ident ~loc @@ -1445,8 +1487,7 @@ let expr ~config mapper expression = (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e -let module_binding ~(config : React_jsx_common.jsxConfig) mapper module_binding - = +let module_binding ~(config : Jsx_common.jsxConfig) mapper module_binding = config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules; let mapped = default_mapper.module_binding mapper module_binding in let () = diff --git a/analysis/vendor/res_syntax/reactjs_jsx_v3.ml b/analysis/vendor/res_syntax/reactjs_jsx_v3.ml index b1ca0e281..83316c9d5 100644 --- a/analysis/vendor/res_syntax/reactjs_jsx_v3.ml +++ b/analysis/vendor/res_syntax/reactjs_jsx_v3.ml @@ -87,7 +87,7 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in @@ -104,7 +104,7 @@ let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = | [(_, childrenExpr)], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) | _ -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: somehow there's more than one `children` label" let unerasableIgnore loc = @@ -122,7 +122,7 @@ let rec getFnName binding = | {ppat_desc = Ppat_var {txt}} -> txt | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat | {ppat_loc} -> - React_jsx_common.raiseError ~loc:ppat_loc + Jsx_common.raiseError ~loc:ppat_loc "react.component calls cannot be destructured." let makeNewBinding binding expression newName = @@ -136,7 +136,7 @@ let makeNewBinding binding expression newName = pvb_attributes = [merlinFocus]; } | {pvb_loc} -> - React_jsx_common.raiseError ~loc:pvb_loc + Jsx_common.raiseError ~loc:pvb_loc "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) @@ -145,7 +145,7 @@ let getPropsNameValue _acc (loc, exp) = | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> {propsName = str} | {txt; loc}, _ -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "react.component only accepts props as an option, given: { %s }" (Longident.last txt) @@ -170,7 +170,7 @@ let getPropsAttr payload = :: _rest)) -> {propsName = "props"} | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - React_jsx_common.raiseError ~loc:pstr_loc + Jsx_common.raiseError ~loc:pstr_loc "react.component accepts a record config with props as an options." | _ -> defaultProps @@ -228,7 +228,7 @@ let rec recursivelyMakeNamedArgsForExternal list args = } (* ~foo: int=1 *) | _label, Some type_, Some _ -> type_ - (* ~foo: option(int)=? *) + (* ~foo: option=? *) | ( label, Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, _ ) @@ -368,7 +368,7 @@ let jsxMapper ~config = | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") | _ -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX name can't be the result of function applications" in let props = @@ -407,7 +407,7 @@ let jsxMapper ~config = "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "A spread as a DOM element's children don't make sense written \ together. You can simply remove the spread." in @@ -450,11 +450,11 @@ let jsxMapper ~config = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raiseError ~loc:expr.pexp_loc "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", _, _, _) -> - React_jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raiseError ~loc:expr.pexp_loc "Ref cannot be passed as a normal prop. Either give the prop a \ different name or use the `forwardRef` API instead." | Pexp_fun (arg, default, pattern, expression) @@ -477,7 +477,7 @@ let jsxMapper ~config = (Preprocessor (Printf.sprintf "React: optional argument annotations must have explicit \ - `option`. Did you mean `option(%s)=?`?" + `option`. Did you mean `option<%s>=?`?" currentType))) | _ -> () in @@ -592,12 +592,12 @@ let jsxMapper ~config = pstr_desc = Pstr_primitive ({pval_name = {txt = fnName}; pval_attributes; pval_type} as - value_description); + value_description); } as pstr -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.hasAttr pval_attributes with | [] -> [item] | [_] -> - let pval_type = React_jsx_common.extractUncurried pval_type in + let pval_type = Jsx_common.extractUncurried pval_type in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -641,15 +641,15 @@ let jsxMapper ~config = in [externalPropsDecl; newStructure] | _ -> - React_jsx_common.raiseError ~loc:pstr_loc + Jsx_common.raiseError ~loc:pstr_loc "Only one react.component call can exist on a component at one time") (* let component = ... *) | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( let fileName = filenameFromLoc pstr_loc in let emptyLoc = Location.in_file fileName in let mapBinding binding = - if React_jsx_common.hasAttrOnBinding binding then - let binding = React_jsx_common.removeArity binding in + if Jsx_common.hasAttrOnBinding binding then + let binding = Jsx_common.removeArity binding in let bindingLoc = binding.pvb_loc in let bindingPatLoc = binding.pvb_pat.ppat_loc in let binding = @@ -689,7 +689,7 @@ let jsxMapper ~config = | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> spelunkForFunExpression innerFunctionExpression | {pexp_loc} -> - React_jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raiseError ~loc:pexp_loc "react.component calls can only be on function definitions \ or component wrappers (forwardRef, memo)." in @@ -814,7 +814,7 @@ let jsxMapper ~config = in let bindingWrapper, hasUnit, expression = modifiedBinding binding in let reactComponentAttribute = - try Some (List.find React_jsx_common.hasAttr binding.pvb_attributes) + try Some (List.find Jsx_common.hasAttr binding.pvb_attributes) with Not_found -> None in let _attr_loc, payload = @@ -1035,12 +1035,12 @@ let jsxMapper ~config = psig_desc = Psig_value ({pval_name = {txt = fnName}; pval_attributes; pval_type} as - psig_desc); + psig_desc); } as psig -> ( - match List.filter React_jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.hasAttr pval_attributes with | [] -> [item] | [_] -> - let pval_type = React_jsx_common.extractUncurried pval_type in + let pval_type = Jsx_common.extractUncurried pval_type in let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) @@ -1084,7 +1084,7 @@ let jsxMapper ~config = in [externalPropsDecl; newStructure] | _ -> - React_jsx_common.raiseError ~loc:psig_loc + Jsx_common.raiseError ~loc:psig_loc "Only one react.component call can exist on a component at one time") | _ -> [item] in @@ -1094,37 +1094,35 @@ let jsxMapper ~config = | Pexp_ident caller -> ( match caller with | {txt = Lident "createElement"; loc} -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: `createElement` should be preceeded by a module name." (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match config.React_jsx_common.version with + match config.Jsx_common.version with | 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments - | _ -> - React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3") + | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) (* turn that into ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) | {loc; txt = Lident id} -> ( match config.version with | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> React_jsx_common.raiseError ~loc "JSX: the JSX version must be 3" - ) + | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: the JSX attribute should be attached to a \ `YourModuleName.createElement` or `YourModuleName.make` call. We \ saw `%s` instead" anythingNotCreateElementOrMake | {txt = Lapply _; loc} -> (* don't think there's ever a case where this is reached *) - React_jsx_common.raiseError ~loc + Jsx_common.raiseError ~loc "JSX: encountered a weird case while processing the code. Please \ report this!") | _ -> - React_jsx_common.raiseError ~loc:callExpression.pexp_loc + Jsx_common.raiseError ~loc:callExpression.pexp_loc "JSX: `createElement` should be preceeded by a simple, direct module \ name." in diff --git a/analysis/vendor/res_syntax/res_cli.ml b/analysis/vendor/res_syntax/res_cli.ml index 7af181f5b..8583f9639 100644 --- a/analysis/vendor/res_syntax/res_cli.ml +++ b/analysis/vendor/res_syntax/res_cli.ml @@ -90,7 +90,7 @@ module Color = struct | Format.String_tag "dim" -> [Dim] | Format.String_tag "filename" -> [FG Cyan] | _ -> raise Not_found - [@@raises Not_found] + [@@raises Not_found] let color_enabled = ref true @@ -177,7 +177,7 @@ end = struct let interface = ref false let jsxVersion = ref (-1) let jsxModule = ref "react" - let jsxMode = ref "classic" + let jsxMode = ref "automatic" let file = ref "" let typechecker = ref false @@ -215,7 +215,7 @@ end = struct "Specify the jsx module. Default: react" ); ( "-jsx-mode", Arg.String (fun txt -> jsxMode := txt), - "Specify the jsx mode, classic or automatic. Default: classic" ); + "Specify the jsx mode, classic or automatic. Default: automatic" ); ( "-typechecker", Arg.Unit (fun () -> typechecker := true), "Parses the ast as it would be passed to the typechecker and not the \ @@ -284,7 +284,7 @@ module CliArgProcessor = struct else exit 1) else let parsetree = - Reactjs_jsx_ppx.rewrite_signature ~jsxVersion ~jsxModule ~jsxMode + Jsx_ppx.rewrite_signature ~jsxVersion ~jsxModule ~jsxMode parseResult.parsetree in printEngine.printInterface ~width ~filename @@ -300,12 +300,12 @@ module CliArgProcessor = struct else exit 1) else let parsetree = - Reactjs_jsx_ppx.rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode + Jsx_ppx.rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode parseResult.parsetree in printEngine.printImplementation ~width ~filename ~comments:parseResult.comments parsetree - [@@raises exit] + [@@raises exit] end (* let () = diff --git a/analysis/vendor/res_syntax/res_comment.ml b/analysis/vendor/res_syntax/res_comment.ml index 23898f8bc..579b5d327 100644 --- a/analysis/vendor/res_syntax/res_comment.ml +++ b/analysis/vendor/res_syntax/res_comment.ml @@ -43,7 +43,7 @@ let makeMultiLineComment ~loc ~docComment ~standalone txt = loc; style = (if docComment then if standalone then ModuleComment else DocComment - else MultiLine); + else MultiLine); prevTokEndPos = Lexing.dummy_pos; } diff --git a/analysis/vendor/res_syntax/res_core.ml b/analysis/vendor/res_syntax/res_core.ml index e15f1e66e..d4fb3c428 100644 --- a/analysis/vendor/res_syntax/res_core.ml +++ b/analysis/vendor/res_syntax/res_core.ml @@ -66,8 +66,8 @@ module ErrorMessages = struct record, since a record needs an explicit declaration and that subset \ wouldn't have one.\n\ Solution: you need to pull out each field you want explicitly." - (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) - [@@live] + (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) + [@@live] let arrayPatternSpread = "Array's `...` spread is not supported in pattern matches.\n\ @@ -151,6 +151,10 @@ module ErrorMessages = struct mean `#" ^ number ^ "`?" end +module InExternal = struct + let status = ref false +end + let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) let uncurriedAppAttr = (Location.mknoloc "res.uapp", Parsetree.PStr []) let ternaryAttr = (Location.mknoloc "res.ternary", Parsetree.PStr []) @@ -176,6 +180,9 @@ let suppressFragileMatchWarningAttr = let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let taggedTemplateLiteralAttr = + (Location.mknoloc "res.taggedTemplate", Parsetree.PStr []) + let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) type argument = { @@ -1290,9 +1297,9 @@ and parseRecordPattern ~attrs p = match field with | PatField field -> (if hasSpread then - let _, pattern = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.recordPatternSpread)); + let _, pattern = field in + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.recordPatternSpread)); (field :: fields, flag) | PatUnderscore -> (fields, flag)) ([], flag) rawFields @@ -2251,6 +2258,66 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = (* ) *) and parseTemplateExpr ?(prefix = "js") p = + let partPrefix = + (* we could stop treating js and j prefix as something special + for json, we would first need to remove @as(json`true`) feature *) + match prefix with + | "js" | "j" | "json" -> Some prefix + | _ -> None + in + let startPos = p.Parser.startPos in + + let parseParts p = + let rec aux acc = + let startPos = p.Parser.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail (txt, lastPos) -> + Parser.next p; + let loc = mkLoc startPos lastPos in + let str = + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc + (Pconst_string (txt, partPrefix)) + in + List.rev ((str, None) :: acc) + | TemplatePart (txt, lastPos) -> + Parser.next p; + let loc = mkLoc startPos lastPos in + let expr = parseExprBlock p in + let str = + Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc + (Pconst_string (txt, partPrefix)) + in + aux ((str, Some expr) :: acc) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] + in + aux [] + in + let parts = parseParts p in + let strings = List.map fst parts in + let values = Ext_list.filter_map parts snd in + let endPos = p.Parser.endPos in + + let genTaggedTemplateCall () = + let lident = Longident.Lident prefix in + let ident = + Ast_helper.Exp.ident ~attrs:[] ~loc:Location.none + (Location.mknoloc lident) + in + let strings_array = + Ast_helper.Exp.array ~attrs:[] ~loc:Location.none strings + in + let values_array = + Ast_helper.Exp.array ~attrs:[] ~loc:Location.none values + in + Ast_helper.Exp.apply + ~attrs:[taggedTemplateLiteralAttr] + ~loc:(mkLoc startPos endPos) ident + [(Nolabel, strings_array); (Nolabel, values_array)] + in + let hiddenOperator = let op = Location.mknoloc (Longident.Lident "^") in Ast_helper.Exp.ident op @@ -2260,56 +2327,33 @@ and parseTemplateExpr ?(prefix = "js") p = Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator [(Nolabel, e1); (Nolabel, e2)] in - let rec parseParts (acc : Parsetree.expression) = - let startPos = p.Parser.startPos in - Parser.nextTemplateLiteralToken p; - match p.token with - | TemplateTail (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - concat acc str - | TemplatePart (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, Some prefix)) - in - let next = - let a = concat acc str in - concat a expr - in - parseParts next - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) - in - let startPos = p.startPos in - Parser.nextTemplateLiteralToken p; - match p.token with - | TemplateTail (txt, lastPos) -> - Parser.next p; - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos lastPos) - (Pconst_string (txt, Some prefix)) - | TemplatePart (txt, lastPos) -> - Parser.next p; - let constantLoc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc - (Pconst_string (txt, Some prefix)) + let genInterpolatedString () = + let subparts = + List.flatten + (List.map + (fun part -> + match part with + | s, Some v -> [s; v] + | s, None -> [s]) + parts) in - let next = concat str expr in - parseParts next - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string ("", None)) + let exprOption = + List.fold_left + (fun acc subpart -> + Some + (match acc with + | Some expr -> concat expr subpart + | None -> subpart)) + None subparts + in + match exprOption with + | Some expr -> expr + | None -> Ast_helper.Exp.constant (Pconst_string ("", None)) + in + + match prefix with + | "js" | "j" | "json" -> genInterpolatedString () + | _ -> genTaggedTemplateCall () (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => * Also overparse constraints: @@ -4276,6 +4320,22 @@ and parseEs6ArrowType ~attrs p = p.uncurried_config |> Res_uncurried.fromDotted ~dotted in let loc = mkLoc startPos endPos in + let arity = + (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *) + match argLbl with + | Labelled _s -> + let typ_is_any = + match typ.ptyp_desc with + | Ptyp_any -> true + | _ -> false + in + let has_as = + Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as") + in + if !InExternal.status && typ_is_any && has_as then arity - 1 + else arity + | _ -> arity + in let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in if uncurried && (paramNum = 1 || p.uncurried_config = Legacy) then (paramNum - 1, Ast_uncurried.uncurriedType ~loc ~arity tArg, 1) @@ -4544,7 +4604,6 @@ and parseConstrDeclArgs p = (* TODO: this could use some cleanup/stratification *) match p.Parser.token with | Lbrace -> ( - let lbrace = p.startPos in Parser.next p; let startPos = p.Parser.startPos in match p.Parser.token with @@ -4676,20 +4735,15 @@ and parseConstrDeclArgs p = let attrs = if optional then optionalAttr :: attrs else attrs in - Parser.expect Comma p; {field with Parsetree.pld_attributes = attrs} in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - in - let () = - match fields with - | [] -> - Parser.err ~startPos:lbrace p - (Diagnostics.message - "An inline record declaration needs at least one field") - | _ -> () + if p.token = Rbrace then [first] + else ( + Parser.expect Comma p; + first + :: parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations ~closing:Rbrace + ~f:parseFieldDeclarationRegion p) in Parser.expect Rbrace p; Parser.optional p Comma |> ignore; @@ -5447,6 +5501,8 @@ and parseTypeDefinitionOrExtension ~attrs p = (* external value-name : typexp = external-declaration *) and parseExternalDef ~attrs ~startPos p = + let inExternal = !InExternal.status in + InExternal.status := true; Parser.leaveBreadcrumb p Grammar.External; Parser.expect Token.External p; let name, loc = parseLident p in @@ -5471,6 +5527,7 @@ and parseExternalDef ~attrs ~startPos p = let loc = mkLoc startPos p.prevEndPos in let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in Parser.eatBreadcrumb p; + InExternal.status := inExternal; vb (* constr-def ::= @@ -5621,7 +5678,7 @@ and parseStructureItemRegion p = Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) | _ -> None) - [@@progress Parser.next, Parser.expect, LoopProgress.listRest] +[@@progress Parser.next, Parser.expect, LoopProgress.listRest] (* include-statement ::= include module-expr *) and parseIncludeStatement ~attrs p = @@ -6253,7 +6310,7 @@ and parseSignatureItemRegion p = (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); Some Recover.defaultSignatureItem | _ -> None) - [@@progress Parser.next, Parser.expect, LoopProgress.listRest] +[@@progress Parser.next, Parser.expect, LoopProgress.listRest] (* module rec module-name : module-type { and module-name: module-type } *) and parseRecModuleSpec ~attrs ~startPos p = diff --git a/analysis/vendor/res_syntax/res_diagnostics_printing_utils.ml b/analysis/vendor/res_syntax/res_diagnostics_printing_utils.ml deleted file mode 100644 index 74d23e404..000000000 --- a/analysis/vendor/res_syntax/res_diagnostics_printing_utils.ml +++ /dev/null @@ -1,389 +0,0 @@ -(* - This file is taken from ReScript's super_code_frame.ml and super_location.ml - We're copying the look of ReScript's terminal error reporting. - See https://github.com/rescript-lang/syntax/pull/77 for the rationale. - A few lines have been commented out and swapped for their tweaked version. -*) - -(* ===== super_code_frame.ml *) - -module Super_code_frame = struct - let digits_count n = - let rec loop n base count = - if n >= base then loop n (base * 10) (count + 1) else count - in - loop (abs n) 1 0 - - let seek_2_lines_before src pos = - let open Lexing in - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_line + 2 >= original_line then (current_char, current_line) - else - loop - (if (src.[current_char] [@doesNotRaise]) = '\n' then current_line + 1 - else current_line) - (current_char + 1) - in - loop 1 0 - - let seek_2_lines_after src pos = - let open Lexing in - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_char = String.length src then (current_char, current_line) - else - match src.[current_char] [@doesNotRaise] with - | '\n' when current_line = original_line + 2 -> - (current_char, current_line) - | '\n' -> loop (current_line + 1) (current_char + 1) - | _ -> loop current_line (current_char + 1) - in - loop original_line pos.pos_cnum - - let leading_space_count str = - let rec loop i count = - if i = String.length str then count - else if (str.[i] [@doesNotRaise]) != ' ' then count - else loop (i + 1) (count + 1) - in - loop 0 0 - - let break_long_line max_width line = - let rec loop pos accum = - if pos = String.length line then accum - else - let chunk_length = min max_width (String.length line - pos) in - let chunk = (String.sub [@doesNotRaise]) line pos chunk_length in - loop (pos + chunk_length) (chunk :: accum) - in - loop 0 [] |> List.rev - - let filter_mapi f l = - let rec loop f l i accum = - match l with - | [] -> accum - | head :: rest -> - let accum = - match f i head with - | None -> accum - | Some result -> result :: accum - in - loop f rest (i + 1) accum - in - loop f l 0 [] |> List.rev - - (* Spiritual equivalent of - https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 - *) - module Color = struct - type color = - | Dim - (* | Filename *) - | Err - | Warn - | NoColor - - let dim = "\x1b[2m" - - (* let filename = "\x1b[46m" *) - let err = "\x1b[1;31m" - let warn = "\x1b[1;33m" - let reset = "\x1b[0m" - - external isatty : out_channel -> bool = "caml_sys_isatty" - - (* reasonable heuristic on whether colors should be enabled *) - let should_enable_color () = - let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" && term <> "" && isatty stderr - - let color_enabled = ref true - - let setup = - let first = ref true in - (* initialize only once *) - fun o -> - if !first then ( - first := false; - color_enabled := - match o with - | Some Misc.Color.Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()); - () - end - - let setup = Color.setup - - type gutter = Number of int | Elided - type highlighted_string = {s: string; start: int; end_: int} - type line = {gutter: gutter; content: highlighted_string list} - - (* - Features: - - display a line gutter - - break long line into multiple for terminal display - - peek 2 lines before & after for context - - center snippet when it's heavily indented - - ellide intermediate lines when the reported range is huge -*) - let print ~is_warning ~src ~startPos ~endPos = - let open Lexing in - let indent = 2 in - let highlight_line_start_line = startPos.pos_lnum in - let highlight_line_end_line = endPos.pos_lnum in - let start_line_line_offset, first_shown_line = - seek_2_lines_before src startPos - in - let end_line_line_end_offset, last_shown_line = - seek_2_lines_after src endPos - in - - let more_than_5_highlighted_lines = - highlight_line_end_line - highlight_line_start_line + 1 > 5 - in - let max_line_digits_count = digits_count last_shown_line in - (* TODO: change this back to a fixed 100? *) - (* 3 for separator + the 2 spaces around it *) - let line_width = 78 - max_line_digits_count - indent - 3 in - let lines = - (String.sub [@doesNotRaise]) src start_line_line_offset - (end_line_line_end_offset - start_line_line_offset) - |> String.split_on_char '\n' - |> filter_mapi (fun i line -> - let line_number = i + first_shown_line in - if more_than_5_highlighted_lines then - if line_number = highlight_line_start_line + 2 then - Some (Elided, line) - else if - line_number > highlight_line_start_line + 2 - && line_number < highlight_line_end_line - 1 - then None - else Some (Number line_number, line) - else Some (Number line_number, line)) - in - let leading_space_to_cut = - lines - |> List.fold_left - (fun current_max (_, line) -> - let leading_spaces = leading_space_count line in - if String.length line = leading_spaces then - (* the line's nothing but spaces. Doesn't count *) - current_max - else min leading_spaces current_max) - 99999 - in - let separator = if leading_space_to_cut = 0 then "│" else "┆" in - let stripped_lines = - lines - |> List.map (fun (gutter, line) -> - let new_content = - if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] - else - (String.sub [@doesNotRaise]) line leading_space_to_cut - (String.length line - leading_space_to_cut) - |> break_long_line line_width - |> List.mapi (fun i line -> - match gutter with - | Elided -> {s = line; start = 0; end_ = 0} - | Number line_number -> - let highlight_line_start_offset = - startPos.pos_cnum - startPos.pos_bol - in - let highlight_line_end_offset = - endPos.pos_cnum - endPos.pos_bol - in - let start = - if i = 0 && line_number = highlight_line_start_line - then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if - line_number = highlight_line_start_line - && line_number = highlight_line_end_line - then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if - line_number > highlight_line_start_line - && line_number < highlight_line_end_line - then String.length line - else if line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_}) - in - {gutter; content = new_content}) - in - let buf = Buffer.create 100 in - let open Color in - let add_ch = - let last_color = ref NoColor in - fun color ch -> - if (not !Color.color_enabled) || !last_color = color then - Buffer.add_char buf ch - else - let ansi = - match (!last_color, color) with - | NoColor, Dim -> dim - (* | NoColor, Filename -> filename *) - | NoColor, Err -> err - | NoColor, Warn -> warn - | _, NoColor -> reset - | _, Dim -> reset ^ dim - (* | _, Filename -> reset ^ filename *) - | _, Err -> reset ^ err - | _, Warn -> reset ^ warn - in - Buffer.add_string buf ansi; - Buffer.add_char buf ch; - last_color := color - in - let draw_gutter color s = - for _i = 1 to max_line_digits_count + indent - String.length s do - add_ch NoColor ' ' - done; - s |> String.iter (add_ch color); - add_ch NoColor ' '; - separator |> String.iter (add_ch Dim); - add_ch NoColor ' ' - in - stripped_lines - |> List.iter (fun {gutter; content} -> - match gutter with - | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n' - | Number line_number -> - content - |> List.iteri (fun i line -> - let gutter_content = - if i = 0 then string_of_int line_number else "" - in - let gutter_color = - if - i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line - then if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; - - line.s - |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor - in - add_ch c ch); - add_ch NoColor '\n')); - Buffer.contents buf -end - -(* ===== super_location.ml *) -module Super_location = struct - let fprintf = Format.fprintf - - let setup_colors () = - Misc.Color.setup !Clflags.color; - Super_code_frame.setup !Clflags.color - - let print_filename = Location.print_filename - - let print_loc ~normalizedRange ppf (loc : Location.t) = - setup_colors (); - let dim_loc ppf = function - | None -> () - | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) - -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - fprintf ppf ":@{%i:%i@}" start_line start_line_start_char - else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char - end_line_end_char - else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char - end_line end_line_end_char - in - fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname - dim_loc normalizedRange - - (* let print ~message_kind intro ppf (loc : Location.t) = *) - let print ~message_kind intro src ppf (loc : Location.t) = - (match message_kind with - | `warning -> fprintf ppf "@[@{%s@}@]@," intro - | `warning_as_error -> - fprintf ppf "@[@{%s@} (configured as error) @]@," intro - | `error -> fprintf ppf "@[@{%s@}@]@," intro); - (* ocaml's reported line/col numbering is horrible and super error-prone - when being handled programmatically (or humanly for that matter. If you're - an ocaml contributor reading this: who the heck reads the character count - starting from the first erroring character?) *) - (* let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in *) - let _file, start_line, start_char = Location.get_pos_info loc.loc_start in - let _, end_line, end_char = Location.get_pos_info loc.loc_end in - (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) - (* start_char is inclusive, end_char is exclusive *) - let normalizedRange = - (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) - if start_char == -1 || end_char == -1 then - (* happens sometimes. Syntax error for example *) - None - else if start_line = end_line && start_char >= end_char then - (* in some errors, starting char and ending char can be the same. But - since ending char was supposed to be exclusive, here it might end up - smaller than the starting char if we naively did start_char + 1 to - just the starting char and forget ending char *) - let same_char = start_char + 1 in - Some ((start_line, same_char), (end_line, same_char)) - else - (* again: end_char is exclusive, so +1-1=0 *) - Some ((start_line, start_char + 1), (end_line, end_char)) - in - fprintf ppf " @[%a@]@," (print_loc ~normalizedRange) loc; - match normalizedRange with - | None -> () - | Some _ -> ( - try - (* let src = Ext_io.load_file file in *) - (* we're putting the line break `@,` here rather than above, because this - branch might not be reached (aka no inline file content display) so - we don't wanna end up with two line breaks in the the consequent *) - fprintf ppf "@,%s" - (Super_code_frame.print ~is_warning:(message_kind = `warning) ~src - ~startPos:loc.loc_start ~endPos:loc.loc_end) - with - (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. - we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> - ()) - - (* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) - (* This is the error report entry point. We'll replace the default reporter with this one. *) - (* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) - let super_error_reporter ppf src ({loc; msg} : Location.error) = - setup_colors (); - (* open a vertical box. Everything in our message is indented 2 spaces *) - (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) - Format.fprintf ppf "@[@, %a@, %s@,@]" - (print ~message_kind:`error "Syntax error!" src) - loc msg - (* List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub *) - (* no need to flush here; location's report_exception (which uses this ultimately) flushes *) -end diff --git a/analysis/vendor/res_syntax/res_doc.ml b/analysis/vendor/res_syntax/res_doc.ml index 125ac7725..fe626e479 100644 --- a/analysis/vendor/res_syntax/res_doc.ml +++ b/analysis/vendor/res_syntax/res_doc.ml @@ -347,4 +347,4 @@ let debug t = in let doc = toDoc t in toString ~width:10 doc |> print_endline - [@@live] +[@@live] diff --git a/analysis/vendor/res_syntax/res_driver.ml b/analysis/vendor/res_syntax/res_driver.ml index 21219b68c..a82c9a2a1 100644 --- a/analysis/vendor/res_syntax/res_driver.ml +++ b/analysis/vendor/res_syntax/res_driver.ml @@ -140,7 +140,7 @@ let parse_implementation ?(ignoreParseErrors = false) sourcefile = Res_diagnostics.printReport parseResult.diagnostics parseResult.source; if not ignoreParseErrors then exit 1); parseResult.parsetree - [@@raises exit] +[@@raises exit] let parse_interface ?(ignoreParseErrors = false) sourcefile = Location.input_name := sourcefile; @@ -151,11 +151,11 @@ let parse_interface ?(ignoreParseErrors = false) sourcefile = Res_diagnostics.printReport parseResult.diagnostics parseResult.source; if not ignoreParseErrors then exit 1); parseResult.parsetree - [@@raises exit] +[@@raises exit] (* suppress unused optional arg *) let _ = fun s -> ( parse_implementation ~ignoreParseErrors:false s, parse_interface ~ignoreParseErrors:false s ) - [@@raises exit] +[@@raises exit] diff --git a/analysis/vendor/res_syntax/res_driver.mli b/analysis/vendor/res_syntax/res_driver.mli index 8a208b2fd..ddc264739 100644 --- a/analysis/vendor/res_syntax/res_driver.mli +++ b/analysis/vendor/res_syntax/res_driver.mli @@ -24,14 +24,14 @@ val parseImplementationFromSource : displayFilename:string -> source:string -> (Parsetree.structure, Res_diagnostics.t list) parseResult - [@@live] +[@@live] val parseInterfaceFromSource : forPrinter:bool -> displayFilename:string -> source:string -> (Parsetree.signature, Res_diagnostics.t list) parseResult - [@@live] +[@@live] type printEngine = { printImplementation: @@ -55,8 +55,8 @@ val printEngine : printEngine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) val parse_implementation : ?ignoreParseErrors:bool -> string -> Parsetree.structure - [@@live] [@@raises Location.Error] +[@@live] [@@raises Location.Error] (* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) val parse_interface : ?ignoreParseErrors:bool -> string -> Parsetree.signature - [@@live] [@@raises Location.Error] +[@@live] [@@raises Location.Error] diff --git a/analysis/vendor/res_syntax/res_driver_ml_parser.mli b/analysis/vendor/res_syntax/res_driver_ml_parser.mli index 63ea8f81f..55a99c4d5 100644 --- a/analysis/vendor/res_syntax/res_driver_ml_parser.mli +++ b/analysis/vendor/res_syntax/res_driver_ml_parser.mli @@ -3,7 +3,7 @@ (* extracts comments and the original string data from an ocaml file *) val extractOcamlConcreteSyntax : string -> (string * Location.t) list * Res_comment.t list - [@@live] +[@@live] val parsingEngine : unit Res_driver.parsingEngine diff --git a/analysis/vendor/res_syntax/res_io.ml b/analysis/vendor/res_syntax/res_io.ml index ef29399ba..e5934b848 100644 --- a/analysis/vendor/res_syntax/res_io.ml +++ b/analysis/vendor/res_syntax/res_io.ml @@ -11,4 +11,4 @@ let writeFile ~filename ~contents:txt = let chan = open_out_bin filename in output_string chan txt; close_out chan - [@@raises Sys_error] +[@@raises Sys_error] diff --git a/analysis/vendor/res_syntax/res_multi_printer.ml b/analysis/vendor/res_syntax/res_multi_printer.ml index 81d14d844..98cd1d423 100644 --- a/analysis/vendor/res_syntax/res_multi_printer.ml +++ b/analysis/vendor/res_syntax/res_multi_printer.ml @@ -85,7 +85,7 @@ let printRes ~ignoreParseErrors ~isInterface ~filename = if not ignoreParseErrors then exit 1); Res_printer.printImplementation ~width:defaultPrintWidth ~comments:parseResult.comments parseResult.parsetree - [@@raises exit] +[@@raises exit] (* print ocaml files to res syntax *) let printMl ~isInterface ~filename = @@ -113,7 +113,7 @@ let print ?(ignoreParseErrors = false) language ~input = match language with | `res -> printRes ~ignoreParseErrors ~isInterface ~filename:input | `ml -> printMl ~isInterface ~filename:input - [@@raises exit] +[@@raises exit] (* suppress unused optional arg *) let _ = fun s -> print ~ignoreParseErrors:false s [@@raises exit] diff --git a/analysis/vendor/res_syntax/res_outcome_printer.ml b/analysis/vendor/res_syntax/res_outcome_printer.ml index c9fda0c6d..7ea56d942 100644 --- a/analysis/vendor/res_syntax/res_outcome_printer.ml +++ b/analysis/vendor/res_syntax/res_outcome_printer.ml @@ -395,7 +395,7 @@ and printOutVariant variant = Doc.concat [ (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); + else Doc.ifBreaks (Doc.text "| ") Doc.nil); Doc.group (Doc.concat [ @@ -477,7 +477,7 @@ and printOutConstructorsDoc constructors = Doc.concat [ (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); + else Doc.ifBreaks (Doc.text "| ") Doc.nil); printOutConstructorDoc constructor; ]) constructors); @@ -733,7 +733,7 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) attrs; kw; (if printNameAsIs then Doc.text outTypeDecl.otype_name - else printIdentLike ~allowUident:false outTypeDecl.otype_name); + else printIdentLike ~allowUident:false outTypeDecl.otype_name); typeParams; kind; ]); @@ -870,7 +870,7 @@ and printOutExtensionConstructorDoc Doc.text " += "; Doc.line; (if outExt.oext_private = Asttypes.Private then Doc.text "private " - else Doc.nil); + else Doc.nil); printOutConstructorDoc (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type); ]) @@ -908,8 +908,8 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = typeParams; Doc.text " += "; (if typeExtension.otyext_private = Asttypes.Private then - Doc.text "private " - else Doc.nil); + Doc.text "private " + else Doc.nil); printOutConstructorsDoc typeExtension.otyext_constructors; ]) diff --git a/analysis/vendor/res_syntax/res_outcome_printer.mli b/analysis/vendor/res_syntax/res_outcome_printer.mli index d3ee60aa4..c51bb0931 100644 --- a/analysis/vendor/res_syntax/res_outcome_printer.mli +++ b/analysis/vendor/res_syntax/res_outcome_printer.mli @@ -15,4 +15,4 @@ val setup : unit lazy_t [@@live] val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] val printOutSigItemDoc : ?printNameAsIs:bool -> Outcometree.out_sig_item -> Res_doc.t - [@@live] +[@@live] diff --git a/analysis/vendor/res_syntax/res_parsetree_viewer.ml b/analysis/vendor/res_syntax/res_parsetree_viewer.ml index 6f951f376..8142ae33b 100644 --- a/analysis/vendor/res_syntax/res_parsetree_viewer.ml +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.ml @@ -135,7 +135,7 @@ let rewriteUnderscoreApply expr = match arg with | ( lbl, ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> + as argExpr) ) -> ( lbl, { argExpr with @@ -634,6 +634,14 @@ let hasTemplateLiteralAttr attrs = | _ -> false) attrs +let hasTaggedTemplateLiteralAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.taggedTemplate"}, _ -> true + | _ -> false) + attrs + let isTemplateLiteral expr = match expr.pexp_desc with | Pexp_apply @@ -645,6 +653,12 @@ let isTemplateLiteral expr = | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false +let isTaggedTemplateLiteral expr = + match expr with + | {pexp_desc = Pexp_apply _; pexp_attributes = attrs} -> + hasTaggedTemplateLiteralAttr attrs + | _ -> false + let hasSpreadAttr attrs = List.exists (fun attr -> diff --git a/analysis/vendor/res_syntax/res_parsetree_viewer.mli b/analysis/vendor/res_syntax/res_parsetree_viewer.mli index 15ca9e150..493b6e851 100644 --- a/analysis/vendor/res_syntax/res_parsetree_viewer.mli +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.mli @@ -137,6 +137,7 @@ val collectPatternsFromListConstruct : val isBlockExpr : Parsetree.expression -> bool val isTemplateLiteral : Parsetree.expression -> bool +val isTaggedTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool val isSpreadBeltListConcat : Parsetree.expression -> bool diff --git a/analysis/vendor/res_syntax/res_printer.ml b/analysis/vendor/res_syntax/res_printer.ml index f85094a7c..3b546e051 100644 --- a/analysis/vendor/res_syntax/res_printer.ml +++ b/analysis/vendor/res_syntax/res_printer.ml @@ -216,7 +216,7 @@ let printLeadingComment ?nextComment comment = Doc.concat [ (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] - else Doc.nil); + else Doc.nil); (match nextComment with | Some next -> let nextLoc = Comment.loc next in @@ -843,7 +843,7 @@ and printModType ~state modType cmtTbl = Doc.concat [ (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); + else Doc.text ": "); printModType ~state modType cmtTbl; ]); ] @@ -896,7 +896,7 @@ and printModType ~state modType cmtTbl = Doc.concat [ (if attrsAlreadyPrinted then Doc.nil - else printAttributes ~state modType.pmty_attributes cmtTbl); + else printAttributes ~state modType.pmty_attributes cmtTbl); modTypeDoc; ] in @@ -1106,23 +1106,23 @@ and printValueDescription ~state valueDescription cmtTbl = Doc.text ": "; printTypExpr ~state valueDescription.pval_type cmtTbl; (if isExternal then - Doc.group - (Doc.concat - [ - Doc.text " ="; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.join ~sep:Doc.line - (List.map - (fun s -> - Doc.concat - [Doc.text "\""; Doc.text s; Doc.text "\""]) - valueDescription.pval_prim); - ]); - ]) - else Doc.nil); + Doc.group + (Doc.concat + [ + Doc.text " ="; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.join ~sep:Doc.line + (List.map + (fun s -> + Doc.concat + [Doc.text "\""; Doc.text s; Doc.text "\""]) + valueDescription.pval_prim); + ]); + ]) + else Doc.nil); ]) and printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl = @@ -1604,16 +1604,16 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = Doc.group attrs; Doc.group (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); + Doc.softLine; + Doc.rparen; + ] + else Doc.concat [typDoc; Doc.text " => "; returnDoc]); ]) | args -> let attrs = printAttributes ~state ~inline:true attrsBefore cmtTbl in @@ -2080,6 +2080,8 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false + | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> + false | e -> ParsetreeViewer.hasAttributes e.pexp_attributes || ParsetreeViewer.isArrayAccess e) @@ -2092,8 +2094,8 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = patternDoc; Doc.text " ="; (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); + Doc.indent (Doc.concat [Doc.line; printedExpr]) + else Doc.concat [Doc.space; printedExpr]); ]) and printPackageType ~state ~printModuleKeywordAndParens @@ -2253,13 +2255,13 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = [ Doc.text "list{"; (if shouldHug then children - else - Doc.concat - [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]); Doc.rbrace; ]) | Ppat_construct (constrName, constructorArgs) -> @@ -2304,13 +2306,13 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = [ Doc.lparen; (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); Doc.rparen; ] in @@ -2355,13 +2357,13 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = [ Doc.lparen; (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); Doc.rparen; ] in @@ -2410,8 +2412,7 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = let patternDoc = printPattern ~state pat cmtTbl in Doc.concat [ - (if i == 0 then Doc.nil - else Doc.concat [Doc.line; Doc.text "| "]); + (if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]); (match pat.ppat_desc with (* (Blue | Red) | (Green | Black) | White *) | Ppat_or _ -> addParens patternDoc @@ -2526,8 +2527,8 @@ and printPatternRecordRow ~state row cmtTbl = printLidentPath longident cmtTbl; Doc.text ":"; (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); + Doc.concat [Doc.space; rhsDoc] + else Doc.indent (Doc.concat [Doc.line; rhsDoc])); ]) in printComments doc cmtTbl locForComments @@ -2663,7 +2664,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = else Doc.group (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) + else Doc.concat [Doc.space; returnDoc]) in let typConstraintDoc = match typConstraint with @@ -2817,13 +2818,13 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = [ Doc.lparen; (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); Doc.rparen; ] in @@ -2942,13 +2943,13 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = [ Doc.lparen; (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; argDoc]); + Doc.trailingComma; + Doc.softLine; + ]); Doc.rparen; ] in @@ -3048,11 +3049,13 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) when ParsetreeViewer.isSpreadBeltListConcat e -> printBeltListConcatApply ~state subLists cmtTbl - | Pexp_apply _ -> + | Pexp_apply (callExpr, args) -> if ParsetreeViewer.isUnaryExpression e then printUnaryExpression ~state e cmtTbl else if ParsetreeViewer.isTemplateLiteral e then printTemplateLiteral ~state e cmtTbl + else if ParsetreeViewer.isTaggedTemplateLiteral e then + printTaggedTemplateLiteral ~state callExpr args cmtTbl else if ParsetreeViewer.isBinaryExpression e then printBinaryExpression ~state e cmtTbl else printPexpApply ~state e cmtTbl @@ -3136,7 +3139,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = [ Doc.text "while "; (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); + else Doc.group (Doc.ifBreaks (addParens condition) condition)); Doc.space; printExpressionBlock ~state ~braces:true expr2 cmtTbl; ]) @@ -3376,14 +3379,14 @@ and printPexpFun ~state ~inCallback e cmtTbl = else Doc.group (if returnShouldIndent then - Doc.concat - [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); - (match inCallback with - | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine - | _ -> Doc.nil); - ] - else Doc.concat [Doc.space; returnDoc]) + Doc.concat + [ + Doc.indent (Doc.concat [Doc.line; returnDoc]); + (match inCallback with + | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine + | _ -> Doc.nil); + ] + else Doc.concat [Doc.space; returnDoc]) in let typConstraintDoc = match typConstraint with @@ -3431,8 +3434,8 @@ and printSetFieldExpr ~state attrs lhs longidentLoc rhs loc cmtTbl = printLidentPath longidentLoc cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in let doc = @@ -3475,6 +3478,53 @@ and printTemplateLiteral ~state expr cmtTbl = Doc.text "`"; ] +and printTaggedTemplateLiteral ~state callExpr args cmtTbl = + let stringsList, valuesList = + match args with + | [ + (_, {Parsetree.pexp_desc = Pexp_array strings}); + (_, {Parsetree.pexp_desc = Pexp_array values}); + ] -> + (strings, values) + | _ -> assert false + in + + let strings = + List.map + (fun x -> + match x with + | {Parsetree.pexp_desc = Pexp_constant (Pconst_string (txt, _))} -> + printStringContents txt + | _ -> assert false) + stringsList + in + + let values = + List.map + (fun x -> + Doc.concat + [ + Doc.text "${"; + printExpressionWithComments ~state x cmtTbl; + Doc.text "}"; + ]) + valuesList + in + + let process strings values = + let rec aux acc = function + | [], [] -> acc + | a_head :: a_rest, b -> aux (Doc.concat [acc; a_head]) (b, a_rest) + | _ -> assert false + in + aux Doc.nil (strings, values) + in + + let content : Doc.t = process strings values in + + let tag = printExpressionWithComments ~state callExpr cmtTbl in + Doc.concat [tag; Doc.text "`"; content; Doc.text "`"] + and printUnaryExpression ~state expr cmtTbl = let printUnaryOperator op = Doc.text @@ -3661,8 +3711,8 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = lhsDoc; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in let doc = @@ -3871,8 +3921,8 @@ and printPexpApply ~state expr cmtTbl = printExpressionWithComments ~state lhs cmtTbl; Doc.text " ="; (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) + else Doc.concat [Doc.space; rhsDoc]); ]) in match expr.pexp_attributes with @@ -3981,8 +4031,8 @@ and printPexpApply ~state expr cmtTbl = Doc.rbracket; Doc.text " ="; (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); + Doc.indent (Doc.concat [Doc.line; targetExpr]) + else Doc.concat [Doc.space; targetExpr]); ]) (* TODO: cleanup, are those branches even remotely performant? *) | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) @@ -4127,24 +4177,24 @@ and printJsxExpression ~state lident args cmtTbl = else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil - else - Doc.concat - [ - (if hasChildren then printChildren children - else - match children with - | Some - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - pexp_loc = loc; - } -> - printCommentsInside cmtTbl loc - | _ -> Doc.nil); - Doc.text " + printCommentsInside cmtTbl loc + | _ -> Doc.nil); + Doc.text " Navbar * Staff.Users.createElement -> Staff.Users *) and printJsxName {txt = lident} = + let printIdent = printIdentLike ~allowUident:true in let rec flatten acc lident = match lident with - | Longident.Lident txt -> txt :: acc - | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt :: acc in - flatten acc lident + | Longident.Lident txt -> printIdent txt :: acc + | Ldot (lident, "createElement") -> flatten acc lident + | Ldot (lident, txt) -> flatten (printIdent txt :: acc) lident | _ -> acc in match lident with - | Longident.Lident txt -> Doc.text txt + | Longident.Lident txt -> printIdent txt | _ as lident -> let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) + Doc.join ~sep:Doc.dot segments and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = (* Because the same subtree gets printed twice, we need to copy the cmtTbl. @@ -4877,9 +4927,9 @@ and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint [ maybeAsyncLparen; (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); + else + Doc.concat + [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); Doc.rparen; ]) @@ -5100,14 +5150,14 @@ and printExpressionBlock ~state ~braces expr cmtTbl = in Doc.breakableGroup ~forceBreak:true (if braces then - Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; block]); - Doc.line; - Doc.rbrace; - ] - else block) + Doc.concat + [ + Doc.lbrace; + Doc.indent (Doc.concat [Doc.line; block]); + Doc.line; + Doc.rbrace; + ] + else block) (* * // user types: @@ -5422,12 +5472,12 @@ and printModExpr ~state modExpr cmtTbl = [ Doc.text "unpack("; (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; - ]); + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); + Doc.softLine; + ]); Doc.rparen; ]) | Pmod_extension extension -> @@ -5449,32 +5499,32 @@ and printModExpr ~state modExpr cmtTbl = [ printModExpr ~state callExpr cmtTbl; (if isUnitSugar then - printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~state - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun modArg -> - printModApplyArg ~state modArg cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] - else Doc.nil); - Doc.rparen; - ]); + printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl + else + Doc.concat + [ + Doc.lparen; + (if shouldHug then + printModApplyArg ~state + (List.hd args [@doesNotRaise]) + cmtTbl + else + Doc.indent + (Doc.concat + [ + Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun modArg -> + printModApplyArg ~state modArg cmtTbl) + args); + ])); + (if not shouldHug then + Doc.concat [Doc.trailingComma; Doc.softLine] + else Doc.nil); + Doc.rparen; + ]); ]) | Pmod_constraint (modExpr, modType) -> Doc.concat diff --git a/analysis/vendor/res_syntax/res_printer.mli b/analysis/vendor/res_syntax/res_printer.mli index bca833da2..3647dc379 100644 --- a/analysis/vendor/res_syntax/res_printer.mli +++ b/analysis/vendor/res_syntax/res_printer.mli @@ -15,10 +15,10 @@ val addParens : Res_doc.t -> Res_doc.t val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t - [@@live] +[@@live] val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t - [@@live] +[@@live] val printImplementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string diff --git a/analysis/vendor/res_syntax/res_scanner.ml b/analysis/vendor/res_syntax/res_scanner.ml index 371711796..afcd4b9f3 100644 --- a/analysis/vendor/res_syntax/res_scanner.ml +++ b/analysis/vendor/res_syntax/res_scanner.ml @@ -92,7 +92,7 @@ let _printDebug ~startPos ~endPos scanner token = print_char '-'; print_int endPos.pos_cnum; print_endline "" - [@@live] +[@@live] let next scanner = let nextOffset = scanner.offset + 1 in diff --git a/analysis/vendor/res_syntax/res_token.ml b/analysis/vendor/res_syntax/res_token.ml index f519af6f0..5d12e0f14 100644 --- a/analysis/vendor/res_syntax/res_token.ml +++ b/analysis/vendor/res_syntax/res_token.ml @@ -238,7 +238,7 @@ let keywordTable = function | "when" -> When | "while" -> While | _ -> raise Not_found - [@@raises Not_found] +[@@raises Not_found] let isKeyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False