From b2d5ca30a75ba129b63230d918b7239497374e08 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 7 Jul 2021 09:42:22 +0200 Subject: [PATCH 01/41] Test vendoring the entire parser. --- .../res_outcome_printer/reactjs_jsx_ppx_v3.ml | 871 +++ .../reactjs_jsx_ppx_v3.mli | 39 + .../res_outcome_printer/res_ast_conversion.ml | 583 ++ .../res_ast_conversion.mli | 24 + .../res_outcome_printer/res_ast_debugger.ml | 1235 ++++ .../res_outcome_printer/res_ast_debugger.mli | 8 + .../src/vendor/res_outcome_printer/res_cli.ml | 296 + .../res_outcome_printer/res_comments_table.ml | 1918 +++++ .../vendor/res_outcome_printer/res_core.ml | 6371 +++++++++++++++++ .../vendor/res_outcome_printer/res_core.mli | 4 + .../res_outcome_printer/res_diagnostics.ml | 182 + .../res_outcome_printer/res_diagnostics.mli | 29 + .../res_diagnostics_printing_utils.ml | 373 + .../vendor/res_outcome_printer/res_driver.ml | 109 + .../vendor/res_outcome_printer/res_driver.mli | 49 + .../res_outcome_printer/res_driver_binary.ml | 12 + .../res_outcome_printer/res_driver_binary.mli | 1 + .../res_driver_ml_parser.ml | 92 + .../res_driver_ml_parser.mli | 9 + .../res_driver_reason_binary.ml | 103 + .../res_driver_reason_binary.mli | 7 + .../vendor/res_outcome_printer/res_grammar.ml | 368 + .../src/vendor/res_outcome_printer/res_io.ml | 14 + .../src/vendor/res_outcome_printer/res_io.mli | 7 + .../vendor/res_outcome_printer/res_js_ffi.ml | 116 + .../res_outcome_printer/res_multi_printer.ml | 128 + .../res_outcome_printer/res_multi_printer.mli | 3 + .../res_outcome_printer.mli | 16 + .../vendor/res_outcome_printer/res_parens.ml | 416 ++ .../vendor/res_outcome_printer/res_parens.mli | 36 + .../vendor/res_outcome_printer/res_parser.ml | 163 + .../vendor/res_outcome_printer/res_parser.mli | 48 + .../res_parsetree_viewer.ml | 576 ++ .../res_parsetree_viewer.mli | 132 + .../vendor/res_outcome_printer/res_printer.ml | 5256 ++++++++++++++ .../res_outcome_printer/res_printer.mli | 20 + .../res_outcome_printer/res_reporting.ml | 12 + .../vendor/res_outcome_printer/res_scanner.ml | 716 ++ .../res_outcome_printer/res_scanner.mli | 35 + 39 files changed, 20377 insertions(+) create mode 100644 analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml create mode 100644 analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_cli.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_comments_table.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_core.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_core.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_diagnostics.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_diagnostics.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_binary.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_binary.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_grammar.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_io.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_io.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_js_ffi.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_multi_printer.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_multi_printer.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_parens.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_parens.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_parser.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_parser.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_printer.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_printer.mli create mode 100644 analysis/src/vendor/res_outcome_printer/res_reporting.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_scanner.ml create mode 100644 analysis/src/vendor/res_outcome_printer/res_scanner.mli diff --git a/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml new file mode 100644 index 000000000..87a08ed59 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml @@ -0,0 +1,871 @@ +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 optionIdent = Lident "option" + +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) + +let safeTypeFromValue valueStr = + let valueStr = getLabel valueStr in + match String.sub valueStr 0 1 with "_" -> "T" ^ valueStr | _ -> valueStr + [@@raises Invalid_argument] + +let keyType loc = Typ.constr ~loc { loc; txt = optionIdent } [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] + +type 'a children = ListLiteral of 'a | Exact of 'a + +type componentConfig = { propsName : string } + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum)) ) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> Exact (mapper.expr mapper notAList) + in + transformChildren_ theList [] + +let transformChildrenIfList ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> mapper.expr mapper notAList + in + transformChildren_ theList [] + +let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = + let rec allButLast_ lst acc = + match lst with + | [] -> [] + | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc + | (Nolabel, _) :: _rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") + | arg :: rest -> allButLast_ rest (arg :: acc) + [@@raises Invalid_argument] + in + let allButLast lst = allButLast_ lst [] |> List.rev [@@raises Invalid_argument] in + match List.partition (fun (label, _) -> label = labelled "children") propsAndChildren with + | [], props -> + (* no children provided? Place a placeholder list *) + (Exp.construct ~loc { loc; txt = Lident "[]" } None, if removeLastPositionUnit then allButLast props else props) + | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) + | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") + [@@raises Invalid_argument] + +let unerasableIgnore loc = ({ loc; txt = "warning" }, PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ]) + +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) + +(* Helper method to look up the [@react.component] attribute *) +let hasAttr (loc, _) = loc.txt = "react.component" + +(* Helper method to filter out any attribute that isn't [@react.component] *) +let otherAttrsPure (loc, _) = loc.txt <> "react.component" + +(* Iterate over the attributes and try to find the [@react.component] attribute *) +let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | { pvb_pat = { ppat_desc = Ppat_var { txt } } } -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +let makeNewBinding binding expression newName = + match binding with + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +(* Lookup the value of `props` otherwise raise Invalid_argument error *) +let getPropsNameValue _acc (loc, exp) = + match (loc, exp) with + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> { propsName = str } + | { txt }, _ -> + raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt)) + [@@raises Invalid_argument] + +(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) +let getPropsAttr payload = + let defaultProps = { propsName = "Props" } in + match payload with + | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _) } :: _rest)) -> + List.fold_left getPropsNameValue defaultProps recordFields + | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) } :: _rest)) -> + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _) } :: _rest)) -> + raise (Invalid_argument "react.component accepts a record config with props as an options.") + | _ -> defaultProps + [@@raises Invalid_argument] + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc : Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with "" -> !Location.input_name | fileName -> fileName in + let fileName = try Filename.chop_extension (Filename.basename fileName) with Invalid_argument _ -> fileName in + let fileName = String.capitalize_ascii fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = + match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | "", nestedModules, "make" -> nestedModules + | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) + | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules + | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, default, loc, interiorType) :: tl -> + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + ( match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, _ + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]) }, _ + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + (* ~foo *) + | label, None, _ -> { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + | _label, Some type_, _ -> type_ ) + args) + | [] -> args + [@@raises Invalid_argument] + +(* Build an AST node for the [@bs.obj] representing props for a component *) +let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = + let propsName = fnName ^ "Props" in + { + pval_name = { txt = propsName; loc }; + pval_type = + recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef + (Typ.arrow nolabel + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = [] } + propsType); + pval_prim = [ "" ]; + pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; + pval_loc = loc; + } + [@@raises Invalid_argument] + +(* Build an AST node representing an `external` with the definition of the [@bs.obj] *) +let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = + { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the signature of the `external` definition *) +let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = + { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the props name when converted to an object inside the function signature *) +let makePropsName ~loc name = { ppat_desc = Ppat_var { txt = name; loc }; ppat_loc = loc; ppat_attributes = [] } + +let makeObjectField loc (str, attrs, type_) = Otag ({ loc; txt = str }, attrs, type_) + +(* Build an AST node representing a "closed" object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal fnName loc + (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + [@@raises Invalid_argument] + +(* TODO: some line number might still be wrong *) +let jsxMapper () = + let jsxVersion = ref None in + + let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = + let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let argsForMake = argsWithLabels in + let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ ( match childrenExpr with + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] ) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] + in + let isCap str = + let first = String.sub str 0 1 [@@raises Invalid_argument] in + let capped = String.uppercase_ascii first in + first = capped + [@@raises Invalid_argument] + in + let ident = + match modulePath with + | Lident _ -> Ldot (modulePath, "make") + | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, "make") + | modulePath -> modulePath + in + let propsIdent = + match ident with + | Lident path -> Lident (path ^ "Props") + | Ldot (ident, path) -> Ldot (ident, path ^ "Props") + | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") + in + let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in + (* handle key, ref, children *) + (* React.createElement(Component.make, props, ...children) *) + match !childrenArg with + | None -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] + | Some children -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props); (nolabel, children) ] + [@@raises Invalid_argument] + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let children, nonChildrenProps = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> + raise + (Invalid_argument + "A spread as a DOM element's children don't make sense written together. You can simply remove the \ + spread.") + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + | nonEmptyProps -> + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) + args + [@@raises Invalid_argument] + in + + let rec recursivelyTransformNamedArgsForMake mapper expr 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 () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( + match ptyp_desc with + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "ReasonReact: optional argument annotations must have explicit `option`. Did you mean \ + `option(%s)=?`?" + currentType)) ) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in + + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) -> + (list, None) + | Pexp_fun + ( Nolabel, + _, + { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, + _expression ) -> + (list, Some txt) + | Pexp_fun (Nolabel, _, pattern, _expression) -> + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: react.component refs only support plain arguments and type annotations." + | _ -> (list, None) + [@@raises Invalid_argument] + in + + let argToType types (name, default, _noLabelName, _alias, loc, type_) = + match (type_, name, default) with + | Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, name, _ when isOptional name -> + ( getLabel name, + [], + { type_ with ptyp_desc = Ptyp_constr ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]) } ) + :: types + | Some type_, name, Some _default -> + ( getLabel name, + [], + { ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); ptyp_loc = loc; ptyp_attributes = [] } ) + :: types + | Some type_, name, _ -> (getLabel name, [], type_) :: types + | None, name, _ when isOptional name -> + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] } ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | None, name, _ when isLabelled name -> + (getLabel name, [], { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] }) + :: types + | _ -> types + [@@raises Invalid_argument] + in + + let argToConcreteType types (name, loc, type_) = + match name with + | name when isLabelled name -> (getLabel name, [], type_) :: types + | name when isOptional name -> (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) :: types + | _ -> types + in + + let nestedModules = ref [] in + let transformComponentDefinition mapper structure returnStructures = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isLabelled name || isOptional name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in + let fnName = getFnName binding in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } -> expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]) } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } -> + spelunkForFunExpression innerFunctionExpression + | _ -> + raise + (Invalid_argument + "react.component calls can only be on function definitions or component wrappers (forwardRef, \ + memo).") + [@@raises Invalid_argument] + in + spelunkForFunExpression expression + in + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { exp with pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + ( wrap, + hasUnit, + unerasableIgnoreExp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp) } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun ((Labelled _ | Optional _), _default, _pattern, _internalExpression) } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression) } -> + if hasApplication.contents then ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with React.forwardRef.\n\ + \ If your component doesn't have any props use () or _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_let (recursive, vbs, exp) }) + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (wrapperExpression, [ (Nolabel, internalExpression) ]) } -> + let () = hasApplication := true in + let _, hasUnit, exp = spelunkForFunExpression internalExpression in + ((fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), hasUnit, exp) + | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression) } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp) }) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try Some (List.find hasAttr binding.pvb_attributes) with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, forwardRef = + recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] + in + let namedArgListWithKeyAndRef = + (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc)) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with label when isOptional label || isLabelled label -> getLabel label | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + (nolabel, Exp.ident ~loc { txt = Lident props.propsName; loc }); + (nolabel, Exp.ident ~loc { txt = Lident labelString; loc }); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalDecl = makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { loc; txt = Lident (match recFlag with Recursive -> internalFnName | Nonrecursive -> fnName) }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { ppat_desc = Ppat_var { txt; loc = emptyLoc }; ppat_loc = emptyLoc; ppat_attributes = [] }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc namedTypeList); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] + (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk (Pat.var { loc = emptyLoc; txt = fnName }) fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression)) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + [@@raises Invalid_argument] + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) = + let externs = match extern with Some extern -> extern :: externs | None -> externs in + let newBindings = + match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings + in + (externs, binding @ bindings, newBindings) + in + let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ ( match newBindings with + | [] -> [] + | newBindings -> [ { pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings) } ] ) + @ returnStructures + | structure -> structure :: returnStructures + [@@raises Invalid_argument] + in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] + [@@raises Invalid_argument] + in + + let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { psig_loc; psig_desc = Psig_value ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc) } + as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isOptional name || isLabelled name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] + in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] + in + + let transformJsxCall mapper callExpression callArguments attrs = + match callExpression.pexp_desc with + | Pexp_ident caller -> ( + match caller with + | { txt = Lident "createElement" } -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match !jsxVersion with + | None | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match !jsxVersion with + | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + | { txt = Ldot (_, anythingNotCreateElementOrMake) } -> + raise + (Invalid_argument + ( "JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or \ + `YourModuleName.make` call. We saw `" ^ anythingNotCreateElementOrMake ^ "` instead" )) + | { txt = Lapply _ } -> + (* don't think there's ever a case where this is reached *) + raise (Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!") ) + | _ -> raise (Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name.") + [@@raises Invalid_argument] + in + + let signature mapper signature = + default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + in + + let structure mapper structure = + match structure with structures -> default_mapper.structure mapper @@ reactComponentTransform mapper structures + [@@raises Invalid_argument] + in + + let expr mapper expression = + 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 + [@@raises Invalid_argument] + in + + let module_binding mapper module_binding = + let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in + let mapped = default_mapper.module_binding mapper module_binding in + let _ = nestedModules := List.tl !nestedModules in + mapped + [@@raises Failure] + in + { default_mapper with structure; expr; signature; module_binding } + [@@raises Invalid_argument, Failure] + +let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = + let mapper = jsxMapper () in + mapper.structure mapper code + [@@raises Invalid_argument, Failure] + +let rewrite_signature (code : Parsetree.signature) : Parsetree.signature = + let mapper = jsxMapper () in + mapper.signature mapper code + [@@raises Invalid_argument, Failure] diff --git a/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli new file mode 100644 index 000000000..da60a051c --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli @@ -0,0 +1,39 @@ +(* + This is the module that handles turning Reason JSX' agnostic function call into + a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx + facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- + points-in-ocaml/ + You wouldn't use this file directly; it's used by ReScript's + bsconfig.json. Specifically, there's a field called `react-jsx` inside the + field `reason`, which enables this ppx through some internal call in bsb +*) + +(* + There are two different transforms that can be selected in this file (v2 and v3): + v2: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo, + bar|])`. + transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into + `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` + v3: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))` + transform the upper-cased case + `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into + `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` +*) + +val rewrite_implementation : Parsetree.structure -> Parsetree.structure + +val rewrite_signature : Parsetree.signature -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml new file mode 100644 index 000000000..20eba5ff5 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml @@ -0,0 +1,583 @@ + +let concatLongidents l1 l2 = + let parts1 = Longident.flatten l1 in + let parts2 = Longident.flatten l2 in + match List.concat [parts1; parts2] |> Longident.unflatten with + | Some longident -> longident + | None -> l2 + +(* TODO: support nested open's ? *) +let rec rewritePpatOpen longidentOpen pat = + match pat.Parsetree.ppat_desc with + | Ppat_array (first::rest) -> + (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) + {pat with ppat_desc = Ppat_array ((rewritePpatOpen longidentOpen first)::rest)} + | Ppat_tuple (first::rest) -> + (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) + {pat with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen first)::rest)} + | Ppat_construct( + {txt = Longident.Lident "::"} as listConstructor, + Some ({ppat_desc=Ppat_tuple (pat::rest)} as element) + ) -> + (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) + {pat with ppat_desc = + Ppat_construct ( + listConstructor, + Some {element with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen pat)::rest)} + ) + } + | Ppat_construct ({txt = constructor} as longidentLoc, optPattern) -> + (* Foo.(Bar(a)) -> Foo.Bar(a) *) + {pat with ppat_desc = + Ppat_construct ( + {longidentLoc with txt = concatLongidents longidentOpen constructor}, + optPattern + ) + } + | Ppat_record (({txt = lbl} as longidentLoc, firstPat)::rest, flag) -> + (* Foo.{x} -> {Foo.x: x} *) + let firstRow = ( + {longidentLoc with txt = concatLongidents longidentOpen lbl}, + firstPat + ) in + {pat with ppat_desc = Ppat_record (firstRow::rest, flag)} + | Ppat_or (pat1, pat2) -> + {pat with ppat_desc = Ppat_or ( + rewritePpatOpen longidentOpen pat1, + rewritePpatOpen longidentOpen pat2 + )} + | Ppat_constraint (pattern, typ) -> + {pat with ppat_desc = Ppat_constraint ( + rewritePpatOpen longidentOpen pattern, + typ + )} + | Ppat_type ({txt = constructor} as longidentLoc) -> + {pat with ppat_desc = Ppat_type ( + {longidentLoc with txt = concatLongidents longidentOpen constructor} + )} + | Ppat_lazy p -> + {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} + | Ppat_exception p -> + {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} + | _ -> pat + +let rec rewriteReasonFastPipe expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op, + [Asttypes.Nolabel, lhs; Nolabel, rhs] + ); pexp_attributes = subAttrs}, + args + ) -> + let rhsLoc = {rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end} in + let newLhs = + let expr = rewriteReasonFastPipe lhs in + {expr with pexp_attributes = List.concat [lhs.pexp_attributes; subAttrs]} + in + let newRhs = { + pexp_loc = rhsLoc; + pexp_attributes = []; + pexp_desc = Pexp_apply (rhs, args) + } in + let allArgs = (Asttypes.Nolabel, newLhs)::[(Asttypes.Nolabel, newRhs)] in + {expr with pexp_desc = Pexp_apply (op, allArgs)} + | _ -> expr + +let makeReasonArityMapper ~forPrinter = + let open Ast_mapper in + { default_mapper with + expr = begin fun mapper expr -> + match expr with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> *) + (* let newArgs = match args with *) + (* | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args-> *) + (* if forPrinter then args else Some sp *) + (* | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp *) + (* | _ -> args *) + (* in *) + (* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} *) + | {pexp_desc=Pexp_construct(lid, args); pexp_loc; pexp_attributes} -> + let newArgs = match args with + | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args -> + if forPrinter then args else Some sp + | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp + | _ -> args + in + default_mapper.expr mapper { pexp_desc=Pexp_construct(lid, newArgs); pexp_loc; pexp_attributes} + | expr -> + default_mapper.expr mapper (rewriteReasonFastPipe expr) + end; + pat = begin fun mapper pattern -> + match pattern with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> *) + (* let newArgs = match args with *) + (* | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> *) + (* if forPrinter then args else Some sp *) + (* | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp *) + (* | _ -> args *) + (* in *) + (* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} *) + | {ppat_desc=Ppat_construct(lid, args); + ppat_loc; + ppat_attributes} -> + let new_args = match args with + | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> + if forPrinter then args else Some sp + | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp + | _ -> args in + default_mapper.pat mapper { ppat_desc=Ppat_construct(lid, new_args); ppat_loc; ppat_attributes;} + | x -> default_mapper.pat mapper x + end; + } + +let escapeTemplateLiteral s = + let len = String.length s in + let b = Buffer.create len in + let i = ref 0 in + while !i < len do + let c = (String.get [@doesNotRaise]) s !i in + if c = '`' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '`'; + incr i; + ) else if c = '$' then ( + if !i + 1 < len then ( + let c2 = (String.get [@doesNotRaise]) s (!i + 1) in + if c2 = '{' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '$'; + Buffer.add_char b '{'; + ) else ( + Buffer.add_char b c; + Buffer.add_char b c2; + ); + i := !i + 2; + ) else ( + Buffer.add_char b c; + incr i + ) + ) else if c = '\\' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '\\'; + incr i; + ) else ( + Buffer.add_char b c; + incr i + ) + done; + Buffer.contents b + +let escapeStringContents s = + let len = String.length s in + let b = Buffer.create len in + + let i = ref 0 in + + while !i < len do + let c = String.unsafe_get s !i in + if c = '\\' then ( + incr i; + Buffer.add_char b c; + let c = String.unsafe_get s !i in + if !i < len then + let () = Buffer.add_char b c in + incr i + else + () + ) else if c = '"' then ( + Buffer.add_char b '\\'; + Buffer.add_char b c; + incr i; + ) else ( + Buffer.add_char b c; + incr i; + ) + done; + Buffer.contents b + +let looksLikeRecursiveTypeDeclaration typeDeclaration = + let open Parsetree in + let name = typeDeclaration.ptype_name.txt in + let rec checkKind kind = + match kind with + | Ptype_abstract | Ptype_open -> false + | Ptype_variant constructorDeclarations -> + List.exists checkConstructorDeclaration constructorDeclarations + | Ptype_record labelDeclarations -> + List.exists checkLabelDeclaration labelDeclarations + + and checkConstructorDeclaration constrDecl = + checkConstructorArguments constrDecl.pcd_args + || (match constrDecl.pcd_res with + | Some typexpr -> + checkTypExpr typexpr + | None -> false + ) + + and checkLabelDeclaration labelDeclaration = + checkTypExpr labelDeclaration.pld_type + + and checkConstructorArguments constrArg = + match constrArg with + | Pcstr_tuple types -> + List.exists checkTypExpr types + | Pcstr_record labelDeclarations -> + List.exists checkLabelDeclaration labelDeclarations + + and checkTypExpr typ = + match typ.ptyp_desc with + | Ptyp_any -> false + | Ptyp_var _ -> false + | Ptyp_object (fields, _) -> + List.exists checkObjectField fields + | Ptyp_class _ -> false + | Ptyp_package _ -> false + | Ptyp_extension _ -> false + | Ptyp_arrow (_lbl, typ1, typ2) -> + checkTypExpr typ1 || checkTypExpr typ2 + | Ptyp_tuple types -> + List.exists checkTypExpr types + | Ptyp_constr ({txt = longident}, types) -> + (match longident with + | Lident ident -> ident = name + | _ -> false + ) || + List.exists checkTypExpr types + | Ptyp_alias (typ, _) -> checkTypExpr typ + | Ptyp_variant (rowFields, _, _) -> + List.exists checkRowFields rowFields + | Ptyp_poly (_, typ) -> + checkTypExpr typ + + and checkObjectField field = match field with + | Otag (_label, _attrs, typ) -> checkTypExpr typ + | Oinherit typ -> checkTypExpr typ + + and checkRowFields rowField = + match rowField with + | Rtag (_, _, _, types) -> + List.exists checkTypExpr types + | Rinherit typexpr -> + checkTypExpr typexpr + + and checkManifest manifest = + match manifest with + | Some typ -> + checkTypExpr typ + | None -> false + in + checkKind typeDeclaration.ptype_kind || checkManifest typeDeclaration.ptype_manifest + + +let filterReasonRawLiteral attrs = + List.filter (fun attr -> + match attr with + | ({Location.txt = ("reason.raw_literal")}, _) -> false + | _ -> true + ) attrs + +let stringLiteralMapper stringData = + let isSameLocation l1 l2 = + let open Location in + l1.loc_start.pos_cnum == l2.loc_start.pos_cnum + in + let remainingStringData = stringData in + let open Ast_mapper in + { default_mapper with + expr = (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (_txt, None)) -> + begin match + List.find_opt (fun (_stringData, stringLoc) -> + isSameLocation stringLoc expr.pexp_loc + ) remainingStringData + with + | Some(stringData, _) -> + let stringData = + let attr = List.find_opt (fun attr -> match attr with + | ({Location.txt = ("reason.raw_literal")}, _) -> true + | _ -> false + ) expr.pexp_attributes in + match attr with + | Some (_, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (raw, _))}, _)}]) -> + raw + | _ -> (String.sub [@doesNotRaise]) stringData 1 (String.length stringData - 2) + in + {expr with + pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; + pexp_desc = Pexp_constant (Pconst_string (stringData, None)) + } + | None -> + default_mapper.expr mapper expr + end + | _ -> default_mapper.expr mapper expr + ) + } + +let hasUncurriedAttribute attrs = List.exists (fun attr -> match attr with + | ({Asttypes.txt = "bs"}, Parsetree.PStr []) -> true + | _ -> false +) attrs + +let normalize = + let open Ast_mapper in + { default_mapper with + extension = (fun mapper ext -> + match ext with + | (id, payload) -> + ( + {id with txt = Res_printer.convertBsExtension id.txt}, + default_mapper.payload mapper payload + ) + ); + attribute = (fun mapper attr -> + match attr with + | (id, payload) -> + ( + {id with txt = Res_printer.convertBsExternalAttribute id.txt}, + default_mapper.payload mapper payload + ) + ); + attributes = (fun mapper attrs -> + attrs + |> List.filter (fun attr -> + match attr with + | ({Location.txt = ( + "reason.preserve_braces" + | "explicit_arity" + | "implicity_arity" + )}, _) -> false + | _ ->true + ) + |> default_mapper.attributes mapper + ); + pat = begin fun mapper p -> + match p.ppat_desc with + | Ppat_open ({txt = longidentOpen}, pattern) -> + let p = rewritePpatOpen longidentOpen pattern in + default_mapper.pat mapper p + | Ppat_constant (Pconst_string (txt, tag)) -> + let newTag = match tag with + (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in + {p with + ppat_attributes = mapper.attributes mapper p.ppat_attributes; + ppat_desc = Ppat_constant s + } + | _ -> + default_mapper.pat mapper p + end; + typ = (fun mapper typ -> + match typ.ptyp_desc with + | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [arg]) -> + (* Js.t({"a": b}) -> {"a": b} + Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) + mapper.typ mapper arg + | _ -> default_mapper.typ mapper typ + ); + expr = (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (txt, None)) -> + let raw = escapeStringContents txt in + let s = Parsetree.Pconst_string (raw, None) in + {expr with pexp_desc = Pexp_constant s} + | Pexp_constant (Pconst_string (txt, tag)) -> + let newTag = match tag with + (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in + {expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_constant s + } + | Pexp_apply ( + callExpr, + [ + Nolabel, + ({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); pexp_attributes = []} as unitExpr) + ] + ) when hasUncurriedAttribute expr.pexp_attributes + -> + {expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_apply ( + callExpr, + [Nolabel, {unitExpr with pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}}] + ) + } + | Pexp_function cases -> + let loc = match (cases, List.rev cases) with + | (first::_), (last::_) -> + {first.pc_lhs.ppat_loc with loc_end = last.pc_rhs.pexp_loc.loc_end} + | _ -> Location.none + in + let var = { + Parsetree.ppat_loc = Location.none; + ppat_attributes = []; + ppat_desc = Ppat_var (Location.mknoloc "x"); + } in + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = Pexp_fun ( + Asttypes.Nolabel, + None, + var, + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = Pexp_match ( + { + pexp_loc = Location.none; + pexp_attributes = []; + pexp_desc = Pexp_ident (Location.mknoloc (Longident.Lident "x")) + }, + (mapper.cases mapper cases) + ) + + } + ) + } + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, + [Asttypes.Nolabel, operand] + ) -> + (* turn `!foo` into `foo.contents` *) + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_field (mapper.expr mapper operand, (Location.mknoloc (Longident.Lident "contents"))) + } + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [ + Asttypes.Nolabel, lhs; Nolabel, + ({pexp_desc = Pexp_constant (Pconst_string (txt, None)) | (Pexp_ident ({txt = Longident.Lident txt})); pexp_loc = labelLoc})] + ) -> + let label = Location.mkloc txt labelLoc in + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_send (mapper.expr mapper lhs, label) + } + | Pexp_match ( + condition, + [ + {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "true"}, None)}; pc_rhs = thenExpr }; + {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "false"}, None)}; pc_rhs = elseExpr }; + ] + ) -> + let ternaryMarker = (Location.mknoloc "ns.ternary", Parsetree.PStr []) in + {Parsetree.pexp_loc = expr.pexp_loc; + pexp_desc = Pexp_ifthenelse ( + mapper.expr mapper condition, + mapper.expr mapper thenExpr, + (Some (mapper.expr mapper elseExpr)) + ); + pexp_attributes = ternaryMarker::expr.pexp_attributes; + } + | _ -> default_mapper.expr mapper expr + ); + structure_item = begin fun mapper structureItem -> + match structureItem.pstr_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Pstr_type (Recursive as recFlag, typeDeclarations) -> + let flag = match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + {structureItem with pstr_desc = Pstr_type ( + flag, + List.map (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration + ) typeDeclarations + )} + | _ -> default_mapper.structure_item mapper structureItem + end; + signature_item = begin fun mapper signatureItem -> + match signatureItem.psig_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Psig_type (Recursive as recFlag, typeDeclarations) -> + let flag = match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + {signatureItem with psig_desc = Psig_type ( + flag, + List.map (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration + ) typeDeclarations + )} + | _ -> default_mapper.signature_item mapper signatureItem + end; + value_binding = begin fun mapper vb -> + match vb with + | { + pvb_pat = {ppat_desc = Ppat_var _} as pat; + pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } + } when expr_loc.loc_ghost -> + (* let t: t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = { + Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ) + } in + {vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} + | { + pvb_pat = {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})} ; + pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } + } when expr_loc.loc_ghost -> + (* let t: . t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = { + Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ) + } in + {vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} + | _ -> default_mapper.value_binding mapper vb + end; + } + +let normalizeReasonArityStructure ~forPrinter s = + let mapper = makeReasonArityMapper ~forPrinter in + mapper.Ast_mapper.structure mapper s + +let normalizeReasonAritySignature ~forPrinter s = + let mapper = makeReasonArityMapper ~forPrinter in + mapper.Ast_mapper.signature mapper s + +let structure s = normalize.Ast_mapper.structure normalize s +let signature s = normalize.Ast_mapper.signature normalize s + +let replaceStringLiteralStructure stringData structure = + let mapper = stringLiteralMapper stringData in + mapper.Ast_mapper.structure mapper structure + +let replaceStringLiteralSignature stringData signature = + let mapper = stringLiteralMapper stringData in + mapper.Ast_mapper.signature mapper signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli new file mode 100644 index 000000000..f66f1965d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli @@ -0,0 +1,24 @@ +(* The purpose of this module is to convert a parsetree coming from the reason + * or ocaml parser, into something consumable by the rescript printer. *) + +(* Ocaml/Reason parser interprets string literals: i.e. escape sequences and unicode. + * For printing purposes you want to preserve the original string. + * Example: "😎" is interpreted as "\240\159\152\142" + * The purpose of this routine is to place the original string back in + * the parsetree for printing purposes. Unicode and escape sequences + * shouldn't be mangled when *) +val replaceStringLiteralStructure: + (string * Location.t) list -> Parsetree.structure -> Parsetree.structure +val replaceStringLiteralSignature: + (string * Location.t) list -> Parsetree.signature -> Parsetree.signature + +(* Get rid of the explicit/implicit arity attributes *) +val normalizeReasonArityStructure: + forPrinter:bool -> Parsetree.structure -> Parsetree.structure +val normalizeReasonAritySignature: + forPrinter:bool -> Parsetree.signature -> Parsetree.signature + +(* transform parts of the parsetree into a suitable parsetree suitable + * for printing. Example: convert reason ternaries into rescript ternaries *) +val structure: Parsetree.structure -> Parsetree.structure +val signature: Parsetree.signature -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml new file mode 100644 index 000000000..1dbb2d420 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml @@ -0,0 +1,1235 @@ +module Doc = Res_doc + +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> + Printast.implementation Format.std_formatter structure + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> + Printast.interface Format.std_formatter signature + end; +} + +module Sexp: sig + type t + + val atom: string -> t + val list: t list -> t + val toString: t -> string +end = struct + type t = + | Atom of string + | List of t list + + let atom s = Atom s + let list l = List l + + let rec toDoc t = + match t with + | Atom s -> Doc.text s + | List [] -> Doc.text "()" + | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen;] + | List (hd::tail) -> + Doc.group ( + Doc.concat [ + Doc.lparen; + toDoc hd; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line (List.map toDoc tail); + ] + ); + Doc.rparen; + ] + ) + + let toString sexpr = + let doc = toDoc sexpr in + Doc.toString ~width:80 doc +end + +module SexpAst = struct + open Parsetree + + let mapEmpty ~f items = + match items with + | [] -> [Sexp.list []] + | items -> List.map f items + + let string txt = + Sexp.atom ("\"" ^ txt ^ "\"") + + let char c = + Sexp.atom ("'" ^ (Char.escaped c) ^ "'") + + let optChar oc = + match oc with + | None -> Sexp.atom "None" + | Some c -> + Sexp.list [ + Sexp.atom "Some"; + char c + ] + + let longident l = + let rec loop l = match l with + | Longident.Lident ident -> Sexp.list [ + Sexp.atom "Lident"; + string ident; + ] + | Longident.Ldot (lident, txt) -> + Sexp.list [ + Sexp.atom "Ldot"; + loop lident; + string txt; + ] + | Longident.Lapply (l1, l2) -> + Sexp.list [ + Sexp.atom "Lapply"; + loop l1; + loop l2; + ] + in + Sexp.list [ + Sexp.atom "longident"; + loop l; + ] + + let closedFlag flag = match flag with + | Asttypes.Closed -> Sexp.atom "Closed" + | Open -> Sexp.atom "Open" + + let directionFlag flag = match flag with + | Asttypes.Upto -> Sexp.atom "Upto" + | Downto -> Sexp.atom "Downto" + + let recFlag flag = match flag with + | Asttypes.Recursive -> Sexp.atom "Recursive" + | Nonrecursive -> Sexp.atom "Nonrecursive" + + let overrideFlag flag = match flag with + | Asttypes.Override -> Sexp.atom "Override" + | Fresh -> Sexp.atom "Fresh" + + let privateFlag flag = match flag with + | Asttypes.Public -> Sexp.atom "Public" + | Private -> Sexp.atom "Private" + + let mutableFlag flag = match flag with + | Asttypes.Immutable -> Sexp.atom "Immutable" + | Mutable -> Sexp.atom "Mutable" + + let variance v = match v with + | Asttypes.Covariant -> Sexp.atom "Covariant" + | Contravariant -> Sexp.atom "Contravariant" + | Invariant -> Sexp.atom "Invariant" + + let argLabel lbl = match lbl with + | Asttypes.Nolabel -> Sexp.atom "Nolabel" + | Labelled txt -> Sexp.list [ + Sexp.atom "Labelled"; + string txt; + ] + | Optional txt -> Sexp.list [ + Sexp.atom "Optional"; + string txt; + ] + + let constant c = + let sexpr = match c with + | Pconst_integer (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_integer"; + string txt; + optChar tag; + ] + | Pconst_char c -> + Sexp.list [ + Sexp.atom "Pconst_char"; + Sexp.atom (Char.escaped c); + ] + | Pconst_string (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_string"; + string txt; + match tag with + | Some txt -> Sexp.list [ + Sexp.atom "Some"; + string txt; + ] + | None -> Sexp.atom "None"; + ] + | Pconst_float (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_float"; + string txt; + optChar tag; + ] + in + Sexp.list [ + Sexp.atom "constant"; + sexpr + ] + + let rec structure s = + Sexp.list ( + (Sexp.atom "structure")::(List.map structureItem s) + ) + + and structureItem si = + let desc = match si.pstr_desc with + | Pstr_eval (expr, attrs) -> + Sexp.list [ + Sexp.atom "Pstr_eval"; + expression expr; + attributes attrs; + ] + | Pstr_value (flag, vbs) -> + Sexp.list [ + Sexp.atom "Pstr_value"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs) + ] + | Pstr_primitive (vd) -> + Sexp.list [ + Sexp.atom "Pstr_primitive"; + valueDescription vd; + ] + | Pstr_type (flag, tds) -> + Sexp.list [ + Sexp.atom "Pstr_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration tds) + ] + | Pstr_typext typext -> + Sexp.list [ + Sexp.atom "Pstr_type"; + typeExtension typext; + ] + | Pstr_exception ec -> + Sexp.list [ + Sexp.atom "Pstr_exception"; + extensionConstructor ec; + ] + | Pstr_module mb -> + Sexp.list [ + Sexp.atom "Pstr_module"; + moduleBinding mb; + ] + | Pstr_recmodule mbs -> + Sexp.list [ + Sexp.atom "Pstr_recmodule"; + Sexp.list (mapEmpty ~f:moduleBinding mbs); + ] + | Pstr_modtype modTypDecl -> + Sexp.list [ + Sexp.atom "Pstr_modtype"; + moduleTypeDeclaration modTypDecl; + ] + | Pstr_open openDesc -> + Sexp.list [ + Sexp.atom "Pstr_open"; + openDescription openDesc; + ] + | Pstr_class _ -> Sexp.atom "Pstr_class" + | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" + | Pstr_include id -> + Sexp.list [ + Sexp.atom "Pstr_include"; + includeDeclaration id; + ] + | Pstr_attribute attr -> + Sexp.list [ + Sexp.atom "Pstr_attribute"; + attribute attr; + ] + | Pstr_extension (ext, attrs) -> + Sexp.list [ + Sexp.atom "Pstr_extension"; + extension ext; + attributes attrs; + ] + in + Sexp.list [ + Sexp.atom "structure_item"; + desc; + ] + + and includeDeclaration id = + Sexp.list [ + Sexp.atom "include_declaration"; + moduleExpression id.pincl_mod; + attributes id.pincl_attributes; + ] + + and openDescription od = + Sexp.list [ + Sexp.atom "open_description"; + longident od.popen_lid.Asttypes.txt; + attributes od.popen_attributes; + ] + + and moduleTypeDeclaration mtd = + Sexp.list [ + Sexp.atom "module_type_declaration"; + string mtd.pmtd_name.Asttypes.txt; + (match mtd.pmtd_type with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + attributes mtd.pmtd_attributes; + ] + + and moduleBinding mb = + Sexp.list [ + Sexp.atom "module_binding"; + string mb.pmb_name.Asttypes.txt; + moduleExpression mb.pmb_expr; + attributes mb.pmb_attributes; + ] + + and moduleExpression me = + let desc = match me.pmod_desc with + | Pmod_ident modName -> + Sexp.list [ + Sexp.atom "Pmod_ident"; + longident modName.Asttypes.txt; + ] + | Pmod_structure s -> + Sexp.list [ + Sexp.atom "Pmod_structure"; + structure s; + ] + | Pmod_functor (lbl, optModType, modExpr) -> + Sexp.list [ + Sexp.atom "Pmod_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + moduleExpression modExpr; + ] + | Pmod_apply (callModExpr, modExprArg) -> + Sexp.list [ + Sexp.atom "Pmod_apply"; + moduleExpression callModExpr; + moduleExpression modExprArg; + ] + | Pmod_constraint (modExpr, modType) -> + Sexp.list [ + Sexp.atom "Pmod_constraint"; + moduleExpression modExpr; + moduleType modType; + ] + | Pmod_unpack expr -> + Sexp.list [ + Sexp.atom "Pmod_unpack"; + expression expr; + ] + | Pmod_extension ext -> + Sexp.list [ + Sexp.atom "Pmod_extension"; + extension ext; + ] + in + Sexp.list [ + Sexp.atom "module_expr"; + desc; + attributes me.pmod_attributes; + ] + + and moduleType mt = + let desc = match mt.pmty_desc with + | Pmty_ident longidentLoc -> + Sexp.list [ + Sexp.atom "Pmty_ident"; + longident longidentLoc.Asttypes.txt; + ] + | Pmty_signature s -> + Sexp.list [ + Sexp.atom "Pmty_signature"; + signature s; + ] + | Pmty_functor (lbl, optModType, modType) -> + Sexp.list [ + Sexp.atom "Pmty_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + moduleType modType; + ] + | Pmty_alias longidentLoc -> + Sexp.list [ + Sexp.atom "Pmty_alias"; + longident longidentLoc.Asttypes.txt; + ] + | Pmty_extension ext -> + Sexp.list [ + Sexp.atom "Pmty_extension"; + extension ext; + ] + | Pmty_typeof modExpr -> + Sexp.list [ + Sexp.atom "Pmty_typeof"; + moduleExpression modExpr; + ] + | Pmty_with (modType, withConstraints) -> + Sexp.list [ + Sexp.atom "Pmty_with"; + moduleType modType; + Sexp.list (mapEmpty ~f:withConstraint withConstraints); + ] + in + Sexp.list [ + Sexp.atom "module_type"; + desc; + attributes mt.pmty_attributes; + ] + + and withConstraint wc = match wc with + | Pwith_type (longidentLoc, td) -> + Sexp.list [ + Sexp.atom "Pmty_with"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] + | Pwith_module (l1, l2) -> + Sexp.list [ + Sexp.atom "Pwith_module"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + | Pwith_typesubst (longidentLoc, td) -> + Sexp.list [ + Sexp.atom "Pwith_typesubst"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] + | Pwith_modsubst (l1, l2) -> + Sexp.list [ + Sexp.atom "Pwith_modsubst"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + + and signature s = + Sexp.list ( + (Sexp.atom "signature")::(List.map signatureItem s) + ) + + and signatureItem si = + let descr = match si.psig_desc with + | Psig_value vd -> + Sexp.list [ + Sexp.atom "Psig_value"; + valueDescription vd; + ] + | Psig_type (flag, typeDeclarations) -> + Sexp.list [ + Sexp.atom "Psig_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); + ] + | Psig_typext typExt -> + Sexp.list [ + Sexp.atom "Psig_typext"; + typeExtension typExt; + ] + | Psig_exception extConstr -> + Sexp.list [ + Sexp.atom "Psig_exception"; + extensionConstructor extConstr; + ] + | Psig_module modDecl -> + Sexp.list [ + Sexp.atom "Psig_module"; + moduleDeclaration modDecl; + ] + | Psig_recmodule modDecls -> + Sexp.list [ + Sexp.atom "Psig_recmodule"; + Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); + ] + | Psig_modtype modTypDecl -> + Sexp.list [ + Sexp.atom "Psig_modtype"; + moduleTypeDeclaration modTypDecl; + ] + | Psig_open openDesc -> + Sexp.list [ + Sexp.atom "Psig_open"; + openDescription openDesc; + ] + | Psig_include inclDecl -> + Sexp.list [ + Sexp.atom "Psig_include"; + includeDescription inclDecl + ] + | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class";] + | Psig_class_type _ -> Sexp.list [ Sexp.atom "Psig_class_type"; ] + | Psig_attribute attr -> + Sexp.list [ + Sexp.atom "Psig_attribute"; + attribute attr; + ] + | Psig_extension (ext, attrs) -> + Sexp.list [ + Sexp.atom "Psig_extension"; + extension ext; + attributes attrs; + ] + in + Sexp.list [ + Sexp.atom "signature_item"; + descr; + ] + + and includeDescription id = + Sexp.list [ + Sexp.atom "include_description"; + moduleType id.pincl_mod; + attributes id.pincl_attributes; + ] + + and moduleDeclaration md = + Sexp.list [ + Sexp.atom "module_declaration"; + string md.pmd_name.Asttypes.txt; + moduleType md.pmd_type; + attributes md.pmd_attributes; + ] + + and valueBinding vb = + Sexp.list [ + Sexp.atom "value_binding"; + pattern vb.pvb_pat; + expression vb.pvb_expr; + attributes vb.pvb_attributes; + ] + + and valueDescription vd = + Sexp.list [ + Sexp.atom "value_description"; + string vd.pval_name.Asttypes.txt; + coreType vd.pval_type; + Sexp.list (mapEmpty ~f:string vd.pval_prim); + attributes vd.pval_attributes; + ] + + and typeDeclaration td = + Sexp.list [ + Sexp.atom "type_declaration"; + string td.ptype_name.Asttypes.txt; + Sexp.list [ + Sexp.atom "ptype_params"; + Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> + Sexp.list [ + coreType typexpr; + variance var; + ]) td.ptype_params) + ]; + Sexp.list [ + Sexp.atom "ptype_cstrs"; + Sexp.list (mapEmpty ~f:(fun (typ1, typ2, _loc) -> + Sexp.list [ + coreType typ1; + coreType typ2; + ]) td.ptype_cstrs) + ]; + Sexp.list [ + Sexp.atom "ptype_kind"; + typeKind td.ptype_kind; + ]; + Sexp.list [ + Sexp.atom "ptype_manifest"; + match td.ptype_manifest with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ]; + Sexp.list [ + Sexp.atom "ptype_private"; + privateFlag td.ptype_private; + ]; + attributes td.ptype_attributes; + ] + + and extensionConstructor ec = + Sexp.list [ + Sexp.atom "extension_constructor"; + string ec.pext_name.Asttypes.txt; + extensionConstructorKind ec.pext_kind; + attributes ec.pext_attributes; + ] + + and extensionConstructorKind kind = match kind with + | Pext_decl (args, optTypExpr) -> + Sexp.list [ + Sexp.atom "Pext_decl"; + constructorArguments args; + match optTypExpr with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ] + | Pext_rebind longidentLoc -> + Sexp.list [ + Sexp.atom "Pext_rebind"; + longident longidentLoc.Asttypes.txt; + ] + + and typeExtension te = + Sexp.list [ + Sexp.atom "type_extension"; + Sexp.list [ + Sexp.atom "ptyext_path"; + longident te.ptyext_path.Asttypes.txt; + ]; + Sexp.list [ + Sexp.atom "ptyext_parms"; + Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> + Sexp.list [ + coreType typexpr; + variance var; + ]) te.ptyext_params) + ]; + Sexp.list [ + Sexp.atom "ptyext_constructors"; + Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); + ]; + Sexp.list [ + Sexp.atom "ptyext_private"; + privateFlag te.ptyext_private; + ]; + attributes te.ptyext_attributes; + ] + + and typeKind kind = match kind with + | Ptype_abstract -> Sexp.atom "Ptype_abstract" + | Ptype_variant constrDecls -> + Sexp.list [ + Sexp.atom "Ptype_variant"; + Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); + ] + | Ptype_record lblDecls -> + Sexp.list [ + Sexp.atom "Ptype_record"; + Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); + ] + | Ptype_open -> Sexp.atom "Ptype_open" + + and constructorDeclaration cd = + Sexp.list [ + Sexp.atom "constructor_declaration"; + string cd.pcd_name.Asttypes.txt; + Sexp.list [ + Sexp.atom "pcd_args"; + constructorArguments cd.pcd_args; + ]; + Sexp.list [ + Sexp.atom "pcd_res"; + match cd.pcd_res with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ]; + attributes cd.pcd_attributes; + ] + + and constructorArguments args = match args with + | Pcstr_tuple types -> + Sexp.list [ + Sexp.atom "Pcstr_tuple"; + Sexp.list (mapEmpty ~f:coreType types) + ] + | Pcstr_record lds -> + Sexp.list [ + Sexp.atom "Pcstr_record"; + Sexp.list (mapEmpty ~f:labelDeclaration lds) + ] + + and labelDeclaration ld = + Sexp.list [ + Sexp.atom "label_declaration"; + string ld.pld_name.Asttypes.txt; + mutableFlag ld.pld_mutable; + coreType ld.pld_type; + attributes ld.pld_attributes; + ] + + and expression expr = + let desc = match expr.pexp_desc with + | Pexp_ident longidentLoc -> + Sexp.list [ + Sexp.atom "Pexp_ident"; + longident longidentLoc.Asttypes.txt; + ] + | Pexp_constant c -> + Sexp.list [ + Sexp.atom "Pexp_constant"; + constant c + ] + | Pexp_let (flag, vbs, expr) -> + Sexp.list [ + Sexp.atom "Pexp_let"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs); + expression expr; + ] + | Pexp_function cases -> + Sexp.list [ + Sexp.atom "Pexp_function"; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_fun (argLbl, exprOpt, pat, expr) -> + Sexp.list [ + Sexp.atom "Pexp_fun"; + argLabel argLbl; + (match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + pattern pat; + expression expr; + ] + | Pexp_apply (expr, args) -> + Sexp.list [ + Sexp.atom "Pexp_apply"; + expression expr; + Sexp.list (mapEmpty ~f:(fun (argLbl, expr) -> Sexp.list [ + argLabel argLbl; + expression expr + ]) args); + ] + | Pexp_match (expr, cases) -> + Sexp.list [ + Sexp.atom "Pexp_match"; + expression expr; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_try (expr, cases) -> + Sexp.list [ + Sexp.atom "Pexp_try"; + expression expr; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_tuple exprs -> + Sexp.list [ + Sexp.atom "Pexp_tuple"; + Sexp.list (mapEmpty ~f:expression exprs); + ] + | Pexp_construct (longidentLoc, exprOpt) -> + Sexp.list [ + Sexp.atom "Pexp_construct"; + longident longidentLoc.Asttypes.txt; + match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ] + | Pexp_variant (lbl, exprOpt) -> + Sexp.list [ + Sexp.atom "Pexp_variant"; + string lbl; + match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ] + | Pexp_record (rows, optExpr) -> + Sexp.list [ + Sexp.atom "Pexp_record"; + Sexp.list (mapEmpty ~f:(fun (longidentLoc, expr) -> Sexp.list [ + longident longidentLoc.Asttypes.txt; + expression expr; + ]) rows); + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + ] + | Pexp_field (expr, longidentLoc) -> + Sexp.list [ + Sexp.atom "Pexp_field"; + expression expr; + longident longidentLoc.Asttypes.txt; + ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_setfield"; + expression expr1; + longident longidentLoc.Asttypes.txt; + expression expr2; + ] + | Pexp_array exprs -> + Sexp.list [ + Sexp.atom "Pexp_array"; + Sexp.list (mapEmpty ~f:expression exprs); + ] + | Pexp_ifthenelse (expr1, expr2, optExpr) -> + Sexp.list [ + Sexp.atom "Pexp_ifthenelse"; + expression expr1; + expression expr2; + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + ] + | Pexp_sequence (expr1, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_sequence"; + expression expr1; + expression expr2; + ] + | Pexp_while (expr1, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_while"; + expression expr1; + expression expr2; + ] + | Pexp_for (pat, e1, e2, flag, e3) -> + Sexp.list [ + Sexp.atom "Pexp_for"; + pattern pat; + expression e1; + expression e2; + directionFlag flag; + expression e3; + ] + | Pexp_constraint (expr, typexpr) -> + Sexp.list [ + Sexp.atom "Pexp_constraint"; + expression expr; + coreType typexpr; + ] + | Pexp_coerce (expr, optTyp, typexpr) -> + Sexp.list [ + Sexp.atom "Pexp_coerce"; + expression expr; + (match optTyp with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ]); + coreType typexpr; + ] + | Pexp_send _ -> + Sexp.list [ + Sexp.atom "Pexp_send"; + ] + | Pexp_new _ -> + Sexp.list [ + Sexp.atom "Pexp_new"; + ] + | Pexp_setinstvar _ -> + Sexp.list [ + Sexp.atom "Pexp_setinstvar"; + ] + | Pexp_override _ -> + Sexp.list [ + Sexp.atom "Pexp_override"; + ] + | Pexp_letmodule (modName, modExpr, expr) -> + Sexp.list [ + Sexp.atom "Pexp_letmodule"; + string modName.Asttypes.txt; + moduleExpression modExpr; + expression expr; + ] + | Pexp_letexception (extConstr, expr) -> + Sexp.list [ + Sexp.atom "Pexp_letexception"; + extensionConstructor extConstr; + expression expr; + ] + | Pexp_assert expr -> + Sexp.list [ + Sexp.atom "Pexp_assert"; + expression expr; + ] + | Pexp_lazy expr -> + Sexp.list [ + Sexp.atom "Pexp_lazy"; + expression expr; + ] + | Pexp_poly _ -> + Sexp.list [ + Sexp.atom "Pexp_poly"; + ] + | Pexp_object _ -> + Sexp.list [ + Sexp.atom "Pexp_object"; + ] + | Pexp_newtype (lbl, expr) -> + Sexp.list [ + Sexp.atom "Pexp_newtype"; + string lbl.Asttypes.txt; + expression expr; + ] + | Pexp_pack modExpr -> + Sexp.list [ + Sexp.atom "Pexp_pack"; + moduleExpression modExpr; + ] + | Pexp_open (flag, longidentLoc, expr) -> + Sexp.list [ + Sexp.atom "Pexp_open"; + overrideFlag flag; + longident longidentLoc.Asttypes.txt; + expression expr; + ] + | Pexp_extension ext -> + Sexp.list [ + Sexp.atom "Pexp_extension"; + extension ext; + ] + | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" + in + Sexp.list [ + Sexp.atom "expression"; + desc; + ] + + and case c = + Sexp.list [ + Sexp.atom "case"; + Sexp.list [ + Sexp.atom "pc_lhs"; + pattern c.pc_lhs; + ]; + Sexp.list [ + Sexp.atom "pc_guard"; + match c.pc_guard with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ]; + Sexp.list [ + Sexp.atom "pc_rhs"; + expression c.pc_rhs; + ] + ] + + and pattern p = + let descr = match p.ppat_desc with + | Ppat_any -> + Sexp.atom "Ppat_any" + | Ppat_var var -> + Sexp.list [ + Sexp.atom "Ppat_var"; + string var.Location.txt; + ] + | Ppat_alias (p, alias) -> + Sexp.list [ + Sexp.atom "Ppat_alias"; + pattern p; + string alias.txt; + ] + | Ppat_constant c -> + Sexp.list [ + Sexp.atom "Ppat_constant"; + constant c; + ] + | Ppat_interval (lo, hi) -> + Sexp.list [ + Sexp.atom "Ppat_interval"; + constant lo; + constant hi; + ] + | Ppat_tuple (patterns) -> + Sexp.list [ + Sexp.atom "Ppat_tuple"; + Sexp.list (mapEmpty ~f:pattern patterns); + ] + | Ppat_construct (longidentLoc, optPattern) -> + Sexp.list [ + Sexp.atom "Ppat_construct"; + longident longidentLoc.Location.txt; + match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [ + Sexp.atom "some"; + pattern p; + ] + ] + | Ppat_variant (lbl, optPattern) -> + Sexp.list [ + Sexp.atom "Ppat_variant"; + string lbl; + match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [ + Sexp.atom "Some"; + pattern p; + ] + ] + | Ppat_record (rows, flag) -> + Sexp.list [ + Sexp.atom "Ppat_record"; + closedFlag flag; + Sexp.list (mapEmpty ~f:(fun (longidentLoc, p) -> + Sexp.list [ + longident longidentLoc.Location.txt; + pattern p; + ] + ) rows) + ] + | Ppat_array patterns -> + Sexp.list [ + Sexp.atom "Ppat_array"; + Sexp.list (mapEmpty ~f:pattern patterns); + ] + | Ppat_or (p1, p2) -> + Sexp.list [ + Sexp.atom "Ppat_or"; + pattern p1; + pattern p2; + ] + | Ppat_constraint (p, typexpr) -> + Sexp.list [ + Sexp.atom "Ppat_constraint"; + pattern p; + coreType typexpr; + ] + | Ppat_type longidentLoc -> + Sexp.list [ + Sexp.atom "Ppat_type"; + longident longidentLoc.Location.txt + ] + | Ppat_lazy p -> + Sexp.list [ + Sexp.atom "Ppat_lazy"; + pattern p; + ] + | Ppat_unpack stringLoc -> + Sexp.list [ + Sexp.atom "Ppat_unpack"; + string stringLoc.Location.txt; + ] + | Ppat_exception p -> + Sexp.list [ + Sexp.atom "Ppat_exception"; + pattern p; + ] + | Ppat_extension ext -> + Sexp.list [ + Sexp.atom "Ppat_extension"; + extension ext; + ] + | Ppat_open (longidentLoc, p) -> + Sexp.list [ + Sexp.atom "Ppat_open"; + longident longidentLoc.Location.txt; + pattern p; + ] + in + Sexp.list [ + Sexp.atom "pattern"; + descr; + ] + + and objectField field = match field with + | Otag (lblLoc, attrs, typexpr) -> + Sexp.list [ + Sexp.atom "Otag"; + string lblLoc.txt; + attributes attrs; + coreType typexpr; + ] + | Oinherit typexpr -> + Sexp.list [ + Sexp.atom "Oinherit"; + coreType typexpr; + ] + + and rowField field = match field with + | Rtag (labelLoc, attrs, truth, types) -> + Sexp.list [ + Sexp.atom "Rtag"; + string labelLoc.txt; + attributes attrs; + Sexp.atom (if truth then "true" else "false"); + Sexp.list (mapEmpty ~f:coreType types); + ] + | Rinherit typexpr -> + Sexp.list [ + Sexp.atom "Rinherit"; + coreType typexpr; + ] + + and packageType (modNameLoc, packageConstraints) = + Sexp.list [ + Sexp.atom "package_type"; + longident modNameLoc.Asttypes.txt; + Sexp.list (mapEmpty ~f:(fun (modNameLoc, typexpr) -> + Sexp.list [ + longident modNameLoc.Asttypes.txt; + coreType typexpr; + ] + ) packageConstraints) + ] + + and coreType typexpr = + let desc = match typexpr.ptyp_desc with + | Ptyp_any -> Sexp.atom "Ptyp_any" + | Ptyp_var var -> Sexp.list [ + Sexp.atom "Ptyp_var"; + string var + ] + | Ptyp_arrow (argLbl, typ1, typ2) -> + Sexp.list [ + Sexp.atom "Ptyp_arrow"; + argLabel argLbl; + coreType typ1; + coreType typ2; + ] + | Ptyp_tuple types -> + Sexp.list [ + Sexp.atom "Ptyp_tuple"; + Sexp.list (mapEmpty ~f:coreType types); + ] + | Ptyp_constr (longidentLoc, types) -> + Sexp.list [ + Sexp.atom "Ptyp_constr"; + longident longidentLoc.txt; + Sexp.list (mapEmpty ~f:coreType types); + ] + | Ptyp_alias (typexpr, alias) -> + Sexp.list [ + Sexp.atom "Ptyp_alias"; + coreType typexpr; + string alias; + ] + | Ptyp_object (fields, flag) -> + Sexp.list [ + Sexp.atom "Ptyp_object"; + closedFlag flag; + Sexp.list (mapEmpty ~f:objectField fields) + ] + | Ptyp_class (longidentLoc, types) -> + Sexp.list [ + Sexp.atom "Ptyp_class"; + longident longidentLoc.Location.txt; + Sexp.list (mapEmpty ~f:coreType types) + ] + | Ptyp_variant (fields, flag, optLabels) -> + Sexp.list [ + Sexp.atom "Ptyp_variant"; + Sexp.list (mapEmpty ~f:rowField fields); + closedFlag flag; + match optLabels with + | None -> Sexp.atom "None" + | Some lbls -> Sexp.list (mapEmpty ~f:string lbls); + ] + | Ptyp_poly (lbls, typexpr) -> + Sexp.list [ + Sexp.atom "Ptyp_poly"; + Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); + coreType typexpr; + ] + | Ptyp_package (package) -> + Sexp.list [ + Sexp.atom "Ptyp_package"; + packageType package; + ] + | Ptyp_extension (ext) -> + Sexp.list [ + Sexp.atom "Ptyp_extension"; + extension ext; + ] + in + Sexp.list [ + Sexp.atom "core_type"; + desc; + ] + + and payload p = + match p with + | PStr s -> + Sexp.list ( + (Sexp.atom "PStr")::(mapEmpty ~f:structureItem s) + ) + | PSig s -> + Sexp.list [ + Sexp.atom "PSig"; + signature s; + ] + | PTyp ct -> + Sexp.list [ + Sexp.atom "PTyp"; + coreType ct + ] + | PPat (pat, optExpr) -> + Sexp.list [ + Sexp.atom "PPat"; + pattern pat; + match optExpr with + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + | None -> Sexp.atom "None"; + ] + + and attribute (stringLoc, p) = + Sexp.list [ + Sexp.atom "attribute"; + Sexp.atom stringLoc.Asttypes.txt; + payload p; + ] + + and extension (stringLoc, p) = + Sexp.list [ + Sexp.atom "extension"; + Sexp.atom stringLoc.Asttypes.txt; + payload p; + ] + + and attributes attrs = + let sexprs = mapEmpty ~f:attribute attrs in + Sexp.list ((Sexp.atom "attributes")::sexprs) + + let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> structure |> Sexp.toString |> print_string + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> signature |> Sexp.toString |> print_string + end; + } +end + +let sexpPrintEngine = SexpAst.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli new file mode 100644 index 000000000..392113312 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli @@ -0,0 +1,8 @@ + + + +val printEngine : Res_driver.printEngine + + +val sexpPrintEngine : Res_driver.printEngine + diff --git a/analysis/src/vendor/res_outcome_printer/res_cli.ml b/analysis/src/vendor/res_outcome_printer/res_cli.ml new file mode 100644 index 000000000..5ec9875ce --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_cli.ml @@ -0,0 +1,296 @@ +(* + This CLI isn't used apart for this repo's testing purposes. The syntax + itself is used by ReScript's compiler programmatically through various other apis. +*) + +(* + This is OCaml's Misc.ml's Color module. More specifically, this is + ReScript's OCaml fork's Misc.ml's Color module: + https://github.com/rescript-lang/ocaml/blob/92e58bedced8d7e3e177677800a38922327ab860/utils/misc.ml#L540 + + The syntax's printing's coloring logic depends on: + 1. a global mutable variable that's set in the compiler: Misc.Color.color_enabled + 2. the colors tags supported by Misc.Color, e.g. style_of_tag, which Format + tags like @{hello@} use + 3. etc. + + When this syntax is programmatically used inside ReScript, the various + Format tags like and get properly colored depending on the + above points. + + But when used by this cli file, that coloring logic doesn't render properly + because we're compiling against vanilla OCaml 4.06 instead of ReScript's + OCaml fork. For example, the vanilla compiler doesn't support the `dim` + color (grey). So we emulate the right coloring logic by copy pasting how our + forked OCaml compiler does it. +*) +module Color = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type color = + | Black [@live] + | Red + | Green [@live] + | Yellow + | Blue [@live] + | Magenta + | Cyan + | White [@live] + ;; + + type style = + | FG of color (* foreground *) + | BG of color [@live] (* background *) + | Bold + | Reset + | Dim + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + | Dim -> "2" + + let ansi_of_style_l l = + let s = match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ";" (List.map code_of_style l) + in + "\x1b[" ^ s ^ "m" + + type styles = { + error: style list; + warning: style list; + loc: style list; + } + + let default_styles = { + warning = [Bold; FG Magenta]; + error = [Bold; FG Red]; + loc = [Bold]; + } + + let cur_styles = ref default_styles + (* let get_styles () = !cur_styles *) + (* let set_styles s = cur_styles := s *) + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = match s with + | "error" -> (!cur_styles).error + | "warning" -> (!cur_styles).warning + | "loc" -> (!cur_styles).loc + | "info" -> [Bold; FG Yellow] + | "dim" -> [Dim] + | "filename" -> [FG Cyan] + | _ -> raise Not_found + [@@raises Not_found] + + let color_enabled = ref true + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !color_enabled then ansi_of_style_l style else "" + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let _ = style_of_tag s in + if !color_enabled then ansi_of_style_l [Reset] else "" + with Not_found -> or_else s + + (* add color handling to formatter [ppf] *) + let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_tag_functions ppf () in + let functions' = {functions with + mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); + mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); + } in + pp_set_mark_tags ppf true; (* enable tags *) + pp_set_formatter_tag_functions ppf functions'; + (* also setup margins *) + pp_set_margin ppf (pp_get_margin std_formatter()); + () + + 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 + + type setting = Auto [@live] | Always [@live] | Never [@live] + + let setup = + let first = ref true in (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_color_tag_handling formatter_l; + color_enabled := (match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()) + ); + () +end + +(* command line flags *) +module ResClflags: sig + val recover: bool ref + val print: string ref + val width: int ref + val origin: string ref + val file: string ref + val interface: bool ref + val ppx: string ref + + val parse: unit -> unit +end = struct + let recover = ref false + let width = ref 100 + + let print = ref "res" + let origin = ref "" + let interface = ref false + let ppx = ref "" + let file = ref "" + + let usage = "\n**This command line is for the repo developer's testing purpose only. DO NOT use it in production**!\n\n" ^ + "Usage:\n rescript \n\n" ^ + "Examples:\n" ^ + " rescript myFile.res\n" ^ + " rescript -parse ml -print res myFile.ml\n" ^ + " rescript -parse res -print binary -interface myFile.resi\n\n" ^ + "Options are:" + + let spec = [ + ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); + ("-parse", Arg.String (fun txt -> origin := txt), "Parse reasonBinary, ml or res. Default: res"); + ("-print", Arg.String (fun txt -> print := txt), "Print either binary, ml, ast, sexp or res. Default: res"); + ("-width", Arg.Int (fun w -> width := w), "Specify the line length for the printer (formatter)"); + ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); + ("-ppx", Arg.String (fun txt -> ppx := txt), "Apply a specific built-in ppx before parsing, none or jsx. Default: none"); + ] + + let parse () = Arg.parse spec (fun f -> file := f) usage +end + +module CliArgProcessor = struct + type backend = Parser: ('diagnostics) Res_driver.parsingEngine -> backend [@@unboxed] + + let processFile ~isInterface ~width ~recover ~origin ~target ~ppx filename = + let len = String.length filename in + let processInterface = + isInterface || len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i' + in + let parsingEngine = + match origin with + | "reasonBinary" -> Parser Res_driver_reason_binary.parsingEngine + | "ml" -> Parser Res_driver_ml_parser.parsingEngine + | "res" -> Parser Res_driver.parsingEngine + | "" -> ( + match Filename.extension filename with + | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine + | ".re" | ".rei" -> Parser Res_driver_reason_binary.parsingEngine + | _ -> Parser Res_driver.parsingEngine + ) + | origin -> + print_endline ("-parse needs to be either reasonBinary, ml or res. You provided " ^ origin); + exit 1 + in + let printEngine = + match target with + | "binary" -> Res_driver_binary.printEngine + | "ml" -> Res_driver_ml_parser.printEngine + | "ast" -> Res_ast_debugger.printEngine + | "sexp" -> Res_ast_debugger.sexpPrintEngine + | "res" -> Res_driver.printEngine + | target -> + print_endline ("-print needs to be either binary, ml, ast, sexp or res. You provided " ^ target); + exit 1 + in + + let forPrinter = match target with + | "res" | "sexp" -> true + | _ -> false + in + + let Parser backend = parsingEngine in + (* This is the whole purpose of the Color module above *) + Color.setup None; + if processInterface then + let parseResult = backend.parseInterface ~forPrinter ~filename in + if parseResult.invalid then begin + backend.stringOfDiagnostics + ~source:parseResult.source + ~filename:parseResult.filename + parseResult.diagnostics; + if recover then + printEngine.printInterface + ~width ~filename ~comments:parseResult.comments parseResult.parsetree + else exit 1 + end + else + let parsetree = match ppx with + | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree + | _ -> parseResult.parsetree + in + printEngine.printInterface + ~width ~filename ~comments:parseResult.comments parsetree + else + let parseResult = backend.parseImplementation ~forPrinter ~filename in + if parseResult.invalid then begin + backend.stringOfDiagnostics + ~source:parseResult.source + ~filename:parseResult.filename + parseResult.diagnostics; + if recover then + printEngine.printImplementation + ~width ~filename ~comments:parseResult.comments parseResult.parsetree + else exit 1 + end + else + let parsetree = match ppx with + | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree + | _ -> parseResult.parsetree + in + printEngine.printImplementation + ~width ~filename ~comments:parseResult.comments parsetree + [@@raises Invalid_argument, Failure, exit] +end + + +(* let [@raises Invalid_argument, Failure, exit] () = + if not !Sys.interactive then begin + ResClflags.parse (); + CliArgProcessor.processFile + ~isInterface:!ResClflags.interface + ~width:!ResClflags.width + ~recover:!ResClflags.recover + ~target:!ResClflags.print + ~origin:!ResClflags.origin + ~ppx:!ResClflags.ppx + !ResClflags.file +end *) diff --git a/analysis/src/vendor/res_outcome_printer/res_comments_table.ml b/analysis/src/vendor/res_outcome_printer/res_comments_table.ml new file mode 100644 index 000000000..c945bd783 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_comments_table.ml @@ -0,0 +1,1918 @@ +module Comment = Res_comment +module Doc = Res_doc + +type t = { + leading: (Location.t, Comment.t list) Hashtbl.t; + inside: (Location.t, Comment.t list) Hashtbl.t; + trailing: (Location.t, Comment.t list) Hashtbl.t; +} + +let make () = { + leading = Hashtbl.create 100; + inside = Hashtbl.create 100; + trailing = Hashtbl.create 100; +} + +let copy tbl = { + leading = Hashtbl.copy tbl.leading; + inside = Hashtbl.copy tbl.inside; + trailing = Hashtbl.copy tbl.trailing; +} + +let empty = make () + +let log t = + let open Location in + let leadingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> + let loc = Doc.concat [ + Doc.lbracket; + Doc.text (string_of_int k.loc_start.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); + Doc.text "-"; + Doc.text (string_of_int k.loc_end.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); + Doc.rbracket; + ] in + let doc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + loc; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.comma (List.map (fun c -> Doc.text (Comment.txt c)) v) + ] + ); + Doc.line; + ] + ) in + doc::acc + ) t.leading [] + in + let trailingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> + let loc = Doc.concat [ + Doc.lbracket; + Doc.text (string_of_int k.loc_start.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); + Doc.text "-"; + Doc.text (string_of_int k.loc_end.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); + Doc.rbracket; + ] in + let doc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + loc; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun c -> Doc.text (Comment.txt c)) v) + ] + ); + Doc.line; + ] + ) in + doc::acc + ) t.trailing [] + in + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "leading comments:"; + Doc.line; + Doc.indent (Doc.concat leadingStuff); + Doc.line; + Doc.line; + Doc.text "trailing comments:"; + Doc.indent (Doc.concat trailingStuff); + Doc.line; + Doc.line; + ] + ) |> Doc.toString ~width:80 |> print_endline + [@@live] + +let attach tbl loc comments = + match comments with + | [] -> () + | comments -> Hashtbl.replace tbl loc comments + +let partitionByLoc comments loc = + let rec loop (leading, inside, trailing) comments = + let open Location in + match comments with + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment::leading, inside, trailing) rest + else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment::trailing) rest + else + loop (leading, comment::inside, trailing) rest + | [] -> (List.rev leading, List.rev inside, List.rev trailing) + in + loop ([], [], []) comments + +let partitionLeadingTrailing comments loc = + let rec loop (leading, trailing) comments = + let open Location in + match comments with + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment::leading, trailing) rest + else + loop (leading, comment::trailing) rest + | [] -> (List.rev leading, List.rev trailing) + in + loop ([], []) comments + +let partitionByOnSameLine loc comments = + let rec loop (onSameLine, onOtherLine) comments = + let open Location in + match comments with + | [] -> (List.rev onSameLine, List.rev onOtherLine) + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment::onSameLine, onOtherLine) rest + else + loop (onSameLine, comment::onOtherLine) rest + in + loop ([], []) comments + +let partitionAdjacentTrailing loc1 comments = + let open Location in + let open Lexing in + let rec loop ~prevEndPos afterLoc1 comments = + match comments with + | [] -> (List.rev afterLoc1, []) + | (comment::rest) as comments -> + let cmtPrevEndPos = Comment.prevTokEndPos comment in + if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then + let commentEnd = (Comment.loc comment).loc_end in + loop ~prevEndPos:commentEnd (comment::afterLoc1) rest + else + (List.rev afterLoc1, comments) + in + loop ~prevEndPos:loc1.loc_end [] comments + +let rec collectListPatterns acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct( + {txt = Longident.Lident "::"}, + Some {ppat_desc=Ppat_tuple (pat::rest::[])} + ) -> + collectListPatterns (pat::acc) rest + | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> + List.rev acc + | _ -> List.rev (pattern::acc) + +let rec collectListExprs acc expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_construct( + {txt = Longident.Lident "::"}, + Some {pexp_desc=Pexp_tuple (expr::rest::[])} + ) -> + collectListExprs (expr::acc) rest + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + List.rev acc + | _ -> List.rev (expr::acc) + +(* TODO: use ParsetreeViewer *) +let arrowType ct = + let open Parsetree in + let rec process attrsBefore acc typ = match typ with + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> + let arg = ([], lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) + | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | typ -> + (attrsBefore, List.rev acc, typ) + in + begin match ct with + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> + process attrs [] {typ with ptyp_attributes = []} + | typ -> process [] [] typ + end + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let modExprApply modExpr = + let rec loop acc modExpr = match modExpr with + | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> + loop (arg::acc) next + | _ -> (modExpr::acc) + in + loop [] modExpr + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let modExprFunctor modExpr = + let rec loop acc modExpr = match modExpr with + | {Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> + let param = (attrs, lbl, modType) in + loop (param::acc) returnModExpr + | returnModExpr -> + (List.rev acc, returnModExpr) + in + loop [] modExpr + +let functorType modtype = + let rec process acc modtype = match modtype with + | {Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> + let arg = (attrs, lbl, argType) in + process (arg::acc) returnType + | modType -> + (List.rev acc, modType) + in + process [] modtype + +let funExpr expr = + let open Parsetree in + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collectNewTypes acc returnExpr = + match returnExpr with + | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> + collectNewTypes (stringLoc::acc) returnExpr + | returnExpr -> + let loc = match (acc, List.rev acc) with + | (_startLoc::_, endLoc::_) -> { endLoc.loc with loc_end = endLoc.loc.loc_end } + | _ -> Location.none + in + let txt = List.fold_right (fun curr acc -> acc ^ " " ^ curr.Location.txt) acc "type" in + (Location.mkloc txt loc, returnExpr) + in + (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, + * otherwise this function would need to return a variant: + * | NormalParamater(...) + * | NewType(...) + * This complicates printing with an extra variant/boxing/allocation for a code-path + * that is not often used. Lets just keep it simple for now *) + let rec collect attrsBefore acc expr = match expr with + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> + let parameter = ([], lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> + let (var, returnExpr) = collectNewTypes [stringLoc] rest in + let parameter = ( + attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:stringLoc.loc var + ) in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | { + pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = attrs + } -> + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | expr -> + (attrsBefore, List.rev acc, expr) + in + begin match expr with + | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> + collect attrs [] {expr with pexp_attributes = []} + | expr -> collect [] [] expr + end + +let rec isBlockExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> true + | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true + | Pexp_constraint (expr, _) when isBlockExpr expr -> true + | Pexp_field (expr, _) when isBlockExpr expr -> true + | Pexp_setfield (expr, _, _) when isBlockExpr expr -> true + | _ -> false + +let isIfThenElseExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_ifthenelse _ -> true + | _ -> false + +let rec walkStructure s t comments = + match s with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | s -> + walkList + ~getLoc:(fun n -> n.Parsetree.pstr_loc) + ~walkNode:walkStructureItem + s + t + comments + + and walkStructureItem si t comments = + match si.Parsetree.pstr_desc with + | _ when comments = [] -> () + | Pstr_primitive valueDescription -> + walkValueDescription valueDescription t comments + | Pstr_open openDescription -> + walkOpenDescription openDescription t comments + | Pstr_value (_, valueBindings) -> + walkValueBindings valueBindings t comments + | Pstr_type (_, typeDeclarations) -> + walkTypeDeclarations typeDeclarations t comments + | Pstr_eval (expr, _) -> + walkExpr expr t comments + | Pstr_module moduleBinding -> + walkModuleBinding moduleBinding t comments + | Pstr_recmodule moduleBindings -> + walkList + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~walkNode:walkModuleBinding + moduleBindings + t + comments + | Pstr_modtype modTypDecl -> + walkModuleTypeDeclaration modTypDecl t comments + | Pstr_attribute attribute -> + walkAttribute attribute t comments + | Pstr_extension (extension, _) -> + walkExtension extension t comments + | Pstr_include includeDeclaration -> + walkIncludeDeclaration includeDeclaration t comments + | Pstr_exception extensionConstructor -> + walkExtConstr extensionConstructor t comments + | Pstr_typext typeExtension -> + walkTypeExtension typeExtension t comments + | Pstr_class_type _ | Pstr_class _ -> () + + and walkValueDescription vd t comments = + let (leading, trailing) = + partitionLeadingTrailing comments vd.pval_name.loc in + attach t.leading vd.pval_name.loc leading; + let (afterName, rest) = + partitionAdjacentTrailing vd.pval_name.loc trailing in + attach t.trailing vd.pval_name.loc afterName; + let (before, inside, after) = + partitionByLoc rest vd.pval_type.ptyp_loc + in + attach t.leading vd.pval_type.ptyp_loc before; + walkTypExpr vd.pval_type t inside; + attach t.trailing vd.pval_type.ptyp_loc after + + and walkTypeExtension te t comments = + let (leading, trailing) = + partitionLeadingTrailing comments te.ptyext_path.loc in + attach t.leading te.ptyext_path.loc leading; + let (afterPath, rest) = + partitionAdjacentTrailing te.ptyext_path.loc trailing in + attach t.trailing te.ptyext_path.loc afterPath; + + (* type params *) + let rest = match te.ptyext_params with + | [] -> rest + | typeParams -> + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam + ~newlineDelimited:false + typeParams + t + rest + in + walkList + ~getLoc:(fun n -> n.Parsetree.pext_loc) + ~walkNode:walkExtConstr + te.ptyext_constructors + t + rest + + and walkIncludeDeclaration inclDecl t comments = + let (before, inside, after) = + partitionByLoc comments inclDecl.pincl_mod.pmod_loc in + attach t.leading inclDecl.pincl_mod.pmod_loc before; + walkModExpr inclDecl.pincl_mod t inside; + attach t.trailing inclDecl.pincl_mod.pmod_loc after + + and walkModuleTypeDeclaration mtd t comments = + let (leading, trailing) = + partitionLeadingTrailing comments mtd.pmtd_name.loc in + attach t.leading mtd.pmtd_name.loc leading; + begin match mtd.pmtd_type with + | None -> + attach t.trailing mtd.pmtd_name.loc trailing + | Some modType -> + let (afterName, rest) = partitionAdjacentTrailing mtd.pmtd_name.loc trailing in + attach t.trailing mtd.pmtd_name.loc afterName; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + end + + and walkModuleBinding mb t comments = + let (leading, trailing) = partitionLeadingTrailing comments mb.pmb_name.loc in + attach t.leading mb.pmb_name.loc leading; + let (afterName, rest) = partitionAdjacentTrailing mb.pmb_name.loc trailing in + attach t.trailing mb.pmb_name.loc afterName; + let (leading, inside, trailing) = partitionByLoc rest mb.pmb_expr.pmod_loc in + begin match mb.pmb_expr.pmod_desc with + | Pmod_constraint _ -> + walkModExpr mb.pmb_expr t (List.concat [leading; inside]); + | _ -> + attach t.leading mb.pmb_expr.pmod_loc leading; + walkModExpr mb.pmb_expr t inside; + end; + attach t.trailing mb.pmb_expr.pmod_loc trailing + + and walkSignature signature t comments = + match signature with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | _s -> + walkList + ~getLoc:(fun n -> n.Parsetree.psig_loc) + ~walkNode:walkSignatureItem + signature + t + comments + + and walkSignatureItem si t comments = + match si.psig_desc with + | _ when comments = [] -> () + | Psig_value valueDescription -> + walkValueDescription valueDescription t comments + | Psig_type (_, typeDeclarations) -> + walkTypeDeclarations typeDeclarations t comments + | Psig_typext typeExtension -> + walkTypeExtension typeExtension t comments + | Psig_exception extensionConstructor -> + walkExtConstr extensionConstructor t comments + | Psig_module moduleDeclaration -> + walkModuleDeclaration moduleDeclaration t comments + | Psig_recmodule moduleDeclarations -> + walkList + ~getLoc:(fun n -> n.Parsetree.pmd_loc) + ~walkNode:walkModuleDeclaration + moduleDeclarations + t + comments + | Psig_modtype moduleTypeDeclaration -> + walkModuleTypeDeclaration moduleTypeDeclaration t comments + | Psig_open openDescription -> + walkOpenDescription openDescription t comments + | Psig_include includeDescription -> + walkIncludeDescription includeDescription t comments + | Psig_attribute attribute -> + walkAttribute attribute t comments + | Psig_extension (extension, _) -> + walkExtension extension t comments + | Psig_class _ | Psig_class_type _ -> () + + and walkIncludeDescription id t comments = + let (before, inside, after) = + partitionByLoc comments id.pincl_mod.pmty_loc in + attach t.leading id.pincl_mod.pmty_loc before; + walkModType id.pincl_mod t inside; + attach t.trailing id.pincl_mod.pmty_loc after + + and walkModuleDeclaration md t comments = + let (leading, trailing) = partitionLeadingTrailing comments md.pmd_name.loc in + attach t.leading md.pmd_name.loc leading; + let (afterName, rest) = partitionAdjacentTrailing md.pmd_name.loc trailing in + attach t.trailing md.pmd_name.loc afterName; + let (leading, inside, trailing) = partitionByLoc rest md.pmd_type.pmty_loc in + attach t.leading md.pmd_type.pmty_loc leading; + walkModType md.pmd_type t inside; + attach t.trailing md.pmd_type.pmty_loc trailing + + and walkList: + 'node. + ?prevLoc:Location.t -> + getLoc:('node -> Location.t) -> + walkNode:('node -> t -> Comment.t list -> unit) -> + 'node list -> t -> Comment.t list -> unit + = fun ?prevLoc ~getLoc ~walkNode l t comments -> + let open Location in + match l with + | _ when comments = [] -> () + | [] -> + begin match prevLoc with + | Some loc -> + attach t.trailing loc comments + | None -> () + end + | node::rest -> + let currLoc = getLoc node in + let (leading, inside, trailing) = partitionByLoc comments currLoc in + begin match prevLoc with + | None -> (* first node, all leading comments attach here *) + attach t.leading currLoc leading + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in + let () = attach t.trailing prevLoc afterPrev in + attach t.leading currLoc beforeCurr + else + let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in + attach t.leading currLoc leading + end; + walkNode node t inside; + walkList ~prevLoc:currLoc ~getLoc ~walkNode rest t trailing + + (* The parsetree doesn't always contain location info about the opening or + * closing token of a "list-of-things". This routine visits the whole list, + * but returns any remaining comments that likely fall after the whole list. *) + and visitListButContinueWithRemainingComments: + 'node. + ?prevLoc:Location.t -> + newlineDelimited:bool -> + getLoc:('node -> Location.t) -> + walkNode:('node -> t -> Comment.t list -> unit) -> + 'node list -> t -> Comment.t list -> Comment.t list + = fun ?prevLoc ~newlineDelimited ~getLoc ~walkNode l t comments -> + let open Location in + match l with + | _ when comments = [] -> [] + | [] -> + begin match prevLoc with + | Some loc -> + let (afterPrev, rest) = + if newlineDelimited then + partitionByOnSameLine loc comments + else + partitionAdjacentTrailing loc comments + in + attach t.trailing loc afterPrev; + rest + | None -> comments + end + | node::rest -> + let currLoc = getLoc node in + let (leading, inside, trailing) = partitionByLoc comments currLoc in + let () = match prevLoc with + | None -> (* first node, all leading comments attach here *) + attach t.leading currLoc leading; + () + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in + let () = attach t.trailing prevLoc afterPrev in + let () = attach t.leading currLoc beforeCurr in + () + else + let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in + let () = attach t.leading currLoc leading in + () + in + walkNode node t inside; + visitListButContinueWithRemainingComments + ~prevLoc:currLoc ~getLoc ~walkNode ~newlineDelimited + rest t trailing + + and walkValueBindings vbs t comments = + walkList + ~getLoc:(fun n -> n.Parsetree.pvb_loc) + ~walkNode:walkValueBinding + vbs + t + comments + + and walkOpenDescription openDescription t comments = + let loc = openDescription.popen_lid.loc in + let (leading, trailing) = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + attach t.trailing loc trailing; + + and walkTypeDeclarations typeDeclarations t comments = + walkList + ~getLoc:(fun n -> n.Parsetree.ptype_loc) + ~walkNode:walkTypeDeclaration + typeDeclarations + t + comments + + and walkTypeParam (typexpr, _variance) t comments = + walkTypExpr typexpr t comments + + and walkTypeDeclaration td t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments td.ptype_name.loc in + attach t.leading td.ptype_name.loc beforeName; + + let (afterName, rest) = + partitionAdjacentTrailing td.ptype_name.loc rest in + attach t.trailing td.ptype_name.loc afterName; + + (* type params *) + let rest = match td.ptype_params with + | [] -> rest + | typeParams -> + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam + ~newlineDelimited:false + typeParams + t + rest + in + + (* manifest: = typexpr *) + let rest = match td.ptype_manifest with + | Some typexpr -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + + let rest = match td.ptype_kind with + | Ptype_abstract | Ptype_open -> rest + | Ptype_record labelDeclarations -> + let () = walkList + ~getLoc:(fun ld -> ld.Parsetree.pld_loc) + ~walkNode:walkLabelDeclaration + labelDeclarations + t + rest + in + [] + | Ptype_variant constructorDeclarations -> + walkConstructorDeclarations constructorDeclarations t rest + in + attach t.trailing td.ptype_loc rest + + and walkLabelDeclarations lds t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun ld -> ld.Parsetree.pld_loc) + ~walkNode:walkLabelDeclaration + ~newlineDelimited:false + lds + t + comments + + and walkLabelDeclaration ld t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments ld.pld_name.loc in + attach t.leading ld.pld_name.loc beforeName; + let (afterName, rest) = partitionAdjacentTrailing ld.pld_name.loc rest in + attach t.trailing ld.pld_name.loc afterName; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest ld.pld_type.ptyp_loc in + attach t.leading ld.pld_type.ptyp_loc beforeTyp; + walkTypExpr ld.pld_type t insideTyp; + attach t.trailing ld.pld_type.ptyp_loc afterTyp + + and walkConstructorDeclarations cds t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) + ~walkNode:walkConstructorDeclaration + ~newlineDelimited:false + cds + t + comments + + and walkConstructorDeclaration cd t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments cd.pcd_name.loc in + attach t.leading cd.pcd_name.loc beforeName; + let (afterName, rest) = + partitionAdjacentTrailing cd.pcd_name.loc rest in + attach t.trailing cd.pcd_name.loc afterName; + let rest = walkConstructorArguments cd.pcd_args t rest in + + let rest = match cd.pcd_res with + | Some typexpr -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + attach t.trailing cd.pcd_loc rest + + and walkConstructorArguments args t comments = + match args with + | Pcstr_tuple typexprs -> + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + ~newlineDelimited:false + typexprs + t + comments + | Pcstr_record labelDeclarations -> + walkLabelDeclarations labelDeclarations t comments + + and walkValueBinding vb t comments = + let open Location in + + let vb = + let open Parsetree in + match (vb.pvb_pat, vb.pvb_expr) with + | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, + {pexp_desc = Pexp_constraint (expr, _typ)} -> + {vb with + pvb_pat = Ast_helper.Pat.constraint_ + ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} pat t; + pvb_expr = expr; + } + | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_::_, t)})}, + {pexp_desc = Pexp_fun _} -> + {vb with + pvb_pat = {vb.pvb_pat with + ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}}} + + | ({ppat_desc = Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_::_, t)} as typ))} as constrainedPattern), + {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + {vb with + pvb_pat = { + constrainedPattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + }; + pvb_expr = expr + } + | _ -> vb + in + let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in + let exprLoc = vb.Parsetree.pvb_expr.pexp_loc in + let expr = vb.pvb_expr in + + let (leading, inside, trailing) = + partitionByLoc comments patternLoc in + + (* everything before start of pattern can only be leading on the pattern: + * let |* before *| a = 1 *) + attach t.leading patternLoc leading; + walkPattern vb.Parsetree.pvb_pat t inside; + let (afterPat, surroundingExpr) = + partitionAdjacentTrailing patternLoc trailing + in + attach t.trailing patternLoc afterPat; + let (beforeExpr, insideExpr, afterExpr) = + partitionByLoc surroundingExpr exprLoc in + if isBlockExpr expr then ( + walkExpr expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + ) else ( + attach t.leading exprLoc beforeExpr; + walkExpr expr t insideExpr; + attach t.trailing exprLoc afterExpr + ) + + and walkExpr expr t comments = + let open Location in + match expr.Parsetree.pexp_desc with + | _ when comments = [] -> () + | Pexp_constant _ -> + let (leading, trailing) = + partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing; + | Pexp_ident longident -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing; + | Pexp_let ( + _recFlag, + valueBindings, + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} + ) -> + walkValueBindings valueBindings t comments + | Pexp_let (_recFlag, valueBindings, expr2) -> + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then + n.pvb_expr.pexp_loc + else + n.Parsetree.pvb_loc + ) + ~walkNode:walkValueBinding + ~newlineDelimited:true + valueBindings + t + comments + in + if isBlockExpr expr2 then ( + walkExpr expr2 t comments; + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_sequence (expr1, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let comments = if isBlockExpr expr1 then ( + let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + comments + ) else ( + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + comments + ) in + if isBlockExpr expr2 then ( + walkExpr expr2 t comments + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_open (_override, longident, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach + t.leading + {expr.pexp_loc with loc_end = longident.loc.loc_end} + leading; + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + let (afterLongident, rest) = + partitionByOnSameLine longident.loc trailing in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_extension ( + {txt = "bs.obj" | "obj"}, + PStr [{ + pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) + }] + ) -> + walkList + ~getLoc:(fun ( + (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) + ) -> { + longident.loc with loc_end = expr.pexp_loc.loc_end + }) + ~walkNode:walkExprRecordRow + rows + t + comments + | Pexp_extension extension -> + walkExtension extension t comments + | Pexp_letexception (extensionConstructor, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach + t.leading + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + leading; + let (leading, inside, trailing) = + partitionByLoc comments extensionConstructor.pext_loc in + attach t.leading extensionConstructor.pext_loc leading; + walkExtConstr extensionConstructor t inside; + let (afterExtConstr, rest) = + partitionByOnSameLine extensionConstructor.pext_loc trailing in + attach t.trailing extensionConstructor.pext_loc afterExtConstr; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_letmodule (stringLoc, modExpr, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} leading; + let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + let (afterString, rest) = + partitionAdjacentTrailing stringLoc.loc trailing in + attach t.trailing stringLoc.loc afterString; + let (beforeModExpr, insideModExpr, afterModExpr) = + partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc beforeModExpr; + walkModExpr modExpr t insideModExpr; + let (afterModExpr, rest) = + partitionByOnSameLine modExpr.pmod_loc afterModExpr in + attach t.trailing modExpr.pmod_loc afterModExpr; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest; + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_assert expr + | Pexp_lazy expr -> + if isBlockExpr expr then ( + walkExpr expr t comments + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | Pexp_coerce (expr, optTypexpr, typexpr) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let rest = match optTypexpr with + | Some typexpr -> + let (leading, inside, trailing) = partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.ptyp_loc trailing in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_constraint (expr, typexpr) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_tuple [] + | Pexp_array [] + | Pexp_construct({txt = Longident.Lident "[]"}, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct({txt = Longident.Lident "::"}, _) -> + walkList + ~getLoc:(fun n -> n.Parsetree.pexp_loc) + ~walkNode:walkExpr + (collectListExprs [] expr) + t + comments + | Pexp_construct (longident, args) -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + begin match args with + | Some expr -> + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc trailing in + attach t.trailing longident.loc afterLongident; + walkExpr expr t rest + | None -> + attach t.trailing longident.loc trailing + end + | Pexp_variant (_label, None) -> + () + | Pexp_variant (_label, Some expr) -> + walkExpr expr t comments + | Pexp_array exprs | Pexp_tuple exprs -> + walkList + ~getLoc:(fun n -> n.Parsetree.pexp_loc) + ~walkNode:walkExpr + exprs + t + comments + | Pexp_record (rows, spreadExpr) -> + let comments = match spreadExpr with + | None -> comments + | Some expr -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + ~getLoc:(fun ( + (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) + ) -> { + longident.loc with loc_end = expr.pexp_loc.loc_end + }) + ~walkNode:walkExprRecordRow + rows + t + comments + | Pexp_field (expr, longident) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + let trailing = if isBlockExpr expr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + walkExpr expr t (List.concat [leading; inside; afterExpr]); + rest + ) else ( + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + trailing + ) in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let (leading, trailing) = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let rest = if isBlockExpr expr1 then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + rest + ) else ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + attach t.trailing expr1.pexp_loc afterExpr; + rest + ) in + let (beforeLongident, afterLongident) = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then + walkExpr expr2 t rest + else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> + let (leading, inside, trailing) = partitionByLoc comments ifExpr.pexp_loc in + let comments = if isBlockExpr ifExpr then ( + let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in + walkExpr ifExpr t (List.concat [leading; inside; afterExpr]); + comments + ) else ( + attach t.leading ifExpr.pexp_loc leading; + walkExpr ifExpr t inside; + let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in + attach t.trailing ifExpr.pexp_loc afterExpr; + comments + ) in + let (leading, inside, trailing) = partitionByLoc comments thenExpr.pexp_loc in + let comments = if isBlockExpr thenExpr then ( + let (afterExpr, trailing) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in + walkExpr thenExpr t (List.concat [leading; inside; afterExpr]); + trailing + ) else ( + attach t.leading thenExpr.pexp_loc leading; + walkExpr thenExpr t inside; + let (afterExpr, comments) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in + attach t.trailing thenExpr.pexp_loc afterExpr; + comments + ) in + begin match elseExpr with + | None -> () + | Some expr -> + if isBlockExpr expr || isIfThenElseExpr expr then + walkExpr expr t comments + else ( + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + end + | Pexp_while (expr1, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let rest = if isBlockExpr expr1 then + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + rest + else ( + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + rest + ) in + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc afterPat; + let (leading, inside, trailing) = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr2.pexp_loc trailing in + attach t.trailing expr2.pexp_loc afterExpr; + if isBlockExpr expr3 then ( + walkExpr expr3 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walkExpr expr3 t inside; + attach t.trailing expr3.pexp_loc trailing + ) + | Pexp_pack modExpr -> + let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | Pexp_match (expr1, [case; elseBranch]) + when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> + let (before, inside, after) = partitionByLoc comments case.pc_lhs.ppat_loc in + attach t.leading case.pc_lhs.ppat_loc before; + walkPattern case.pc_lhs t inside; + let (afterPat, rest) = + partitionAdjacentTrailing case.pc_lhs.ppat_loc after in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let (before, inside, after) = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walkExpr expr1 t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc afterExpr; + let (before, inside, after) = partitionByLoc rest case.pc_rhs.pexp_loc in + let after = if isBlockExpr case.pc_rhs then ( + let (afterExpr, rest) = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after in + walkExpr case.pc_rhs t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading case.pc_rhs.pexp_loc before; + walkExpr case.pc_rhs t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing case.pc_rhs.pexp_loc after in + attach t.trailing case.pc_rhs.pexp_loc afterExpr; + let (before, inside, after) = partitionByLoc rest elseBranch.pc_rhs.pexp_loc in + let after = if isBlockExpr elseBranch.pc_rhs then ( + let (afterExpr, rest) = + partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after in + walkExpr elseBranch.pc_rhs t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading elseBranch.pc_rhs.pexp_loc before; + walkExpr elseBranch.pc_rhs t inside; + after + ) in + attach t.trailing elseBranch.pc_rhs.pexp_loc after + + | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + let after = if isBlockExpr expr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc after in + walkExpr expr t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc afterExpr; + walkList + ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with + loc_end = n.pc_rhs.pexp_loc.loc_end}) + ~walkNode:walkCase + cases + t + rest + (* unary expression: todo use parsetreeviewer *) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident + ("~+" | "~+." | "~-" | "~-." | "not" | "!") + }}, + [Nolabel, argExpr] + ) -> + let (before, inside, after) = partitionByLoc comments argExpr.pexp_loc in + attach t.leading argExpr.pexp_loc before; + walkExpr argExpr t inside; + attach t.trailing argExpr.pexp_loc after + (* binary expression *) + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident + (":=" | "||" | "&&" | "=" | "==" | "<" | ">" + | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." + | "-" | "-." | "++" | "^" | "*" | "*." | "/" + | "/." | "**" | "|." | "<>") }}, + [(Nolabel, operand1); (Nolabel, operand2)] + ) -> + let (before, inside, after) = partitionByLoc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walkExpr operand1 t inside; + let (afterOperand1, rest) = + partitionAdjacentTrailing operand1.pexp_loc after in + attach t.trailing operand1.pexp_loc afterOperand1; + let (before, inside, after) = partitionByLoc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walkExpr operand2 t inside; (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after; + | Pexp_apply (callExpr, arguments) -> + let (before, inside, after) = partitionByLoc comments callExpr.pexp_loc in + let after = if isBlockExpr callExpr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing callExpr.pexp_loc after in + walkExpr callExpr t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading callExpr.pexp_loc before; + walkExpr callExpr t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing callExpr.pexp_loc after in + attach t.trailing callExpr.pexp_loc afterExpr; + walkList + ~getLoc:(fun (_argLabel, expr) -> + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> + expr.pexp_loc + ) + ~walkNode:walkExprArgument + arguments + t + rest + | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> + let (_, parameters, returnExpr) = funExpr expr in + let comments = visitListButContinueWithRemainingComments + ~newlineDelimited:false + ~walkNode:walkExprPararameter + ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + let open Parsetree in + let startPos = match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + loc.loc_start + | _ -> + pattern.ppat_loc.loc_start + in + match exprOpt with + | None -> {pattern.ppat_loc with loc_start = startPos} + | Some expr -> { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end + } + ) + parameters + t + comments + in + begin match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum + -> + let (leading, inside, trailing) = partitionByLoc comments typ.ptyp_loc in + attach t.leading typ.ptyp_loc leading; + walkTypExpr typ t inside; + let (afterTyp, comments) = + partitionAdjacentTrailing typ.ptyp_loc trailing in + attach t.trailing typ.ptyp_loc afterTyp; + if isBlockExpr expr then + walkExpr expr t comments + else ( + let (leading, inside, trailing) = + partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | _ -> + if isBlockExpr returnExpr then + walkExpr returnExpr t comments + else ( + let (leading, inside, trailing) = + partitionByLoc comments returnExpr.pexp_loc in + attach t.leading returnExpr.pexp_loc leading; + walkExpr returnExpr t inside; + attach t.trailing returnExpr.pexp_loc trailing + ) + end + | _ -> () + +and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = + let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + begin match exprOpt with + | Some expr -> + let (_afterPat, rest) = + partitionAdjacentTrailing pattern.ppat_loc trailing in + attach t.trailing pattern.ppat_loc trailing; + if isBlockExpr expr then + walkExpr expr t rest + else ( + let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | None -> + attach t.trailing pattern.ppat_loc trailing + end + +and walkExprArgument (_argLabel, expr) t comments = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + let (leading, trailing) = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + let (afterLabel, rest) = partitionAdjacentTrailing loc trailing in + attach t.trailing loc afterLabel; + let (before, inside, after) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + | _ -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + + and walkCase case t comments = + let (before, inside, after) = partitionByLoc comments case.pc_lhs.ppat_loc in + (* cases don't have a location on their own, leading comments should go + * after the bar on the pattern *) + walkPattern case.pc_lhs t (List.concat [before; inside]); + let (afterPat, rest) = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let comments = match case.pc_guard with + | Some expr -> + let (before, inside, after) = partitionByLoc rest expr.pexp_loc in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in + if isBlockExpr expr then ( + walkExpr expr t (List.concat [before; inside; afterExpr]) + ) else ( + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc afterExpr; + ); + rest + | None -> rest + in + if isBlockExpr case.pc_rhs then ( + walkExpr case.pc_rhs t comments + ) else ( + let (before, inside, after) = partitionByLoc comments case.pc_rhs.pexp_loc in + attach t.leading case.pc_rhs.pexp_loc before; + walkExpr case.pc_rhs t inside; + attach t.trailing case.pc_rhs.pexp_loc after + ) + + and walkExprRecordRow (longident, expr) t comments = + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + + and walkExtConstr extConstr t comments = + let (leading, trailing) = + partitionLeadingTrailing comments extConstr.pext_name.loc in + attach t.leading extConstr.pext_name.loc leading; + let (afterName, rest) = + partitionAdjacentTrailing extConstr.pext_name.loc trailing in + attach t.trailing extConstr.pext_name.loc afterName; + walkExtensionConstructorKind extConstr.pext_kind t rest + + and walkExtensionConstructorKind kind t comments = + match kind with + | Pext_rebind longident -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pext_decl (constructorArguments, maybeTypExpr) -> + let rest = walkConstructorArguments constructorArguments t comments in + begin match maybeTypExpr with + | None -> () + | Some typexpr -> + let (before, inside, after) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc after + end + + and walkModExpr modExpr t comments = + match modExpr.pmod_desc with + | Pmod_ident longident -> + let (before, after) = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after + | Pmod_structure [] -> + attach t.inside modExpr.pmod_loc comments + | Pmod_structure structure -> + walkStructure structure t comments + | Pmod_extension extension -> + walkExtension extension t comments + | Pmod_unpack expr -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + | Pmod_constraint (modexpr, modtype) -> + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let (before, inside, after) = partitionByLoc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModExpr modexpr t inside; + let (after, rest) = partitionAdjacentTrailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let (before, inside, after) = partitionByLoc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + attach t.trailing modtype.pmty_loc after + ) else ( + let (before, inside, after) = partitionByLoc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + let (after, rest) = partitionAdjacentTrailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let (before, inside, after) = partitionByLoc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModExpr modexpr t inside; + attach t.trailing modexpr.pmod_loc after; + ) + | Pmod_apply (_callModExpr, _argModExpr) -> + let modExprs = modExprApply modExpr in + walkList + ~getLoc:(fun n -> n.Parsetree.pmod_loc) + ~walkNode:walkModExpr + modExprs + t + comments + | Pmod_functor _ -> + let (parameters, returnModExpr) = modExprFunctor modExpr in + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun + (_, lbl, modTypeOption) -> match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + ) + ~walkNode:walkModExprParameter + ~newlineDelimited:false + parameters + t + comments + in + begin match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) + when modType.pmty_loc.loc_end.pos_cnum <= modExpr.pmod_loc.loc_start.pos_cnum -> + let (before, inside, after) = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + let (after, rest) = partitionAdjacentTrailing modType.pmty_loc after in + attach t.trailing modType.pmty_loc after; + let (before, inside, after) = partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | _ -> + let (before, inside, after) = partitionByLoc comments returnModExpr.pmod_loc in + attach t.leading returnModExpr.pmod_loc before; + walkModExpr returnModExpr t inside; + attach t.trailing returnModExpr.pmod_loc after + end + + and walkModExprParameter parameter t comments = + let (_attrs, lbl, modTypeOption) = parameter in + let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc leading; + begin match modTypeOption with + | None -> attach t.trailing lbl.loc trailing + | Some modType -> + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after; + end + + and walkModType modType t comments = + match modType.pmty_desc with + | Pmty_ident longident | Pmty_alias longident -> + let (leading, trailing) = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing; + | Pmty_signature [] -> + attach t.inside modType.pmty_loc comments + | Pmty_signature signature -> + walkSignature signature t comments + | Pmty_extension extension -> + walkExtension extension t comments + | Pmty_typeof modExpr -> + let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after; + | Pmty_with (modType, _withConstraints) -> + let (before, inside, after) = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + (* TODO: withConstraints*) + | Pmty_functor _ -> + let (parameters, returnModType) = functorType modType in + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun + (_, lbl, modTypeOption) -> match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + if lbl.txt = "_" then modType.Parsetree.pmty_loc + else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + ) + ~walkNode:walkModTypeParameter + ~newlineDelimited:false + parameters + t + comments + in + let (before, inside, after) = partitionByLoc comments returnModType.pmty_loc in + attach t.leading returnModType.pmty_loc before; + walkModType returnModType t inside; + attach t.trailing returnModType.pmty_loc after + + and walkModTypeParameter (_, lbl, modTypeOption) t comments = + let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc leading; + begin match modTypeOption with + | None -> attach t.trailing lbl.loc trailing + | Some modType -> + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after; + end + + and walkPattern pat t comments = + let open Location in + match pat.Parsetree.ppat_desc with + | _ when comments = [] -> () + | Ppat_alias (pat, alias) -> + let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc afterPat; + let (beforeAlias, afterAlias) = partitionLeadingTrailing rest alias.loc in + attach t.leading alias.loc beforeAlias; + attach t.trailing alias.loc afterAlias + | Ppat_tuple [] + | Ppat_array [] + | Ppat_construct({txt = Longident.Lident "()"}, _) + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> + attach t.inside pat.ppat_loc comments; + | Ppat_array patterns -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + patterns + t + comments + | Ppat_tuple patterns -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + patterns + t + comments + | Ppat_construct({txt = Longident.Lident "::"}, _) -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + (collectListPatterns [] pat) + t + comments + | Ppat_construct (constr, None) -> + let (beforeConstr, afterConstr) = + partitionLeadingTrailing comments constr.loc + in + attach t.leading constr.loc beforeConstr; + attach t.trailing constr.loc afterConstr + | Ppat_construct (constr, Some pat) -> + let (leading, trailing) = partitionLeadingTrailing comments constr.loc in + attach t.leading constr.loc leading; + let (afterConstructor, rest) = + partitionAdjacentTrailing constr.loc trailing + in + attach t.trailing constr.loc afterConstructor; + let (leading, inside, trailing) = partitionByLoc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + attach t.trailing pat.ppat_loc trailing + | Ppat_variant (_label, None) -> + () + | Ppat_variant (_label, Some pat) -> + walkPattern pat t comments + | Ppat_type _ -> + () + | Ppat_record (recordRows, _) -> + walkList + ~getLoc:(fun ( + (longidentLoc, pattern): (Longident.t Asttypes.loc * Parsetree.pattern) + ) -> { + longidentLoc.loc with + loc_end = pattern.Parsetree.ppat_loc.loc_end + }) + ~walkNode:walkPatternRecordRow + recordRows + t + comments + | Ppat_or (pattern1, pattern2) -> + let (beforePattern1, insidePattern1, afterPattern1) = + partitionByLoc comments pattern1.ppat_loc + in + attach t.leading pattern1.ppat_loc beforePattern1; + walkPattern pattern1 t insidePattern1; + let (afterPattern1, rest) = + partitionAdjacentTrailing pattern1.ppat_loc afterPattern1 + in + attach t.trailing pattern1.ppat_loc afterPattern1; + let (beforePattern2, insidePattern2, afterPattern2) = + partitionByLoc rest pattern2.ppat_loc + in + attach t.leading pattern2.ppat_loc beforePattern2; + walkPattern pattern2 t insidePattern2; + attach t.trailing pattern2.ppat_loc afterPattern2 + | Ppat_constraint (pattern, typ) -> + let (beforePattern, insidePattern, afterPattern) = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc beforePattern; + walkPattern pattern t insidePattern; + let (afterPattern, rest) = + partitionAdjacentTrailing pattern.ppat_loc afterPattern + in + attach t.trailing pattern.ppat_loc afterPattern; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typ.ptyp_loc + in + attach t.leading typ.ptyp_loc beforeTyp; + walkTypExpr typ t insideTyp; + attach t.trailing typ.ptyp_loc afterTyp + | Ppat_lazy pattern | Ppat_exception pattern -> + let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + | Ppat_unpack stringLoc -> + let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + attach t.trailing stringLoc.loc trailing + | Ppat_extension extension -> + walkExtension extension t comments + | _ -> () + + (* name: firstName *) + and walkPatternRecordRow row t comments = + match row with + (* punned {x}*) + | ({Location.txt=Longident.Lident ident; loc = longidentLoc}, + {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> + let (beforeLbl, afterLbl) = + partitionLeadingTrailing comments longidentLoc + in + attach t.leading longidentLoc beforeLbl; + attach t.trailing longidentLoc afterLbl + | (longident, pattern) -> + let (beforeLbl, afterLbl) = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLbl; + let (afterLbl, rest) = partitionAdjacentTrailing longident.loc afterLbl in + attach t.trailing longident.loc afterLbl; + let (leading, inside, trailing) = partitionByLoc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + + and walkTypExpr typ t comments = + match typ.Parsetree.ptyp_desc with + | _ when comments = [] -> () + | Ptyp_tuple typexprs -> + walkList + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + typexprs + t + comments + | Ptyp_extension extension -> + walkExtension extension t comments + | Ptyp_package packageType -> + walkPackageType packageType t comments + | Ptyp_alias (typexpr, _alias) -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp; + | Ptyp_poly (strings, typexpr) -> + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Asttypes.loc) + ~walkNode:(fun longident t comments -> + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident + ) + ~newlineDelimited:false + strings + t + comments + in + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | Ptyp_constr (longident, typexprs) -> + let (beforeLongident, _afterLongident) = + partitionLeadingTrailing comments longident.loc in + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc comments in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident; + walkList + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + typexprs + t + rest + | Ptyp_arrow _ -> + let (_, parameters, typexpr) = arrowType typ in + let comments = walkTypeParameters parameters t comments in + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | Ptyp_object (fields, _) -> + walkTypObjectFields fields t comments + | _ -> () + + and walkTypObjectFields fields t comments = + walkList + ~getLoc:(fun field -> + match field with + | Parsetree.Otag (lbl, _, typ) -> + {lbl.loc with loc_end = typ.ptyp_loc.loc_end} + | _ -> Location.none + ) + ~walkNode:walkTypObjectField + fields + t + comments + + and walkTypObjectField field t comments = + match field with + | Otag (lbl, _, typexpr) -> + let (beforeLbl, afterLbl) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc beforeLbl; + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc afterLbl in + attach t.trailing lbl.loc afterLbl; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | _ -> () + + and walkTypeParameters typeParameters t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, _, typexpr) -> + match typexpr.Parsetree.ptyp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + {loc with loc_end = typexpr.ptyp_loc.loc_end} + | _ -> + typexpr.ptyp_loc + ) + ~walkNode:walkTypeParameter + ~newlineDelimited:false + typeParameters + t + comments + + and walkTypeParameter (_attrs, _lbl, typexpr) t comments = + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + + and walkPackageType packageType t comments = + let (longident, packageConstraints) = packageType in + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + walkPackageConstraints packageConstraints t rest + + and walkPackageConstraints packageConstraints t comments = + walkList + ~getLoc:(fun (longident, typexpr) -> {longident.Asttypes.loc with + loc_end = typexpr.Parsetree.ptyp_loc.loc_end + }) + ~walkNode:walkPackageConstraint + packageConstraints + t + comments + + and walkPackageConstraint packageConstraint t comments = + let (longident, typexpr) = packageConstraint in + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp; + + and walkExtension extension t comments = + let (id, payload) = extension in + let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in + attach t.leading id.loc beforeId; + let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in + attach t.trailing id.loc afterId; + walkPayload payload t rest + + and walkAttribute (id, payload) t comments = + let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in + attach t.leading id.loc beforeId; + let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in + attach t.trailing id.loc afterId; + walkPayload payload t rest + + and walkPayload payload t comments = + match payload with + | PStr s -> walkStructure s t comments + | _ -> () diff --git a/analysis/src/vendor/res_outcome_printer/res_core.ml b/analysis/src/vendor/res_outcome_printer/res_core.ml new file mode 100644 index 000000000..940223486 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_core.ml @@ -0,0 +1,6371 @@ +module Doc = Res_doc +module Grammar = Res_grammar +module Token = Res_token +module Diagnostics = Res_diagnostics +module CommentTable = Res_comments_table +module ResPrinter = Res_printer +module Scanner = Res_scanner +module JsFfi = Res_js_ffi +module Parser = Res_parser + +let mkLoc startLoc endLoc = Location.{ + loc_start = startLoc; + loc_end = endLoc; + loc_ghost = false; +} + +module Recover = struct + let defaultExpr () = + let id = Location.mknoloc "rescript.exprhole" in + Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) + + let defaultType () = + let id = Location.mknoloc "rescript.typehole" in + Ast_helper.Typ.extension (id, PStr []) + + let defaultPattern () = + let id = Location.mknoloc "rescript.patternhole" in + Ast_helper.Pat.extension (id, PStr []) + + let defaultModuleExpr () = Ast_helper.Mod.structure [] + let defaultModuleType () = Ast_helper.Mty.signature [] + + let defaultSignatureItem = + let id = Location.mknoloc "rescript.sigitemhole" in + Ast_helper.Sig.extension (id, PStr []) + + let recoverEqualGreater p = + Parser.expect EqualGreater p; + match p.Parser.token with + | MinusGreater -> Parser.next p + | _ -> () + + let shouldAbortListParse p = + let rec check breadcrumbs = + match breadcrumbs with + | [] -> false + | (grammar, _)::rest -> + if Grammar.isPartOfList grammar p.Parser.token then + true + else + check rest + in + check p.breadcrumbs +end + +module ErrorMessages = struct + let listPatternSpread = "List pattern matches only supports one `...` spread, at the end.\n\ +Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list[s]; out of performance concern, our pattern matching currently guarantees to never create new intermediate data." + + let recordPatternSpread = "Record's `...` spread is not supported in pattern matches.\n\ +Explanation: you can't collect a subset of a record's field into its own 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 arrayPatternSpread = "Array's `...` spread is not supported in pattern matches.\n\ +Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data.\n\ +Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." + + let arrayExprSpread = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." + + let recordExprSpread = "Records can only have one `...` spread, at the beginning.\n\ +Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway." + + let listExprSpread = "Lists can only have one `...` spread, and at the end.\n\ +Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `list[a, ...bc]` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar.\n\ +Solution: directly use `concat`." + + let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter or be a number (e.g. #742)" + + let experimentalIfLet expr = + let switchExpr = {expr with Parsetree.pexp_attributes = []} in + Doc.concat [ + Doc.text "If-let is currently highly experimental."; + Doc.line; + Doc.text "Use a regular `switch` with pattern matching instead:"; + Doc.concat [ + Doc.hardLine; + Doc.hardLine; + ResPrinter.printExpression switchExpr (CommentTable.empty); + ] + ] |> Doc.toString ~width:80 + + let typeParam = "A type param consists of a singlequote followed by a name like `'a` or `'A`" + let typeVar = "A type variable consists of a singlequote followed by a name like `'a` or `'A`" + + let attributeWithoutNode (attr : Parsetree.attribute) = + let ({Asttypes.txt = attrName}, _) = attr in + "Did you forget to attach `" ^ attrName ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" ^ attrName ^"`" + + let typeDeclarationNameLongident longident = + "A type declaration's name cannot contain a module access. Did you mean `" ^ (Longident.last longident) ^"`?" + + let tupleSingleElement = "A tuple needs at least two elements" + + let missingTildeLabeledParameter name = + if name = "" then + "A labeled parameter starts with a `~`." + else + ("A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?") + + let stringInterpolationInPattern = + "String interpolation is not supported in pattern matching." + + let spreadInRecordDeclaration = + "A record type declaration doesn't support the ... spread. Only an object (with quoted field names) does." + + let objectQuotedFieldName name = + "An object type declaration needs quoted field names. Did you mean \"" ^ name ^ "\"?" + + let forbiddenInlineRecordDeclaration = + "An inline record type declaration is only allowed in a variant constructor's declaration" + + let sameTypeSpread = + "You're using a ... spread without extra fields. This is the same type." + + let polyVarIntWithSuffix number = + "A numeric polymorphic variant cannot be followed by a letter. Did you mean `#" ^ number ^ "`?" +end + + +let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) +let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) +let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) +let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) +let suppressFragileMatchWarningAttr = (Location.mknoloc "warning", Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None)))]) +let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) + +type stringLiteralState = + | Start + | Backslash + | HexEscape + | DecimalEscape + | OctalEscape + | EscapedLineBreak + +type typDefOrExt = + | TypeDef of {recFlag: Asttypes.rec_flag; types: Parsetree.type_declaration list} + | TypeExt of Parsetree.type_extension + +type labelledParameter = + | TermParameter of + {uncurried: bool; attrs: Parsetree.attributes; label: Asttypes.arg_label; expr: Parsetree.expression option; + pat: Parsetree.pattern; pos: Lexing.position} + | TypeParameter of {uncurried: bool; attrs: Parsetree.attributes; locs: string Location.loc list; pos: Lexing.position} + +type recordPatternItem = + | PatUnderscore + | PatField of (Ast_helper.lid * Parsetree.pattern) + +type context = + | OrdinaryExpr + | TernaryTrueBranchExpr + | WhenExpr + +let getClosingToken = function + | Token.Lparen -> Token.Rparen + | Lbrace -> Rbrace + | Lbracket -> Rbracket + | List -> Rbrace + | LessThan -> GreaterThan + | _ -> assert false + +let rec goToClosing closingToken state = + match (state.Parser.token, closingToken) with + | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) | (GreaterThan, GreaterThan) -> + Parser.next state; + () + | (Token.Lbracket | Lparen | Lbrace | List | LessThan) as t, _ -> + Parser.next state; + goToClosing (getClosingToken t) state; + goToClosing closingToken state + | ((Rparen | Token.Rbrace | Rbracket | Eof), _) -> + () (* TODO: how do report errors here? *) + | _ -> + Parser.next state; + goToClosing closingToken state + +(* Madness *) +let isEs6ArrowExpression ~inTernary p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lident _ | Underscore -> + Parser.next state; + begin match state.Parser.token with + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false + end + | Lparen -> + let prevEndPos = state.prevEndPos in + Parser.next state; + begin match state.token with + (* arrived at `()` here *) + | Rparen -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :` here *) + | Colon when not inTernary -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Parser.next state; + goToClosing GreaterThan state; + | _ -> () + end; + begin match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> + true + | _ -> false + end + | _ -> true + end + | EqualGreater -> true + | _ -> false + end + | Dot (* uncurried *) -> true + | Tilde -> true + | Backtick -> false (* (` always indicates the start of an expr, can't be es6 parameter *) + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not inTernary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + * *) + false + | _ -> + Parser.next state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + begin match state.Parser.token with + | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum -> true + | _ -> false + end + end + end + | _ -> false) + + +let isEs6ArrowFunctor p = + Parser.lookahead p (fun state -> + match state.Parser.token with + (* | Uident _ | Underscore -> *) + (* Parser.next state; *) + (* begin match state.Parser.token with *) + (* | EqualGreater -> true *) + (* | _ -> false *) + (* end *) + | Lparen -> + Parser.next state; + begin match state.token with + | Rparen -> + Parser.next state; + begin match state.token with + | Colon | EqualGreater -> true + | _ -> false + end + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false + end + end + | _ -> false + ) + +let isEs6ArrowType p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lparen -> + Parser.next state; + begin match state.Parser.token with + | Rparen -> + Parser.next state; + begin match state.Parser.token with + | EqualGreater -> true + | _ -> false + end + | Tilde | Dot -> true + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater -> true + | _ -> false + end + end + | Tilde -> true + | _ -> false + ) + +let buildLongident words = match List.rev words with + | [] -> assert false + | hd::tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl + +let makeInfixOperator p token startPos endPos = + let stringifiedToken = + if token = Token.MinusGreater then "|." + else if token = Token.PlusPlus then "^" + else if token = Token.BangEqual then "<>" + else if token = Token.BangEqualEqual then "!=" + else if token = Token.Equal then ( + (* TODO: could have a totally different meaning like x->fooSet(y)*) + Parser.err ~startPos ~endPos p ( + Diagnostics.message "Did you mean `==` here?" + ); + "=" + ) else if token = Token.EqualEqual then "=" + else if token = Token.EqualEqualEqual then "==" + else Token.toString token + in + let loc = mkLoc startPos endPos in + let operator = Location.mkloc + (Longident.Lident stringifiedToken) loc + in + Ast_helper.Exp.ident ~loc operator + +let negateString s = + if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' + then (String.sub [@doesNotRaise]) s 1 (String.length s - 1) + else "-" ^ s + +let makeUnaryExpr startPos tokenEnd token operand = + match token, operand.Parsetree.pexp_desc with + | (Token.Plus | PlusDot), Pexp_constant((Pconst_integer _ | Pconst_float _)) -> + operand + | Minus, Pexp_constant(Pconst_integer (n,m)) -> + {operand with pexp_desc = Pexp_constant(Pconst_integer (negateString n,m))} + | (Minus | MinusDot), Pexp_constant(Pconst_float (n,m)) -> + {operand with pexp_desc = Pexp_constant(Pconst_float (negateString n,m))} + | (Token.Plus | PlusDot | Minus | MinusDot ), _ -> + let tokenLoc = mkLoc startPos tokenEnd in + let operator = "~" ^ Token.toString token in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident operator) tokenLoc)) + [Nolabel, operand] + | Token.Bang, _ -> + let tokenLoc = mkLoc startPos tokenEnd in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident "not") tokenLoc)) + [Nolabel, operand] + | _ -> + operand + +let makeListExpression loc seq extOpt = + let rec handleSeq = function + | [] -> + begin match extOpt with + | Some ext -> ext + | None -> + let loc = {loc with Location.loc_ghost = true} in + let nil = Location.mkloc (Longident.Lident "[]") loc in + Ast_helper.Exp.construct ~loc nil None + end + | e1 :: el -> + let exp_el = handleSeq el in + let loc = mkLoc + e1.Parsetree.pexp_loc.Location.loc_start + exp_el.pexp_loc.loc_end + in + let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "::") loc) + (Some arg) + in + let expr = handleSeq seq in + {expr with pexp_loc = loc} + +let makeListPattern loc seq ext_opt = + let rec handle_seq = function + [] -> + let base_case = match ext_opt with + | Some ext -> + ext + | None -> + let loc = { loc with Location.loc_ghost = true} in + let nil = { Location.txt = Longident.Lident "[]"; loc } in + Ast_helper.Pat.construct ~loc nil None + in + base_case + | p1 :: pl -> + let pat_pl = handle_seq pl in + let loc = + mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in + let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in + Ast_helper.Pat.mk ~loc (Ppat_construct(Location.mkloc (Longident.Lident "::") loc, Some arg)) + in + handle_seq seq + +(* TODO: diagnostic reporting *) +let lidentOfPath longident = + match Longident.flatten longident |> List.rev with + | [] -> "" + | ident::_ -> ident + +let makeNewtypes ~attrs ~loc newtypes exp = + let expr = List.fold_right (fun newtype exp -> + Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp)) + ) newtypes exp + in {expr with pexp_attributes = attrs} + +(* locally abstract types syntax sugar + * Transforms + * let f: type t u v. = (foo : list) => ... + * into + * let f = (type t u v. foo : list) => ... + *) +let wrapTypeAnnotation ~loc newtypes core_type body = + let exp = makeNewtypes ~attrs:[] ~loc newtypes + (Ast_helper.Exp.constraint_ ~loc body core_type) + in + let typ = Ast_helper.Typ.poly ~loc newtypes + (Ast_helper.Typ.varify_constructors newtypes core_type) + in + (exp, typ) + +(** + * process the occurrence of _ in the arguments of a function application + * replace _ with a new variable, currently __x, in the arguments + * return a wrapping function that wraps ((__x) => ...) around an expression + * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) + *) +let processUnderscoreApplication args = + let open Parsetree in + let exp_question = ref None in + let hidden_var = "__x" in + let check_arg ((lab, exp) as arg) = + match exp.pexp_desc with + | Pexp_ident ({ txt = Lident "_"} as id) -> + let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in + let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in + exp_question := Some new_exp; + (lab, new_exp) + | _ -> + arg + in + let args = List.map check_arg args in + let wrap exp_apply = + match !exp_question with + | Some {pexp_loc=loc} -> + let pattern = Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc in + Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc + | None -> + exp_apply + in + (args, wrap) + +let hexValue x = + match x with + | '0' .. '9' -> + (Char.code x) - 48 + | 'A' .. 'Z' -> + (Char.code x) - 55 + | 'a' .. 'z' -> + (Char.code x) - 97 + | _ -> 16 + +let parseStringLiteral s = + let len = String.length s in + let b = Buffer.create (String.length s) in + + let rec parse state i d = + if i = len then + (match state with + | HexEscape | DecimalEscape | OctalEscape -> false + | _ -> true) + else + let c = String.unsafe_get s i in + match state with + | Start -> + (match c with + | '\\' -> parse Backslash (i + 1) d + | c -> Buffer.add_char b c; parse Start (i + 1) d) + | Backslash -> + (match c with + | 'n' -> Buffer.add_char b '\n'; parse Start (i + 1) d + | 'r' -> Buffer.add_char b '\r'; parse Start (i + 1) d + | 'b' -> Buffer.add_char b '\008'; parse Start (i + 1) d + | 't' -> Buffer.add_char b '\009'; parse Start (i + 1) d + | ('\\' | ' ' | '\'' | '"') as c -> Buffer.add_char b c; parse Start (i + 1) d + | 'x' -> parse HexEscape (i + 1) 0 + | 'o' -> parse OctalEscape (i + 1) 0 + | '0' .. '9' -> parse DecimalEscape i 0 + | '\010' | '\013' -> parse EscapedLineBreak (i + 1) d + | c -> Buffer.add_char b '\\'; Buffer.add_char b c; parse Start (i + 1) d) + | HexEscape -> + if d == 1 then + let c0 = String.unsafe_get s (i - 1) in + let c1 = String.unsafe_get s i in + let c = (16 * (hexValue c0)) + (hexValue c1) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse HexEscape (i + 1) (d + 1) + | DecimalEscape -> + if d == 2 then + let c0 = String.unsafe_get s (i - 2) in + let c1 = String.unsafe_get s (i - 1) in + let c2 = String.unsafe_get s i in + let c = 100 * (Char.code c0 - 48) + 10 * (Char.code c1 - 48) + (Char.code c2 - 48) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse DecimalEscape (i + 1) (d + 1) + | OctalEscape -> + if d == 2 then + let c0 = String.unsafe_get s (i - 2) in + let c1 = String.unsafe_get s (i - 1) in + let c2 = String.unsafe_get s i in + let c = 64 * (Char.code c0 - 48) + 8 * (Char.code c1 - 48) + (Char.code c2 - 48) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse OctalEscape (i + 1) (d + 1) + | EscapedLineBreak -> + (match c with + | ' ' | '\t' -> parse EscapedLineBreak (i + 1) d + | c -> Buffer.add_char b c; parse Start (i + 1) d) + in + if parse Start 0 0 then Buffer.contents b else s + +let rec parseLident p = + let recoverLident p = + if ( + Token.isKeyword p.Parser.token && + p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + ) + then ( + Parser.err p (Diagnostics.lident p.Parser.token); + Parser.next p; + None + ) else ( + let rec loop p = + if not (Recover.shouldAbortListParse p) + then begin + Parser.next p; + loop p + end + in + Parser.next p; + loop p; + match p.Parser.token with + | Lident _ -> Some () + | _ -> None + ) + in + let startPos = p.Parser.startPos in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) + | _ -> + begin match recoverLident p with + | Some () -> + parseLident p + | None -> + ("_", mkLoc startPos p.prevEndPos) + end + +let parseIdent ~msg ~startPos p = + match p.Parser.token with + | Lident ident + | Uident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) + | token when Token.isKeyword token && + p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let tokenTxt = Token.toString token in + let msg = + "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + in + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + (tokenTxt, mkLoc startPos p.prevEndPos) + | _token -> + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + ("", mkLoc startPos p.prevEndPos) + +let parseHashIdent ~startPos p = + Parser.expect Hash p; + match p.token with + | String text -> + let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int {i; suffix} -> + let () = match suffix with + | Some _ -> + Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | _ -> + parseIdent ~startPos ~msg:ErrorMessages.variantIdent p + +(* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) +let parseValuePath p = + let startPos = p.Parser.startPos in + let rec aux p path = + match p.Parser.token with + | Lident ident -> Longident.Ldot(path, ident) + | Uident uident -> + Parser.next p; + Parser.expect Dot p; + aux p (Ldot (path, uident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Lident "_" + in + let ident = match p.Parser.token with + | Lident ident -> Longident.Lident ident + | Uident ident -> + Parser.next p; + Parser.expect Dot p; + aux p (Lident ident) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Lident "_" + in + Parser.next p; + Location.mkloc ident (mkLoc startPos p.prevEndPos) + +let parseValuePathTail p startPos ident = + let rec loop p path = + match p.Parser.token with + | Lident ident -> + Parser.next p; + Location.mkloc (Longident.Ldot(path, ident)) (mkLoc startPos p.prevEndPos) + | Uident ident -> + Parser.next p; + Parser.expect Dot p; + loop p (Longident.Ldot (path, ident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mknoloc path + in + loop p ident + +let parseModuleLongIdentTail ~lowercase p startPos ident = + let rec loop p acc = + match p.Parser.token with + | Lident ident when lowercase -> + Parser.next p; + let lident = (Longident.Ldot (acc, ident)) in + Location.mkloc lident (mkLoc startPos p.prevEndPos) + | Uident ident -> + Parser.next p; + let endPos = p.prevEndPos in + let lident = (Longident.Ldot (acc, ident)) in + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> Location.mkloc lident (mkLoc startPos endPos) + end + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc acc (mkLoc startPos p.prevEndPos) + in + loop p ident + +(* Parses module identifiers: + Foo + Foo.Bar *) +let parseModuleLongIdent ~lowercase p = + (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) + let startPos = p.Parser.startPos in + let moduleIdent = match p.Parser.token with + | Lident ident when lowercase -> + let loc = mkLoc startPos p.endPos in + let lident = Longident.Lident ident in + Parser.next p; + Location.mkloc lident loc + | Uident ident -> + let lident = Longident.Lident ident in + let endPos = p.endPos in + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + parseModuleLongIdentTail ~lowercase p startPos lident + | _ -> Location.mkloc lident (mkLoc startPos endPos) + end + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + in + (* Parser.eatBreadcrumb p; *) + moduleIdent + +(* `window.location` or `Math` or `Foo.Bar` *) +let parseIdentPath p = + let rec loop p acc = + match p.Parser.token with + | Uident ident | Lident ident -> + Parser.next p; + let lident = (Longident.Ldot (acc, ident)) in + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> lident + end + | _t -> acc + in + match p.Parser.token with + | Lident ident | Uident ident -> + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p (Longident.Lident ident) + | _ -> Longident.Lident ident + end + | _ -> + Longident.Lident "_" + +let verifyJsxOpeningClosingName p nameExpr = + let closing = match p.Parser.token with + | Lident lident -> Parser.next p; Longident.Lident lident + | Uident _ -> + (parseModuleLongIdent ~lowercase:true p).txt + | _ -> Longident.Lident "" + in + match nameExpr.Parsetree.pexp_desc with + | Pexp_ident openingIdent -> + let opening = + let withoutCreateElement = + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + in + match (Longident.unflatten withoutCreateElement) with + | Some li -> li + | None -> Longident.Lident "" + in + opening = closing + | _ -> assert false + +let string_of_pexp_ident nameExpr = + match nameExpr.Parsetree.pexp_desc with + | Pexp_ident openingIdent -> + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + |> String.concat "." + | _ -> "" + +(* open-def ::= + * | open module-path + * | open! module-path *) +let parseOpenDescription ~attrs p = + Parser.leaveBreadcrumb p Grammar.OpenDescription; + let startPos = p.Parser.startPos in + Parser.expect Open p; + let override = if Parser.optional p Token.Bang then + Asttypes.Override + else + Asttypes.Fresh + in + let modident = parseModuleLongIdent ~lowercase:false p in + let loc = mkLoc startPos p.prevEndPos in + Parser.eatBreadcrumb p; + Ast_helper.Opn.mk ~loc ~attrs ~override modident + +let parseTemplateStringLiteral s = + let len = String.length s in + let b = Buffer.create len in + + let rec loop i = + if i < len then + let c = String.unsafe_get s i in + match c with + | '\\' as c -> + if i + 1 < len then + let nextChar = String.unsafe_get s (i + 1) in + begin match nextChar with + | '\\' as c -> + Buffer.add_char b c; + loop (i + 2) + | '$' as c -> + Buffer.add_char b c; + loop (i + 2) + | '`' as c -> + Buffer.add_char b c; + loop (i + 2) + | '\n' | '\r' -> + (* line break *) + loop (i + 2) + | c -> + Buffer.add_char b '\\'; + Buffer.add_char b c; + loop (i + 2) + end + else ( + Buffer.add_char b c + ) + + | c -> + Buffer.add_char b c; + loop (i + 1) + + else + () + in + loop 0; + Buffer.contents b + +(* constant ::= integer-literal *) + (* ∣ float-literal *) + (* ∣ string-literal *) +let parseConstant p = + let isNegative = match p.Parser.token with + | Token.Minus -> Parser.next p; true + | Plus -> Parser.next p; false + | _ -> false + in + let constant = match p.Parser.token with + | Int {i; suffix} -> + let intTxt = if isNegative then "-" ^ i else i in + Parsetree.Pconst_integer (intTxt, suffix) + | Float {f; suffix} -> + let floatTxt = if isNegative then "-" ^ f else f in + Parsetree.Pconst_float (floatTxt, suffix) + | String s -> + let txt = if p.mode = ParseForTypeChecker then + parseStringLiteral s + else + s + in + Pconst_string(txt, None) + | Character c -> Pconst_char c + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string("", None) + in + Parser.next p; + constant + +let parseTemplateConstant ~prefix (p : Parser.t) = + (* Arrived at the ` char *) + let startPos = p.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail txt -> + Parser.next p; + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + Parsetree.Pconst_string (txt, prefix) + | _ -> + let rec skipTokens () = + Parser.next p; + match p.token with + | Backtick -> Parser.next p; () + | _ -> skipTokens () + in + skipTokens (); + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.stringInterpolationInPattern); + Pconst_string ("", None) + +let parseCommaDelimitedRegion p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + begin match p.Parser.token with + | Comma -> + Parser.next p; + loop (node::nodes) + | token when token = closing || token = Eof -> + List.rev (node::nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node::nodes) + | _ -> + if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then + Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node::nodes) + end + | None -> + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ); + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseCommaDelimitedReversedList p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + begin match p.Parser.token with + | Comma -> + Parser.next p; + loop (node::nodes) + | token when token = closing || token = Eof -> + (node::nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node::nodes) + | _ -> + if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then + Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node::nodes) + end + | None -> + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then + nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ); + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseDelimitedRegion p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + loop (node::nodes) + | None -> + if ( + p.Parser.token = Token.Eof || + p.token = closing || + Recover.shouldAbortListParse p + ) then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ) + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseRegion p ~grammar ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + loop (node::nodes) + | None -> + if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ) + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +(* let-binding ::= pattern = expr *) + (* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) + (* ∣ value-name : poly-typexpr = expr *) + + (* pattern ::= value-name *) + (* ∣ _ *) + (* ∣ constant *) + (* ∣ pattern as value-name *) + (* ∣ ( pattern ) *) + (* ∣ ( pattern : typexpr ) *) + (* ∣ pattern | pattern *) + (* ∣ constr pattern *) + (* ∣ #variant variant-pattern *) + (* ∣ #...type *) + (* ∣ / pattern { , pattern }+ / *) + (* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) + (* ∣ [ pattern { ; pattern } [ ; ] ] *) + (* ∣ pattern :: pattern *) + (* ∣ [| pattern { ; pattern } [ ; ] |] *) + (* ∣ char-literal .. char-literal *) + (* ∣ exception pattern *) +let rec parsePattern ?(alias=true) ?(or_=true) p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let pat = match p.Parser.token with + | (True | False) as token -> + let endPos = p.endPos in + Parser.next p; + let loc = mkLoc startPos endPos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) None + | Int _ | String _ | Float _ | Character _ | Minus | Plus -> + let c = parseConstant p in + begin match p.token with + | DotDot -> + Parser.next p; + let c2 = parseConstant p in + Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 + | _ -> + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c + end + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | Lparen -> + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> + let pat = parseConstrainedPattern p in + begin match p.token with + | Comma -> + Parser.next p; + parseTuplePattern ~attrs ~first:pat ~startPos p + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + {pat with ppat_loc = loc} + end + end + | Lbracket -> + parseArrayPattern ~attrs p + | Lbrace -> + parseRecordPattern ~attrs p + | Underscore -> + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () + | Lident ident -> + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + begin match p.token with + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | _ -> + Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) + end + | Uident _ -> + let constr = parseModuleLongIdent ~lowercase:false p in + begin match p.Parser.token with + | Lparen -> + parseConstructorPatternArgs p constr startPos attrs + | _ -> + Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None + end + | Hash -> + Parser.next p; + if p.Parser.token == DotDotDot then ( + Parser.next p; + let ident = parseValuePath p in + let loc = mkLoc startPos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident + ) else ( + let (ident, loc) = match p.token with + | String text -> + let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int {i; suffix} -> + let () = match suffix with + | Some _ -> + Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | _ -> + parseIdent ~msg:ErrorMessages.variantIdent ~startPos p + in + begin match p.Parser.token with + | Lparen -> + parseVariantPatternArgs p ident startPos attrs + | _ -> + Ast_helper.Pat.variant ~loc ~attrs ident None + end + ) + | Exception -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.exception_ ~loc ~attrs pat + | Lazy -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.lazy_ ~loc ~attrs pat + | List -> + Parser.next p; + parseListPattern ~startPos ~attrs p + | Module -> + parseModulePattern ~attrs p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.extension ~loc ~attrs extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart with + | None -> + Recover.defaultPattern() + | Some () -> + parsePattern p + end + in + let pat = if alias then parseAliasPattern ~attrs pat p else pat in + if or_ then parseOrPattern pat p else pat + +and skipTokensAndMaybeRetry p ~isStartOfGrammar = + if Token.isKeyword p.Parser.token + && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + then ( + Parser.next p; + None + ) else ( + if Recover.shouldAbortListParse p then + begin + if isStartOfGrammar p.Parser.token then + begin + Parser.next p; + Some () + end + else + None + end + else + begin + Parser.next p; + let rec loop p = + if not (Recover.shouldAbortListParse p) + then begin + Parser.next p; + loop p + end in + loop p; + if isStartOfGrammar p.Parser.token then + Some () + else + None + end + ) + +(* alias ::= pattern as lident *) +and parseAliasPattern ~attrs pattern p = + match p.Parser.token with + | As -> + Parser.next p; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Ast_helper.Pat.alias + ~loc:({pattern.ppat_loc with loc_end = p.prevEndPos}) + ~attrs + pattern + name + | _ -> pattern + +(* or ::= pattern | pattern + * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) +and parseOrPattern pattern1 p = + let rec loop pattern1 = + match p.Parser.token with + | Bar -> + Parser.next p; + let pattern2 = parsePattern ~or_:false p in + let loc = { pattern1.Parsetree.ppat_loc with + loc_end = pattern2.ppat_loc.loc_end + } in + loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) + | _ -> pattern1 + in + loop pattern1 + +and parseNonSpreadPattern ~msg p = + let () = match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | token when Grammar.isPatternStart token -> + let pat = parsePattern p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Some (Ast_helper.Pat.constraint_ ~loc pat typ) + | _ -> Some pat + end + | _ -> None + +and parseConstrainedPattern p = + let pat = parsePattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Ast_helper.Pat.constraint_ ~loc pat typ + | _ -> pat + +and parseConstrainedPatternRegion p = + match p.Parser.token with + | token when Grammar.isPatternStart token -> + Some (parseConstrainedPattern p) + | _ -> None + +(* field ::= + * | longident + * | longident : pattern + * | longident as lident + * + * row ::= + * | field , + * | field , _ + * | field , _, + *) +and parseRecordPatternField p = + let label = parseValuePath p in + let pattern = match p.Parser.token with + | Colon -> + Parser.next p; + parsePattern p + | _ -> + Ast_helper.Pat.var + ~loc:label.loc + (Location.mkloc (Longident.last label.txt) label.loc) + in + (label, pattern) + + (* TODO: there are better representations than PatField|Underscore ? *) +and parseRecordPatternItem p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, PatField (parseRecordPatternField p)) + | Uident _ | Lident _ -> + Some (false, PatField (parseRecordPatternField p)) + | Underscore -> + Parser.next p; + Some (false, PatUnderscore) + | _ -> + None + +and parseRecordPattern ~attrs p = + let startPos = p.startPos in + Parser.expect Lbrace p; + let rawFields = + parseCommaDelimitedReversedList p + ~grammar:PatternRecord + ~closing:Rbrace + ~f:parseRecordPatternItem + in + Parser.expect Rbrace p; + let (fields, closedFlag) = + let (rawFields, flag) = match rawFields with + | (_hasSpread, PatUnderscore)::rest -> + (rest, Asttypes.Open) + | rawFields -> + (rawFields, Asttypes.Closed) + in + List.fold_left (fun (fields, flag) curr -> + let (hasSpread, field) = curr in + 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) + ); + (field::fields, flag) + | PatUnderscore -> + (fields, flag) + ) ([], flag) rawFields + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.record ~loc ~attrs fields closedFlag + +and parseTuplePattern ~attrs ~first ~startPos p = + let patterns = + first::( + parseCommaDelimitedRegion p + ~grammar:Grammar.PatternList + ~closing:Rparen + ~f:parseConstrainedPatternRegion + ) + in + Parser.expect Rparen p; + let () = match patterns with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.tuple ~loc ~attrs (patterns) + +and parsePatternRegion p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, parseConstrainedPattern p) + | token when Grammar.isPatternStart token -> + Some (false, parseConstrainedPattern p) + | _ -> None + +and parseModulePattern ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + Parser.expect Lparen p; + let uident = match p.token with + | Uident uident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc uident loc + | _ -> (* TODO: error recovery *) + Location.mknoloc "_" + in + begin match p.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let packageTypAttrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in + Ast_helper.Pat.constraint_ + ~loc + ~attrs + unpack + packageType + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.unpack ~loc ~attrs uident + end + +and parseListPattern ~startPos ~attrs p = + let listPatterns = + parseCommaDelimitedReversedList p + ~grammar:Grammar.PatternOcamlList + ~closing:Rbrace + ~f:parsePatternRegion + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let filterSpread (hasSpread, pattern) = + if hasSpread then ( + Parser.err + ~startPos:pattern.Parsetree.ppat_loc.loc_start + p + (Diagnostics.message ErrorMessages.listPatternSpread); + pattern + ) else + pattern + in + match listPatterns with + | (true, pattern)::patterns -> + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns (Some pattern) in + {pat with ppat_loc = loc; ppat_attributes = attrs;} + | patterns -> + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns None in + {pat with ppat_loc = loc; ppat_attributes = attrs;} + +and parseArrayPattern ~attrs p = + let startPos = p.startPos in + Parser.expect Lbracket p; + let patterns = + parseCommaDelimitedRegion + p + ~grammar:Grammar.PatternList + ~closing:Rbracket + ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) + in + Parser.expect Rbracket p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.array ~loc ~attrs patterns + +and parseConstructorPatternArgs p constr startPos attrs = + let lparen = p.startPos in + Parser.expect Lparen p; + let args = parseCommaDelimitedRegion + p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + Some ( + Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + ) + | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + in + Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + +and parseVariantPatternArgs p ident startPos attrs = + let lparen = p.startPos in + Parser.expect Lparen p; + let patterns = + parseCommaDelimitedRegion + p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion in + let args = + match patterns with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + Some ( + Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + ) + | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> + if p.mode = ParseForTypeChecker then + (* #ident(1, 2) for type-checker *) + Some pat + else + (* #ident((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + in + Parser.expect Rparen p; + Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args + +and parseExpr ?(context=OrdinaryExpr) p = + let expr = parseOperandExpr ~context p in + let expr = parseBinaryExpr ~context ~a:expr p 1 in + parseTernaryExpr expr p + +(* expr ? expr : expr *) +and parseTernaryExpr leftOperand p = + match p.Parser.token with + | Question -> + Parser.leaveBreadcrumb p Grammar.Ternary; + Parser.next p; + let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in + Parser.expect Colon p; + let falseBranch = parseExpr p in + Parser.eatBreadcrumb p; + let loc = {leftOperand.Parsetree.pexp_loc with + loc_start = leftOperand.pexp_loc.loc_start; + loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + } in + Ast_helper.Exp.ifthenelse + ~attrs:[ternaryAttr] ~loc + leftOperand trueBranch (Some falseBranch) + | _ -> + leftOperand + +and parseEs6ArrowExpression ?context ?parameters p = + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; + let parameters = match parameters with + | Some params -> params + | None -> parseParameters p + in + let returnType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr ~es6Arrow:false p) + | _ -> + None + in + Parser.expect EqualGreater p; + let body = + let expr = parseExpr ?context p in + match returnType with + | Some typ -> + Ast_helper.Exp.constraint_ + ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) expr typ + | None -> expr + in + Parser.eatBreadcrumb p; + let endPos = p.prevEndPos in + let arrowExpr = + List.fold_right (fun parameter expr -> + match parameter with + | TermParameter {uncurried; attrs; label = lbl; expr = defaultExpr; pat; pos = startPos} -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl defaultExpr pat expr + | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr + ) parameters body + in + {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} + +(* + * uncurried_parameter ::= + * | . parameter + * + * parameter ::= + * | pattern + * | pattern : type + * | ~ labelName + * | ~ labelName as pattern + * | ~ labelName as pattern : type + * | ~ labelName = expr + * | ~ labelName as pattern = expr + * | ~ labelName as pattern : type = expr + * | ~ labelName = ? + * | ~ labelName as pattern = ? + * | ~ labelName as pattern : type = ? + * + * labelName ::= lident + *) +and parseParameter p = + if ( + p.Parser.token = Token.Typ || + p.token = Tilde || + p.token = Dot || + Grammar.isPatternStart p.token + ) then ( + let startPos = p.Parser.startPos in + let uncurried = Parser.optional p Token.Dot in + (* two scenarios: + * attrs ~lbl ... + * attrs pattern + * Attributes before a labelled arg, indicate that it's on the whole arrow expr + * Otherwise it's part of the pattern + * *) + let attrs = parseAttributes p in + if p.Parser.token = Typ then ( + Parser.next p; + let lidents = parseLidentList p in + Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos}) + ) else ( + let (attrs, lbl, pat) = match p.Parser.token with + | Tilde -> + Parser.next p; + let (lblName, loc) = parseLident p in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + begin match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mkLoc startPos p.prevEndPos in + ( + attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc (Location.mkloc lblName loc) + ) + | Colon -> + let lblEnd = p.prevEndPos in + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos lblEnd in + let pat = + let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ in + (attrs, Asttypes.Labelled lblName, pat) + | As -> + Parser.next p; + let pat = + let pat = parseConstrainedPattern p in + {pat with ppat_attributes = propLocAttr::pat.ppat_attributes} + in + (attrs, Asttypes.Labelled lblName, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mkLoc startPos p.prevEndPos in + ( + attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) + ) + end + | _ -> + let pattern = parseConstrainedPattern p in + let attrs = List.concat [attrs; pattern.ppat_attributes] in + ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) + in + match p.Parser.token with + | Equal -> + Parser.next p; + let lbl = match lbl with + | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Nolabel -> + let lblName = match pat.ppat_desc with | Ppat_var var -> var.txt | _ -> "" in + Parser.err ~startPos ~endPos:p.prevEndPos p ( + Diagnostics.message (ErrorMessages.missingTildeLabeledParameter lblName) + ); + Asttypes.Optional lblName + | lbl -> lbl + in + begin match p.Parser.token with + | Question -> + Parser.next p; + Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + Some (TermParameter {uncurried; attrs; label = lbl; expr = Some expr; pat; pos = startPos}) + end + | _ -> + Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + ) + ) else None + +and parseParameterList p = + let parameters = + parseCommaDelimitedRegion + ~grammar:Grammar.ParameterList + ~f:parseParameter + ~closing:Rparen + p + in + Parser.expect Rparen p; + parameters + +(* parameters ::= + * | _ + * | lident + * | () + * | (.) + * | ( parameter {, parameter} [,] ) + *) +and parseParameters p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [TermParameter { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + pos = startPos; + }] + | Underscore -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); pos = startPos}] + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = Ast_helper.Pat.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] + | Dot -> + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = Ast_helper.Pat.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + [TermParameter {uncurried = true; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] + | _ -> + begin match parseParameterList p with + | (TermParameter {attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest -> + (TermParameter {uncurried = true; attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest + | parameters -> parameters + end + end + | _ -> parseParameterList p + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] + +and parseCoercedExpr ~(expr: Parsetree.expression) p = + Parser.expect ColonGreaterThan p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in + Ast_helper.Exp.coerce ~loc expr None typ + +and parseConstrainedOrCoercedExpr p = + let expr = parseExpr p in + match p.Parser.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | Colon -> + Parser.next p; + begin match p.token with + | _ -> + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + begin match p.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | _ -> + expr + end + end + | _ -> expr + + +and parseConstrainedExprRegion p = + match p.Parser.token with + | token when Grammar.isExprStart token -> + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr + end + | _ -> None + +(* Atomic expressions represent unambiguous expressions. + * This means that regardless of the context, these expressions + * are always interpreted correctly. *) +and parseAtomicExpr p = + Parser.leaveBreadcrumb p Grammar.ExprOperand; + let startPos = p.Parser.startPos in + let expr = match p.Parser.token with + | (True | False) as token -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) None + | Int _ | String _ | Float _ | Character _ -> + let c = parseConstant p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constant ~loc c + | Backtick -> + let expr = parseTemplateExpr p in + {expr with pexp_loc = mkLoc startPos p.prevEndPos} + | Uident _ | Lident _ -> + parseValueOrConstructor p + | Hash -> + parsePolyVariantExpr p + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + | _t -> + let expr = parseConstrainedOrCoercedExpr p in + begin match p.token with + | Comma -> + Parser.next p; + parseTupleExpr ~startPos ~first:expr p + | _ -> + Parser.expect Rparen p; + expr + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *) + end + end + | List -> + Parser.next p; + parseListExpr ~startPos p + | Module -> + Parser.next p; + parseFirstClassModuleExpr ~startPos p + | Lbracket -> + parseArrayExp p + | Lbrace -> + parseBracedOrRecordExpr p + | LessThan -> + parseJsx p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.extension ~loc extension + | Underscore as token -> + (* This case is for error recovery. Not sure if it's the correct place *) + Parser.err p (Diagnostics.lident token); + Parser.next p; + Recover.defaultExpr () + | token -> + let errPos = p.prevEndPos in + Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart with + | None -> Recover.defaultExpr() + | Some () -> parseAtomicExpr p + end + in + Parser.eatBreadcrumb p; + expr + +(* module(module-expr) + * module(module-expr : package-type) *) +and parseFirstClassModuleExpr ~startPos p = + Parser.expect Lparen p; + + let modExpr = parseModuleExpr p in + let modEndLoc = p.prevEndPos in + begin match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos modEndLoc in + let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constraint_ ~loc firstClassModule packageType + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.pack ~loc modExpr + end + +and parseBracketAccess p expr startPos = + Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; + let lbracket = p.startPos in + Parser.next p; + let stringStart = p.startPos in + match p.Parser.token with + | String s -> + let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in + Parser.next p; + let stringEnd = p.prevEndPos in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let e = + let identLoc = mkLoc stringStart stringEnd in + let loc = mkLoc lbracket rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) + in + let e = parsePrimaryExpr ~operand:e p in + let equalStart = p.startPos in + begin match p.token with + | Equal -> + Parser.next p; + let equalEnd = p.prevEndPos in + let rhsExpr = parseExpr p in + let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in + let operatorLoc = mkLoc equalStart equalEnd in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc:operatorLoc (Location.mkloc (Longident.Lident "#=") operatorLoc)) + [Nolabel, e; Nolabel, rhsExpr] + | _ -> e + end + | _ -> + let accessExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let arrayLoc = mkLoc lbracket rbracket in + begin match p.token with + | Equal -> + Parser.leaveBreadcrumb p ExprArrayMutation; + Parser.next p; + let rhsExpr = parseExpr p in + let arraySet = Location.mkloc + (Longident.Ldot(Lident "Array", "set")) + arrayLoc + in + let endPos = p.prevEndPos in + let arraySet = Ast_helper.Exp.apply + ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) + [Nolabel, expr; Nolabel, accessExpr; Nolabel, rhsExpr] + in + Parser.eatBreadcrumb p; + arraySet + | _ -> + let endPos = p.prevEndPos in + let e = + Ast_helper.Exp.apply + ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident + ~loc:arrayLoc + (Location.mkloc (Longident.Ldot(Lident "Array", "get")) arrayLoc) + ) + [Nolabel, expr; Nolabel, accessExpr] + in + parsePrimaryExpr ~operand:e p + end + +(* * A primary expression represents + * - atomic-expr + * - john.age + * - array[0] + * - applyFunctionTo(arg1, arg2) + * + * The "operand" represents the expression that is operated on + *) +and parsePrimaryExpr ~operand ?(noCall=false) p = + let startPos = operand.pexp_loc.loc_start in + let rec loop p expr = + match p.Parser.token with + | Dot -> + Parser.next p; + let lident = parseValuePath p in + begin match p.Parser.token with + | Equal when noCall = false -> + Parser.leaveBreadcrumb p Grammar.ExprSetField; + Parser.next p; + let targetExpr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in + Parser.eatBreadcrumb p; + setfield + | _ -> + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + loop p (Ast_helper.Exp.field ~loc expr lident) + end + | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + parseBracketAccess p expr startPos + | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + loop p (parseCallExpr p expr) + | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + begin match expr.pexp_desc with + | Pexp_ident {txt = Longident.Lident ident} -> + parseTemplateExpr ~prefix:ident p + | _ -> + Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:expr.pexp_loc.loc_end + p + (Diagnostics.message "Tagged template literals are currently restricted to names like: json`null`."); + parseTemplateExpr p + end + | _ -> expr + in + loop p operand + +(* a unary expression is an expression with only one operand and + * unary operator. Examples: + * -1 + * !condition + * -. 1.6 + *) +and parseUnaryExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> + Parser.leaveBreadcrumb p Grammar.ExprUnary; + let tokenEnd = p.endPos in + Parser.next p; + let operand = parseUnaryExpr p in + let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in + Parser.eatBreadcrumb p; + unaryExpr + | _ -> + parsePrimaryExpr ~operand:(parseAtomicExpr p) p + +(* Represents an "operand" in a binary expression. + * If you have `a + b`, `a` and `b` both represent + * the operands of the binary expression with opeartor `+` *) +and parseOperandExpr ~context p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let expr = match p.Parser.token with + | Assert -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.assert_ ~loc expr + | Lazy -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.lazy_ ~loc expr + | Try -> + parseTryExpression p + | If -> + parseIfOrIfLetExpression p + | For -> + parseForExpression p + | While -> + parseWhileExpression p + | Switch -> + parseSwitchExpression p + | _ -> + if (context != WhenExpr) && + isEs6ArrowExpression ~inTernary:(context=TernaryTrueBranchExpr) p + then + parseEs6ArrowExpression ~context p + else + parseUnaryExpr p + in + (* let endPos = p.Parser.prevEndPos in *) + {expr with + pexp_attributes = List.concat[expr.Parsetree.pexp_attributes; attrs]; + (* pexp_loc = mkLoc startPos endPos *) + } + +(* a binary expression is an expression that combines two expressions with an + * operator. Examples: + * a + b + * f(x) |> g(y) + *) +and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec = + let a = match a with + | Some e -> e + | None -> parseOperandExpr ~context p + in + let rec loop a = + let token = p.Parser.token in + let tokenPrec = + match token with + (* Can the minus be interpreted as a binary operator? Or is it a unary? + * let w = { + * x + * -10 + * } + * vs + * let w = { + * width + * - gap + * } + * + * First case is unary, second is a binary operator. + * See Scanner.isBinaryOp *) + | Minus | MinusDot | LessThan when not ( + Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum + ) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> -1 + | token -> Token.precedence token + in + if tokenPrec < prec then a + else begin + Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let b = parseBinaryExpr ~context p (tokenPrec + 1) in + let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in + let expr = Ast_helper.Exp.apply + ~loc + (makeInfixOperator p token startPos endPos) + [Nolabel, a; Nolabel, b] + in + Parser.eatBreadcrumb p; + loop expr + end + in + loop a + +(* If we even need this, determines if < might be the start of jsx. Not 100% complete *) +(* and isStartOfJsx p = *) + (* Parser.lookahead p (fun p -> *) + (* match p.Parser.token with *) + (* | LessThan -> *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | GreaterThan (* <> *) -> true *) + (* | Lident _ | Uident _ | List -> *) + (* ignore (parseJsxName p); *) + (* begin match p.token with *) + (* | GreaterThan (*
*) -> true *) + (* | Question (* true *) + (* | Lident _ | List -> *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | Equal (* true *) + (* | _ -> false (* TODO *) *) + (* end *) + (* | Forwardslash (* *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | GreaterThan (* *) -> true *) + (* | _ -> false *) + (* end *) + (* | _ -> *) + (* false *) + (* end *) + (* | _ -> false *) + (* end *) + (* | _ -> false *) + (* ) *) + +and parseTemplateExpr ?(prefix="js") p = + let hiddenOperator = + let op = Location.mknoloc (Longident.Lident "^") in + Ast_helper.Exp.ident op + in + let rec parseParts acc = + let startPos = p.Parser.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail txt -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + if String.length txt > 0 then + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in + Ast_helper.Exp.apply ~loc hiddenOperator + [Nolabel, acc; Nolabel, str] + else + acc + | TemplatePart txt -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let expr = parseExprBlock p in + let fullLoc = mkLoc startPos p.prevEndPos in + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in + let next = + let a = if String.length txt > 0 then + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, acc; Nolabel, str] + else acc + in + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator + [Nolabel, a; Nolabel, 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 -> + Parser.next p; + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + Ast_helper.Exp.constant ~loc:(mkLoc startPos p.prevEndPos) (Pconst_string(txt, Some prefix)) + | TemplatePart txt -> + Parser.next p; + let constantLoc = mkLoc startPos p.prevEndPos in + let expr = parseExprBlock p in + let fullLoc = mkLoc startPos p.prevEndPos in + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc:constantLoc (Pconst_string(txt, Some prefix)) in + let next = + if String.length txt > 0 then + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, str; Nolabel, expr] + else + expr + in + parseParts next + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string("", None)) + +(* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => + * Also overparse constraints: + * let x = { + * let a = 1 + * a + pi: int + * } + * + * We want to give a nice error message in these cases + * *) +and overParseConstrainedOrCoercedOrArrowExpression p expr = + match p.Parser.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | Colon -> + Parser.next p; + let typ = parseTypExpr ~es6Arrow:false p in + begin match p.Parser.token with + | EqualGreater -> + Parser.next p; + let body = parseExpr p in + let pat = match expr.pexp_desc with + | Pexp_ident longident -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + Ast_helper.Pat.var ~loc:expr.pexp_loc (Location.mkloc "pattern" expr.pexp_loc) + in + let arrow1 = Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel + None + pat + (Ast_helper.Exp.constraint_ body typ) + in + let arrow2 = Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel + None + (Ast_helper.Pat.constraint_ pat typ) + body + in + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Did you mean to annotate the parameter type or the return type?"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.text "1) "; + ResPrinter.printExpression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.printExpression arrow2 CommentTable.empty; + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:body.pexp_loc.loc_end + p + (Diagnostics.message msg); + arrow1 + | _ -> + let open Parsetree in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + let () = Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:typ.ptyp_loc.loc_end + p + (Diagnostics.message + (Doc.breakableGroup ~forceBreak:true (Doc.concat [ + Doc.text "Expressions with type constraints need to be wrapped in parens:"; + Doc.indent ( + Doc.concat [ + Doc.line; + ResPrinter.addParens (ResPrinter.printExpression expr CommentTable.empty); + ] + ) + ]) |> Doc.toString ~width:80 + )) + in + expr + end + | _ -> expr + +and parseLetBindingBody ~startPos ~attrs p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.LetBinding; + let pat, exp = + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Colon -> + Parser.next p; + begin match p.token with + | Typ -> (* locally abstract types *) + Parser.next p; + let newtypes = parseLidentList p in + Parser.expect Dot p; + let typ = parseTypExpr p in + Parser.expect Equal p; + let expr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly in + (pat, exp) + | _ -> + let polyType = parsePolyTypeExpr p in + let loc = {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} in + let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in + Parser.expect Token.Equal p; + let exp = parseExpr p in + let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in + (pat, exp) + end + | _ -> + Parser.expect Token.Equal p; + let exp = overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) in + (pat, exp) + in + let loc = mkLoc startPos p.prevEndPos in + let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in + Parser.eatBreadcrumb p; + Parser.endRegion p; + vb + +(* TODO: find a better way? Is it possible? + * let a = 1 + * @attr + * and b = 2 + * + * The problem is that without semi we need a lookahead to determine + * if the attr is on the letbinding or the start of a new thing + * + * let a = 1 + * @attr + * let b = 1 + * + * Here @attr should attach to something "new": `let b = 1` + * The parser state is forked, which is quite expensive… + *) +and parseAttributesAndBinding (p : Parser.t) = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let lineOffset = p.scanner.lineOffset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let startPos = p.startPos in + let endPos = p.endPos in + let prevEndPos = p.prevEndPos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + match p.Parser.token with + | At -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | And -> + attrs + | _ -> + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + [] + end + | _ -> [] + +(* definition ::= let [rec] let-binding { and let-binding } *) +and parseLetBindings ~attrs p = + let startPos = p.Parser.startPos in + Parser.optional p Let |> ignore; + let recFlag = if Parser.optional p Token.Rec then + Asttypes.Recursive + else + Asttypes.Nonrecursive + in + let first = parseLetBindingBody ~startPos ~attrs p in + + let rec loop p bindings = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + let attrs = match p.token with + | Export -> + let exportLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + genTypeAttr::attrs + | _ -> attrs + in + ignore(Parser.optional p Let); (* overparse for fault tolerance *) + let letBinding = parseLetBindingBody ~startPos ~attrs p in + loop p (letBinding::bindings) + | _ -> + List.rev bindings + in + (recFlag, loop p [first]) + +(* + * div -> div + * Foo -> Foo.createElement + * Foo.Bar -> Foo.Bar.createElement + *) +and parseJsxName p = + let longident = match p.Parser.token with + | Lident ident -> + let identStart = p.startPos in + let identEnd = p.endPos in + Parser.next p; + let loc = mkLoc identStart identEnd in + Location.mkloc (Longident.Lident ident) loc + | Uident _ -> + let longident = parseModuleLongIdent ~lowercase:true p in + Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc + | _ -> + let msg = "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " + in + Parser.err p (Diagnostics.message msg); + Location.mknoloc (Longident.Lident "_") + in + Ast_helper.Exp.ident ~loc:longident.loc longident + +and parseJsxOpeningOrSelfClosingElement ~startPos p = + let jsxStartPos = p.Parser.startPos in + let name = parseJsxName p in + let jsxProps = parseJsxProps p in + let children = match p.Parser.token with + | Forwardslash -> (* *) + let childrenStartPos = p.Parser.startPos in + Parser.next p; + let childrenEndPos = p.Parser.startPos in + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + makeListExpression loc [] None (* no children *) + | GreaterThan -> (* bar *) + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.next p; + let (spread, children) = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in + let () = match p.token with + | LessThanSlash -> Parser.next p + | LessThan -> Parser.next p; Parser.expect Forwardslash p + | token when Grammar.isStructureItemStart token -> () + | _ -> Parser.expect LessThanSlash p + in + begin match p.Parser.token with + | Lident _ | Uident _ when verifyJsxOpeningClosingName p name -> + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + ( match spread, children with + | true, child :: _ -> + child + | _ -> + makeListExpression loc children None + ) + | token -> + let () = if Grammar.isStructureItemStart token then ( + let closing = "" in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~startPos ~endPos:p.prevEndPos p msg; + ) else ( + let opening = "" in + let msg = "Closing jsx name should be the same as the opening name. Did you mean " ^ opening ^ " ?" in + Parser.err ~startPos ~endPos:p.prevEndPos p (Diagnostics.message msg); + Parser.expect GreaterThan p + ) + in + let loc = mkLoc childrenStartPos childrenEndPos in + ( match spread, children with + | true, child :: _ -> + child + | _ -> + makeListExpression loc children None + ) + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + makeListExpression Location.none [] None + in + let jsxEndPos = p.prevEndPos in + let loc = mkLoc jsxStartPos jsxEndPos in + Ast_helper.Exp.apply + ~loc + name + (List.concat [jsxProps; [ + (Asttypes.Labelled "children", children); + (Asttypes.Nolabel, Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None) + ]]) + +(* + * jsx ::= + * | <> jsx-children + * | + * | jsx-children + * + * jsx-children ::= primary-expr* * => 0 or more + *) +and parseJsx p = + Parser.leaveBreadcrumb p Grammar.Jsx; + let startPos = p.Parser.startPos in + Parser.expect LessThan p; + let jsxExpr = match p.Parser.token with + | Lident _ | Uident _ -> + parseJsxOpeningOrSelfClosingElement ~startPos p + | GreaterThan -> (* fragment: <> foo *) + parseJsxFragment p + | _ -> + parseJsxName p + in + Parser.eatBreadcrumb p; + {jsxExpr with pexp_attributes = [jsxAttr]} + +(* + * jsx-fragment ::= + * | <> + * | <> jsx-children + *) +and parseJsxFragment p = + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.expect GreaterThan p; + let (_spread, children) = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in + Parser.expect LessThanSlash p; + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + makeListExpression loc children None + + +(* + * jsx-prop ::= + * | lident + * | ?lident + * | lident = jsx_expr + * | lident = ?jsx_expr + *) +and parseJsxProp p = + match p.Parser.token with + | Question | Lident _ -> + let optional = Parser.optional p Question in + let (name, loc) = parseLident p in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + (* optional punning: *) + if optional then + Some ( + Asttypes.Optional name, + Ast_helper.Exp.ident ~attrs:[propLocAttr] + ~loc (Location.mkloc (Longident.Lident name) loc) + ) + else begin + match p.Parser.token with + | Equal -> + Parser.next p; + (* no punning *) + let optional = Parser.optional p Question in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + {e with pexp_attributes = propLocAttr::e.pexp_attributes} + in + let label = + if optional then Asttypes.Optional name else Asttypes.Labelled name + in + Some (label, attrExpr) + | _ -> + let attrExpr = + Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] + (Location.mkloc (Longident.Lident name) loc) in + let label = + if optional then Asttypes.Optional name else Asttypes.Labelled name + in + Some (label, attrExpr) + end + | _ -> + None + +and parseJsxProps p = + parseRegion + ~grammar:Grammar.JsxAttribute + ~f:parseJsxProp + p + +and parseJsxChildren p = + let rec loop p children = + match p.Parser.token with + | Token.Eof | LessThanSlash -> + Scanner.popMode p.scanner Jsx; + List.rev children + | LessThan -> + (* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) + let token = Scanner.reconsiderLessThan p.scanner in + if token = LessThan then + let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in + loop p (child::children) + else (* LessThanSlash *) + let () = p.token <- token in + let () = Scanner.popMode p.scanner Jsx in + List.rev children + | token when Grammar.isJsxChildStart token -> + let () = Scanner.popMode p.scanner Jsx in + let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in + loop p (child::children) + | _ -> + Scanner.popMode p.scanner Jsx; + List.rev children + in + match p.Parser.token with + | DotDotDot -> + Parser.next p; + (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) + | _ -> (false, loop p []) + +and parseBracedOrRecordExpr p = + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + match p.Parser.token with + | Rbrace -> + Parser.err p (Diagnostics.unexpected Rbrace p.breadcrumbs); + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + Ast_helper.Exp.construct ~attrs:[braces] ~loc + (Location.mkloc (Longident.Lident "()") loc) None + | DotDotDot -> + (* beginning of record spread, parse record *) + Parser.next p; + let spreadExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in + Parser.expect Rbrace p; + expr + | String s -> + let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in + let field = + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc (Longident.Lident s) loc + in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Parser.optional p Comma |> ignore; + let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in + Parser.expect Rbrace p; + expr + | _ -> + let constant = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string(s, None)) in + let a = parsePrimaryExpr ~operand:constant p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with Parsetree.pexp_attributes = braces::expr.Parsetree.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | Uident _ | Lident _ -> + let valueOrConstructor = parseValueOrConstructor p in + begin match valueOrConstructor.pexp_desc with + | Pexp_ident pathIdent -> + let identEndPos = p.prevEndPos in + begin match p.Parser.token with + | Comma -> + Parser.next p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + begin match p.token with + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None + | _ -> + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in + Parser.expect Rbrace p; + expr + end + (* error case *) + | Lident _ -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + ) else ( + Parser.expect Colon p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + ) + | Semicolon -> + let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | EqualGreater -> + let loc = mkLoc startPos identEndPos in + let ident = Location.mkloc (Longident.last pathIdent.txt) loc in + let a = parseEs6ArrowExpression + ~parameters:[TermParameter { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ident; + pos = startPos; + }] + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + | _ -> + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | _ -> + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:valueOrConstructor p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | _ -> + let expr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + +and parseRecordRowWithStringKey p = + match p.Parser.token with + | String s -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + let field = Location.mkloc (Longident.Lident s) loc in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> + Some (field, Ast_helper.Exp.ident ~loc:field.loc field) + end + | _ -> None + +and parseRecordRow p = + let () = match p.Parser.token with + | Token.DotDotDot -> + Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | Lident _ | Uident _ -> + let field = parseValuePath p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> + Some (field, Ast_helper.Exp.ident ~loc:field.loc field) + end + | _ -> None + +and parseRecordExprWithStringKeys ~startPos firstRow p = + let rows = firstRow::( + parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey ~closing:Rbrace ~f:parseRecordRowWithStringKey p + ) in + let loc = mkLoc startPos p.endPos in + let recordStrExpr = Ast_helper.Str.eval ~loc ( + Ast_helper.Exp.record ~loc rows None + ) in + Ast_helper.Exp.extension ~loc + (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) + +and parseRecordExpr ~startPos ?(spread=None) rows p = + let exprs = + parseCommaDelimitedRegion + ~grammar:Grammar.RecordRows + ~closing:Rbrace + ~f:parseRecordRow p + in + let rows = List.concat [rows; exprs] in + let () = match rows with + | [] -> + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg); + | _rows -> () + in + let loc = mkLoc startPos p.endPos in + Ast_helper.Exp.record ~loc rows spread + + +and parseNewlineOrSemicolonExprBlock p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isBlockExprStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive expressions on a line must be separated by ';' or a newline") + | _ -> () + +and parseExprBlockItem p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Module -> + Parser.next p; + begin match p.token with + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + parseTernaryExpr expr p + | _ -> + let name = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + parseNewlineOrSemicolonExprBlock p; + let expr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letmodule ~loc name body expr + end + | Exception -> + let extensionConstructor = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr + | Open -> + let od = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr + | Let -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let next = if Grammar.isBlockExprStart p.Parser.token then + parseExprBlock p + else + let loc = mkLoc p.startPos p.endPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.let_ ~loc recFlag letBindings next + | _ -> + let e1 = + let expr = parseExpr p in + {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} + in + parseNewlineOrSemicolonExprBlock p; + if Grammar.isBlockExprStart p.Parser.token then + let e2 = parseExprBlock p in + let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc e1 e2 + else e1 + +(* blockExpr ::= expr + * | expr ; + * | expr ; blockExpr + * | module ... ; blockExpr + * | open ... ; blockExpr + * | exception ... ; blockExpr + * | let ... + * | let ... ; + * | let ... ; blockExpr + * + * note: semi should be made optional + * a block of expression is always + *) +and parseExprBlock ?first p = + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let item = match first with + | Some e -> e + | None -> parseExprBlockItem p + in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = if Grammar.isBlockExprStart p.Parser.token then + let next = parseExprBlockItem p in + let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc item next + else + item + in + Parser.eatBreadcrumb p; + overParseConstrainedOrCoercedOrArrowExpression p blockExpr + +and parseTryExpression p = + let startPos = p.Parser.startPos in + Parser.expect Try p; + let expr = parseExpr ~context:WhenExpr p in + Parser.expect Res_token.catch p; + Parser.expect Lbrace p; + let cases = parsePatternMatching p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.try_ ~loc expr cases + +and parseIfCondition p = + Parser.leaveBreadcrumb p Grammar.IfCondition; + (* doesn't make sense to try es6 arrow here? *) + let conditionExpr = parseExpr ~context:WhenExpr p in + Parser.eatBreadcrumb p; + conditionExpr + +and parseThenBranch p = + Parser.leaveBreadcrumb p IfBranch; + Parser.expect Lbrace p; + let thenExpr = parseExprBlock p in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + thenExpr + +and parseElseBranch p = + Parser.expect Lbrace p; + let blockExpr = parseExprBlock p in + Parser.expect Rbrace p; + blockExpr; + +and parseIfExpr startPos p = + let conditionExpr = parseIfCondition p in + let thenExpr = parseThenBranch p in + let elseExpr = match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = match p.token with + | If -> + parseIfOrIfLetExpression p + | _ -> + parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + Some elseExpr + | _ -> + Parser.endRegion p; + None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr + +and parseIfLetExpr startPos p = + let pattern = parsePattern p in + Parser.expect Equal p; + let conditionExpr = parseIfCondition p in + let thenExpr = parseThenBranch p in + let elseExpr = match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = match p.token with + | If -> + parseIfOrIfLetExpression p + | _ -> + parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + elseExpr + | _ -> + Parser.endRegion p; + let startPos = p.Parser.startPos in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [ + Ast_helper.Exp.case pattern thenExpr; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; + ] + +and parseIfOrIfLetExpression p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.ExprIf; + let startPos = p.Parser.startPos in + Parser.expect If p; + let expr = match p.Parser.token with + | Let -> + Parser.next p; + let ifLetExpr = parseIfLetExpr startPos p in + Parser.err + ~startPos:ifLetExpr.pexp_loc.loc_start + ~endPos:ifLetExpr.pexp_loc.loc_end + p + (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); + ifLetExpr + | _ -> + parseIfExpr startPos p + in + Parser.eatBreadcrumb p; + expr; + +and parseForRest hasOpeningParen pattern startPos p = + Parser.expect In p; + let e1 = parseExpr p in + let direction = match p.Parser.token with + | Lident "to" -> Asttypes.Upto + | Lident "downto" -> Asttypes.Downto + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto + in + Parser.next p; + let e2 = parseExpr ~context:WhenExpr p in + if hasOpeningParen then Parser.expect Rparen p; + Parser.expect Lbrace p; + let bodyExpr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr + +and parseForExpression p = + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.ExprFor; + Parser.expect For p; + Parser.beginRegion p; + let forExpr = match p.token with + | Lparen -> + let lparen = p.startPos in + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let unitPattern = + let loc = mkLoc lparen p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parseForRest false (parseAliasPattern ~attrs:[] unitPattern p) startPos p + | _ -> + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + begin match p.token with + | Comma -> + Parser.next p; + let tuplePattern = + parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + in + let pattern = parseAliasPattern ~attrs:[] tuplePattern p in + parseForRest false pattern startPos p + | _ -> + parseForRest true pat startPos p + end + end + | _ -> + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + parseForRest false pat startPos p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + forExpr + + +and parseWhileExpression p = + let startPos = p.Parser.startPos in + Parser.expect While p; + let expr1 = parseExpr ~context:WhenExpr p in + Parser.expect Lbrace p; + let expr2 = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.while_ ~loc expr1 expr2 + +and parsePatternGuard p = + match p.Parser.token with + | When | If -> + Parser.next p; + Some (parseExpr ~context:WhenExpr p) + | _ -> + None + +and parsePatternMatchCase p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.PatternMatchCase; + match p.Parser.token with + | Token.Bar -> + Parser.next p; + Parser.leaveBreadcrumb p Grammar.Pattern; + let lhs = parsePattern p in + Parser.eatBreadcrumb p; + let guard = parsePatternGuard p in + let () = match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recoverEqualGreater p + in + let rhs = parseExprBlock p in + Parser.endRegion p; + Parser.eatBreadcrumb p; + Some (Ast_helper.Exp.case lhs ?guard rhs) + | _ -> + Parser.endRegion p; + Parser.eatBreadcrumb p; + None + +and parsePatternMatching p = + let cases = + parseDelimitedRegion + ~grammar:Grammar.PatternMatching + ~closing:Rbrace + ~f:parsePatternMatchCase + p + in + let () = match cases with + | [] -> Parser.err ~startPos:p.prevEndPos p ( + Diagnostics.message "Pattern matching needs at least one case" + ) + | _ -> () + in + cases + +and parseSwitchExpression p = + let startPos = p.Parser.startPos in + Parser.expect Switch p; + let switchExpr = parseExpr ~context:WhenExpr p in + Parser.expect Lbrace p; + let cases = parsePatternMatching p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.match_ ~loc switchExpr cases + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type + * + * uncurried_argument ::= + * | . argument + *) +and parseArgument p = + if ( + p.Parser.token = Token.Tilde || + p.token = Dot || + p.token = Underscore || + Grammar.isExprStart p.token + ) then ( + match p.Parser.token with + | Dot -> + let uncurried = true in + Parser.next(p); + begin match p.token with + (* apply(.) *) + | Rparen -> + let unitExpr = Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None + in + Some (uncurried, Asttypes.Nolabel, unitExpr) + | _ -> + parseArgument2 p ~uncurried + end + | _ -> + parseArgument2 p ~uncurried:false + ) else + None + +and parseArgument2 p ~uncurried = + match p.Parser.token with + (* foo(_), do not confuse with foo(_ => x), TODO: performance *) + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + let exp = Ast_helper.Exp.ident ~loc ( + Location.mkloc (Longident.Lident "_") loc + ) in + Some (uncurried, Asttypes.Nolabel, exp) + | Tilde -> + Parser.next p; + (* TODO: nesting of pattern matches not intuitive for error recovery *) + begin match p.Parser.token with + | Lident ident -> + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc ( + Location.mkloc (Longident.Lident ident) loc + ) in + begin match p.Parser.token with + | Question -> + Parser.next p; + Some (uncurried, Asttypes.Optional ident, identExpr) + | Equal -> + Parser.next p; + let label = match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional ident + | _ -> + Labelled ident + in + let expr = match p.Parser.token with + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Ast_helper.Exp.ident ~loc ( + Location.mkloc (Longident.Lident "_") loc + ) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + {expr with pexp_attributes = propLocAttr::expr.pexp_attributes} + in + Some (uncurried, label, expr) + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in + Some (uncurried, Labelled ident, expr) + | _ -> + Some (uncurried, Labelled ident, identExpr) + end + | t -> + Parser.err p (Diagnostics.lident t); + Some (uncurried, Nolabel, Recover.defaultExpr ()) + end + | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) + +and parseCallExpr p funExpr = + Parser.expect Lparen p; + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.ExprCall; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ArgumentList + ~closing:Rparen + ~f:parseArgument p + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + (* No args -> unit sugar: `foo()` *) + [ false, + Asttypes.Nolabel, + Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + ] + | [ + true, + Asttypes.Nolabel, + ({ + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_loc = loc; + pexp_attributes = [] + } as expr) + ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> + (* Since there is no syntax space for arity zero vs arity one, + * we expand + * `fn(. ())` into + * `fn(. {let __res_unit = (); __res_unit})` + * when the parsetree is intended for type checking + * + * Note: + * `fn(.)` is treated as zero arity application. + * The invisible unit expression here has loc_ghost === true + * + * Related: https://github.com/rescript-lang/syntax/issues/138 + *) + [ + true, + Asttypes.Nolabel, + Ast_helper.Exp.let_ + Asttypes.Nonrecursive + [Ast_helper.Vb.mk + (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) + expr] + (Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident "__res_unit"))) + ] + | args -> args + in + let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in + let args = match args with + | (u, lbl, expr)::args -> + let group (grp, acc) (uncurried, lbl, expr) = + let (_u, grp) = grp in + if uncurried == true then + ((true, [lbl, expr]), ((_u, (List.rev grp))::acc)) + else + ((_u, ((lbl, expr)::grp)), acc) + in + let ((_u, grp), acc) = List.fold_left group((u, [lbl, expr]), []) args in + List.rev ((_u, (List.rev grp))::acc) + | [] -> [] + in + let apply = List.fold_left (fun callBody group -> + let (uncurried, args) = group in + let (args, wrap) = processUnderscoreApplication args in + let exp = if uncurried then + let attrs = [uncurryAttr] in + Ast_helper.Exp.apply ~loc ~attrs callBody args + else + Ast_helper.Exp.apply ~loc callBody args + in + wrap exp + ) funExpr args + in + Parser.eatBreadcrumb p; + apply + +and parseValueOrConstructor p = + let startPos = p.Parser.startPos in + let rec aux p acc = + match p.Parser.token with + | Uident ident -> + let endPosLident = p.endPos in + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + aux p (ident::acc) + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let lident = buildLongident (ident::acc) in + let tail = match args with + | [] -> None + | [{Parsetree.pexp_desc = Pexp_tuple _} as arg] as args -> + let loc = mkLoc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [arg] -> + Some arg + | args -> + let loc = mkLoc lparen rparen in + Some (Ast_helper.Exp.tuple ~loc args) + in + let loc = mkLoc startPos p.prevEndPos in + let identLoc = mkLoc startPos endPosLident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident::acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None + end + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident::acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + | token -> + Parser.next p; + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultExpr() + in + aux p [] + +and parsePolyVariantExpr p = + let startPos = p.startPos in + let (ident, _loc) = parseHashIdent ~startPos p in + begin match p.Parser.token with + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let loc_paren = mkLoc lparen rparen in + let tail = match args with + | [] -> None + | [{Parsetree.pexp_desc = Pexp_tuple _} as expr ] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [arg] -> Some arg + | args -> + (* #a((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident None + end + +and parseConstructorArgs p = + let lparen = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ExprList ~f:parseConstrainedExprRegion ~closing:Rparen p + in + Parser.expect Rparen p; + match args with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + [Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None] + | args -> args + +and parseTupleExpr ~first ~startPos p = + let exprs = + first::( + parseCommaDelimitedRegion + p + ~grammar:Grammar.ExprList + ~closing:Rparen + ~f:parseConstrainedExprRegion + ) + in + Parser.expect Rparen p; + let () = match exprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.tuple ~loc exprs + +and parseSpreadExprRegion p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + let expr = parseConstrainedOrCoercedExpr p in + Some (true, expr) + | token when Grammar.isExprStart token -> + Some (false, parseConstrainedOrCoercedExpr p) + | _ -> None + +and parseListExpr ~startPos p = + let listExprs = + parseCommaDelimitedReversedList + p ~grammar:Grammar.ListExpr ~closing:Rbrace ~f:parseSpreadExprRegion + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + match listExprs with + | (true, expr)::exprs -> + let exprs = exprs |> List.map snd |> List.rev in + makeListExpression loc exprs (Some expr) + | exprs -> + let exprs = + exprs + |> List.map (fun (spread, expr) -> + if spread then + Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); + expr) + |> List.rev + in + makeListExpression loc exprs None + +(* Overparse ... and give a nice error message *) +and parseNonSpreadExp ~msg p = + let () = match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | token when Grammar.isExprStart token -> + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr + end + | _ -> None + +and parseArrayExp p = + let startPos = p.Parser.startPos in + Parser.expect Lbracket p; + let exprs = + parseCommaDelimitedRegion + p + ~grammar:Grammar.ExprList + ~closing:Rbracket + ~f:(parseNonSpreadExp ~msg:ErrorMessages.arrayExprSpread) + in + Parser.expect Rbracket p; + Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs + +(* TODO: check attributes in the case of poly type vars, + * might be context dependend: parseFieldDeclaration (see ocaml) *) +and parsePolyTypeExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | SingleQuote -> + let vars = parseTypeVarList p in + begin match vars with + | _v1::_v2::_ -> + Parser.expect Dot p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | [var] -> + begin match p.Parser.token with + | Dot -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | EqualGreater -> + Parser.next p; + let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> + Ast_helper.Typ.var ~loc:var.loc var.txt + end + | _ -> assert false + end + | _ -> + parseTypExpr p + +(* 'a 'b 'c *) +and parseTypeVarList p = + let rec loop p vars = + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (lident, loc) = parseLident p in + let var = Location.mkloc lident loc in + loop p (var::vars) + | _ -> + List.rev vars + in + loop p [] + +and parseLidentList p = + let rec loop p ls = + match p.Parser.token with + | Lident lident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + loop p ((Location.mkloc lident loc)::ls) + | _ -> + List.rev ls + in + loop p [] + +and parseAtomicTypExpr ~attrs p = + Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; + let startPos = p.Parser.startPos in + let typ = match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (ident, loc) = parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p in + Ast_helper.Typ.var ~loc ~attrs ident + | Underscore -> + let endPos = p.endPos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unitConstr [] + | _ -> + let t = parseTypExpr p in + begin match p.token with + | Comma -> + Parser.next p; + parseTupleType ~attrs ~first:t ~startPos p + | _ -> + Parser.expect Rparen p; + {t with + ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_attributes = List.concat [attrs; t.ptyp_attributes]} + end + end + | Lbracket -> + parsePolymorphicVariantType ~attrs p + | Uident _ | Lident _ -> + let constr = parseValuePath p in + let args = parseTypeConstructorArgs ~constrName:constr p in + Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + | Module -> + Parser.next p; + Parser.expect Lparen p; + let packageType = parsePackageType ~startPos ~attrs p in + Parser.expect Rparen p; + {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.extension ~attrs ~loc extension + | Lbrace -> + parseRecordOrObjectType ~attrs p + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart with + | Some () -> + parseAtomicTypExpr ~attrs p + | None -> + Parser.err ~startPos:p.prevEndPos p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultType() + end + in + Parser.eatBreadcrumb p; + typ + +(* package-type ::= + | modtype-path + ∣ modtype-path with package-constraint { and package-constraint } + *) +and parsePackageType ~startPos ~attrs p = + let modTypePath = parseModuleLongIdent ~lowercase:true p in + begin match p.Parser.token with + | Lident "with" -> + Parser.next p; + let constraints = parsePackageConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath constraints + | _ -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath [] + end + +(* package-constraint { and package-constraint } *) +and parsePackageConstraints p = + let first = + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + (typeConstr, typ) + in + let rest = parseRegion + ~grammar:Grammar.PackageConstraint + ~f:parsePackageConstraint + p + in + first::rest + +(* and type typeconstr = typexpr *) +and parsePackageConstraint p = + match p.Parser.token with + | And -> + Parser.next p; + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + Some (typeConstr, typ) + | _ -> None + +and parseRecordOrObjectType ~attrs p = + (* for inline record in constructor *) + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let () = match p.token with + | Lident _ -> + Parser.err p (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + | _ -> () + in + let startFirstField = p.startPos in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + let () = match fields with + | [Parsetree.Oinherit {ptyp_loc}] -> + (* {...x}, spread without extra fields *) + Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end + (Diagnostics.message ErrorMessages.sameTypeSpread) + | _ -> () + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.object_ ~loc ~attrs fields closedFlag + +(* TODO: check associativity in combination with attributes *) +and parseTypeAlias p typ = + match p.Parser.token with + | As -> + Parser.next p; + Parser.expect SingleQuote p; + let (ident, _loc) = parseLident p in + (* TODO: how do we parse attributes here? *) + Ast_helper.Typ.alias ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) typ ident + | _ -> typ + + +(* type_parameter ::= + * | type_expr + * | ~ident: type_expr + * | ~ident: type_expr=? + * + * note: + * | attrs ~ident: type_expr -> attrs are on the arrow + * | attrs type_expr -> attrs are here part of the type_expr + * + * uncurried_type_parameter ::= + * | . type_parameter + *) +and parseTypeParameter p = + if ( + p.Parser.token = Token.Tilde || + p.token = Dot || + Grammar.isTypExprStart p.token + ) then ( + let startPos = p.Parser.startPos in + let uncurried = Parser.optional p Dot in + let attrs = parseAttributes p in + match p.Parser.token with + | Tilde -> + Parser.next p; + let (name, loc) = parseLident p in + let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr p in + {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + in + begin match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> + Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + end + | Lident _ -> + let (name, loc) = parseLident p in + begin match p.token with + | Colon -> + let () = + let error = Diagnostics.message ( + ErrorMessages.missingTildeLabeledParameter name + ) in + Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + in + Parser.next p; + let typ = parseTypExpr p in + begin match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> + Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + end + | _ -> + let constr = Location.mkloc (Longident.Lident name) loc in + let args = parseTypeConstructorArgs ~constrName:constr p in + let typ = Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + in + + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parseTypeAlias p typ in + Some (uncurried, [], Asttypes.Nolabel, typ, startPos) + end + | _ -> + let typ = parseTypExpr p in + let typWithAttributes = {typ with ptyp_attributes = List.concat[attrs; typ.ptyp_attributes]} in + Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) + ) else + None + +(* (int, ~x:string, float) *) +and parseTypeParameters p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unitConstr [] in + [(false, [], Asttypes.Nolabel, typ, startPos)] + | _ -> + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen ~f:parseTypeParameter p + in + Parser.expect Rparen p; + params + +and parseEs6ArrowType ~attrs p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Tilde -> + Parser.next p; + let (name, loc) = parseLident p in + let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr ~alias:false ~es6Arrow:false p in + {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + in + let arg = match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional name + | _ -> + Asttypes.Labelled name + in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType + | _ -> + let parameters = parseTypeParameters p in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let endPos = p.prevEndPos in + let typ = List.fold_right (fun (uncurried, attrs, argLbl, typ, startPos) t -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t + ) parameters returnType + in + {typ with + ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; + ptyp_loc = mkLoc startPos p.prevEndPos} + +(* + * typexpr ::= + * | 'ident + * | _ + * | (typexpr) + * | typexpr => typexpr --> es6 arrow + * | (typexpr, typexpr) => typexpr --> es6 arrow + * | /typexpr, typexpr, typexpr/ --> tuple + * | typeconstr + * | typeconstr + * | typeconstr + * | typexpr as 'ident + * | %attr-id --> extension + * | %attr-id(payload) --> extension + * + * typeconstr ::= + * | lident + * | uident.lident + * | uident.uident.lident --> long module path + *) +and parseTypExpr ?attrs ?(es6Arrow=true) ?(alias=true) p = + (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) + let startPos = p.Parser.startPos in + let attrs = match attrs with + | Some attrs -> + attrs + | None -> + parseAttributes p in + let typ = if es6Arrow && isEs6ArrowType p then + parseEs6ArrowType ~attrs p + else + let typ = parseAtomicTypExpr ~attrs p in + parseArrowTypeRest ~es6Arrow ~startPos typ p + in + let typ = if alias then parseTypeAlias p typ else typ in + (* Parser.eatBreadcrumb p; *) + typ + +and parseArrowTypeRest ~es6Arrow ~startPos typ p = + match p.Parser.token with + | (EqualGreater | MinusGreater) as token when es6Arrow == true -> + (* error recovery *) + if token = MinusGreater then ( + Parser.expect EqualGreater p; + ); + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> typ + +and parseTypExprRegion p = + if Grammar.isTypExprStart p.Parser.token then + Some (parseTypExpr p) + else + None + +and parseTupleType ~attrs ~first ~startPos p = + let typexprs = + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + ) + in + Parser.expect Rparen p; + let () = match typexprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let tupleLoc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs + +and parseTypeConstructorArgRegion p = + if Grammar.isTypExprStart p.Parser.token then + Some (parseTypExpr p) + else if p.token = LessThan then ( + Parser.next p; + parseTypeConstructorArgRegion p + ) else + None + +(* Js.Nullable.value<'a> *) +and parseTypeConstructorArgs ~constrName p = + let opening = p.Parser.token in + let openingStartPos = p.startPos in + match opening with + | LessThan | Lparen -> + Scanner.setDiamondMode p.scanner; + Parser.next p; + let typeArgs = + (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:GreaterThan + ~f:parseTypeConstructorArgRegion + p + in + let () = match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constrName typeArgs in + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent ( + Doc.concat [ + Doc.line; + ResPrinter.printTypExpr typ CommentTable.empty; + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> + Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + typeArgs + | _ -> [] + +(* string-field-decl ::= + * | string: poly-typexpr + * | attributes string-field-decl *) +and parseStringFieldDeclaration p = + let attrs = parseAttributes p in + match p.Parser.token with + | String name -> + let nameStartPos = p.startPos in + let nameEndPos = p.endPos in + Parser.next p; + let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some(Parsetree.Otag (fieldName, attrs, typ)) + | DotDotDot -> + Parser.next p; + let typ = parseTypExpr p in + Some(Parsetree.Oinherit typ) + | Lident name -> + let nameLoc = mkLoc p.startPos p.endPos in + Parser.err p (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + Parser.next p; + let fieldName = Location.mkloc name nameLoc in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some(Parsetree.Otag (fieldName, attrs, typ)) + | _token -> + None + +(* field-decl ::= + * | [mutable] field-name : poly-typexpr + * | attributes field-decl *) +and parseFieldDeclaration p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let mut = if Parser.optional p Token.Mutable then + Asttypes.Mutable + else + Asttypes.Immutable + in + let (lident, loc) = match p.token with + | _ -> parseLident p + in + let name = Location.mkloc lident loc in + let typ = match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + Ast_helper.Type.field ~attrs ~loc ~mut name typ + + +and parseFieldDeclarationRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let mut = if Parser.optional p Token.Mutable then + Asttypes.Mutable + else + Asttypes.Immutable + in + match p.token with + | Lident _ -> + let (lident, loc) = parseLident p in + let name = Location.mkloc lident loc in + let typ = match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + Some(Ast_helper.Type.field ~attrs ~loc ~mut name typ) + | _ -> + None + +(* record-decl ::= + * | { field-decl } + * | { field-decl, field-decl } + * | { field-decl, field-decl, field-decl, } + *) +and parseRecordDeclaration p = + Parser.leaveBreadcrumb p Grammar.RecordDecl; + Parser.expect Lbrace p; + let rows = + parseCommaDelimitedRegion + ~grammar:Grammar.RecordDecl + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + rows + +(* constr-args ::= + * | (typexpr) + * | (typexpr, typexpr) + * | (typexpr, typexpr, typexpr,) + * | (record-decl) + * + * TODO: should we overparse inline-records in every position? + * Give a good error message afterwards? + *) +and parseConstrDeclArgs p = + let constrArgs = match p.Parser.token with + | Lparen -> + Parser.next p; + (* TODO: this could use some cleanup/stratification *) + begin match p.Parser.token with + | Lbrace -> + let lbrace = p.startPos in + Parser.next p; + let startPos = p.Parser.startPos in + begin match p.Parser.token with + | DotDot | Dot -> + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `User({...a, "u": int})` *) + Parser.next p; + let typ = parseTypExpr p in + let () = match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p; + | _ -> Parser.expect Comma p + in + let () = match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + (Parsetree.Oinherit typ)::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | _ -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + begin match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + end + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | _ -> + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + | attrs -> + let first = + let field = parseFieldDeclaration p 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" + ) + | _ -> () + in + Parser.expect Rbrace p; + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record fields + end + end + | _ -> + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple args + end + | _ -> Pcstr_tuple [] + in + let res = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr p) + | _ -> None + in + (constrArgs, res) + +(* constr-decl ::= + * | constr-name + * | attrs constr-name + * | constr-name const-args + * | attrs constr-name const-args *) + and parseTypeConstructorDeclarationWithBar p = + match p.Parser.token with + | Bar -> + let startPos = p.Parser.startPos in + Parser.next p; + Some (parseTypeConstructorDeclaration ~startPos p) + | _ -> None + + and parseTypeConstructorDeclaration ~startPos p = + Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; + let attrs = parseAttributes p in + match p.Parser.token with + | Uident uident -> + let uidentLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let (args, res) = parseConstrDeclArgs p in + Parser.eatBreadcrumb p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args (Location.mkloc uident uidentLoc) + | t -> + Parser.err p (Diagnostics.uident t); + Ast_helper.Type.constructor (Location.mknoloc "_") + + (* [|] constr-decl { | constr-decl } *) + and parseTypeConstructorDeclarations ?first p = + let firstConstrDecl = match first with + | None -> + let startPos = p.Parser.startPos in + ignore (Parser.optional p Token.Bar); + parseTypeConstructorDeclaration ~startPos p + | Some firstConstrDecl -> + firstConstrDecl + in + firstConstrDecl::( + parseRegion + ~grammar:Grammar.ConstructorDeclaration + ~f:parseTypeConstructorDeclarationWithBar + p + ) + +(* + * type-representation ::= + * ∣ = [ | ] constr-decl { | constr-decl } + * ∣ = private [ | ] constr-decl { | constr-decl } + * | = | + * ∣ = private | + * ∣ = record-decl + * ∣ = private record-decl + * | = .. + *) +and parseTypeRepresentation p = + Parser.leaveBreadcrumb p Grammar.TypeRepresentation; + (* = consumed *) + let privateFlag = + if Parser.optional p Token.Private + then Asttypes.Private + else Asttypes.Public + in + let kind = match p.Parser.token with + | Bar | Uident _ -> + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) + | Lbrace -> + Parsetree.Ptype_record (parseRecordDeclaration p) + | DotDot -> + Parser.next p; + Ptype_open + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] + in + Parser.eatBreadcrumb p; + (privateFlag, kind) + +(* type-param ::= + * | variance 'lident + * | variance 'uident + * | variance _ + * + * variance ::= + * | + + * | - + * | (* empty *) + *) +and parseTypeParam p = + let variance = match p.Parser.token with + | Plus -> Parser.next p; Asttypes.Covariant + | Minus -> Parser.next p; Contravariant + | _ -> Invariant + in + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (ident, loc) = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + Some (Ast_helper.Typ.var ~loc ident, variance) + | Underscore -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Some (Ast_helper.Typ.any ~loc (), variance) + | (Uident _ | Lident _) as token -> + Parser.err p (Diagnostics.message ( + "Type params start with a singlequote: '" ^ (Token.toString token) + )); + let (ident, loc) = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + Some (Ast_helper.Typ.var ~loc ident, variance) + | _token -> + None + +(* type-params ::= + * | + * ∣ + * ∣ + * ∣ + * + * TODO: when we have pretty-printer show an error + * with the actual code corrected. *) +and parseTypeParams ~parent p = + let opening = p.Parser.token in + match opening with + | LessThan | Lparen when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> + Scanner.setDiamondMode p.scanner; + let openingStartPos = p.startPos in + Parser.leaveBreadcrumb p Grammar.TypeParams; + Parser.next p; + let params = + parseCommaDelimitedRegion + ~grammar:Grammar.TypeParams + ~closing:GreaterThan + ~f:parseTypeParam + p + in + let () = match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.concat [ + ResPrinter.printLongident parent.Location.txt; + ResPrinter.printTypeParams params CommentTable.empty; + ] + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> + Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + Parser.eatBreadcrumb p; + params + | _ -> [] + +(* type-constraint ::= constraint ' ident = typexpr *) +and parseTypeConstraint p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Token.Constraint -> + Parser.next p; + Parser.expect SingleQuote p; + begin match p.Parser.token with + | Lident ident -> + let identLoc = mkLoc startPos p.endPos in + Parser.next p; + Parser.expect Equal p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) + | t -> + Parser.err p (Diagnostics.lident t); + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.any (), parseTypExpr p, loc) + end + | _ -> None + +(* type-constraints ::= + * | (* empty *) + * | type-constraint + * | type-constraint type-constraint + * | type-constraint type-constraint type-constraint (* 0 or more *) + *) +and parseTypeConstraints p = + parseRegion + ~grammar:Grammar.TypeConstraint + ~f:parseTypeConstraint + p + +and parseTypeEquationOrConstrDecl p = + let uidentStartPos = p.Parser.startPos in + match p.Parser.token with + | Uident uident -> + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + let typeConstr = + parseValuePathTail p uidentStartPos (Longident.Lident uident) + in + let loc = mkLoc uidentStartPos p.prevEndPos in + let typ = parseTypeAlias p ( + Ast_helper.Typ.constr ~loc typeConstr (parseTypeConstructorArgs ~constrName:typeConstr p) + ) in + begin match p.token with + | Equal -> + Parser.next p; + let (priv, kind) = parseTypeRepresentation p in + (Some typ, priv, kind) + | EqualGreater -> + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc uidentStartPos p.prevEndPos in + let arrowType = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in + let typ = parseTypeAlias p arrowType in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + end + | _ -> + let uidentEndPos = p.prevEndPos in + let (args, res) = parseConstrDeclArgs p in + let first = Some ( + let uidentLoc = mkLoc uidentStartPos uidentEndPos in + Ast_helper.Type.constructor + ~loc:(mkLoc uidentStartPos p.prevEndPos) + ?res + ~args + (Location.mkloc uident uidentLoc) + ) in + (None, Asttypes.Public, Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first)) + end + | t -> + Parser.err p (Diagnostics.uident t); + (* TODO: is this a good idea? *) + (None, Asttypes.Public, Parsetree.Ptype_abstract) + +and parseRecordOrObjectDecl p = + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + match p.Parser.token with + | DotDot | Dot -> + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) + Parser.next p; + let typ = parseTypExpr p in + let () = match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p; + | _ -> Parser.expect Comma p + in + let () = match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + (Parsetree.Oinherit typ)::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + begin match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + end + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + Parser.leaveBreadcrumb p Grammar.RecordDecl; + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + | attr::_ as attrs -> + let first = + let field = parseFieldDeclaration p in + Parser.optional p Comma |> ignore; + {field with + Parsetree.pld_attributes = attrs; + pld_loc = { + field.Parsetree.pld_loc with loc_start = + (attr |> fst).loc.loc_start + } + } + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + ) + in + let () = match fields with + | [] -> Parser.err ~startPos p ( + Diagnostics.message "A record needs at least one field" + ) + | _ -> () + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + (None, Asttypes.Public, Parsetree.Ptype_record fields) + end + +and parsePrivateEqOrRepr p = + Parser.expect Private p; + match p.Parser.token with + | Lbrace -> + let (manifest, _ ,kind) = parseRecordOrObjectDecl p in + (manifest, Asttypes.Private, kind) + | Uident _ -> + let (manifest, _, kind) = parseTypeEquationOrConstrDecl p in + (manifest, Asttypes.Private, kind) + | Bar | DotDot -> + let (_, kind) = parseTypeRepresentation p in + (None, Asttypes.Private, kind) + | t when Grammar.isTypExprStart t -> + (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) + | _ -> + let (_, kind) = parseTypeRepresentation p in + (None, Asttypes.Private, kind) + +(* + polymorphic-variant-type ::= + | [ tag-spec-first { | tag-spec } ] + | [> [ tag-spec ] { | tag-spec } ] + | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] + + tag-spec-first ::= `tag-name [ of typexpr ] + | [ typexpr ] | tag-spec + + tag-spec ::= `tag-name [ of typexpr ] + | typexpr + + tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] + | typexpr +*) +and parsePolymorphicVariantType ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Lbracket p; + match p.token with + | GreaterThan -> + Parser.next p; + let rowFields = + begin match p.token with + | Rbracket -> + [] + | Bar -> + parseTagSpecs p + | _ -> + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + end + in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc rowFields Open None in + Parser.expect Rbracket p; + variant + | LessThan -> + Parser.next p; + Parser.optional p Bar |> ignore; + let rowField = parseTagSpecFull p in + let rowFields = parseTagSpecFulls p in + let tagNames = + if p.token == GreaterThan + then begin + Parser.next p; + let rec loop p = match p.Parser.token with + | Rbracket -> [] + | _ -> + let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in + ident :: loop p + in + loop p + end + else [] in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in + Parser.expect Rbracket p; + variant + | _ -> + let rowFields1 = parseTagSpecFirst p in + let rowFields2 = parseTagSpecs p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None in + Parser.expect Rbracket p; + variant + +and parseTagSpecFulls p = + match p.Parser.token with + | Rbracket -> + [] + | GreaterThan -> + [] + | Bar -> + Parser.next p; + let rowField = parseTagSpecFull p in + rowField ::parseTagSpecFulls p + | _ -> + [] + +and parseTagSpecFull p = + let attrs = parseAttributes p in + match p.Parser.token with + | Hash -> + parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p + | _ -> + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ + +and parseTagSpecs p = + match p.Parser.token with + | Bar -> + Parser.next p; + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + | _ -> + [] + +and parseTagSpec p = + let attrs = parseAttributes p in + match p.Parser.token with + | Hash -> + parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p + | _ -> + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ + +and parseTagSpecFirst p = + let attrs = parseAttributes p in + match p.Parser.token with + | Bar -> + Parser.next p; + [parseTagSpec p] + | Hash -> + [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + | _ -> + let typ = parseTypExpr ~attrs p in + begin match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [Parsetree.Rinherit typ;] + | _ -> + Parser.expect Bar p; + [Parsetree.Rinherit typ; parseTagSpec p] + end + +and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = + let startPos = p.Parser.startPos in + let (ident, loc) = parseHashIdent ~startPos p in + let rec loop p = + match p.Parser.token with + | Band when full -> + Parser.next p; + let rowField = parsePolymorphicVariantTypeArgs p in + rowField :: loop p + | _ -> + [] + in + let firstTuple, tagContainsAConstantEmptyConstructor = + match p.Parser.token with + | Band when full -> + Parser.next p; + [parsePolymorphicVariantTypeArgs p], true + | Lparen -> + [parsePolymorphicVariantTypeArgs p], false + | _ -> + [], true + in + let tuples = firstTuple @ loop p in + Parsetree.Rtag ( + Location.mkloc ident loc, + attrs, + tagContainsAConstantEmptyConstructor, + tuples + ) + +and parsePolymorphicVariantTypeArgs p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + let attrs = [] in + let loc = mkLoc startPos p.prevEndPos in + match args with + | [{ptyp_desc = Ptyp_tuple _} as typ] as types -> + if p.mode = ParseForTypeChecker then + typ + else + Ast_helper.Typ.tuple ~loc ~attrs types + | [typ] -> typ + | types -> Ast_helper.Typ.tuple ~loc ~attrs types + +and parseTypeEquationAndRepresentation p = + match p.Parser.token with + | Equal | Bar as token -> + if token = Bar then Parser.expect Equal p; + Parser.next p; + begin match p.Parser.token with + | Uident _ -> + parseTypeEquationOrConstrDecl p + | Lbrace -> + parseRecordOrObjectDecl p + | Private -> + parsePrivateEqOrRepr p + | Bar | DotDot -> + let (priv, kind) = parseTypeRepresentation p in + (None, priv, kind) + | _ -> + let manifest = Some (parseTypExpr p) in + begin match p.Parser.token with + | Equal -> + Parser.next p; + let (priv, kind) = parseTypeRepresentation p in + (manifest, priv, kind) + | _ -> + (manifest, Public, Parsetree.Ptype_abstract) + end + end + | _ -> (None, Public, Parsetree.Ptype_abstract) + +(* type-definition ::= type [rec] typedef { and typedef } + * typedef ::= typeconstr-name [type-params] type-information + * type-information ::= [type-equation] [type-representation] { type-constraint } + * type-equation ::= = typexpr *) +and parseTypeDef ~attrs ~startPos p = + Parser.leaveBreadcrumb p Grammar.TypeDef; + (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) + Parser.leaveBreadcrumb p Grammar.TypeConstrName; + let (name, loc) = parseLident p in + let typeConstrName = Location.mkloc name loc in + Parser.eatBreadcrumb p; + let params = + let constrName = Location.mkloc (Longident.Lident name) loc in + parseTypeParams ~parent:constrName p in + let typeDef = + let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in + let cstrs = parseTypeConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.mk + ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest typeConstrName + in + Parser.eatBreadcrumb p; + typeDef + +and parseTypeExtension ~params ~attrs ~name p = + Parser.expect PlusEqual p; + let priv = + if Parser.optional p Token.Private + then Asttypes.Private + else Asttypes.Public + in + let constrStart = p.Parser.startPos in + Parser.optional p Bar |> ignore; + let first = + let (attrs, name, kind) = match p.Parser.token with + | Bar -> + Parser.next p; + parseConstrDef ~parseAttrs:true p + | _ -> + parseConstrDef ~parseAttrs:true p + in + let loc = mkLoc constrStart p.prevEndPos in + Ast_helper.Te.constructor ~loc ~attrs name kind + in + let rec loop p cs = + match p.Parser.token with + | Bar -> + let startPos = p.Parser.startPos in + Parser.next p; + let (attrs, name, kind) = parseConstrDef ~parseAttrs:true p in + let extConstr = + Ast_helper.Te.constructor ~attrs ~loc:(mkLoc startPos p.prevEndPos) name kind + in + loop p (extConstr::cs) + | _ -> + List.rev cs + in + let constructors = loop p [first] in + Ast_helper.Te.mk ~attrs ~params ~priv name constructors + +and parseTypeDefinitions ~attrs ~name ~params ~startPos p = + let typeDef = + let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in + let cstrs = parseTypeConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.mk + ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + {name with txt = lidentOfPath name.Location.txt} + in + let rec loop p defs = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + let attrs = match p.token with + | Export -> + let exportLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + genTypeAttr::attrs + | _ -> attrs + in + let typeDef = parseTypeDef ~attrs ~startPos p in + loop p (typeDef::defs) + | _ -> + List.rev defs + in + loop p [typeDef] + +(* TODO: decide if we really want type extensions (eg. type x += Blue) + * It adds quite a bit of complexity that can be avoided, + * implemented for now. Needed to get a feel for the complexities of + * this territory of the grammar *) +and parseTypeDefinitionOrExtension ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Typ p; + let recFlag = match p.token with + | Rec -> Parser.next p; Asttypes.Recursive + | Lident "nonrec" -> + Parser.next p; + Asttypes.Nonrecursive + | _ -> Asttypes.Nonrecursive + in + let name = parseValuePath p in + let params = parseTypeParams ~parent:name p in + match p.Parser.token with + | PlusEqual -> + TypeExt(parseTypeExtension ~params ~attrs ~name p) + | _ -> + (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) + let () = match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p + (longident |> ErrorMessages.typeDeclarationNameLongident |> Diagnostics.message) + in + let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in + TypeDef {recFlag; types = typeDefs} + +(* external value-name : typexp = external-declaration *) +and parseExternalDef ~attrs ~startPos p = + Parser.leaveBreadcrumb p Grammar.External; + Parser.expect Token.External p; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Parser.expect ~grammar:(Grammar.TypeExpression) Colon p; + let typExpr = parseTypExpr p in + let equalStart = p.startPos in + let equalEnd = p.endPos in + Parser.expect Equal p; + let prim = match p.token with + | String s -> Parser.next p; [s] + | _ -> + Parser.err ~startPos:equalStart ~endPos:equalEnd p + (Diagnostics.message + ("An external requires the name of the JS value you're referring to, like \"" + ^ name.txt ^ "\".")); + [] + in + let loc = mkLoc startPos p.prevEndPos in + let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in + Parser.eatBreadcrumb p; + vb + +(* constr-def ::= + * | constr-decl + * | constr-name = constr + * + * constr-decl ::= constr-name constr-args + * constr-name ::= uident + * constr ::= path-uident *) +and parseConstrDef ~parseAttrs p = + let attrs = if parseAttrs then parseAttributes p else [] in + let name = match p.Parser.token with + | Uident name -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc name loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let kind = match p.Parser.token with + | Lparen -> + let (args, res) = parseConstrDeclArgs p in + Parsetree.Pext_decl (args, res) + | Equal -> + Parser.next p; + let longident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pext_rebind longident + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + | _ -> + Parsetree.Pext_decl (Pcstr_tuple [], None) + in + (attrs, name, kind) + +(* + * exception-definition ::= + * | exception constr-decl + * ∣ exception constr-name = constr + * + * constr-name ::= uident + * constr ::= long_uident *) +and parseExceptionDef ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Exception p; + let (_, name, kind) = parseConstrDef ~parseAttrs:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Te.constructor ~loc ~attrs name kind + +(* module structure on the file level *) +and parseImplementation p : Parsetree.structure = + parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion + [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] + +and parseNewlineOrSemicolonStructure p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isStructureItemStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive statements on a line must be separated by ';' or a newline") + | _ -> () + +and parseStructureItemRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Open -> + let openDescription = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.open_ ~loc openDescription) + | Let -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.value ~loc recFlag letBindings) + | Typ -> + Parser.beginRegion p; + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_ ~loc recFlag types) + | TypeExt(ext) -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_extension ~loc ext) + end + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.primitive ~loc externalDef) + | Import -> + let importDescr = parseJsImport ~startPos ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + let structureItem = JsFfi.toParsetree importDescr in + Some {structureItem with pstr_loc = loc} + | Exception -> + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.exception_ ~loc exceptionDef) + | Include -> + let includeStatement = parseIncludeStatement ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.include_ ~loc includeStatement) + | Export -> + let structureItem = parseJsExport ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some {structureItem with pstr_loc = loc} + | Module -> + Parser.beginRegion p; + let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some {structureItem with pstr_loc = loc} + | AtAt -> + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.attribute ~loc attr) + | PercentPercent -> + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.extension ~attrs ~loc extension) + | token when Grammar.isExprStart token -> + let prevEndPos = p.Parser.endPos in + let exp = parseExpr p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.checkProgress ~prevEndPos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p + | _ -> + begin match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> + Parser.err + ~startPos:attrLoc.loc_start + ~endPos:attrLoc.loc_end + p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + let expr = parseExpr p in + Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) + | _ -> + None + end + +and parseJsImport ~startPos ~attrs p = + Parser.expect Token.Import p; + let importSpec = match p.Parser.token with + | Token.Lident _ | Token.At -> + let decl = match parseJsFfiDeclaration p with + | Some decl -> decl + | None -> assert false + in + JsFfi.Default decl + | _ -> JsFfi.Spec(parseJsFfiDeclarations p) + in + let scope = parseJsFfiScope p in + let loc = mkLoc startPos p.prevEndPos in + JsFfi.importDescr ~attrs ~importSpec ~scope ~loc + +and parseJsExport ~attrs p = + let exportStart = p.Parser.startPos in + Parser.expect Token.Export p; + let exportLoc = mkLoc exportStart p.prevEndPos in + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + let attrs = genTypeAttr::attrs in + match p.Parser.token with + | Typ -> + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + Ast_helper.Str.type_ recFlag types + | TypeExt(ext) -> + Ast_helper.Str.type_extension ext + end + | (* Let *) _ -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + Ast_helper.Str.value recFlag letBindings + +and parseSignJsExport ~attrs p = + let exportStart = p.Parser.startPos in + Parser.expect Token.Export p; + let exportLoc = mkLoc exportStart p.prevEndPos in + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + let attrs = genTypeAttr::attrs in + match p.Parser.token with + | Typ -> + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.type_ recFlag types ~loc + | TypeExt(ext) -> + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.type_extension ext ~loc + end + | (* Let *) _ -> + let valueDesc = parseSignLetDesc ~attrs p in + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.value valueDesc ~loc + +and parseJsFfiScope p = + match p.Parser.token with + | Token.Lident "from" -> + Parser.next p; + begin match p.token with + | String s -> Parser.next p; JsFfi.Module s + | Uident _ | Lident _ -> + let value = parseIdentPath p in + JsFfi.Scope value + | _ -> JsFfi.Global + end + | _ -> JsFfi.Global + +and parseJsFfiDeclarations p = + Parser.expect Token.Lbrace p; + let decls = parseCommaDelimitedRegion + ~grammar:Grammar.JsFfiImport + ~closing:Rbrace + ~f:parseJsFfiDeclaration + p + in + Parser.expect Rbrace p; + decls + +and parseJsFfiDeclaration p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Lident _ -> + let (ident, _) = parseLident p in + let alias = match p.token with + | As -> + Parser.next p; + let (ident, _) = parseLident p in + ident + | _ -> + ident + in + Parser.expect Token.Colon p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (JsFfi.decl ~loc ~alias ~attrs ~name:ident ~typ) + | _ -> None + +(* include-statement ::= include module-expr *) +and parseIncludeStatement ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Include p; + let modExpr = parseModuleExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Incl.mk ~loc ~attrs modExpr + +and parseAtomicModuleExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Uident _ident -> + let longident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mod.ident ~loc:longident.loc longident + | Lbrace -> + Parser.next p; + let structure = Ast_helper.Mod.structure ( + parseDelimitedRegion + ~grammar:Grammar.Structure + ~closing:Rbrace + ~f:parseStructureItemRegion + p + ) in + Parser.expect Rbrace p; + let endPos = p.prevEndPos in + {structure with pmod_loc = mkLoc startPos endPos} + | Lparen -> + Parser.next p; + let modExpr = match p.token with + | Rparen -> + Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] + | _ -> + parseConstrainedModExpr p + in + Parser.expect Rparen p; + modExpr + | Lident "unpack" -> (* TODO: should this be made a keyword?? *) + Parser.next p; + Parser.expect Lparen p; + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let constraintExpr = Ast_helper.Exp.constraint_ + ~loc + expr packageType + in + Ast_helper.Mod.unpack ~loc constraintExpr + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.unpack ~loc expr + end + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleExpr() + +and parsePrimaryModExpr p = + let startPos = p.Parser.startPos in + let modExpr = parseAtomicModuleExpr p in + let rec loop p modExpr = + match p.Parser.token with + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + loop p (parseModuleApplication p modExpr) + | _ -> modExpr + in + let modExpr = loop p modExpr in + {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} + +(* + * functor-arg ::= + * | uident : modtype + * | _ : modtype + * | modtype --> "punning" for _ : modtype + * | attributes functor-arg + *) +and parseFunctorArg p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Uident ident -> + Parser.next p; + let uidentEndPos = p.prevEndPos in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let moduleType = parseModuleType p in + let loc = mkLoc startPos uidentEndPos in + let argName = Location.mkloc ident loc in + Some (attrs, argName, Some moduleType, startPos) + | Dot -> + Parser.next p; + let moduleType = + let moduleLongIdent = + parseModuleLongIdentTail ~lowercase:false p startPos (Longident.Lident ident) in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + | _ -> + let loc = mkLoc startPos uidentEndPos in + let modIdent = Location.mkloc (Longident.Lident ident) loc in + let moduleType = Ast_helper.Mty.ident ~loc modIdent in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + end + | Underscore -> + Parser.next p; + let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in + Parser.expect Colon p; + let moduleType = parseModuleType p in + Some (attrs, argName, Some moduleType, startPos) + | Lparen -> + Parser.next p; + Parser.expect Rparen p; + let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in + Some (attrs, argName, None, startPos) + | _ -> + None + +and parseFunctorArgs p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.FunctorArgs + ~closing:Rparen + ~f:parseFunctorArg + p + in + Parser.expect Rparen p; + match args with + | [] -> + [[], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos] + | args -> args + +and parseFunctorModuleExpr p = + let startPos = p.Parser.startPos in + let args = parseFunctorArgs p in + let returnType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType ~es6Arrow:false p) + | _ -> None + in + Parser.expect EqualGreater p; + let rhsModuleExpr = + let modExpr = parseModuleExpr p in + match returnType with + | Some modType -> + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) + modExpr modType + | None -> modExpr + in + let endPos = p.prevEndPos in + let modExpr = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mod.functor_ + ~loc:(mkLoc startPos endPos) + ~attrs + name moduleType acc + ) args rhsModuleExpr + in + {modExpr with pmod_loc = mkLoc startPos endPos} + +(* module-expr ::= + * | module-path + * ∣ { structure-items } + * ∣ functorArgs => module-expr + * ∣ module-expr(module-expr) + * ∣ ( module-expr ) + * ∣ ( module-expr : module-type ) + * | extension + * | attributes module-expr *) +and parseModuleExpr p = + let attrs = parseAttributes p in + let modExpr = if isEs6ArrowFunctor p then + parseFunctorModuleExpr p + else + parsePrimaryModExpr p + in + {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} + +and parseConstrainedModExpr p = + let modExpr = parseModuleExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let modType = parseModuleType p in + let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc modExpr modType + | _ -> modExpr + +and parseConstrainedModExprRegion p = + if Grammar.isModExprStart p.Parser.token then + Some (parseConstrainedModExpr p) + else + None + +and parseModuleApplication p modExpr = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ModExprList + ~closing:Rparen + ~f:parseConstrainedModExprRegion + p + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + [Ast_helper.Mod.structure ~loc []] + | args -> args + in + List.fold_left (fun modExpr arg -> + Ast_helper.Mod.apply + ~loc:(mkLoc modExpr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end) + modExpr arg + ) modExpr args + +and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + match p.Parser.token with + | Typ -> parseModuleTypeImpl ~attrs startPos p + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + let expr = parseTernaryExpr expr p in + Ast_helper.Str.eval ~attrs expr + | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p + +and parseModuleTypeImpl ~attrs startPos p = + Parser.expect Typ p; + let nameStart = p.Parser.startPos in + let name = match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | Uident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Equal p; + let moduleType = parseModuleType p in + let moduleTypeDeclaration = + Ast_helper.Mtd.mk + ~attrs + ~loc:(mkLoc nameStart p.prevEndPos) + ~typ:moduleType + name + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Str.modtype ~loc moduleTypeDeclaration + +(* definition ::= + ∣ module rec module-name : module-type = module-expr { and module-name + : module-type = module-expr } *) +and parseMaybeRecModuleBinding ~attrs ~startPos p = + match p.Parser.token with + | Token.Rec -> + Parser.next p; + Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) + | _ -> + Ast_helper.Str.module_ (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + +and parseModuleBinding ~attrs ~startPos p = + let name = match p.Parser.token with + | Uident ident -> + let startPos = p.Parser.startPos in + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mb.mk ~attrs ~loc name body + +and parseModuleBindingBody p = + (* TODO: make required with good error message when rec module binding *) + let returnModType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType p) + | _ -> None + in + Parser.expect Equal p; + let modExpr = parseModuleExpr p in + match returnModType with + | Some modType -> + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) + modExpr modType + | None -> modExpr + + +(* module-name : module-type = module-expr + * { and module-name : module-type = module-expr } *) +and parseModuleBindings ~attrs ~startPos p = + let rec loop p acc = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + ignore(Parser.optional p Module); (* over-parse for fault-tolerance *) + let modBinding = parseModuleBinding ~attrs ~startPos p in + loop p (modBinding::acc) + | _ -> List.rev acc + in + let first = parseModuleBinding ~attrs ~startPos p in + loop p [first] + +and parseAtomicModuleType p = + let startPos = p.Parser.startPos in + let moduleType = match p.Parser.token with + | Uident _ | Lident _ -> + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + | Lparen -> + Parser.next p; + let mty = parseModuleType p in + Parser.expect Rparen p; + {mty with pmty_loc = mkLoc startPos p.prevEndPos} + | Lbrace -> + Parser.next p; + let spec = + parseDelimitedRegion + ~grammar:Grammar.Signature + ~closing:Rbrace + ~f:parseSignatureItemRegion + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.signature ~loc spec + | Module -> (* TODO: check if this is still atomic when implementing first class modules*) + parseModuleTypeOf p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType() + in + let moduleTypeLoc = mkLoc startPos p.prevEndPos in + {moduleType with pmty_loc = moduleTypeLoc} + +and parseFunctorModuleType p = + let startPos = p.Parser.startPos in + let args = parseFunctorArgs p in + Parser.expect EqualGreater p; + let rhs = parseModuleType p in + let endPos = p.prevEndPos in + let modType = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mty.functor_ + ~loc:(mkLoc startPos endPos) + ~attrs + name moduleType acc + ) args rhs + in + {modType with pmty_loc = mkLoc startPos endPos} + +(* Module types are the module-level equivalent of type expressions: they + * specify the general shape and type properties of modules. + * + * module-type ::= + * | modtype-path + * | { signature } + * | ( module-type ) --> parenthesized module-type + * | functor-args => module-type --> functor + * | module-type => module-type --> functor + * | module type of module-expr + * | attributes module-type + * | module-type with-mod-constraints + * | extension + *) + and parseModuleType ?(es6Arrow=true) ?(with_=true) p = + let attrs = parseAttributes p in + let modty = if es6Arrow && isEs6ArrowFunctor p then + parseFunctorModuleType p + else + let modty = parseAtomicModuleType p in + match p.Parser.token with + | EqualGreater when es6Arrow == true -> + Parser.next p; + let rhs = parseModuleType ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + | _ -> modty + in + let moduleType = { modty with + pmty_attributes = List.concat [modty.pmty_attributes; attrs] + } in + if with_ then + parseWithConstraints moduleType p + else moduleType + + +and parseWithConstraints moduleType p = + match p.Parser.token with + | Lident "with" -> + Parser.next p; + let first = parseWithConstraint p in + let rec loop p acc = + match p.Parser.token with + | And -> + Parser.next p; + loop p ((parseWithConstraint p)::acc) + | _ -> + List.rev acc + in + let constraints = loop p [first] in + let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.with_ ~loc moduleType constraints + | _ -> + moduleType + +(* mod-constraint ::= + * | type typeconstr type-equation type-constraints? + * ∣ type typeconstr-name := typexpr + * ∣ module module-path = extended-module-path + * ∣ module module-path := extended-module-path + * + * TODO: split this up into multiple functions, better errors *) +and parseWithConstraint p = + match p.Parser.token with + | Module -> + Parser.next p; + let modulePath = parseModuleLongIdent ~lowercase:false p in + begin match p.Parser.token with + | ColonEqual -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_module (modulePath, lident) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + end + | Typ -> + Parser.next p; + let typeConstr = parseValuePath p in + let params = parseTypeParams ~parent:typeConstr p in + begin match p.Parser.token with + | ColonEqual -> + Parser.next p; + let typExpr = parseTypExpr p in + Parsetree.Pwith_typesubst ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | Equal -> + Parser.next p; + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + end + | token -> + (* TODO: implement recovery strategy *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parsetree.Pwith_type ( + (Location.mknoloc (Longident.Lident "")), + Ast_helper.Type.mk + ~params:[] + ~manifest:(Recover.defaultType ()) + ~cstrs:[] + (Location.mknoloc "") + ) + +and parseModuleTypeOf p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + Parser.expect Typ p; + Parser.expect Of p; + let moduleExpr = parseModuleExpr p in + Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr + +(* module signature on the file level *) +and parseSpecification p = + parseRegion ~grammar:Grammar.Specification ~f:parseSignatureItemRegion p + [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] + +and parseNewlineOrSemicolonSignature p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isSignatureItemStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive specifications on a line must be separated by ';' or a newline") + | _ -> () + +and parseSignatureItemRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Let -> + Parser.beginRegion p; + let valueDesc = parseSignLetDesc ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.value ~loc valueDesc) + | Typ -> + Parser.beginRegion p; + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_ ~loc recFlag types) + | TypeExt(ext) -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_extension ~loc ext) + end + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.value ~loc externalDef) + | Export -> + let signatureItem = parseSignJsExport ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some {signatureItem with psig_loc = loc} + | Exception -> + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.exception_ ~loc exceptionDef) + | Open -> + let openDescription = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.open_ ~loc openDescription) + | Include -> + Parser.next p; + let moduleType = parseModuleType p in + let includeDescription = Ast_helper.Incl.mk + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs + moduleType + in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.include_ ~loc includeDescription) + | Module -> + Parser.beginRegion p; + Parser.next p; + begin match p.Parser.token with + | Uident _ -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + | Rec -> + let recModule = parseRecModuleSpec ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.rec_module ~loc recModule) + | Typ -> + let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in + Parser.endRegion p; + Some modTypeDecl + | _t -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + end + | AtAt -> + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.attribute ~loc attr) + | PercentPercent -> + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.extension ~attrs ~loc extension) + | Import -> + Parser.next p; + parseSignatureItemRegion p + | _ -> + begin match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> + Parser.err + ~startPos:attrLoc.loc_start + ~endPos:attrLoc.loc_end + p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Some Recover.defaultSignatureItem + | _ -> + None + end + +(* module rec module-name : module-type { and module-name: module-type } *) +and parseRecModuleSpec ~attrs ~startPos p = + Parser.expect Rec p; + let rec loop p spec = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + (* TODO: give a good error message when with constraint, no parens + * and ASet: (Set.S with type elt = A.t) + * and BTree: (Btree.S with type elt = A.t) + * Without parens, the `and` signals the start of another + * `with-constraint` + *) + Parser.expect And p; + let decl = parseRecModuleDeclaration ~attrs ~startPos p in + loop p (decl::spec) + | _ -> + List.rev spec + in + let first = parseRecModuleDeclaration ~attrs ~startPos p in + loop p [first] + +(* module-name : module-type *) +and parseRecModuleDeclaration ~attrs ~startPos p = + let name = match p.Parser.token with + | Uident modName -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc modName loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Colon p; + let modType = parseModuleType p in + Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType + +and parseModuleDeclarationOrAlias ~attrs p = + let startPos = p.Parser.startPos in + let moduleName = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.Parser.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = match p.Parser.token with + | Colon -> + Parser.next p; + parseModuleType p + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mty.alias lident + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType() + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Md.mk ~loc ~attrs moduleName body + +and parseModuleTypeDeclaration ~attrs ~startPos p = + Parser.expect Typ p; + let moduleName = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | Lident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let typ = match p.Parser.token with + | Equal -> + Parser.next p; + Some (parseModuleType p) + | _ -> None + in + let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in + Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl + +and parseSignLetDesc ~attrs p = + let startPos = p.Parser.startPos in + Parser.optional p Let |> ignore; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Parser.expect Colon p; + let typExpr = parsePolyTypeExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Val.mk ~loc ~attrs name typExpr + +(* attr-id ::= lowercase-ident +∣ capitalized-ident +∣ attr-id . attr-id *) +and parseAttributeId ~startPos p = + let rec loop p acc = + match p.Parser.token with + | Lident ident | Uident ident -> + Parser.next p; + let id = acc ^ ident in + begin match p.Parser.token with + | Dot -> Parser.next p; loop p (id ^ ".") + | _ -> id + end + | token when Token.isKeyword token -> + Parser.next p; + let id = acc ^ (Token.toString token) in + begin match p.Parser.token with + | Dot -> Parser.next p; loop p (id ^ ".") + | _ -> id + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + acc + in + let id = loop p "" in + let endPos = p.prevEndPos in + Location.mkloc id (mkLoc startPos endPos) + +(* + * payload ::= empty + * | ( structure-item ) + * + * TODO: what about multiple structure items? + * @attr({let x = 1; let x = 2}) + * + * Also what about type-expressions and specifications? + * @attr(:myType) ??? + *) +and parsePayload p = + match p.Parser.token with + | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> + Parser.leaveBreadcrumb p Grammar.AttributePayload; + Parser.next p; + begin match p.token with + | Colon -> + Parser.next p; + let payload = if Grammar.isSignatureItemStart p.token then + Parsetree.PSig ( + parseDelimitedRegion + ~grammar:Grammar.Signature + ~closing:Rparen + ~f:parseSignatureItemRegion + p + ) + else + Parsetree.PTyp (parseTypExpr p) + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + payload + | Question -> + Parser.next p; + let pattern = parsePattern p in + let expr = match p.token with + | When | If -> + Parser.next p; + Some (parseExpr p) + | _ -> + None + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PPat (pattern, expr) + | _ -> + let items = parseDelimitedRegion + ~grammar:Grammar.Structure + ~closing:Rparen + ~f:parseStructureItemRegion + p + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PStr items + end + | _ -> Parsetree.PStr [] + +(* type attribute = string loc * payload *) +and parseAttribute p = + match p.Parser.token with + | At -> + let startPos = p.startPos in + Parser.next p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + Some(attrId, payload) + | _ -> None + +and parseAttributes p = + parseRegion p + ~grammar:Grammar.Attribute + ~f:parseAttribute + +(* + * standalone-attribute ::= + * | @@ atribute-id + * | @@ attribute-id ( structure-item ) + *) +and parseStandaloneAttribute p = + let startPos = p.startPos in + Parser.expect AtAt p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + (attrId, payload) + +(* extension ::= % attr-id attr-payload + * | %% attr-id( + * expr ::= ... + * ∣ extension + * + * typexpr ::= ... + * ∣ extension + * + * pattern ::= ... + * ∣ extension + * + * module-expr ::= ... + * ∣ extension + * + * module-type ::= ... + * ∣ extension + * + * class-expr ::= ... + * ∣ extension + * + * class-type ::= ... + * ∣ extension + * + * + * item extension nodes usable in structures and signature + * + * item-extension ::= %% attr-id + * | %% attr-id(structure-item) + * + * attr-payload ::= structure-item + * + * ~moduleLanguage represents whether we're on the module level or not + *) +and parseExtension ?(moduleLanguage=false) p = + let startPos = p.Parser.startPos in + if moduleLanguage then + Parser.expect PercentPercent p + else + Parser.expect Percent p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + (attrId, payload) diff --git a/analysis/src/vendor/res_outcome_printer/res_core.mli b/analysis/src/vendor/res_outcome_printer/res_core.mli new file mode 100644 index 000000000..760881cd6 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_core.mli @@ -0,0 +1,4 @@ +val parseImplementation: + Res_parser.t -> Parsetree.structure +val parseSpecification: + Res_parser.t -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml b/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml new file mode 100644 index 000000000..843d3e428 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml @@ -0,0 +1,182 @@ +module Grammar = Res_grammar +module Token = Res_token + +type category = + | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} + | Expected of {context: Grammar.t option; pos: Lexing.position (* prev token end*); token: Token.t} + | Message of string + | Uident of Token.t + | Lident of Token.t + | UnclosedString + | UnclosedTemplate + | UnclosedComment + | UnknownUchar of Char.t + +type t = { + startPos: Lexing.position; + endPos: Lexing.position; + category: category; +} + +type report = t list + +let getStartPos t = t.startPos +let getEndPos t = t.endPos + +let defaultUnexpected token = + "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"." + +let reservedKeyword token = + let tokenTxt = Token.toString token in + "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + +let explain t = + match t.category with + | Uident currentToken -> + begin match currentToken with + | Lident lident -> + let guess = String.capitalize_ascii lident in + "Did you mean `" ^ guess ^"` instead of `" ^ lident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword." + | _ -> + "At this point, I'm looking for an uppercased name like `Belt` or `Array`" + end + | Lident currentToken -> + begin match currentToken with + | Uident uident -> + let guess = String.uncapitalize_ascii uident in + "Did you mean `" ^ guess ^"` instead of `" ^ uident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\"" + | Underscore -> + "`_` isn't a valid name." + | _ -> + "I'm expecting a lowercase name like `user or `age`" + end + | Message txt -> txt + | UnclosedString -> + "This string is missing a double quote at the end" + | UnclosedTemplate -> + "Did you forget to close this template expression with a backtick?" + | UnclosedComment -> + "This comment seems to be missing a closing `*/`" + | UnknownUchar uchar -> + begin match uchar with + | '^' -> + "Not sure what to do with this character.\n" ^ + " If you're trying to dereference a mutable value, use `myValue.contents` instead.\n" ^ + " To concatenate strings, use `\"a\" ++ \"b\"` instead." + | _ -> + "Not sure what to do with this character." + end + | Expected {context; token = t} -> + let hint = match context with + | Some grammar -> " It signals the start of " ^ (Grammar.toString grammar) + | None -> "" + in + "Did you forget a `" ^ (Token.toString t) ^ "` here?" ^ hint + | Unexpected {token = t; context = breadcrumbs} -> + let name = (Token.toString t) in + begin match breadcrumbs with + | (AtomicTypExpr, _)::breadcrumbs -> + begin match breadcrumbs, t with + | ((StringFieldDeclarations | FieldDeclarations) , _) :: _, (String _ | At | Rbrace | Comma | Eof) -> + "I'm missing a type here" + | _, t when Grammar.isStructureItemStart t || t = Eof -> + "Missing a type here" + | _ -> + defaultUnexpected t + end + | (ExprOperand, _)::breadcrumbs -> + begin match breadcrumbs, t with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) ::_, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _)::_, _ -> + "This let-binding misses an expression" + | _::_, (Rbracket | Rbrace | Eof) -> + "Missing expression" + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + | (TypeParam, _)::_ -> + begin match t with + | Lident ident -> + "Did you mean '" ^ ident ^"? A Type parameter starts with a quote." + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + | (Pattern, _)::breadcrumbs -> + begin match t, breadcrumbs with + | (Equal, (LetBinding,_)::_) -> + "I was expecting a name for this let-binding. Example: `let message = \"hello\"`" + | (In, (ExprFor,_)::_) -> + "A for-loop has the following form: `for i in 0 to 10`. Did you forget to supply a name before `in`?" + | (EqualGreater, (PatternMatchCase,_)::_) -> + "I was expecting a pattern to match on before the `=>`" + | (token, _) when Token.isKeyword t -> + reservedKeyword token + | (token, _) -> + defaultUnexpected token + end + | _ -> + (* TODO: match on circumstance to verify Lident needed ? *) + if Token.isKeyword t then + "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ (Token.toString t) ^ "\"" + else + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + +let make ~startPos ~endPos category = { + startPos; + endPos; + category +} + +let printReport diagnostics src = + let rec print diagnostics src = + match diagnostics with + | [] -> () + | d::rest -> + Res_diagnostics_printing_utils.Super_location.super_error_reporter + Format.err_formatter + src + Location.{ + loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; + msg = explain d; + sub = []; + if_highlight = ""; + }; + begin match rest with + | [] -> () + | _ -> Format.fprintf Format.err_formatter "@." + end; + print rest src + in + Format.fprintf Format.err_formatter "@["; + print (List.rev diagnostics) src; + Format.fprintf Format.err_formatter "@]@." + +let unexpected token context = + Unexpected {token; context} + +let expected ?grammar pos token = + Expected {context = grammar; pos; token} + +let uident currentToken = Uident currentToken +let lident currentToken = Lident currentToken +let unclosedString = UnclosedString +let unclosedComment = UnclosedComment +let unclosedTemplate = UnclosedTemplate +let unknownUchar code = UnknownUchar code +let message txt = Message txt diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli b/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli new file mode 100644 index 000000000..7855a984f --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli @@ -0,0 +1,29 @@ +module Token = Res_token +module Grammar = Res_grammar + +type t +type category +type report + +val getStartPos: t -> Lexing.position [@@live] (* for playground *) +val getEndPos: t -> Lexing.position [@@live] (* for playground *) + +val explain: t -> string [@@live] (* for playground *) + +val unexpected: Token.t -> (Grammar.t * Lexing.position) list -> category +val expected: ?grammar:Grammar.t -> Lexing.position -> Token.t -> category +val uident: Token.t -> category +val lident: Token.t -> category +val unclosedString: category +val unclosedTemplate: category +val unclosedComment: category +val unknownUchar: Char.t -> category +val message: string -> category + +val make: + startPos: Lexing.position + -> endPos: Lexing.position + -> category + -> t + +val printReport: t list -> string -> unit diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml b/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml new file mode 100644 index 000000000..758478a43 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml @@ -0,0 +1,373 @@ +(* + 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 begin + 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; + end + 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 -> begin + 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'; + ); + end + ); + 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) = + begin match message_kind with + | `warning -> fprintf ppf "@[@{%s@}@]@," intro + | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro + | `error -> fprintf ppf "@[@{%s@}@]@," intro + end; + (* 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 _ -> begin + 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 _ -> () + end +;; + +(* 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/src/vendor/res_outcome_printer/res_driver.ml b/analysis/src/vendor/res_outcome_printer/res_driver.ml new file mode 100644 index 000000000..d827880ac --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver.ml @@ -0,0 +1,109 @@ +module IO = Res_io + +type ('ast, 'diagnostics) parseResult = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list +} + +type ('diagnostics) parsingEngine = { + parseImplementation: + forPrinter:bool -> filename:string + -> (Parsetree.structure, 'diagnostics) parseResult; + parseInterface: + forPrinter:bool -> filename:string + -> (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit +} + +type printEngine = { + printImplementation: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.structure + -> unit; + printInterface: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.signature + -> unit; +} + +let setup ~filename ~forPrinter () = + let src = IO.readFile ~filename in + let mode = if forPrinter then Res_parser.Default + else ParseForTypeChecker + in + Res_parser.make ~mode src filename + +let parsingEngine = { + parseImplementation = begin fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let structure = Res_core.parseImplementation engine in + let (invalid, diagnostics) = match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + end; + parseInterface = begin fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let signature = Res_core.parseSpecification engine in + let (invalid, diagnostics) = match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + end; + stringOfDiagnostics = begin fun ~source ~filename:_ diagnostics -> + Res_diagnostics.printReport diagnostics source + end; +} + +let printEngine = { + printImplementation = begin fun ~width ~filename:_ ~comments structure -> + print_string (Res_printer.printImplementation ~width structure ~comments) + end; + printInterface = begin fun ~width ~filename:_ ~comments signature -> + print_string (Res_printer.printInterface ~width signature ~comments) + end; +} + +let parse_implementation sourcefile = + Location.input_name := sourcefile; + let parseResult = + parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile + in + if parseResult.invalid then begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end; + parseResult.parsetree +[@@raises exit] + +let parse_interface sourcefile = + Location.input_name := sourcefile; + let parseResult = parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile in + if parseResult.invalid then begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end; + parseResult.parsetree +[@@raises exit] diff --git a/analysis/src/vendor/res_outcome_printer/res_driver.mli b/analysis/src/vendor/res_outcome_printer/res_driver.mli new file mode 100644 index 000000000..0facc0a52 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver.mli @@ -0,0 +1,49 @@ +type ('ast, 'diagnostics) parseResult = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list +} + +type ('diagnostics) parsingEngine = { + parseImplementation: + forPrinter:bool -> filename:string + -> (Parsetree.structure, 'diagnostics) parseResult; + parseInterface: + forPrinter:bool -> filename:string + -> (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit +} + +type printEngine = { + printImplementation: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.structure + -> unit; + printInterface: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.signature + -> unit; +} + +val parsingEngine: (Res_diagnostics.t list) parsingEngine + +val printEngine: printEngine + +(* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) +val parse_implementation: + string -> Parsetree.structure +[@@live] +[@@raises Location.Error] + +(* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) +val parse_interface: + string -> Parsetree.signature +[@@live] +[@@raises Location.Error] diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml b/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml new file mode 100644 index 000000000..408515578 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml @@ -0,0 +1,12 @@ +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename ~comments:_ structure -> + output_string stdout Config.ast_impl_magic_number; + output_value stdout filename; + output_value stdout structure + end; + printInterface = begin fun ~width:_ ~filename ~comments:_ signature -> + output_string stdout Config.ast_intf_magic_number; + output_value stdout filename; + output_value stdout signature + end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli b/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli new file mode 100644 index 000000000..7991ba8db --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli @@ -0,0 +1 @@ +val printEngine : Res_driver.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml new file mode 100644 index 000000000..221a31c5d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml @@ -0,0 +1,92 @@ +module OcamlParser = Parser +module IO = Res_io + +let setup ~filename = + if String.length filename > 0 then ( + Location.input_name := filename; + IO.readFile ~filename |> Lexing.from_string + ) else + Lexing.from_channel stdin + +let extractOcamlConcreteSyntax filename = + let lexbuf = if String.length filename > 0 then + IO.readFile ~filename |> Lexing.from_string + else + Lexing.from_channel stdin + in + let stringLocs = ref [] in + let commentData = ref [] in + let rec next (prevTokEndPos : Lexing.position) () = + let token = Lexer.token_with_comments lexbuf in + match token with + | OcamlParser.COMMENT (txt, loc) -> + let comment = Res_comment.fromOcamlComment + ~loc + ~prevTokEndPos + ~txt + in + commentData := comment::(!commentData); + next loc.Location.loc_end () + | OcamlParser.STRING (_txt, None) -> + let open Location in + let loc = { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.Lexing.lex_curr_p; + loc_ghost = false; + } in + let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let txt = Bytes.to_string ( + (Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len + ) in + stringLocs := (txt, loc)::(!stringLocs); + next lexbuf.Lexing.lex_curr_p () + | OcamlParser.EOF -> () + | _ -> next lexbuf.Lexing.lex_curr_p () + in + next lexbuf.Lexing.lex_start_p (); + (List.rev !stringLocs, List.rev !commentData) + +let parsingEngine = { + Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in + let structure = + Parse.implementation lexbuf + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.structure + in { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = structure; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + parseInterface = begin fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in + let signature = + Parse.interface lexbuf + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.signature + in { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = signature; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; +} + +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> + Pprintast.structure Format.std_formatter structure + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> + Pprintast.signature Format.std_formatter signature + end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli new file mode 100644 index 000000000..4743e229a --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli @@ -0,0 +1,9 @@ +(* This module represents a general interface to parse marshalled reason ast *) + +(* extracts comments and the original string data from an ocaml file *) +val extractOcamlConcreteSyntax : + string -> (string * Location.t) list * Res_comment.t list [@@live] + +val parsingEngine : unit Res_driver.parsingEngine + +val printEngine : Res_driver.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml new file mode 100644 index 000000000..ad1beac74 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml @@ -0,0 +1,103 @@ +module IO = Res_io + +let isReasonDocComment (comment: Res_comment.t) = + let content = Res_comment.txt comment in + let len = String.length content in + if len = 0 then true + else if len >= 2 && (String.unsafe_get content 0 = '*' && String.unsafe_get content 1 = '*') then false + else if len >= 1 && (String.unsafe_get content 0 = '*') then true + else false + +let extractConcreteSyntax filename = + let commentData = ref [] in + let stringData = ref [] in + let src = IO.readFile ~filename in + let scanner = Res_scanner.make src ~filename in + + let rec next prevEndPos scanner = + let (startPos, endPos, token) = Res_scanner.scan scanner in + match token with + | Eof -> () + | Comment c -> + Res_comment.setPrevTokEndPos c prevEndPos; + commentData := c::(!commentData); + next endPos scanner + | String _ -> + let loc = {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} in + let len = endPos.pos_cnum - startPos.pos_cnum in + let txt = (String.sub [@doesNotRaise]) src startPos.pos_cnum len in + stringData := (txt, loc)::(!stringData); + next endPos scanner; + | Lbrace -> + (* handle {| |} or {sql||sql} quoted strings. We don't care about its contents. + Why? // abcdef inside the quoted string would otherwise be picked up as an extra comment *) + Res_scanner.tryAdvanceQuotedString scanner; + next endPos scanner + | _ -> + next endPos scanner + in + next Lexing.dummy_pos scanner; + let comments = + !commentData + |> List.filter (fun c -> not (isReasonDocComment c)) + |> List.rev + in + (comments, !stringData) + +let parsingEngine = { + Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> + let (chan, close) = if (String.length filename) == 0 then + (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + file_chan, close_in_noerr + in + let magic = Config.ast_impl_magic_number in + ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in + let ast = input_value chan in + close chan; + let structure = ast + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.normalizeReasonArityStructure ~forPrinter:true + |> Res_ast_conversion.structure + in { + Res_driver.filename = filename; + source = ""; + parsetree = structure; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + parseInterface = begin fun ~forPrinter:_ ~filename -> + let (chan, close) = if String.length filename == 0 then + (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + file_chan, close_in_noerr + in + let magic = Config.ast_intf_magic_number in + ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in + let ast = input_value chan in + close chan; + let signature = ast + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.normalizeReasonAritySignature ~forPrinter:true + |> Res_ast_conversion.signature + in { + Res_driver.filename; + source = ""; + parsetree = signature; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli new file mode 100644 index 000000000..dce2d65ad --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli @@ -0,0 +1,7 @@ +(* This module represents a general interface to parse marshalled reason ast *) + +(* extracts comments and the original string data from a reason file *) +val extractConcreteSyntax : + string -> Res_token.Comment.t list * (string * Location.t) list + +val parsingEngine : unit Res_driver.parsingEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_grammar.ml b/analysis/src/vendor/res_outcome_printer/res_grammar.ml new file mode 100644 index 000000000..394bdd960 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_grammar.ml @@ -0,0 +1,368 @@ +module Token = Res_token + +type t = + | OpenDescription (* open Belt *) + | ModuleLongIdent (* Foo or Foo.Bar *) [@live] + | Ternary (* condExpr ? trueExpr : falseExpr *) + | Es6ArrowExpr + | Jsx + | JsxAttribute + | JsxChild [@live] + | ExprOperand + | ExprUnary + | ExprSetField + | ExprBinaryAfterOp of Token.t + | ExprBlock + | ExprCall + | ExprList + | ExprArrayAccess + | ExprArrayMutation + | ExprIf + | ExprFor + | IfCondition | IfBranch | ElseBranch + | TypeExpression + | External + | PatternMatching + | PatternMatchCase + | LetBinding + | PatternList + | PatternOcamlList + | PatternRecord + + | TypeDef + | TypeConstrName + | TypeParams + | TypeParam [@live] + | PackageConstraint + | TypeRepresentation + | RecordDecl + | ConstructorDeclaration + | ParameterList + | StringFieldDeclarations + | FieldDeclarations + | TypExprList + | FunctorArgs + | ModExprList + | TypeParameters + | RecordRows + | RecordRowsStringKey + | ArgumentList + | Signature + | Specification + | Structure + | Implementation + | Attribute + | TypeConstraint + | AtomicTypExpr + | ListExpr + | JsFfiImport + | Pattern + | AttributePayload + +let toString = function + | OpenDescription -> "an open description" + | ModuleLongIdent -> "a module path" + | Ternary -> "a ternary expression" + | Es6ArrowExpr -> "an es6 arrow function" + | Jsx -> "a jsx expression" + | JsxAttribute -> "a jsx attribute" + | ExprOperand -> "a basic expression" + | ExprUnary -> "a unary expression" + | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op ^ "\"" + | ExprIf -> "an if expression" + | IfCondition -> "the condition of an if expression" + | IfBranch -> "the true-branch of an if expression" + | ElseBranch -> "the else-branch of an if expression" + | TypeExpression -> "a type" + | External -> "an external" + | PatternMatching -> "the cases of a pattern match" + | ExprBlock -> "a block with expressions" + | ExprSetField -> "a record field mutation" + | ExprCall -> "a function application" + | ExprArrayAccess -> "an array access expression" + | ExprArrayMutation -> "an array mutation" + | LetBinding -> "a let binding" + | TypeDef -> "a type definition" + | TypeParams -> "type parameters" + | TypeParam -> "a type parameter" + | TypeConstrName -> "a type-constructor name" + | TypeRepresentation -> "a type representation" + | RecordDecl -> "a record declaration" + | PatternMatchCase -> "a pattern match case" + | ConstructorDeclaration -> "a constructor declaration" + | ExprList -> "multiple expressions" + | PatternList -> "multiple patterns" + | PatternOcamlList -> "a list pattern" + | PatternRecord -> "a record pattern" + | ParameterList -> "parameters" + | StringFieldDeclarations -> "string field declarations" + | FieldDeclarations -> "field declarations" + | TypExprList -> "list of types" + | FunctorArgs -> "functor arguments" + | ModExprList -> "list of module expressions" + | TypeParameters -> "list of type parameters" + | RecordRows -> "rows of a record" + | RecordRowsStringKey -> "rows of a record with string keys" + | ArgumentList -> "arguments" + | Signature -> "signature" + | Specification -> "specification" + | Structure -> "structure" + | Implementation -> "implementation" + | Attribute -> "an attribute" + | TypeConstraint -> "constraints on a type" + | AtomicTypExpr -> "a type" + | ListExpr -> "an ocaml list expr" + | PackageConstraint -> "a package constraint" + | JsFfiImport -> "js ffi import" + | JsxChild -> "jsx child" + | Pattern -> "pattern" + | ExprFor -> "a for expression" + | AttributePayload -> "an attribute payload" + +let isSignatureItemStart = function + | Token.At + | Let + | Typ + | External + | Exception + | Open + | Include + | Module + | AtAt + | Export + | PercentPercent -> true + | _ -> false + +let isAtomicPatternStart = function + | Token.Int _ | String _ | Character _ | Backtick + | Lparen | Lbracket | Lbrace + | Underscore + | Lident _ | Uident _ | List + | Exception | Lazy + | Percent -> true + | _ -> false + +let isAtomicExprStart = function + | Token.True | False + | Int _ | String _ | Float _ | Character _ + | Backtick + | Uident _ | Lident _ | Hash + | Lparen + | List + | Lbracket + | Lbrace + | LessThan + | Module + | Percent -> true + | _ -> false + +let isAtomicTypExprStart = function + | Token.SingleQuote | Underscore + | Lparen | Lbrace + | Uident _ | Lident _ + | Percent -> true + | _ -> false + +let isExprStart = function + | Token.True | False + | Int _ | String _ | Float _ | Character _ | Backtick + | Underscore (* _ => doThings() *) + | Uident _ | Lident _ | Hash + | Lparen | List | Module | Lbracket | Lbrace + | LessThan + | Minus | MinusDot | Plus | PlusDot | Bang + | Percent | At + | If | Switch | While | For | Assert | Lazy | Try -> true + | _ -> false + +let isJsxAttributeStart = function + | Token.Lident _ | Question -> true + | _ -> false + +let isStructureItemStart = function + | Token.Open + | Let + | Typ + | External | Import | Export + | Exception + | Include + | Module + | AtAt + | PercentPercent + | At -> true + | t when isExprStart t -> true + | _ -> false + +let isPatternStart = function + | Token.Int _ | Float _ | String _ | Character _ | Backtick | True | False | Minus | Plus + | Lparen | Lbracket | Lbrace | List + | Underscore + | Lident _ | Uident _ | Hash + | Exception | Lazy | Percent | Module + | At -> true + | _ -> false + +let isParameterStart = function + | Token.Typ | Tilde | Dot -> true + | token when isPatternStart token -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let isStringFieldDeclStart = function + | Token.String _ | Lident _ | At | DotDotDot -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let isFieldDeclStart = function + | Token.At | Mutable | Lident _ -> true + (* recovery, TODO: this is not ideal… *) + | Uident _ -> true + | t when Token.isKeyword t -> true + | _ -> false + +let isRecordDeclStart = function + | Token.At + | Mutable + | Lident _ -> true + | _ -> false + +let isTypExprStart = function + | Token.At + | SingleQuote + | Underscore + | Lparen | Lbracket + | Uident _ | Lident _ + | Module + | Percent + | Lbrace -> true + | _ -> false + +let isTypeParameterStart = function + | Token.Tilde | Dot -> true + | token when isTypExprStart token -> true + | _ -> false + +let isTypeParamStart = function + | Token.Plus | Minus | SingleQuote | Underscore -> true + | _ -> false + +let isFunctorArgStart = function + | Token.At | Uident _ | Underscore + | Percent + | Lbrace + | Lparen -> true + | _ -> false + +let isModExprStart = function + | Token.At | Percent + | Uident _ | Lbrace | Lparen + | Lident "unpack" -> true + | _ -> false + +let isRecordRowStart = function + | Token.DotDotDot -> true + | Token.Uident _ | Lident _ -> true + (* TODO *) + | t when Token.isKeyword t -> true + | _ -> false + +let isRecordRowStringKeyStart = function + | Token.String _ -> true + | _ -> false + +let isArgumentStart = function + | Token.Tilde | Dot | Underscore -> true + | t when isExprStart t -> true + | _ -> false + +let isPatternMatchStart = function + | Token.Bar -> true + | t when isPatternStart t -> true + | _ -> false + +let isPatternOcamlListStart = function + | Token.DotDotDot -> true + | t when isPatternStart t -> true + | _ -> false + +let isPatternRecordItemStart = function + | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true + | _ -> false + +let isAttributeStart = function + | Token.At -> true + | _ -> false + +let isJsFfiImportStart = function + | Token.Lident _ | At -> true + | _ -> false + +let isJsxChildStart = isAtomicExprStart + +let isBlockExprStart = function + | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang + | True | False | Float _ | Int _ | String _ | Character _ | Lident _ | Uident _ + | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert + | Lazy | If | For | While | Switch | Open | Module | Exception | Let + | LessThan | Backtick | Try | Underscore -> true + | _ -> false + +let isListElement grammar token = + match grammar with + | ExprList -> token = Token.DotDotDot || isExprStart token + | ListExpr -> token = DotDotDot || isExprStart token + | PatternList -> token = DotDotDot || isPatternStart token + | ParameterList -> isParameterStart token + | StringFieldDeclarations -> isStringFieldDeclStart token + | FieldDeclarations -> isFieldDeclStart token + | RecordDecl -> isRecordDeclStart token + | TypExprList -> isTypExprStart token || token = Token.LessThan + | TypeParams -> isTypeParamStart token + | FunctorArgs -> isFunctorArgStart token + | ModExprList -> isModExprStart token + | TypeParameters -> isTypeParameterStart token + | RecordRows -> isRecordRowStart token + | RecordRowsStringKey -> isRecordRowStringKeyStart token + | ArgumentList -> isArgumentStart token + | Signature | Specification -> isSignatureItemStart token + | Structure | Implementation -> isStructureItemStart token + | PatternMatching -> isPatternMatchStart token + | PatternOcamlList -> isPatternOcamlListStart token + | PatternRecord -> isPatternRecordItemStart token + | Attribute -> isAttributeStart token + | TypeConstraint -> token = Constraint + | PackageConstraint -> token = And + | ConstructorDeclaration -> token = Bar + | JsxAttribute -> isJsxAttributeStart token + | JsFfiImport -> isJsFfiImportStart token + | AttributePayload -> token = Lparen + | _ -> false + +let isListTerminator grammar token = + match grammar, token with + | _, Token.Eof + | ExprList, (Rparen | Forwardslash | Rbracket) + | ListExpr, Rparen + | ArgumentList, Rparen + | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) + | ModExprList, Rparen + | (PatternList | PatternOcamlList | PatternRecord), + (Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) | In (* for expressions *) | Equal (* let {x} = foo *)) + | ExprBlock, Rbrace + | (Structure | Signature), Rbrace + | TypeParams, Rparen + | ParameterList, (EqualGreater | Lbrace) + | JsxAttribute, (Forwardslash | GreaterThan) + | JsFfiImport, Rbrace + | StringFieldDeclarations, Rbrace -> true + + | Attribute, token when token <> At -> true + | TypeConstraint, token when token <> Constraint -> true + | PackageConstraint, token when token <> And -> true + | ConstructorDeclaration, token when token <> Bar -> true + | AttributePayload, Rparen -> true + + | _ -> false + +let isPartOfList grammar token = + isListElement grammar token || isListTerminator grammar token diff --git a/analysis/src/vendor/res_outcome_printer/res_io.ml b/analysis/src/vendor/res_outcome_printer/res_io.ml new file mode 100644 index 000000000..e5934b848 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_io.ml @@ -0,0 +1,14 @@ +let readFile ~filename = + let chan = open_in_bin filename in + let content = + try really_input_string chan (in_channel_length chan) + with End_of_file -> "" + in + close_in_noerr chan; + content + +let writeFile ~filename ~contents:txt = + let chan = open_out_bin filename in + output_string chan txt; + close_out chan +[@@raises Sys_error] diff --git a/analysis/src/vendor/res_outcome_printer/res_io.mli b/analysis/src/vendor/res_outcome_printer/res_io.mli new file mode 100644 index 000000000..6260c27c5 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_io.mli @@ -0,0 +1,7 @@ +(* utilities to read and write to/from files or stdin *) + +(* reads the contents of "filename" into a string *) +val readFile: filename: string -> string + +(* writes "content" into file with name "filename" *) +val writeFile: filename: string -> contents: string -> unit diff --git a/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml b/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml new file mode 100644 index 000000000..f8a082a19 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml @@ -0,0 +1,116 @@ +(* AST for js externals *) +type scope = + | Global + | Module of string (* bs.module("path") *) + | Scope of Longident.t (* bs.scope(/"window", "location"/) *) + +type label_declaration = { + jld_attributes: Parsetree.attributes; [@live] + jld_name: string; + jld_alias: string; + jld_type: Parsetree.core_type; + jld_loc: Location.t +} + +type importSpec = + | Default of label_declaration + | Spec of label_declaration list + +type import_description = { + jid_loc: Location.t; + jid_spec: importSpec; + jid_scope: scope; + jid_attributes: Parsetree.attributes; +} + +let decl ~attrs ~loc ~name ~alias ~typ = { + jld_loc = loc; + jld_attributes = attrs; + jld_name = name; + jld_alias = alias; + jld_type = typ +} + +let importDescr ~attrs ~scope ~importSpec ~loc = { + jid_loc = loc; + jid_spec = importSpec; + jid_scope = scope; + jid_attributes = attrs; +} + +let toParsetree importDescr = + let bsVal = (Location.mknoloc "val", Parsetree.PStr []) in + let attrs = match importDescr.jid_scope with + | Global -> [bsVal] + (* @genType.import("./MyMath"), + * @genType.import(/"./MyMath", "default"/) *) + | Module s -> + let structure = [ + Parsetree.Pconst_string (s, None) + |> Ast_helper.Exp.constant + |> Ast_helper.Str.eval + ] in + let genType = (Location.mknoloc "genType.import", Parsetree.PStr structure) in + [genType] + | Scope longident -> + let structureItem = + let expr = match Longident.flatten longident |> List.map (fun s -> + Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None)) + ) with + | [expr] -> expr + | [] as exprs | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple + in + Ast_helper.Str.eval expr + in + let bsScope = ( + Location.mknoloc "scope", + Parsetree. PStr [structureItem] + ) in + [bsVal; bsScope] + in + let valueDescrs = match importDescr.jid_spec with + | Default decl -> + let prim = [decl.jld_name] in + let allAttrs = + List.concat [attrs; importDescr.jid_attributes] + |> List.map (fun attr -> match attr with + | ( + {Location.txt = "genType.import"} as id, + Parsetree.PStr [{pstr_desc = Parsetree.Pstr_eval (moduleName, _) }] + ) -> + let default = + Parsetree.Pconst_string ("default", None) |> Ast_helper.Exp.constant + in + let structureItem = + [moduleName; default] + |> Ast_helper.Exp.tuple + |> Ast_helper.Str.eval + in + (id, Parsetree.PStr [structureItem]) + | attr -> attr + ) + in + [Ast_helper.Val.mk + ~loc:importDescr.jid_loc + ~prim + ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive] + | Spec decls -> + List.map (fun decl -> + let prim = [decl.jld_name] in + let allAttrs = List.concat [attrs; decl.jld_attributes] in + Ast_helper.Val.mk + ~loc:importDescr.jid_loc + ~prim + ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive ~loc:decl.jld_loc + ) decls + in + let jsFfiAttr = (Location.mknoloc "ns.jsFfi", Parsetree.PStr []) in + Ast_helper.Mod.structure ~loc:importDescr.jid_loc valueDescrs + |> Ast_helper.Incl.mk ~attrs:[jsFfiAttr] ~loc:importDescr.jid_loc + |> Ast_helper.Str.include_ ~loc:importDescr.jid_loc diff --git a/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml b/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml new file mode 100644 index 000000000..cfcf19427 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml @@ -0,0 +1,128 @@ +module IO = Res_io + +let defaultPrintWidth = 100 + +(* print res files to res syntax *) +let printRes ~isInterface ~filename = + if isInterface then + let parseResult = + Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename + in + if parseResult.invalid then + begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end + else + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename + in + if parseResult.invalid then + begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end + else + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree +[@@raises exit] + +(* print ocaml files to res syntax *) +let printMl ~isInterface ~filename = + if isInterface then + let parseResult = + Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true ~filename in + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true ~filename in + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + +(* How does printing Reason to Res work? + * -> open a tempfile + * -> write the source code found in "filename" into the tempfile + * -> run refmt in-place in binary mode on the tempfile, + * mutates contents tempfile with marshalled AST.j + * -> read the marshalled ast (from the binary output in the tempfile) + * -> re-read the original "filename" and extract string + comment data + * -> put the comment- and string data back into the unmarshalled parsetree + * -> pretty print to res + * -> take a deep breath and exhale slowly *) +let printReason ~refmtPath ~isInterface ~filename = + (* open a tempfile *) + let (tempFilename, chan) = + (* refmt is just a prefix, `open_temp_file` takes care of providing a random name + * It tries 1000 times in the case of a name conflict. + * In practise this means that we shouldn't worry too much about filesystem races *) + Filename.open_temp_file "refmt" (if isInterface then ".rei" else ".re") in + close_out chan; + (* Write the source code found in "filename" into the tempfile *) + IO.writeFile ~filename:tempFilename ~contents:(IO.readFile ~filename); + let cmd = Printf.sprintf "%s --print=binary --in-place --interface=%b %s" refmtPath isInterface tempFilename in + (* run refmt in-place in binary mode on the tempfile *) + ignore (Sys.command cmd); + let result = + if isInterface then + let parseResult = + (* read the marshalled ast (from the binary output in the tempfile) *) + Res_driver_reason_binary.parsingEngine.parseInterface ~forPrinter:true ~filename:tempFilename in + (* re-read the original "filename" and extract string + comment data *) + let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in + (* put the comment- and string data back into the unmarshalled parsetree *) + let parseResult = { + parseResult with + parsetree = + parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralSignature stringData; + comments = comments; + } in + (* pretty print to res *) + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + (* read the marshalled ast (from the binary output in the tempfile) *) + Res_driver_reason_binary.parsingEngine.parseImplementation ~forPrinter:true ~filename:tempFilename in + let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in + (* put the comment- and string data back into the unmarshalled parsetree *) + let parseResult = { + parseResult with + parsetree = + parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralStructure stringData; + comments = comments; + } in + (* pretty print to res *) + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + in + Sys.remove tempFilename; + result +[@@raises Sys_error] + +(* print the given file named input to from "language" to res, general interface exposed by the compiler *) +let print language ~input = + let isInterface = + let len = String.length input in + len > 0 && String.unsafe_get input (len - 1) = 'i' + in + match language with + | `res -> printRes ~isInterface ~filename:input + | `ml -> printMl ~isInterface ~filename:input + | `refmt path -> printReason ~refmtPath:path ~isInterface ~filename:input +[@@raises Sys_error, exit] diff --git a/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli b/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli new file mode 100644 index 000000000..1a1d9624d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli @@ -0,0 +1,3 @@ +(* Interface to print source code from different languages to res. + * Takes a filename called "input" and returns the corresponding formatted res syntax *) +val print: [`ml | `res | `refmt of string (* path to refmt *)] -> input: string -> string diff --git a/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli new file mode 100644 index 000000000..674a5eeb1 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli @@ -0,0 +1,16 @@ +(* For the curious: the outcome printer is a printer to print data + * from the outcometree.mli file in the ocaml compiler. + * The outcome tree is used by: + * - ocaml's toplevel/repl, print results/errors + * - super errors, print nice errors + * - editor tooling, e.g. show type on hover + * + * In general it represent messages to show results or errors to the user. *) + +val parenthesized_ident : string -> bool [@@live] + +val setup : unit lazy_t [@@live] + +(* Needed for e.g. the playground to print typedtree data *) +val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] +val printOutSigItemDoc : Outcometree.out_sig_item -> Res_doc.t [@@live] diff --git a/analysis/src/vendor/res_outcome_printer/res_parens.ml b/analysis/src/vendor/res_outcome_printer/res_parens.ml new file mode 100644 index 000000000..948f36925 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parens.ml @@ -0,0 +1,416 @@ +module ParsetreeViewer = Res_parsetree_viewer +type kind = Parenthesized | Braced of Location.t | Nothing + + let expr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let callExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | _ when ParsetreeViewer.isUnaryExpression expr || ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let structureExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes && + not (ParsetreeViewer.isJsxExpression expr) -> Parenthesized + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let unaryExprOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when + ParsetreeViewer.isUnaryExpression expr || + ParsetreeViewer.isBinaryExpression expr + -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let binaryExprOperand ~isLhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _} -> Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + } when isLhs -> Parenthesized + | _ -> Nothing + end + + let subBinaryExprOperand parentOperator childOperator = + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence childOperator in + precParent > precChild || + (precParent == precChild && + not (ParsetreeViewer.flattenableOperators parentOperator childOperator)) || + (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) + (parentOperator = "||" && childOperator = "&&") + + let rhsBinaryExprOperand parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply( + {pexp_attributes = []; + pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [_, _left; _, _right] + ) when ParsetreeViewer.isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") -> + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent == precChild + | _ -> false + + let flattenOperandRhs parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [_, _left; _, _right] + ) when ParsetreeViewer.isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") -> + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ) -> false + | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_setfield _ + | Pexp_constraint _ -> true + | _ when ParsetreeViewer.isTernaryExpr rhs -> true + | _ -> false + + let lazyOrAssertExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let isNegativeConstant constant = + let isNeg txt = + let len = String.length txt in + len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' + in + match constant with + | Parsetree.Pconst_integer (i, _) | Pconst_float (i, _) when isNeg i -> true + | _ -> false + + let fieldExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when + ParsetreeViewer.isBinaryExpression expr || + ParsetreeViewer.isUnaryExpression expr + -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constant c } when isNegativeConstant c -> Parenthesized + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let setFieldExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let ternaryOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> + let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr expr in + begin match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing + end + | _ -> Nothing + end + + let startsWithMinus txt = + let len = String.length txt in + if len == 0 then + false + else + let s = (String.get [@doesNotRaise]) txt 0 in + s = '-' + + let jsxPropExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ + | Pexp_sequence _ + | Pexp_letexception _ + | Pexp_letmodule _ + | Pexp_open _ -> Nothing + | _ -> + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + begin match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []} + when startsWithMinus x -> Parenthesized + | {Parsetree.pexp_desc = + Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | + Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | + Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | + Pexp_let _ | Pexp_tuple _; + pexp_attributes = [] + } -> Nothing + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ); pexp_attributes = []} -> Nothing + | _ -> Parenthesized + end + end + + let jsxChildExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ + | Pexp_sequence _ + | Pexp_letexception _ + | Pexp_letmodule _ + | Pexp_open _ -> Nothing + | _ -> + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + begin match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = [] + } when startsWithMinus x -> Parenthesized + | {Parsetree.pexp_desc = + Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | + Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | + Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | + Pexp_let _; + pexp_attributes = [] + } -> Nothing + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ); pexp_attributes = []} -> Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized + end + end + + let binaryExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = _::_} as expr + when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | _ -> Nothing + end + + let modTypeFunctorReturn modType = match modType with + | {Parsetree.pmty_desc = Pmty_with _} -> true + | _ -> false + + (* Add parens for readability: + module type Functor = SetLike => Set with type t = A.t + This is actually: + module type Functor = (SetLike => Set) with type t = A.t + *) + let modTypeWithOperand modType = match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + + let modExprFunctorConstraint modType = match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + + let bracedExpr expr = match expr.Parsetree.pexp_desc with + | Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ) -> false + | Pexp_constraint _ -> true + | _ -> false + + let includeModExpr modExpr = match modExpr.Parsetree.pmod_desc with + | Parsetree.Pmod_constraint _ -> true + | _ -> false + +let arrowReturnTypExpr typExpr = match typExpr.Parsetree.ptyp_desc with + | Parsetree.Ptyp_arrow _ -> true + | _ -> false + +let patternRecordRowRhs (pattern : Parsetree.pattern) = + match pattern.ppat_desc with + | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) -> false + | Ppat_constraint _ -> true + | _ -> false diff --git a/analysis/src/vendor/res_outcome_printer/res_parens.mli b/analysis/src/vendor/res_outcome_printer/res_parens.mli new file mode 100644 index 000000000..095b56308 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parens.mli @@ -0,0 +1,36 @@ +type kind = Parenthesized | Braced of Location.t | Nothing + +val expr: Parsetree.expression -> kind +val structureExpr: Parsetree.expression -> kind + +val unaryExprOperand: Parsetree.expression -> kind + +val binaryExprOperand: isLhs:bool -> Parsetree.expression -> kind +val subBinaryExprOperand: string -> string -> bool +val rhsBinaryExprOperand: string -> Parsetree.expression -> bool +val flattenOperandRhs: string -> Parsetree.expression -> bool + +val lazyOrAssertExprRhs: Parsetree.expression -> kind + +val fieldExpr: Parsetree.expression -> kind + +val setFieldExprRhs: Parsetree.expression -> kind + +val ternaryOperand: Parsetree.expression -> kind + +val jsxPropExpr: Parsetree.expression -> kind +val jsxChildExpr: Parsetree.expression -> kind + +val binaryExpr: Parsetree.expression -> kind +val modTypeFunctorReturn: Parsetree.module_type -> bool +val modTypeWithOperand: Parsetree.module_type -> bool +val modExprFunctorConstraint: Parsetree.module_type -> bool + +val bracedExpr: Parsetree.expression -> bool +val callExpr: Parsetree.expression -> kind + +val includeModExpr : Parsetree.module_expr -> bool + +val arrowReturnTypExpr: Parsetree.core_type -> bool + +val patternRecordRowRhs: Parsetree.pattern -> bool diff --git a/analysis/src/vendor/res_outcome_printer/res_parser.ml b/analysis/src/vendor/res_outcome_printer/res_parser.ml new file mode 100644 index 000000000..6aa63f97f --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parser.ml @@ -0,0 +1,163 @@ +module Scanner = Res_scanner +module Diagnostics = Res_diagnostics +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting + +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type regionStatus = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable startPos: Lexing.position; + mutable endPos: Lexing.position; + mutable prevEndPos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parseError list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: regionStatus ref list; +} + +let err ?startPos ?endPos p error = + match p.regions with + | {contents = Report} as region::_ -> + let d = + Diagnostics.make + ~startPos:(match startPos with | Some pos -> pos | None -> p.startPos) + ~endPos:(match endPos with | Some pos -> pos | None -> p.endPos) + error + in ( + p.diagnostics <- d::p.diagnostics; + region := Silent + ) + | _ -> () + +let beginRegion p = + p.regions <- ref Report :: p.regions +let endRegion p = + match p.regions with + | [] -> () + | _::rest -> p.regions <- rest + +(* Advance to the next non-comment token and store any encountered comment +* in the parser's state. Every comment contains the end position of its +* previous token to facilite comment interleaving *) +let rec next ?prevEndPos p = + let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in + let (startPos, endPos, token) = Scanner.scan p.scanner in + match token with + | Comment c -> + Comment.setPrevTokEndPos c p.endPos; + p.comments <- c::p.comments; + p.prevEndPos <- p.endPos; + p.endPos <- endPos; + next ~prevEndPos p + | _ -> + p.token <- token; + (* p.prevEndPos <- prevEndPos; *) + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos + +let nextTemplateLiteralToken p = + let (startPos, endPos, token) = Scanner.scanTemplateLiteralToken p.scanner in + p.token <- token; + p.prevEndPos <- p.endPos; + p.startPos <- startPos; + p.endPos <- endPos + +let checkProgress ~prevEndPos ~result p = + if p.endPos == prevEndPos + then None + else Some result + +let make ?(mode=ParseForTypeChecker) src filename = + let scanner = Scanner.make ~filename src in + let parserState = { + mode; + scanner; + token = Token.Eof; + startPos = Lexing.dummy_pos; + prevEndPos = Lexing.dummy_pos; + endPos = Lexing.dummy_pos; + breadcrumbs = []; + errors = []; + diagnostics = []; + comments = []; + regions = [ref Report]; + } in + parserState.scanner.err <- (fun ~startPos ~endPos error -> + let diagnostic = Diagnostics.make + ~startPos + ~endPos + error + in + parserState.diagnostics <- diagnostic::parserState.diagnostics + ); + next parserState; + parserState + +let leaveBreadcrumb p circumstance = + let crumb = (circumstance, p.startPos) in + p.breadcrumbs <- crumb::p.breadcrumbs + +let eatBreadcrumb p = + match p.breadcrumbs with + | [] -> () + | _::crumbs -> p.breadcrumbs <- crumbs + +let optional p token = + if p.token = token then + let () = next p in true + else + false + +let expect ?grammar token p = + if p.token = token then + next p + else + let error = Diagnostics.expected ?grammar p.prevEndPos token in + err ~startPos:p.prevEndPos p error + +(* Don't use immutable copies here, it trashes certain heuristics + * in the ocaml compiler, resulting in massive slowdowns of the parser *) +let lookahead p callback = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let lineOffset = p.scanner.lineOffset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let startPos = p.startPos in + let endPos = p.endPos in + let prevEndPos = p.prevEndPos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + let res = callback p in + + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + + res diff --git a/analysis/src/vendor/res_outcome_printer/res_parser.mli b/analysis/src/vendor/res_outcome_printer/res_parser.mli new file mode 100644 index 000000000..80a1c6394 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parser.mli @@ -0,0 +1,48 @@ +module Scanner = Res_scanner +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting +module Diagnostics = Res_diagnostics +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type regionStatus = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable startPos: Lexing.position; + mutable endPos: Lexing.position; + mutable prevEndPos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parseError list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: regionStatus ref list; +} + +val make: ?mode:mode -> string -> string -> t + +val expect: ?grammar:Grammar.t -> Token.t -> t -> unit +val optional: t -> Token.t -> bool +val next: ?prevEndPos:Lexing.position -> t -> unit +val nextTemplateLiteralToken: t -> unit +val lookahead: t -> (t -> 'a) -> 'a +val err: + ?startPos:Lexing.position -> + ?endPos:Lexing.position -> + t -> Diagnostics.category -> unit + +val leaveBreadcrumb: t -> Grammar.t -> unit +val eatBreadcrumb: t -> unit + +val beginRegion: t -> unit +val endRegion: t -> unit + +val checkProgress: + prevEndPos: Lexing.position -> + result: 'a -> + t -> + 'a option diff --git a/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml new file mode 100644 index 000000000..7c25e3aaa --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml @@ -0,0 +1,576 @@ +open Parsetree + +let arrowType ct = + let rec process attrsBefore acc typ = match typ with + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> + let arg = ([], lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) + | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | typ -> + (attrsBefore, List.rev acc, typ) + in + begin match ct with + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> + process attrs [] {typ with ptyp_attributes = []} + | typ -> process [] [] typ + end + +let functorType modtype = + let rec process acc modtype = match modtype with + | {pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> + let arg = (attrs, lbl, argType) in + process (arg::acc) returnType + | modType -> + (List.rev acc, modType) + in + process [] modtype + +let processUncurriedAttribute attrs = + let rec process uncurriedSpotted acc attrs = + match attrs with + | [] -> (uncurriedSpotted, List.rev acc) + | ({Location.txt = "bs"}, _)::rest -> process true acc rest + | attr::rest -> process uncurriedSpotted (attr::acc) rest + in + process false [] attrs + +let collectListExpressions expr = + let rec collect acc expr = match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + (List.rev acc, None) + | Pexp_construct ( + {txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple (hd::[tail])} + ) -> + collect (hd::acc) tail + | _ -> + (List.rev acc, Some expr) + in + collect [] expr + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +let rewriteUnderscoreApply expr = + match expr.pexp_desc with + | Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + ({pexp_desc = Pexp_apply (callExpr, args)} as e) + ) -> + let newArgs = List.map (fun arg -> + match arg with + | ( + lbl, + ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} as argExpr) + ) -> + (lbl, {argExpr with pexp_desc = Pexp_ident ({lid with txt = Longident.Lident "_"})}) + | arg -> arg + ) args in + {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + | _ -> expr + +type funParamKind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + defaultExpr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +let funExpr expr = + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collectNewTypes acc returnExpr = + match returnExpr with + | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> + collectNewTypes (stringLoc::acc) returnExpr + | returnExpr -> + (List.rev acc, returnExpr) + in + let rec collect attrsBefore acc expr = match expr with + | {pexp_desc = Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + {pexp_desc = Pexp_apply _} + )} -> + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> + let parameter = Parameter { + attrs = []; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> + let (stringLocs, returnExpr) = collectNewTypes [stringLoc] rest in + let param = NewTypes {attrs; locs = stringLocs} in + collect attrsBefore (param::acc) returnExpr + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> + let parameter = Parameter { + attrs = attrs; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | { + pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = attrs + } -> + let parameter = Parameter { + attrs = attrs; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | expr -> + (attrsBefore, List.rev acc, expr) + in + begin match expr with + | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> + collect attrs [] {expr with pexp_attributes = []} + | expr -> collect [] [] expr + end + +let processBracesAttr expr = + match expr.pexp_attributes with + | (({txt = "ns.braces"}, _) as attr)::attrs -> + (Some attr, {expr with pexp_attributes = attrs}) + | _ -> + (None, expr) + +let filterParsingAttrs attrs = + List.filter (fun attr -> + match attr with + | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false + | _ -> true + ) attrs + +let isBlockExpr expr = + match expr.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> true + | _ -> false + +let isBracedExpr expr = + match processBracesAttr expr with + | (Some _, _) -> true + | _ -> false + +let isMultilineText txt = + let len = String.length txt in + let rec check i= + if i >= len then false + else + let c = String.unsafe_get txt i in + match c with + | '\010' | '\013' -> true + | '\\' -> + if (i + 2) = len then false + else + check (i + 2) + | _ -> check (i + 1) + in + check 0 + +let isHuggableExpression expr = + match expr.pexp_desc with + | Pexp_array _ + | Pexp_tuple _ + | Pexp_constant (Pconst_string (_, Some _)) + | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) + | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_record _ -> true + | _ when isBlockExpr expr -> true + | _ when isBracedExpr expr -> true + | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true + | _ -> false + +let isHuggableRhs expr = + match expr.pexp_desc with + | Pexp_array _ + | Pexp_tuple _ + | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) + | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_record _ -> true + | _ when isBracedExpr expr -> true + | _ -> false + +let isHuggablePattern pattern = + match pattern.ppat_desc with + | Ppat_array _ + | Ppat_tuple _ + | Ppat_record _ + | Ppat_variant _ + | Ppat_construct _ -> true + | _ -> false + +let operatorPrecedence operator = match operator with + | ":=" -> 1 + | "||" -> 2 + | "&&" -> 3 + | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" -> 4 + | "+" | "+." | "-" | "-." | "^" -> 5 + | "*" | "*." | "/" | "/." -> 6 + | "**" -> 7 + | "#" | "##" | "|." -> 8 + | _ -> 0 + +let isUnaryOperator operator = match operator with + | "~+" | "~+." | "~-" | "~-." | "not" -> true + | _ -> false + +let isUnaryExpression expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, _arg] + ) when isUnaryOperator operator -> true + | _ -> false + +(* TODO: tweak this to check for ghost ^ as template literal *) +let isBinaryOperator operator = match operator with + | ":=" + | "||" + | "&&" + | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" + | "+" | "+." | "-" | "-." | "^" + | "*" | "*." | "/" | "/." + | "**" + | "|." | "<>" -> true + | _ -> false + +let isBinaryExpression expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [(Nolabel, _operand1); (Nolabel, _operand2)] + ) when isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") (* template literal *) + -> true + | _ -> false + +let isEqualityOperator operator = match operator with + | "=" | "==" | "<>" | "!=" -> true + | _ -> false + +let flattenableOperators parentOperator childOperator = + let precParent = operatorPrecedence parentOperator in + let precChild = operatorPrecedence childOperator in + if precParent == precChild then + not ( + isEqualityOperator parentOperator && + isEqualityOperator childOperator + ) + else + false + +let rec hasIfLetAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt="ns.iflet"},_)::_ -> true + | _::attrs -> hasIfLetAttribute attrs + +let isIfLetExpr expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_match _ + } when hasIfLetAttribute attrs -> true + | _ -> false + +let hasAttributes attrs = + List.exists (fun attr -> match attr with + | ({Location.txt = "bs" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false + (* Remove the fragile pattern warning for iflet expressions *) + | ({Location.txt="warning"}, PStr [{ + pstr_desc = Pstr_eval ({ + pexp_desc = Pexp_constant ( + Pconst_string ("-4", None) + ) + }, _) + }]) -> not (hasIfLetAttribute attrs) + | _ -> true + ) attrs + +let isArrayAccess expr = match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [Nolabel, _parentExpr; Nolabel, _memberExpr] + ) -> true + | _ -> false + + +type ifConditionKind = +| If of Parsetree.expression +| IfLet of Parsetree.pattern * Parsetree.expression + +let collectIfExpressions expr = + let rec collect acc expr = match expr.pexp_desc with + | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> + collect ((If(ifExpr), thenExpr)::acc) elseExpr + | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> + let ifs = List.rev ((If(ifExpr), thenExpr)::acc) in + (ifs, elseExpr) + | Pexp_match (condition, [{ + pc_lhs = pattern; + pc_guard = None; + pc_rhs = thenExpr; + }; { + pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + }]) when isIfLetExpr expr -> + let ifs = List.rev ((IfLet(pattern, condition), thenExpr)::acc) in + (ifs, None) + | Pexp_match (condition, [{ + pc_lhs = pattern; + pc_guard = None; + pc_rhs = thenExpr; + }; { + pc_rhs = elseExpr; + }]) when isIfLetExpr expr -> + collect ((IfLet(pattern, condition), thenExpr)::acc) elseExpr + | _ -> + (List.rev acc, Some expr) + in + collect [] expr + +let rec hasTernaryAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt="ns.ternary"},_)::_ -> true + | _::attrs -> hasTernaryAttribute attrs + +let isTernaryExpr expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse _ + } when hasTernaryAttribute attrs -> true + | _ -> false + +let collectTernaryParts expr = + let rec collect acc expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse (condition, consequent, Some(alternate)) + } when hasTernaryAttribute attrs -> collect ((condition, consequent)::acc) alternate + | alternate -> (List.rev acc, alternate) + in + collect [] expr + +let parametersShouldHug parameters = match parameters with + | [Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = pat + }] when isHuggablePattern pat -> true + | _ -> false + +let filterTernaryAttributes attrs = + List.filter (fun attr -> match attr with + |({Location.txt="ns.ternary"},_) -> false + | _ -> true + ) attrs + +let filterFragileMatchAttributes attrs = + List.filter (fun attr -> match attr with + | ({Location.txt="warning"}, PStr [{ + pstr_desc = Pstr_eval ({ + pexp_desc = Pexp_constant ( + Pconst_string ("-4", _) + ) + }, _) + }]) -> false + | _ -> true + ) attrs + +let isJsxExpression expr = + let rec loop attrs = + match attrs with + | [] -> false + | ({Location.txt = "JSX"}, _)::_ -> true + | _::attrs -> loop attrs + in + match expr.pexp_desc with + | Pexp_apply _ -> + loop expr.Parsetree.pexp_attributes + | _ -> false + +let hasJsxAttribute attributes = + let rec loop attrs = + match attrs with + | [] -> false + | ({Location.txt = "JSX"}, _)::_ -> true + | _::attrs -> loop attrs + in + loop attributes + +let shouldIndentBinaryExpr expr = + let samePrecedenceSubExpression operator subExpression = + match subExpression with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, + [Nolabel, _lhs; Nolabel, _rhs] + )} when isBinaryOperator subOperator -> + flattenableOperators operator subOperator + | _ -> true + in + match expr with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, lhs; Nolabel, _rhs] + )} when isBinaryOperator operator -> + isEqualityOperator operator || + not (samePrecedenceSubExpression operator lhs) || + operator = ":=" + | _ -> false + +let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with + | Parsetree.Pexp_constant _ + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_sequence _ + | Pexp_open _ + | Pexp_ifthenelse _ + | Pexp_for _ + | Pexp_while _ + | Pexp_try _ + | Pexp_array _ + | Pexp_record _ -> true + | _ -> false + +let filterPrinteableAttributes attrs = + List.filter (fun attr -> match attr with + | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false + | _ -> true + ) attrs + +let partitionPrinteableAttributes attrs = + List.partition (fun attr -> match attr with + | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false + | _ -> true + ) attrs + +let requiresSpecialCallbackPrintingLastArg args = + let rec loop args = match args with + | [] -> false + | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false + | _::rest -> loop rest + in + loop args + +let requiresSpecialCallbackPrintingFirstArg args = + let rec loop args = match args with + | [] -> true + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false + | _::rest -> loop rest + in + match args with + | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::rest -> loop rest + | _ -> false + +let modExprApply modExpr = + let rec loop acc modExpr = match modExpr with + | {pmod_desc = Pmod_apply (next, arg)} -> + loop (arg::acc) next + | _ -> (acc, modExpr) + in + loop [] modExpr + +let modExprFunctor modExpr = + let rec loop acc modExpr = match modExpr with + | {pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> + let param = (attrs, lbl, modType) in + loop (param::acc) returnModExpr + | returnModExpr -> + (List.rev acc, returnModExpr) + in + loop [] modExpr + +let rec collectPatternsFromListConstruct acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct( + {txt = Longident.Lident "::"}, + Some {ppat_desc=Ppat_tuple (pat::rest::[])} + ) -> + collectPatternsFromListConstruct (pat::acc) rest + | _ -> List.rev acc, pattern + +(* Simple heuristic to detect template literal sugar: + * `${user.name} lastName` parses internally as user.name ++ ` lastName`. + * The thing is: the ++ operator (parsed as `^`) will always have a ghost loc. + * A ghost loc is only produced by our parser. + * Hence, if we have that ghost operator, we know for sure it's a template literal. *) +let isTemplateLiteral expr = + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [Nolabel, _; Nolabel, _] + ) when loc.loc_ghost -> true + | _ -> false + +(* Blue | Red | Green -> [Blue; Red; Green] *) +let collectOrPatternChain pat = + let rec loop pattern chain = + match pattern.ppat_desc with + | Ppat_or (left, right) -> loop left (right::chain) + | _ -> pattern::chain + in + loop pat [] + +let isSinglePipeExpr expr = + (* handles: + * x + * ->Js.Dict.get("wm-property") + * ->Option.flatMap(Js.Json.decodeString) + * ->Option.flatMap(x => + * switch x { + * | "like-of" => Some(#like) + * | "repost-of" => Some(#repost) + * | _ => None + * } + * ) + *) + let isPipeExpr expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, + [(Nolabel, _operand1); (Nolabel, _operand2)] + ) -> true + | _ -> false + in + match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, + [(Nolabel, operand1); (Nolabel, _operand2)] + ) when not (isPipeExpr operand1) -> true + | _ -> false + +let isUnderscoreApplySugar expr = + match expr.pexp_desc with + | Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + {pexp_desc = Pexp_apply _} + ) -> true + | _ -> false + +let isRewrittenUnderscoreApplySugar expr = + match expr.pexp_desc with + | Pexp_ident {txt = Longident.Lident "_"} -> true + | _ -> false diff --git a/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli new file mode 100644 index 000000000..f83ea02f4 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli @@ -0,0 +1,132 @@ +(* Restructures a nested tree of arrow types into its args & returnType + * The parsetree contains: a => b => c => d, for printing purposes + * we restructure the tree into (a, b, c) and its returnType d *) + val arrowType: Parsetree.core_type -> + Parsetree.attributes * + (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list * + Parsetree.core_type + +val functorType: Parsetree.module_type -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * + Parsetree.module_type + +(* filters @bs out of the provided attributes *) +val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes + +type ifConditionKind = + | If of Parsetree.expression + | IfLet of Parsetree.pattern * Parsetree.expression + +(* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } +* The purpose of this function is to flatten nested ifs into one sequence. +* Basically compute: ([if, else if, else if, else if], else) *) +val collectIfExpressions: + Parsetree.expression -> + (ifConditionKind * Parsetree.expression) list * Parsetree.expression option + +val collectListExpressions: + Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option) + +type funParamKind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + defaultExpr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +val funExpr: + Parsetree.expression -> + Parsetree.attributes * + funParamKind list * + Parsetree.expression + +(* example: +* `makeCoordinate({ +* x: 1, +* y: 2, +* })` +* Notice howe `({` and `})` "hug" or stick to each other *) +val isHuggableExpression: Parsetree.expression -> bool + +val isHuggablePattern: Parsetree.pattern -> bool + +val isHuggableRhs: Parsetree.expression -> bool + +val operatorPrecedence: string -> int + +val isUnaryExpression: Parsetree.expression -> bool +val isBinaryOperator: string -> bool +val isBinaryExpression: Parsetree.expression -> bool + +val flattenableOperators: string -> string -> bool + +val hasAttributes: Parsetree.attributes -> bool + +val isArrayAccess: Parsetree.expression -> bool +val isTernaryExpr: Parsetree.expression -> bool +val isIfLetExpr: Parsetree.expression -> bool + +val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression) + +val parametersShouldHug: + funParamKind list -> bool + +val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes +val filterFragileMatchAttributes: Parsetree.attributes -> Parsetree.attributes + +val isJsxExpression: Parsetree.expression -> bool +val hasJsxAttribute: Parsetree.attributes -> bool + +val shouldIndentBinaryExpr: Parsetree.expression -> bool +val shouldInlineRhsBinaryExpr: Parsetree.expression -> bool +val filterPrinteableAttributes: Parsetree.attributes -> Parsetree.attributes +val partitionPrinteableAttributes: Parsetree.attributes -> (Parsetree.attributes * Parsetree.attributes) + +val requiresSpecialCallbackPrintingLastArg: (Asttypes.arg_label * Parsetree.expression) list -> bool +val requiresSpecialCallbackPrintingFirstArg: (Asttypes.arg_label * Parsetree.expression) list -> bool + +val modExprApply : Parsetree.module_expr -> ( + Parsetree.module_expr list * Parsetree.module_expr +) + +(* Collection of utilities to view the ast in a more a convenient form, + * allowing for easier processing. + * Example: given a ptyp_arrow type, what are its arguments and what is the + * returnType? *) + + +val modExprFunctor : Parsetree.module_expr -> ( + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * + Parsetree.module_expr +) + +val collectPatternsFromListConstruct: + Parsetree.pattern list -> Parsetree.pattern -> + (Parsetree.pattern list * Parsetree.pattern) + +val isBlockExpr : Parsetree.expression -> bool + +val isTemplateLiteral: Parsetree.expression -> bool + +val collectOrPatternChain: + Parsetree.pattern -> Parsetree.pattern list + +val processBracesAttr : Parsetree.expression -> (Parsetree.attribute option * Parsetree.expression) + +val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes + +val isBracedExpr : Parsetree.expression -> bool + +val isSinglePipeExpr : Parsetree.expression -> bool + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val isUnderscoreApplySugar: Parsetree.expression -> bool + +val hasIfLetAttribute: Parsetree.attributes -> bool + +val isRewrittenUnderscoreApplySugar: Parsetree.expression -> bool diff --git a/analysis/src/vendor/res_outcome_printer/res_printer.ml b/analysis/src/vendor/res_outcome_printer/res_printer.ml new file mode 100644 index 000000000..edd92d326 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_printer.ml @@ -0,0 +1,5256 @@ +module Doc = Res_doc +module CommentTable = Res_comments_table +module Comment = Res_comment +module Token = Res_token +module Parens = Res_parens +module ParsetreeViewer = Res_parsetree_viewer + +type callbackStyle = + (* regular arrow function, example: `let f = x => x + 1` *) + | NoCallback + (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *) + | FitsOnOneLine + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + | ArgumentsFitOnOneLine + +(* Since compiler version 8.3, the bs. prefix is no longer needed *) +(* Synced from + https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_external_process.ml#L291-L367 *) +let convertBsExternalAttribute = function + | "bs.as" -> "as" + | "bs.deriving" -> "deriving" + | "bs.get" -> "get" + | "bs.get_index" -> "get_index" + | "bs.ignore" -> "ignore" + | "bs.inline" -> "inline" + | "bs.int" -> "int" + | "bs.meth" -> "meth" + | "bs.module" -> "module" + | "bs.new" -> "new" + | "bs.obj" -> "obj" + | "bs.optional" -> "optional" + | "bs.return" -> "return" + | "bs.send" -> "send" + | "bs.scope" -> "scope" + | "bs.set" -> "set" + | "bs.set_index" -> "set_index" + | "bs.splice" | "bs.variadic" -> "variadic" + | "bs.string" -> "string" + | "bs.this" -> "this" + | "bs.uncurry" -> "uncurry" + | "bs.unwrap" -> "unwrap" + | "bs.val" -> "val" + (* bs.send.pipe shouldn't be transformed *) + | txt -> txt + +(* These haven't been needed for a long time now *) +(* Synced from + https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_exp_extension.ml *) +let convertBsExtension = function + | "bs.debugger" -> "debugger" + | "bs.external" -> "raw" + (* We should never see this one since we use the sugared object form, but still *) + | "bs.obj" -> "obj" + | "bs.raw" -> "raw" + | "bs.re" -> "re" + (* TODO: what about bs.time and bs.node? *) + | txt -> txt + +let addParens doc = + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + doc + ] + ); + Doc.softLine; + Doc.rparen; + ] + ) + +let addBraces doc = + Doc.group ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + doc; + ] + ); + Doc.softLine; + Doc.rbrace; + ] + ) + +let getFirstLeadingComment tbl loc = + match Hashtbl.find tbl.CommentTable.leading loc with + | comment::_ -> Some comment + | [] -> None + | exception Not_found -> None + +(* Checks if `loc` has a leading line comment, i.e. `// comment above`*) +let hasLeadingLineComment tbl loc = + match getFirstLeadingComment tbl loc with + | Some comment -> Comment.isSingleLineComment comment + | None -> false + +let hasCommentBelow tbl loc = + match Hashtbl.find tbl.CommentTable.trailing loc with + | comment::_ -> + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + | [] -> false + | exception Not_found -> false + +let printMultilineCommentContent txt = + (* Turns + * |* first line + * * second line + * * third line *| + * Into + * |* first line + * * second line + * * third line *| + * + * What makes a comment suitable for this kind of indentation? + * -> multiple lines + every line starts with a star + *) + let rec indentStars lines acc = + match lines with + | [] -> Doc.nil + | [lastLine] -> + let line = String.trim lastLine in + let doc = Doc.text (" " ^ line) in + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace::doc::acc) |> Doc.concat + | line::lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine::doc::acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && (String.unsafe_get txt (len - 1) = ' ') then + Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [Doc.text content; trailingSpace] + in + let lines = String.split_on_char '\n' txt in + match lines with + | [] -> Doc.text "/* */" + | [line] -> Doc.concat [ + Doc.text "/* "; + Doc.text (Comment.trimSpaces line); + Doc.text " */"; + ] + | first::rest -> + let firstLine = Comment.trimSpaces first in + Doc.concat [ + Doc.text "/*"; + (match firstLine with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indentStars rest [Doc.hardLine; Doc.text firstLine]; + Doc.text "*/"; + ] + +let printTrailingComment (prevLoc: Location.t) (nodeLoc : Location.t) comment = + let singleLine = Comment.isSingleLineComment comment in + let content = + let txt = Comment.txt comment in + if singleLine then + Doc.text ("//" ^ txt) + else + printMultilineCommentContent txt + in + let diff = + let cmtStart = (Comment.loc comment).loc_start in + cmtStart.pos_lnum - prevLoc.loc_end.pos_lnum + in + let isBelow = + (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum in + if diff > 0 || isBelow then + Doc.concat [ + Doc.breakParent; + Doc.lineSuffix( + (Doc.concat [Doc.hardLine; if diff > 1 then Doc.hardLine else Doc.nil; content]) + ) + ] + else if not singleLine then + Doc.concat [Doc.space; content] + else + Doc.lineSuffix (Doc.concat [Doc.space; content]) + +let printLeadingComment ?nextComment comment = + let singleLine = Comment.isSingleLineComment comment in + let content = + let txt = Comment.txt comment in + if singleLine then + Doc.text ("//" ^ txt) + else + printMultilineCommentContent txt + in + let separator = Doc.concat [ + if singleLine then Doc.concat [ + Doc.hardLine; + Doc.breakParent; + ] else Doc.nil; + (match nextComment with + | Some next -> + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum - + currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else + if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else if diff == 1 then Doc.hardLine + else + Doc.space + | None -> Doc.nil) + ] + in + Doc.concat [ + content; + separator; + ] + +let printCommentsInside cmtTbl loc = + let rec loop acc comments = + match comments with + | [] -> Doc.nil + | [comment] -> + let cmtDoc = printLeadingComment comment in + let doc = Doc.group ( + Doc.concat [ + Doc.concat (List.rev (cmtDoc::acc)); + ] + ) + in + doc + | comment::((nextComment::_comments) as rest) -> + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc::acc) rest + in + match Hashtbl.find cmtTbl.CommentTable.inside loc with + | exception Not_found -> Doc.nil + | comments -> + Hashtbl.remove cmtTbl.inside loc; + Doc.group ( + loop [] comments + ) + +let printLeadingComments node tbl loc = + let rec loop acc comments = + match comments with + | [] -> node + | [comment] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum - + (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then + Doc.space + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.hardLine + in + let doc = Doc.group ( + Doc.concat [ + Doc.concat (List.rev (cmtDoc::acc)); + separator; + node + ] + ) + in + doc + | comment::((nextComment::_comments) as rest) -> + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc::acc) rest + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments + +let printTrailingComments node tbl loc = + let rec loop prev acc comments = + match comments with + | [] -> Doc.concat (List.rev acc) + | comment::comments -> + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc::acc) comments + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | [] -> node + | (_first::_) as comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [ + node; + cmtsDoc; + ] + +let printComments doc (tbl: CommentTable.t) loc = + let docWithLeadingComments = printLeadingComments doc tbl.leading loc in + printTrailingComments docWithLeadingComments tbl.trailing loc + +let printList ~getLoc ~nodes ~print ?(forceBreak=false) t = + let rec loop (prevLoc: Location.t) acc nodes = + match nodes with + | [] -> (prevLoc, Doc.concat (List.rev acc)) + | node::nodes -> + let loc = getLoc node in + let startPos = match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc::sep::acc) nodes + in + match nodes with + | [] -> Doc.nil + | node::nodes -> + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let (lastLoc, docs) = loop firstLoc [doc] nodes in + let forceBreak = + forceBreak || + firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs + +let printListi ~getLoc ~nodes ~print ?(forceBreak=false) t = + let rec loop i (prevLoc: Location.t) acc nodes = + match nodes with + | [] -> (prevLoc, Doc.concat (List.rev acc)) + | node::nodes -> + let loc = getLoc node in + let startPos = match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc::sep::acc) nodes + in + match nodes with + | [] -> Doc.nil + | node::nodes -> + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let (lastLoc, docs) = loop 1 firstLoc [doc] nodes in + let forceBreak = + forceBreak || + firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs + +let rec printLongidentAux accu = function +| Longident.Lident s -> (Doc.text s) :: accu +| Ldot(lid, s) -> printLongidentAux ((Doc.text s) :: accu) lid +| Lapply(lid1, lid2) -> + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + (Doc.concat [d1; Doc.lparen; d2; Doc.rparen]) :: accu + +let printLongident = function +| Longident.Lident txt -> Doc.text txt +| lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid) + +type identifierStyle = + | ExoticIdent + | NormalIdent + +let classifyIdentContent ?(allowUident=false) txt = + if Token.isKeywordTxt txt then + ExoticIdent + else + let len = String.length txt in + let rec loop i = + if i == len then NormalIdent + else if i == 0 then + match String.unsafe_get txt i with + | 'A'..'Z' when allowUident -> loop (i + 1) + | 'a'..'z' | '_' -> loop (i + 1) + | _ -> ExoticIdent + else + match String.unsafe_get txt i with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> loop (i + 1) + | _ -> ExoticIdent + in + loop 0 + +let printIdentLike ?allowUident txt = + match classifyIdentContent ?allowUident txt with + | ExoticIdent -> Doc.concat [ + Doc.text "\\\""; + Doc.text txt; + Doc.text"\"" + ] + | NormalIdent -> Doc.text txt + +let rec unsafe_for_all_range s ~start ~finish p = + start > finish || + p (String.unsafe_get s start) && + unsafe_for_all_range s ~start:(start + 1) ~finish p + +let for_all_from s start p = + let len = String.length s in + unsafe_for_all_range s ~start ~finish:(len - 1) p + +(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) +let isValidNumericPolyvarNumber (x : string) = + let len = String.length x in + len > 0 && ( + let a = Char.code (String.unsafe_get x 0) in + a <= 57 && + (if len > 1 then + a > 48 && + for_all_from x 1 (function '0' .. '9' -> true | _ -> false) + else + a >= 48 ) + ) + +(* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) +let printPolyVarIdent txt = + (* numeric poly-vars don't need quotes: #644 *) + if isValidNumericPolyvarNumber txt then + Doc.text txt + else + match classifyIdentContent ~allowUident:true txt with + | ExoticIdent -> Doc.concat [ + Doc.text "\""; + Doc.text txt; + Doc.text"\"" + ] + | NormalIdent -> Doc.text txt + + +let printLident l = match l with + | Longident.Lident txt -> printIdentLike txt + | Longident.Ldot (path, txt) -> + let txts = Longident.flatten path in + Doc.concat [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | _ -> Doc.text("printLident: Longident.Lapply is not supported") + +let printLongidentLocation l cmtTbl = + let doc = printLongident l.Location.txt in + printComments doc cmtTbl l.loc + +(* Module.SubModule.x *) +let printLidentPath path cmtTbl = + let doc = printLident path.Location.txt in + printComments doc cmtTbl path.loc + +(* Module.SubModule.x or Module.SubModule.X *) +let printIdentPath path cmtTbl = + let doc = printLident path.Location.txt in + printComments doc cmtTbl path.loc + +let printStringLoc sloc cmtTbl = + let doc = printIdentLike sloc.Location.txt in + printComments doc cmtTbl sloc.loc + +let printStringContents txt = + let lines = String.split_on_char '\n' txt in + Doc.join ~sep:Doc.literalLine (List.map Doc.text lines) + +let printConstant c = match c with + | Parsetree.Pconst_integer (s, suffix) -> + begin match suffix with + | Some c -> Doc.text (s ^ (Char.escaped c)) + | None -> Doc.text s + end + | Pconst_string (txt, None) -> + Doc.concat [ + Doc.text "\""; + printStringContents txt; + Doc.text "\""; + ] + | Pconst_string (txt, Some prefix) -> + Doc.concat [ + if prefix = "js" then Doc.nil else Doc.text prefix; + Doc.text "`"; + printStringContents txt; + Doc.text "`"; + ] + | Pconst_float (s, _) -> Doc.text s + | Pconst_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") + +let rec printStructure (s : Parsetree.structure) t = + match s with + | [] -> printCommentsInside t Location.none + | structure -> + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:printStructureItem + t + +and printStructureItem (si: Parsetree.structure_item) cmtTbl = + match si.pstr_desc with + | Pstr_value(rec_flag, valueBindings) -> + let recFlag = match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~recFlag valueBindings cmtTbl + | Pstr_type(recFlag, typeDeclarations) -> + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~recFlag typeDeclarations cmtTbl + | Pstr_primitive valueDescription -> + printValueDescription valueDescription cmtTbl + | Pstr_eval (expr, attrs) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + printAttributes attrs cmtTbl; + exprDoc; + ] + | Pstr_attribute attr -> Doc.concat [ + Doc.text "@"; + printAttribute attr cmtTbl + ] + | Pstr_extension (extension, attrs) -> Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + ] + | Pstr_include includeDeclaration -> + printIncludeDeclaration includeDeclaration cmtTbl + | Pstr_open openDescription -> + printOpenDescription openDescription cmtTbl + | Pstr_modtype modTypeDecl -> + printModuleTypeDeclaration modTypeDecl cmtTbl + | Pstr_module moduleBinding -> + printModuleBinding ~isRec:false moduleBinding cmtTbl 0 + | Pstr_recmodule moduleBindings -> + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~isRec:true) + cmtTbl + | Pstr_exception extensionConstructor -> + printExceptionDef extensionConstructor cmtTbl + | Pstr_typext typeExtension -> + printTypeExtension typeExtension cmtTbl + | Pstr_class _ | Pstr_class_type _ -> Doc.nil + +and printTypeExtension (te : Parsetree.type_extension) cmtTbl = + let prefix = Doc.text "type " in + let name = printLidentPath te.ptyext_path cmtTbl in + let typeParams = printTypeParams te.ptyext_params cmtTbl in + let extensionConstructors = + let ecs = te.ptyext_constructors in + let forceBreak = + match (ecs, List.rev ecs) with + | (first::_, last::_) -> + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || + first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + | _ -> false + in + let privateFlag = match te.ptyext_private with + | Asttypes.Private -> Doc.concat [ + Doc.text "private"; + Doc.line; + ] + | Public -> Doc.nil + in + let rows = + printListi + ~getLoc:(fun n -> n.Parsetree.pext_loc) + ~print:printExtensionConstructor + ~nodes: ecs + ~forceBreak + cmtTbl + in + Doc.breakableGroup ~forceBreak ( + Doc.indent ( + Doc.concat [ + Doc.line; + privateFlag; + rows; + (* Doc.join ~sep:Doc.line ( *) + (* List.mapi printExtensionConstructor ecs *) + (* ) *) + ] + ) + ) + in + Doc.group ( + Doc.concat [ + printAttributes ~loc: te.ptyext_path.loc te.ptyext_attributes cmtTbl; + prefix; + name; + typeParams; + Doc.text " +="; + extensionConstructors; + ] + ) + +and printModuleBinding ~isRec moduleBinding cmtTbl i = + let prefix = if i = 0 then + Doc.concat [ + Doc.text "module "; + if isRec then Doc.text "rec " else Doc.nil; + ] + else + Doc.text "and " + in + let (modExprDoc, modConstraintDoc) = + match moduleBinding.pmb_expr with + | {pmod_desc = Pmod_constraint (modExpr, modType)} -> + ( + printModExpr modExpr cmtTbl, + Doc.concat [ + Doc.text ": "; + printModType modType cmtTbl + ] + ) + | modExpr -> + (printModExpr modExpr cmtTbl, Doc.nil) + in + let modName = + let doc = Doc.text moduleBinding.pmb_name.Location.txt in + printComments doc cmtTbl moduleBinding.pmb_name.loc + in + let doc = Doc.concat [ + printAttributes + ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes cmtTbl; + prefix; + modName; + modConstraintDoc; + Doc.text " = "; + modExprDoc; + ] in + printComments doc cmtTbl moduleBinding.pmb_loc + +and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = + let modName = + let doc = Doc.text modTypeDecl.pmtd_name.txt in + printComments doc cmtTbl modTypeDecl.pmtd_name.loc + in + Doc.concat [ + printAttributes modTypeDecl.pmtd_attributes cmtTbl; + Doc.text "module type "; + modName; + (match modTypeDecl.pmtd_type with + | None -> Doc.nil + | Some modType -> Doc.concat [ + Doc.text " = "; + printModType modType cmtTbl; + ]); + ] + +and printModType modType cmtTbl = + let modTypeDoc = match modType.pmty_desc with + | Parsetree.Pmty_ident longident -> + Doc.concat [ + printAttributes ~loc:longident.loc modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl + ] + | Pmty_signature [] -> + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum < modType.pmty_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printCommentsInside cmtTbl modType.pmty_loc; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmty_signature signature -> + let signatureDoc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.line; + printSignature signature cmtTbl; + ] + ); + Doc.line; + Doc.rbrace; + ] + ) in + Doc.concat [ + printAttributes modType.pmty_attributes cmtTbl; + signatureDoc + ] + | Pmty_functor _ -> + let (parameters, returnType) = ParsetreeViewer.functorType modType in + let parametersDoc = match parameters with + | [] -> Doc.nil + | [attrs, {Location.txt = "_"; loc}, Some modType] -> + let cmtLoc = + {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes attrs cmtTbl in + let doc = Doc.concat [ + attrs; + printModType modType cmtTbl + ] in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (attrs, lbl, modType) -> + let cmtLoc = match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + {lbl.Asttypes.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes attrs cmtTbl in + let lblDoc = if lbl.Location.txt = "_" then Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.concat [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> Doc.concat [ + if lbl.txt = "_" then Doc.nil else Doc.text ": "; + printModType modType cmtTbl; + ]); + ] in + printComments doc cmtTbl cmtLoc + ) params + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + let returnDoc = + let doc = printModType returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group ( + Doc.concat [ + parametersDoc; + Doc.group ( + Doc.concat [ + Doc.text " =>"; + Doc.line; + returnDoc; + ] + ) + ] + ) + | Pmty_typeof modExpr -> Doc.concat [ + Doc.text "module type of "; + printModExpr modExpr cmtTbl + ] + | Pmty_extension extension -> printExtension ~atModuleLvl:false extension cmtTbl + | Pmty_alias longident -> Doc.concat [ + Doc.text "module "; + printLongidentLocation longident cmtTbl; + ] + | Pmty_with (modType, withConstraints) -> + let operand = + let doc = printModType modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group ( + Doc.concat [ + operand; + Doc.indent ( + Doc.concat [ + Doc.line; + printWithConstraints withConstraints cmtTbl; + ] + ) + ] + ) + in + let attrsAlreadyPrinted = match modType.pmty_desc with + | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true + | _ -> false + in + let doc =Doc.concat [ + if attrsAlreadyPrinted then Doc.nil else printAttributes modType.pmty_attributes cmtTbl; + modTypeDoc; + ] in + printComments doc cmtTbl modType.pmty_loc + +and printWithConstraints withConstraints cmtTbl = + let rows = List.mapi (fun i withConstraint -> + Doc.group ( + Doc.concat [ + if i == 0 then Doc.text "with " else Doc.text "and "; + printWithConstraint withConstraint cmtTbl; + ] + ) + ) withConstraints + in + Doc.join ~sep:Doc.line rows + +and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = + match withConstraint with + (* with type X.t = ... *) + | Pwith_type (longident, typeDeclaration) -> + Doc.group (printTypeDeclaration + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" + ~recFlag:Doc.nil + 0 + typeDeclaration + CommentTable.empty) + (* with module X.Y = Z *) + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printLongident longident2; + ] + ) + ] + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_typesubst (longident, typeDeclaration) -> + Doc.group(printTypeDeclaration + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" + ~recFlag:Doc.nil + 0 + typeDeclaration + CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent ( + Doc.concat [ + Doc.line; + printLongident longident2; + ] + ) + ] + +and printSignature signature cmtTbl = + match signature with + | [] -> printCommentsInside cmtTbl Location.none + | signature -> + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:printSignatureItem + cmtTbl + +and printSignatureItem (si : Parsetree.signature_item) cmtTbl = + match si.psig_desc with + | Parsetree.Psig_value valueDescription -> + printValueDescription valueDescription cmtTbl + | Psig_type (recFlag, typeDeclarations) -> + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~recFlag typeDeclarations cmtTbl + | Psig_typext typeExtension -> + printTypeExtension typeExtension cmtTbl + | Psig_exception extensionConstructor -> + printExceptionDef extensionConstructor cmtTbl + | Psig_module moduleDeclaration -> + printModuleDeclaration moduleDeclaration cmtTbl + | Psig_recmodule moduleDeclarations -> + printRecModuleDeclarations moduleDeclarations cmtTbl + | Psig_modtype modTypeDecl -> + printModuleTypeDeclaration modTypeDecl cmtTbl + | Psig_open openDescription -> + printOpenDescription openDescription cmtTbl + | Psig_include includeDescription -> + printIncludeDescription includeDescription cmtTbl + | Psig_attribute attr -> Doc.concat [ + Doc.text "@"; + printAttribute attr cmtTbl + ] + | Psig_extension (extension, attrs) -> Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + ] + | Psig_class _ | Psig_class_type _ -> Doc.nil + +and printRecModuleDeclarations moduleDeclarations cmtTbl = + printListi + ~getLoc:(fun n -> n.Parsetree.pmd_loc) + ~nodes:moduleDeclarations + ~print:printRecModuleDeclaration + cmtTbl + +and printRecModuleDeclaration md cmtTbl i = + let body = match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + | _ -> + let needsParens = match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let modTypeDoc = + let doc = printModType md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [Doc.text ": "; modTypeDoc] + in + let prefix = if i < 1 then "module rec " else "and " in + Doc.concat [ + printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + Doc.text prefix; + printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + body + ] + +and printModuleDeclaration (md: Parsetree.module_declaration) cmtTbl = + let body = match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type cmtTbl] + in + Doc.concat [ + printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + Doc.text "module "; + printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + body + ] + +and printOpenDescription (openDescription : Parsetree.open_description) cmtTbl = + Doc.concat [ + printAttributes openDescription.popen_attributes cmtTbl; + Doc.text "open"; + (match openDescription.popen_override with + | Asttypes.Fresh -> Doc.space + | Asttypes.Override -> Doc.text "! "); + printLongidentLocation openDescription.popen_lid cmtTbl + ] + +and printIncludeDescription (includeDescription: Parsetree.include_description) cmtTbl = + Doc.concat [ + printAttributes includeDescription.pincl_attributes cmtTbl; + Doc.text "include "; + printModType includeDescription.pincl_mod cmtTbl; + ] + +and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) cmtTbl = + Doc.concat [ + printAttributes includeDeclaration.pincl_attributes cmtTbl; + Doc.text "include "; + let includeDoc = + printModExpr includeDeclaration.pincl_mod cmtTbl + in + if Parens.includeModExpr includeDeclaration.pincl_mod then + addParens includeDoc + else includeDoc; + ] + +and printValueBindings ~recFlag (vbs: Parsetree.value_binding list) cmtTbl = + printListi + ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) + ~nodes:vbs + ~print:(printValueBinding ~recFlag) + cmtTbl + +and printValueDescription valueDescription cmtTbl = + let isExternal = + match valueDescription.pval_prim with | [] -> false | _ -> true + in + let attrs = + printAttributes + ~loc:valueDescription.pval_name.loc + valueDescription.pval_attributes + cmtTbl + in + let header = + if isExternal then "external " else "let " in + Doc.group ( + Doc.concat [ + attrs; + Doc.text header; + printComments + (printIdentLike valueDescription.pval_name.txt) + cmtTbl + valueDescription.pval_name.loc; + Doc.text ": "; + printTypExpr 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 + ] + ) + +and printTypeDeclarations ~recFlag typeDeclarations cmtTbl = + printListi + ~getLoc:(fun n -> n.Parsetree.ptype_loc) + ~nodes:typeDeclarations + ~print:(printTypeDeclaration2 ~recFlag) + cmtTbl + +(* + * type_declaration = { + * ptype_name: string loc; + * ptype_params: (core_type * variance) list; + * (* ('a1,...'an) t; None represents _*) + * ptype_cstrs: (core_type * core_type * Location.t) list; + * (* ... constraint T1=T1' ... constraint Tn=Tn' *) + * ptype_kind: type_kind; + * ptype_private: private_flag; (* = private ... *) + * ptype_manifest: core_type option; (* = T *) + * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + * ptype_loc: Location.t; + * } + * + * + * type t (abstract, no manifest) + * type t = T0 (abstract, manifest=T0) + * type t = C of T | ... (variant, no manifest) + * type t = T0 = C of T | ... (variant, manifest=T0) + * type t = {l: T; ...} (record, no manifest) + * type t = T0 = {l : T; ...} (record, manifest=T0) + * type t = .. (open, no manifest) + * + * + * and type_kind = + * | Ptype_abstract + * | Ptype_variant of constructor_declaration list + * (* Invariant: non-empty list *) + * | Ptype_record of label_declaration list + * (* Invariant: non-empty list *) + * | Ptype_open + *) +and printTypeDeclaration ~name ~equalSign ~recFlag i (td: Parsetree.type_declaration) cmtTbl = + let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let prefix = if i > 0 then + Doc.text "and " + else + Doc.concat [Doc.text "type "; recFlag] + in + let typeName = name in + let typeParams = printTypeParams td.ptype_params cmtTbl in + let manifestAndKind = match td.ptype_kind with + | Ptype_abstract -> + begin match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> + Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printTypExpr typ cmtTbl; + ] + end + | Ptype_open -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record(lds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration lds cmtTbl; + ] + | Ptype_variant(cds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + ] + in + let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + Doc.group ( + Doc.concat [ + attrs; + prefix; + typeName; + typeParams; + manifestAndKind; + constraints; + ] + ) + +and printTypeDeclaration2 ~recFlag (td: Parsetree.type_declaration) cmtTbl i = + let name = + let doc = printIdentLike td.Parsetree.ptype_name.txt in + printComments doc cmtTbl td.ptype_name.loc + in + let equalSign = "=" in + let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let prefix = if i > 0 then + Doc.text "and " + else + Doc.concat [ + Doc.text "type "; + recFlag + ] + in + let typeName = name in + let typeParams = printTypeParams td.ptype_params cmtTbl in + let manifestAndKind = match td.ptype_kind with + | Ptype_abstract -> + begin match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> + Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printTypExpr typ cmtTbl; + ] + end + | Ptype_open -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record(lds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration lds cmtTbl; + ] + | Ptype_variant(cds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + ] + in + let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + Doc.group ( + Doc.concat [ + attrs; + prefix; + typeName; + typeParams; + manifestAndKind; + constraints; + ] + ) + +and printTypeDefinitionConstraints cstrs = + match cstrs with + | [] -> Doc.nil + | cstrs -> Doc.indent ( + Doc.group ( + Doc.concat [ + Doc.line; + Doc.group( + Doc.join ~sep:Doc.line ( + List.map printTypeDefinitionConstraint cstrs + ) + ) + ] + ) + ) + +and printTypeDefinitionConstraint ((typ1, typ2, _loc ): Parsetree.core_type * Parsetree.core_type * Location.t) = + Doc.concat [ + Doc.text "constraint "; + printTypExpr typ1 CommentTable.empty; + Doc.text " = "; + printTypExpr typ2 CommentTable.empty; + ] + +and printPrivateFlag (flag : Asttypes.private_flag) = match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil + +and printTypeParams typeParams cmtTbl = + match typeParams with + | [] -> Doc.nil + | typeParams -> + Doc.group ( + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typeParam -> + let doc = printTypeParam typeParam cmtTbl in + printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc + ) typeParams + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + ) + +and printTypeParam (param : (Parsetree.core_type * Asttypes.variance)) cmtTbl = + let (typ, variance) = param in + let printedVariance = match variance with + | Covariant -> Doc.text "+" + | Contravariant -> Doc.text "-" + | Invariant -> Doc.nil + in + Doc.concat [ + printedVariance; + printTypExpr typ cmtTbl + ] + +and printRecordDeclaration (lds: Parsetree.label_declaration list) cmtTbl = + let forceBreak = match (lds, List.rev lds) with + | (first::_, last::_) -> + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun ld -> + let doc = printLabelDeclaration ld cmtTbl in + printComments doc cmtTbl ld.Parsetree.pld_loc + ) lds) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] + ) + +and printConstructorDeclarations + ~privateFlag (cds: Parsetree.constructor_declaration list) cmtTbl += + let forceBreak = match (cds, List.rev cds) with + | (first::_, last::_) -> + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + | _ -> false + in + let privateFlag = match privateFlag with + | Asttypes.Private -> Doc.concat [ + Doc.text "private"; + Doc.line; + ] + | Public -> Doc.nil + in + let rows = + printListi + ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) + ~nodes:cds + ~print:(fun cd cmtTbl i -> + let doc = printConstructorDeclaration2 i cd cmtTbl in + printComments doc cmtTbl cd.Parsetree.pcd_loc + ) + ~forceBreak + cmtTbl + in + Doc.breakableGroup ~forceBreak ( + Doc.indent ( + Doc.concat [ + Doc.line; + privateFlag; + rows; + ] + ) + ) + +and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) cmtTbl = + let attrs = printAttributes cd.pcd_attributes cmtTbl in + let bar = if i > 0 || cd.pcd_attributes <> [] then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil + in + let constrName = + let doc = Doc.text cd.pcd_name.txt in + printComments doc cmtTbl cd.pcd_name.loc + in + let constrArgs = printConstructorArguments ~indent:true cd.pcd_args cmtTbl in + let gadt = match cd.pcd_res with + | None -> Doc.nil + | Some(typ) -> Doc.indent ( + Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + ) + in + Doc.concat [ + bar; + Doc.group ( + Doc.concat [ + attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *) + constrName; + constrArgs; + gadt; + ] + ) + ] + +and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) cmtTbl = + match cdArgs with + | Pcstr_tuple [] -> Doc.nil + | Pcstr_tuple types -> + let args = Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typexpr -> + printTypExpr typexpr cmtTbl + ) types + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] in + Doc.group ( + if indent then Doc.indent args else args + ) + | Pcstr_record lds -> + let args = Doc.concat [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun ld -> + let doc = printLabelDeclaration ld cmtTbl in + printComments doc cmtTbl ld.Parsetree.pld_loc + ) lds) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] in + if indent then Doc.indent args else args + +and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = + let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl in + let mutableFlag = match ld.pld_mutable with + | Mutable -> Doc.text "mutable " + | Immutable -> Doc.nil + in + let name = + let doc = printIdentLike ld.pld_name.txt in + printComments doc cmtTbl ld.pld_name.loc + in + Doc.group ( + Doc.concat [ + attrs; + mutableFlag; + name; + Doc.text ": "; + printTypExpr ld.pld_type cmtTbl; + ] + ) + +and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = + let renderedType = match typExpr.ptyp_desc with + | Ptyp_any -> Doc.text "_" + | Ptyp_var var -> Doc.concat [ + Doc.text "'"; + printIdentLike ~allowUident:true var; + ] + | Ptyp_extension(extension) -> + printExtension ~atModuleLvl:false extension cmtTbl + | Ptyp_alias(typ, alias) -> + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false + in + let doc = printTypExpr typ cmtTbl in + if needsParens then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else + doc + in + Doc.concat [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + + (* object printings *) + | Ptyp_object (fields, openFlag) -> + printObject ~inline:false fields openFlag cmtTbl + | Ptyp_constr(longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat([ + constrName; + Doc.lessThan; + printObject ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ]) + + | Ptyp_constr(longidentLoc, [{ ptyp_desc = Parsetree.Ptyp_tuple tuple }]) -> + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.group( + Doc.concat([ + constrName; + Doc.lessThan; + printTupleType ~inline:true tuple cmtTbl; + Doc.greaterThan; + ]) + ) + | Ptyp_constr(longidentLoc, constrArgs) -> + let constrName = printLidentPath longidentLoc cmtTbl in + begin match constrArgs with + | [] -> constrName + | _args -> Doc.group( + Doc.concat([ + constrName; + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun typexpr -> printTypExpr typexpr cmtTbl) + constrArgs + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) + ) + end + | Ptyp_arrow _ -> + let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr returnType cmtTbl in + if returnTypeNeedsParens then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let (isUncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + begin match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = if hasAttrsBefore then printAttributes ~inline:true attrsBefore cmtTbl else Doc.nil + in + let typDoc = + let doc = printTypExpr n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group ( + Doc.concat [ + 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; + ] + ) + ] + ) + | args -> + let attrs = printAttributes ~inline:true attrs cmtTbl in + let renderedArgs = Doc.concat [ + attrs; + Doc.text "("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun tp -> + printTypeParameter tp cmtTbl + ) args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] in + Doc.group ( + Doc.concat [ + renderedArgs; + Doc.text " => "; + returnDoc; + ] + ) + end + | Ptyp_tuple types -> printTupleType ~inline:false types cmtTbl + | Ptyp_poly([], typ) -> + printTypExpr typ cmtTbl + | Ptyp_poly(stringLocs, typ) -> + Doc.concat [ + Doc.join ~sep:Doc.space (List.map (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + printComments doc cmtTbl loc + ) stringLocs); + Doc.dot; + Doc.space; + printTypExpr typ cmtTbl + ] + | Ptyp_package packageType -> + printPackageType ~printModuleKeywordAndParens:true packageType cmtTbl + | Ptyp_class _ -> + Doc.text "classes are not supported in types" + | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> + let forceBreak = typExpr.ptyp_loc.Location.loc_start.pos_lnum < typExpr.ptyp_loc.loc_end.pos_lnum in + let printRowField = function + | Parsetree.Rtag ({txt}, attrs, true, []) -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt] + ] + ) + | Rtag ({txt}, attrs, truth, types) -> + let doType t = match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr t cmtTbl + | _ -> Doc.concat [ Doc.lparen; printTypExpr t cmtTbl; Doc.rparen ] + in + let printedTypes = List.map doType types in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes in + let cases = if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases in + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + cases + ] + ) + | Rinherit coreType -> + printTypExpr coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in + let cases = + if docs = [] then cases + else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + in + let openingSymbol = + if closedFlag = Open + then Doc.concat [Doc.greaterThan; Doc.line] + else if labelsOpt = None + then Doc.softLine + else Doc.concat [Doc.lessThan; Doc.line] in + let labels = match labelsOpt with + | None + | Some([]) -> + Doc.nil + | Some(labels) -> + Doc.concat ( + List.map (fun label -> + Doc.concat [Doc.line; Doc.text "#" ; printPolyVarIdent label] + ) labels + ) + in + let closingSymbol = match labelsOpt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak ( + Doc.concat [ + Doc.lbracket; + Doc.indent ( + Doc.concat [ + openingSymbol; + cases; + closingSymbol; + labels; + ] + ); + Doc.softLine; + Doc.rbracket + ] + ) + in + let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with + | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true + | _ -> false + in + let doc = begin match typExpr.ptyp_attributes with + | _::_ as attrs when not shouldPrintItsOwnAttributes -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + renderedType; + ] + ) + | _ -> renderedType + end + in + printComments doc cmtTbl typExpr.ptyp_loc + +and printObject ~inline fields openFlag cmtTbl = + let doc = match fields with + | [] -> Doc.concat [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace + ] + | fields -> + Doc.concat [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> + begin match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | (Oinherit _)::_ -> Doc.text ".. " + | _ -> Doc.dotdot + end + ); + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun field -> printObjectField field cmtTbl) fields + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] + in + if inline then doc else Doc.group doc + +and printTupleType ~inline (types: Parsetree.core_type list) cmtTbl = + let tuple = Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types + ) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + if inline == false then Doc.group(tuple) else tuple + +and printObjectField (field : Parsetree.object_field) cmtTbl = + match field with + | Otag (labelLoc, attrs, typ) -> + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = Doc.concat [ + printAttributes ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] in + let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in + printComments doc cmtTbl cmtLoc + | Oinherit typexpr -> + Doc.concat [ + Doc.dotdotdot; + printTypExpr typexpr cmtTbl + ] + +(* es6 arrow type arg + * type t = (~foo: string, ~bar: float=?, unit) => unit + * i.e. ~foo: string, ~bar: float *) +and printTypeParameter (attrs, lbl, typ) cmtTbl = + let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes attrs cmtTbl in + let label = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Labelled lbl -> Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + ] + | Optional lbl -> Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + ] + in + let optionalIndicator = match lbl with + | Asttypes.Nolabel + | Labelled _ -> Doc.nil + | Optional _lbl -> Doc.text "=?" + in + let (loc, typ) = match typ.ptyp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + ({loc with loc_end = typ.ptyp_loc.loc_end}, {typ with ptyp_attributes = attrs}) + | _ -> (typ.ptyp_loc, typ) + in + let doc = Doc.group ( + Doc.concat [ + uncurried; + attrs; + label; + printTypExpr typ cmtTbl; + optionalIndicator; + ] + ) in + printComments doc cmtTbl loc + +and printValueBinding ~recFlag vb cmtTbl i = + let attrs = printAttributes ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl in + let header = + if i == 0 then + Doc.concat [ + Doc.text "let "; + recFlag + ] else + Doc.text "and " + in + match vb with + | {pvb_pat = + {ppat_desc = Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp))}; + pvb_expr = + {pexp_desc = Pexp_newtype _} as expr + } -> + let (_attrs, parameters, returnExpr) = ParsetreeViewer.funExpr expr in + let abstractType = match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat [ + Doc.text "type "; + Doc.join ~sep:Doc.space (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + begin match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group ( + Doc.concat [ + attrs; + header; + printPattern pattern cmtTbl; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + abstractType; + Doc.space; + printTypExpr typ cmtTbl; + Doc.text " ="; + Doc.concat [ + Doc.line; + printExpressionWithComments expr cmtTbl; + ] + ] + ) + ] + ) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group ( + Doc.concat [ + attrs; + header; + printPattern pattern cmtTbl; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + abstractType; + Doc.space; + printTypExpr patTyp cmtTbl; + Doc.text " ="; + Doc.concat [ + Doc.line; + printExpressionWithComments expr cmtTbl; + ] + ] + ) + ] + ) + end + | _ -> + let (optBraces, expr) = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = printExpressionWithComments vb.pvb_expr cmtTbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let patternDoc = printPattern vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout [ + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.space; + printedExpr; + ] + ); + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printedExpr; + ] + ) + ] + ); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> + ParsetreeViewer.isBinaryExpression expr || + (match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt="ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _) + } -> + ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes || + ParsetreeViewer.isArrayAccess e + ) + in + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + if shouldIndent then + Doc.indent ( + Doc.concat [ + Doc.line; + printedExpr; + ] + ) + else + Doc.concat [ + Doc.space; + printedExpr; + ] + ] + ) + +and printPackageType ~printModuleKeywordAndParens (packageType: Parsetree.package_type) cmtTbl = + let doc = match packageType with + | (longidentLoc, []) -> Doc.group( + Doc.concat [ + printLongidentLocation longidentLoc cmtTbl; + ] + ) + | (longidentLoc, packageConstraints) -> Doc.group( + Doc.concat [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints packageConstraints cmtTbl; + Doc.softLine; + ] + ) + in + if printModuleKeywordAndParens then + Doc.concat[ + Doc.text "module("; + doc; + Doc.rparen + ] + else + doc + +and printPackageConstraints packageConstraints cmtTbl = + Doc.concat [ + Doc.text " with"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line ( + List.mapi (fun i pc -> + let (longident, typexpr) = pc in + let cmtLoc = {longident.Asttypes.loc with + loc_end = typexpr.Parsetree.ptyp_loc.loc_end + } in + let doc = printPackageConstraint i cmtTbl pc in + printComments doc cmtTbl cmtLoc + ) packageConstraints + ) + ] + ) + ] + +and printPackageConstraint i cmtTbl (longidentLoc, typ) = + let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in + Doc.concat [ + prefix; + printLongidentLocation longidentLoc cmtTbl; + Doc.text " = "; + printTypExpr typ cmtTbl; + ] + +and printExtension ~atModuleLvl (stringLoc, payload) cmtTbl = + let txt = convertBsExtension stringLoc.Location.txt in + let extName = + let doc = Doc.concat [ + Doc.text "%"; + if atModuleLvl then Doc.text "%" else Doc.nil; + Doc.text txt + ] in + printComments doc cmtTbl stringLoc.Location.loc + in + Doc.group ( + Doc.concat [ + extName; + printPayload payload cmtTbl; + ] + ) + +and printPattern (p : Parsetree.pattern) cmtTbl = + let patternWithoutAttributes = match p.ppat_desc with + | Ppat_any -> Doc.text "_" + | Ppat_var var -> printIdentLike var.txt + | Ppat_constant c -> printConstant c + | Ppat_tuple patterns -> + Doc.group( + Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen + ]) + ) + | Ppat_array [] -> + Doc.concat [ + Doc.lbracket; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rbracket; + ] + | Ppat_array patterns -> + Doc.group( + Doc.concat([ + Doc.text "["; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + ) + | Ppat_construct({txt = Longident.Lident "()"}, _) -> + Doc.concat [ + Doc.lparen; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rparen; + ] + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> + Doc.concat [ + Doc.text "list{"; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rbrace; + ] + | Ppat_construct({txt = Longident.Lident "::"}, _) -> + let (patterns, tail) = ParsetreeViewer.collectPatternsFromListConstruct [] p in + let shouldHug = match (patterns, tail) with + | ([pat], + {ppat_desc = Ppat_construct({txt = Longident.Lident "[]"}, _)}) when ParsetreeViewer.isHuggablePattern pat -> true + | _ -> false + in + let children = Doc.concat([ + if shouldHug then Doc.nil else Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns); + begin match tail.Parsetree.ppat_desc with + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = Doc.concat [Doc.text "..."; printPattern tail cmtTbl] in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat([Doc.text ","; Doc.line; tail]) + end; + ]) in + Doc.group( + Doc.concat([ + Doc.text "list{"; + if shouldHug then children else Doc.concat [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]; + Doc.rbrace; + ]) + ) + | Ppat_construct(constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = match constructorArgs with + | None -> Doc.nil + | Some({ppat_loc; ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.concat [ + Doc.lparen; + printCommentsInside cmtTbl ppat_loc; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> + Doc.concat [ + Doc.lparen; + Doc.softLine; + printCommentsInside cmtTbl loc; + Doc.rparen; + ] + (* Some((1, 2) *) + | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + printPattern arg cmtTbl; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple patterns}) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun pat -> printPattern pat cmtTbl) patterns + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = printPattern arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + + ] + in + Doc.group(Doc.concat [constrName; argsDoc]) + | Ppat_variant (label, None) -> + Doc.concat [Doc.text "#"; printPolyVarIdent label] + | Ppat_variant (label, variantArgs) -> + let variantName = + Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let argsDoc = match variantArgs with + | None -> Doc.nil + | Some({ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> + Doc.concat [ + Doc.lparen; + Doc.softLine; + printCommentsInside cmtTbl loc; + Doc.rparen; + ] + (* Some((1, 2) *) + | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + printPattern arg cmtTbl; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple patterns}) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun pat -> printPattern pat cmtTbl) patterns + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = printPattern arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + + ] + in + Doc.group(Doc.concat [variantName; argsDoc]) + | Ppat_type ident -> + Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + | Ppat_record(rows, openFlag) -> + Doc.group( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printPatternRecordRow row cmtTbl) rows); + begin match openFlag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil + end; + ] + ); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) + ) + + | Ppat_exception p -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.group ( + Doc.concat [Doc.text "exception"; Doc.line; pat] + ) + | Ppat_or _ -> + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = List.mapi (fun i pat -> + let patternDoc = printPattern pat cmtTbl in + Doc.concat [ + 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 + | _ -> patternDoc + ] + ) orChain in + let isSpreadOverMultipleLines = match (orChain, List.rev orChain) with + | first::_, last::_ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) + | Ppat_extension ext -> + printExtension ~atModuleLvl:false ext cmtTbl + | Ppat_lazy p -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.concat [Doc.text "lazy "; pat] + | Ppat_alias (p, aliasLoc) -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.concat([ + renderedPattern; + Doc.text " as "; + printStringLoc aliasLoc cmtTbl; + ]) + + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_constraint ({ppat_desc = Ppat_unpack stringLoc}, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> + Doc.concat [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl + ptyp_loc; + Doc.rparen; + ] + | Ppat_constraint (pattern, typ) -> + Doc.concat [ + printPattern pattern cmtTbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_unpack stringLoc -> + Doc.concat [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] + | Ppat_interval (a, b) -> + Doc.concat [ + printConstant a; + Doc.text " .. "; + printConstant b; + ] + | Ppat_open _ -> Doc.nil + in + let doc = match p.ppat_attributes with + | [] -> patternWithoutAttributes + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + patternWithoutAttributes; + ] + ) + in + printComments doc cmtTbl p.ppat_loc + +and printPatternRecordRow row cmtTbl = + match row with + (* punned {x}*) + | ({Location.txt=Longident.Lident ident} as longident, + {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> + printLidentPath longident cmtTbl + | (longident, pattern) -> + let locForComments = { + longident.loc with + loc_end = pattern.Parsetree.ppat_loc.loc_end + } in + let rhsDoc = + let doc = printPattern pattern cmtTbl in + if Parens.patternRecordRowRhs pattern then + addParens doc + else + doc + in + let doc = Doc.group ( + Doc.concat([ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [Doc.space; rhsDoc] + else + Doc.indent( + Doc.concat [ + Doc.line; + rhsDoc; + ] + ) + ); + ]) + ) in + printComments doc cmtTbl locForComments + +and printExpressionWithComments expr cmtTbl = + let doc = printExpression expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc + +and printIfChain pexp_attributes ifs elseExpr cmtTbl = + let ifDocs = Doc.join ~sep:Doc.space ( + List.mapi (fun i (ifExpr, thenExpr) -> + let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in + match ifExpr with + | ParsetreeViewer.If ifExpr -> + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~braces:true ifExpr cmtTbl + else + let doc = printExpressionWithComments ifExpr cmtTbl in + match Parens.expr ifExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat [ + ifTxt; + Doc.group (condition); + Doc.space; + let thenExpr = match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | (Some _, expr) -> expr + | _ -> thenExpr + in + printExpressionBlock ~braces:true thenExpr cmtTbl; + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = + let doc = printExpressionWithComments conditionExpr cmtTbl in + match Parens.expr conditionExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc + in + Doc.concat [ + ifTxt; + Doc.text "let "; + printPattern pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~braces:true thenExpr cmtTbl; + ] + ) ifs + ) in + let elseDoc = match elseExpr with + | None -> Doc.nil + | Some expr -> Doc.concat [ + Doc.text " else "; + printExpressionBlock ~braces:true expr cmtTbl; + ] + in + let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in + Doc.concat [ + printAttributes attrs cmtTbl; + ifDocs; + elseDoc; + ] + +and printExpression (e : Parsetree.expression) cmtTbl = + let printedExpression = match e.pexp_desc with + | Parsetree.Pexp_constant c -> printConstant c + | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> + printJsxFragment e cmtTbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat [ + Doc.text "list{"; + printCommentsInside cmtTbl e.pexp_loc; + Doc.rbrace; + ] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let (expressions, spread) = ParsetreeViewer.collectListExpressions e in + let spreadDoc = match spread with + | Some(expr) -> Doc.concat [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ] + | None -> Doc.nil + in + Doc.group( + Doc.concat([ + Doc.text "list{"; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ) + expressions); + spreadDoc; + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | Pexp_construct (longidentLoc, args) -> + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = match args with + | None -> Doc.nil + | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + (* Some((1, 2)) *) + | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + (let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some({pexp_desc = Pexp_tuple args }) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + in + Doc.group(Doc.concat [constr; args]) + | Pexp_ident path -> + printLidentPath path cmtTbl + | Pexp_tuple exprs -> + Doc.group( + Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs) + ]) + ); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) + ) + | Pexp_array [] -> + Doc.concat [ + Doc.lbracket; + printCommentsInside cmtTbl e.pexp_loc; + Doc.rbracket; + ] + | Pexp_array exprs -> + Doc.group( + Doc.concat([ + Doc.lbracket; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ) exprs) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) + ) + | Pexp_variant (label, args) -> + let variantName = + Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let args = match args with + | None -> Doc.nil + | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + (* #poly((1, 2) *) + | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + (let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some({pexp_desc = Pexp_tuple args }) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + in + Doc.group(Doc.concat [variantName; args]) + | Pexp_record (rows, spreadExpr) -> + let spread = match spreadExpr with + | None -> Doc.nil + | Some expr -> Doc.concat [ + Doc.dotdotdot; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak ( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + spread; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printRecordRow row cmtTbl) rows) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | Pexp_extension extension -> + begin match extension with + | ( + {txt = "bs.obj" | "obj"}, + PStr [{ + pstr_loc = loc; + pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) + }] + ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = + loc.loc_start.pos_lnum < loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak ( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printBsObjectRow row cmtTbl) rows) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | extension -> + printExtension ~atModuleLvl:false extension cmtTbl + end + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression e cmtTbl + else + printPexpApply e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + lhs; + Doc.dot; + printLidentPath longidentLoc cmtTbl; + ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> + let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = match parts with + | (condition1, consequent1)::rest -> + Doc.group (Doc.concat [ + printTernaryOperand condition1 cmtTbl; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.indent ( + Doc.concat [ + Doc.text "? "; + printTernaryOperand consequent1 cmtTbl + ] + ); + Doc.concat ( + List.map (fun (condition, consequent) -> + Doc.concat [ + Doc.line; + Doc.text ": "; + printTernaryOperand condition cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand consequent cmtTbl; + ] + ) rest + ); + Doc.line; + Doc.text ": "; + Doc.indent (printTernaryOperand alternate cmtTbl); + ] + ) + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false | _ -> true + in + Doc.concat [ + printAttributes attrs cmtTbl; + if needsParens then addParens ternaryDoc else ternaryDoc; + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in + printIfChain e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "while "; + if ParsetreeViewer.isBlockExpr expr1 then + condition + else + Doc.group ( + Doc.ifBreaks (addParens condition) condition + ); + Doc.space; + printExpressionBlock ~braces:true expr2 cmtTbl; + ] + ) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "for "; + printPattern pattern cmtTbl; + Doc.text " in "; + (let doc = printExpressionWithComments fromExpr cmtTbl in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = printExpressionWithComments toExpr cmtTbl in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~braces:true body cmtTbl; + ] + ) + | Pexp_constraint( + {pexp_desc = Pexp_pack modExpr}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} + ) -> + Doc.group ( + Doc.concat [ + Doc.text "module("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printModExpr modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl + ptyp_loc + ] + ); + Doc.softLine; + Doc.rparen; + ] + ) + + | Pexp_constraint (expr, typ) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + exprDoc; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_letexception (_extensionConstructor, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_assert expr -> + let rhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.lazyOrAssertExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "assert "; + rhs; + ] + | Pexp_lazy expr -> + let rhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.lazyOrAssertExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group ( + Doc.concat [ + Doc.text "lazy "; + rhs; + ] + ) + | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_pack (modExpr) -> + Doc.group (Doc.concat [ + Doc.text "module("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printModExpr modExpr cmtTbl; + ] + ); + Doc.softLine; + Doc.rparen; + ]) + | Pexp_sequence _ -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_let _ -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_fun (Nolabel, None, {ppat_desc = Ppat_var {txt="__x"}}, ({pexp_desc = Pexp_apply _})) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments (ParsetreeViewer.rewriteUnderscoreApply e) cmtTbl + | Pexp_fun _ | Pexp_newtype _ -> + let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsOnArrow + in + let (returnExpr, typConstraint) = match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> ( + {expr with pexp_attributes = List.concat [ + expr.pexp_attributes; + returnExpr.pexp_attributes; + ]}, + Some typ + ) + | _ -> (returnExpr, None) + in + let hasConstraint = match typConstraint with | Some _ -> true | None -> false in + let parametersDoc = printExprFunParameters + ~inCallback:NoCallback + ~uncurried + ~hasConstraint + parameters + cmtTbl + in + let returnExprDoc = + let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = match (returnExpr.pexp_desc, optBraces) with + | (_, Some _ ) -> true + | ((Pexp_array _ + | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _), _) -> true + | _ -> false + in + let shouldIndent = match returnExpr.pexp_desc with + | Pexp_sequence _ + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_open _ -> false + | _ -> true + in + let returnDoc = + let doc = printExpressionWithComments returnExpr cmtTbl in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc + in + if shouldInline then Doc.concat [ + Doc.space; + returnDoc; + ] else + Doc.group ( + if shouldIndent then + Doc.indent ( + Doc.concat [ + Doc.line; + returnDoc; + ] + ) + else + Doc.concat [ + Doc.space; + returnDoc + ] + ) + in + let typConstraintDoc = match typConstraint with + | Some(typ) -> + let typDoc = + let doc = printTypExpr typ cmtTbl in + if Parens.arrowReturnTypExpr typ then + addParens doc + else + doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes attrs cmtTbl in + Doc.group ( + Doc.concat [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ] + ) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases cases cmtTbl; + ] + | Pexp_match (_, [_;_]) when ParsetreeViewer.isIfLetExpr e -> + let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in + printIfChain e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_match (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases cases cmtTbl; + ] + | Pexp_function cases -> + Doc.concat [ + Doc.text "x => switch x "; + printCases cases cmtTbl; + ] + | Pexp_coerce (expr, typOpt, typ) -> + let docExpr = printExpressionWithComments expr cmtTbl in + let docTyp = printTypExpr typ cmtTbl in + let ofType = match typOpt with + | None -> Doc.nil + | Some(typ1) -> + Doc.concat [Doc.text ": "; printTypExpr typ1 cmtTbl] + in + Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] + | Pexp_send (parentExpr, label) -> + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group ( + Doc.concat [ + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ] + ) + | Pexp_new _ -> + Doc.text "Pexp_new not impemented in printer" + | Pexp_setinstvar _ -> + Doc.text "Pexp_setinstvar not impemented in printer" + | Pexp_override _ -> + Doc.text "Pexp_override not impemented in printer" + | Pexp_poly _ -> + Doc.text "Pexp_poly not impemented in printer" + | Pexp_object _ -> + Doc.text "Pexp_object not impemented in printer" + in + let shouldPrintItsOwnAttributes = match e.pexp_desc with + | Pexp_apply _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_setfield _ + | Pexp_ifthenelse _ -> true + | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true + | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true + | _ -> false + in + match e.pexp_attributes with + | [] -> printedExpression + | attrs when not shouldPrintItsOwnAttributes -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + printedExpression; + ] + ) + | _ -> printedExpression + +and printPexpFun ~inCallback e cmtTbl = + let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsOnArrow + in + let (returnExpr, typConstraint) = match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> ( + {expr with pexp_attributes = List.concat [ + expr.pexp_attributes; + returnExpr.pexp_attributes; + ]}, + Some typ + ) + | _ -> (returnExpr, None) + in + let parametersDoc = printExprFunParameters + ~inCallback + ~uncurried + ~hasConstraint:(match typConstraint with | Some _ -> true | None -> false) + parameters cmtTbl in + let returnShouldIndent = match returnExpr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false + | _ -> true + in + let returnExprDoc = + let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = match (returnExpr.pexp_desc, optBraces) with + | (_, Some _) -> true + | ((Pexp_array _ + | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _), _) -> true + | _ -> false + in + let returnDoc = + let doc = printExpressionWithComments returnExpr cmtTbl in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc + in + if shouldInline then Doc.concat [ + Doc.space; + returnDoc; + ] 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; + ] + ) + in + let typConstraintDoc = match typConstraint with + | Some(typ) -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl + ] + | _ -> Doc.nil + in + Doc.concat [ + printAttributes attrs cmtTbl; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ] + +and printTernaryOperand expr cmtTbl = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.ternaryOperand expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + +and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl = + let rhsDoc = + let doc = printExpressionWithComments rhs cmtTbl in + match Parens.setFieldExprRhs rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + let lhsDoc = + let doc = printExpressionWithComments lhs cmtTbl in + match Parens.fieldExpr lhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc lhs braces + | Nothing -> doc + in + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group (Doc.concat [ + lhsDoc; + Doc.dot; + printLidentPath longidentLoc cmtTbl; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent ( + (Doc.concat [Doc.line; rhsDoc]) + ) + ) else + Doc.concat [Doc.space; rhsDoc] + ]) in + let doc = match attrs with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + in + printComments doc cmtTbl loc + +and printTemplateLiteral expr cmtTbl = + let tag = ref "js" in + let rec walkExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [Nolabel, arg1; Nolabel, arg2] + ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [lhs; rhs] + | Pexp_constant (Pconst_string (txt, Some prefix)) -> + tag := prefix; + printStringContents txt + | _ -> + let doc = printExpressionWithComments expr cmtTbl in + Doc.group ( + Doc.concat [ + Doc.text "${"; + Doc.indent doc; + Doc.rbrace; + ] + ) + in + let content = walkExpr expr in + Doc.concat [ + if !tag = "js" then Doc.nil else Doc.text !tag; + Doc.text "`"; + content; + Doc.text "`" + ] + +and printUnaryExpression expr cmtTbl = + let printUnaryOperator op = Doc.text ( + match op with + | "~+" -> "+" + | "~+." -> "+." + | "~-" -> "-" + | "~-." -> "-." + | "not" -> "!" + | _ -> assert false + ) in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, operand] + ) -> + let printedOperand = + let doc = printExpressionWithComments operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [ + printUnaryOperator operator; + printedOperand; + ] in + printComments doc cmtTbl expr.pexp_loc + | _ -> assert false + +and printBinaryExpression (expr : Parsetree.expression) cmtTbl = + let printBinaryOperator ~inlineRhs operator = + let operatorTxt = match operator with + | "|." -> "->" + | "^" -> "++" + | "=" -> "==" + | "==" -> "===" + | "<>" -> "!=" + | "!=" -> "!==" + | txt -> txt + in + let spacingBeforeOperator = + if operator = "|." then Doc.softLine + else if operator = "|>" then Doc.line + else Doc.space; + in + let spacingAfterOperator = + if operator = "|." then Doc.nil + else if operator = "|>" then Doc.space + else if inlineRhs then Doc.space else Doc.line + in + Doc.concat [ + spacingBeforeOperator; + Doc.text operatorTxt; + spacingAfterOperator; + ] + in + let printOperand ~isLhs expr parentOperator = + let rec flatten ~isLhs expr parentOperator = + if ParsetreeViewer.isBinaryExpression expr then + begin match expr with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [_, left; _, right] + )} -> + if ParsetreeViewer.flattenableOperators parentOperator operator && + not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let (_, rightAttrs) = + ParsetreeViewer.partitionPrinteableAttributes right.pexp_attributes + in + let doc = + printExpressionWithComments + {right with pexp_attributes = rightAttrs} + cmtTbl + in + let doc = if Parens.flattenOperandRhs parentOperator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else + doc + in + let printeableAttrs = + ParsetreeViewer.filterPrinteableAttributes right.pexp_attributes + in + Doc.concat [printAttributes printeableAttrs cmtTbl; doc] + in + let doc = Doc.concat [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] in + let doc = + if not isLhs && (Parens.rhsBinaryExprOperand operator expr) then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else ( + let doc = printExpressionWithComments {expr with pexp_attributes = []} cmtTbl in + let doc = if Parens.subBinaryExprOperand parentOperator operator || + (expr.pexp_attributes <> [] && + (ParsetreeViewer.isBinaryExpression expr || + ParsetreeViewer.isTernaryExpr expr)) + then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + doc + ] + ) + | _ -> assert false + end + else + begin match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [Nolabel, _; Nolabel, _] + ) when loc.loc_ghost -> + let doc = printTemplateLiteral expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc + | Pexp_setfield (lhs, field, rhs) -> + let doc = printSetFieldExpr expr.pexp_attributes lhs field rhs expr.pexp_loc cmtTbl in + if isLhs then addParens doc else doc + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] + ) -> + let rhsDoc = printExpressionWithComments rhs cmtTbl in + let lhsDoc = printExpressionWithComments lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group ( + Doc.concat [ + lhsDoc; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent (Doc.concat [Doc.line; rhsDoc]) + ) else + Doc.concat [Doc.space; rhsDoc] + ] + ) in + let doc = match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + in + if isLhs then addParens doc else doc + | _ -> + let doc = printExpressionWithComments expr cmtTbl in + begin match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + end + end + in + flatten ~isLhs expr parentOperator + in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + [Nolabel, lhs; Nolabel, rhs] + ) when not ( + ParsetreeViewer.isBinaryExpression lhs || + ParsetreeViewer.isBinaryExpression rhs + ) -> + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group ( + Doc.concat [ + lhsDoc; + (match lhsHasCommentBelow, op with + | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil + ); + rhsDoc; + ] + ) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, lhs; Nolabel, rhs] + ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) operator; + rhsDoc; + ] in + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs + in + let doc = Doc.group ( + Doc.concat [ + printOperand ~isLhs:true lhs operator; + right + ] + ) in + Doc.group ( + Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + match Parens.binaryExpr {expr with + pexp_attributes = List.filter (fun attr -> + match attr with + | ({Location.txt = ("ns.braces")}, _) -> false + | _ -> true + ) expr.pexp_attributes + } with + | Braced(bracesLoc) -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc; + ] + ) + | _ -> Doc.nil + +(* callExpr(arg1, arg2) *) +and printPexpApply expr cmtTbl = + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [Nolabel, parentExpr; Nolabel, memberExpr] + ) -> + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments memberExpr cmtTbl + in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group (Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [Nolabel, lhs; Nolabel, rhs] + ) -> + let rhsDoc = + let doc = printExpressionWithComments rhs cmtTbl in + match Parens.expr rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let shouldIndent = not (ParsetreeViewer.isBracedExpr rhs) && ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group( + Doc.concat [ + printExpressionWithComments lhs cmtTbl; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent ( + (Doc.concat [Doc.line; rhsDoc]) + ) + ) else + Doc.concat [Doc.space; rhsDoc] + ] + ) in + begin match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + end + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [Nolabel, parentExpr; Nolabel, memberExpr] + ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = printExpressionWithComments memberExpr cmtTbl in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc else ( + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + memberDoc; + ] + ); + Doc.softLine + ] + ) + in + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group (Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [Nolabel, parentExpr; Nolabel, memberExpr; Nolabel, targetExpr] + ) -> + let member = + let memberDoc = + let doc = printExpressionWithComments memberExpr cmtTbl in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc else ( + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + memberDoc; + ] + ); + Doc.softLine + ] + ) + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then + false + else + ParsetreeViewer.isBinaryExpression targetExpr || + (match targetExpr with + | { + pexp_attributes = [({Location.txt="ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _) + } -> + ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes || + ParsetreeViewer.isArrayAccess e + ) + in + let targetExpr = + let doc = printExpressionWithComments targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group ( + Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + if shouldIndentTargetExpr then + 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 + ) when ParsetreeViewer.isJsxExpression expr -> + printJsxExpression lident args cmtTbl + | Pexp_apply (callExpr, args) -> + let args = List.map (fun (lbl, arg) -> + (lbl, ParsetreeViewer.rewriteUnderscoreApply arg) + ) args + in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + in + let callExprDoc = + let doc = printExpressionWithComments callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc + in + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl + in + Doc.concat [ + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + in + Doc.concat [ + maybeBreakParent; + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~uncurried args cmtTbl in + Doc.concat [ + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + | _ -> assert false + +and printJsxExpression lident args cmtTbl = + let name = printJsxName lident in + let (formattedProps, children) = printJsxProps args cmtTbl in + (*
*) + let isSelfClosing = + match children with + | Some ({Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)}) -> true + | _ -> false + in + Doc.group ( + Doc.concat [ + Doc.group ( + Doc.concat [ + printComments (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; + formattedProps; + if isSelfClosing then Doc.concat [Doc.line; Doc.text "/>"] else Doc.nil + ] + ); + if isSelfClosing then Doc.nil + else + Doc.concat [ + Doc.greaterThan; + Doc.indent ( + Doc.concat [ + Doc.line; + (match children with + | Some childrenExpression -> printJsxChildren childrenExpression cmtTbl + | None -> Doc.nil + ); + ] + ); + Doc.line; + Doc.text "" in + let closing = Doc.text "" in + (* let (children, _) = ParsetreeViewer.collectListExpressions expr in *) + Doc.group ( + Doc.concat [ + opening; + begin match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil + | _ -> + Doc.indent ( + Doc.concat [ + Doc.line; + printJsxChildren expr cmtTbl; + ] + ) + end; + Doc.line; + closing; + ] + ) + +and printJsxChildren (childrenExpr : Parsetree.expression) cmtTbl = + match childrenExpr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let (children, _) = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group ( + Doc.join ~sep:Doc.line ( + List.map (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in + let exprDoc = printExpressionWithComments expr cmtTbl in + match Parens.jsxChildExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens exprDoc else exprDoc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc + ) children + ) + ) + | _ -> + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl childrenExpr.pexp_loc in + let exprDoc = printExpressionWithComments childrenExpr cmtTbl in + Doc.concat [ + Doc.dotdotdot; + match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = if Parens.bracedExpr childrenExpr then addParens exprDoc else exprDoc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc + ] + +and printJsxProps args cmtTbl :(Doc.t * Parsetree.expression option) = + let rec loop props args = + match args with + | [] -> (Doc.nil, None) + | [ + (Asttypes.Labelled "children", children); + ( + Asttypes.Nolabel, + {Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} + ) + ] -> + let formattedProps = Doc.indent ( + match props with + | [] -> Doc.nil + | props -> + Doc.concat [ + Doc.line; + Doc.group ( + Doc.join ~sep:Doc.line (props |> List.rev) + ) + ] + ) in + (formattedProps, Some children) + | arg::args -> + let propDoc = printJsxProp arg cmtTbl in + loop (propDoc::props) args + in + loop [] args + +and printJsxProp arg cmtTbl = + match arg with + | ( + (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, + { + Parsetree.pexp_attributes = [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + pexp_desc = Pexp_ident {txt = Longident.Lident ident} + } + ) when lblTxt = ident (* jsx punning *) -> + begin match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> + printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [ + Doc.question; + printIdentLike ident; + ] in + printComments doc cmtTbl argLoc + end + | ( + (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, + { + Parsetree.pexp_attributes = []; + pexp_desc = Pexp_ident {txt = Longident.Lident ident} + } + ) when lblTxt = ident (* jsx punning when printing from Reason *) -> + begin match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [ + Doc.question; + printIdentLike ident; + ] + end + | (lbl, expr) -> + let (argLoc, expr) = match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> + Location.none, expr + in + let lblDoc = match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal; Doc.question] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in + let doc = printExpressionWithComments expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced(_) -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | _ -> doc + in + let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + printComments + (Doc.concat [ + lblDoc; + exprDoc; + ]) + cmtTbl + fullLoc + +(* div -> div. + * Navabar.createElement -> Navbar + * Staff.Users.createElement -> Staff.Users *) +and printJsxName {txt = lident} = + 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 + | _ -> acc + in + match lident with + | Longident.Lident txt -> Doc.text txt + | _ as lident -> + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) + +and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = + (* Because the same subtree gets printed twice, we need to copy the cmtTbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let cmtTblCopy = CommentTable.copy cmtTbl in + let (callback, printedArgs) = match args with + | (lbl, expr)::args -> + let lblDoc = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; + ] + | Asttypes.Optional txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; + ] + in + let callback = Doc.concat [ + lblDoc; + printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl + ] in + let callback = printComments callback cmtTbl expr.pexp_loc in + let printedArgs = + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun arg -> printArgument arg cmtTbl) args + ) + in + (callback, printedArgs) + | _ -> assert false + in + + (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *) + (* Thing.map((arg1, arg2) => { + * MyModuleBlah.toList(argument) + * }, longArgumet, veryLooooongArgument) + *) + let fitsOnOneLine = Doc.concat [ + if uncurried then Doc.text "(. " else Doc.lparen; + callback; + Doc.comma; + Doc.line; + printedArgs; + Doc.rparen; + ] in + + (* Thing.map( + * (param1, parm2) => doStuff(param1, parm2), + * arg1, + * arg2, + * arg3, + * ) + *) + let breakAllArgs = printArguments ~uncurried args cmtTblCopy in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ~onConfirm={() => ()}, + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if Doc.willBreak printedArgs then + breakAllArgs + else + Doc.customLayout [ + fitsOnOneLine; + breakAllArgs; + ] + +and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = + (* Because the same subtree gets printed twice, we need to copy the cmtTbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let cmtTblCopy = CommentTable.copy cmtTbl in + let cmtTblCopy2 = CommentTable.copy cmtTbl in + let rec loop acc args = match args with + | [] -> (Doc.nil, Doc.nil, Doc.nil) + | [lbl, expr] -> + let lblDoc = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; + ] + | Asttypes.Optional txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; + ] + in + let callbackFitsOnOneLine = + let pexpFunDoc = printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc + in + let callbackArgumentsFitsOnOneLine = + let pexpFunDoc = printPexpFun ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc + in + ( + Doc.concat (List.rev acc), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine + ) + | arg::args -> + let argDoc = printArgument arg cmtTbl in + loop (Doc.line::Doc.comma::argDoc::acc) args + in + let (printedArgs, callback, callback2) = loop [] args in + + (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) + let fitsOnOneLine = Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + printedArgs; + callback; + Doc.rparen; + ] in + + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + let arugmentsFitOnOneLine = + Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + printedArgs; + Doc.breakableGroup ~forceBreak:true callback2; + Doc.rparen; + ] + in + + (* Thing.map( + * arg1, + * arg2, + * arg3, + * (param1, parm2) => doStuff(param1, parm2) + * ) + *) + let breakAllArgs = printArguments ~uncurried args cmtTblCopy2 in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ~onConfirm={() => ()}, + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if Doc.willBreak printedArgs then + breakAllArgs + else + Doc.customLayout [ + fitsOnOneLine; + arugmentsFitOnOneLine; + breakAllArgs; + ] + +and printArguments ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = + match args with + | [Nolabel, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc}] -> + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + begin match uncurried, loc.loc_ghost with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()" + end + | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat [ + if uncurried then Doc.text "(. " else Doc.lparen; + argDoc; + Doc.rparen; + ] + | args -> Doc.group ( + Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + Doc.indent ( + Doc.concat [ + if uncurried then Doc.line else Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun arg -> printArgument arg cmtTbl) args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type *) +and printArgument (argLbl, arg) cmtTbl = + match (argLbl, arg) with + (* ~a (punned)*) + | ( + (Asttypes.Labelled lbl), + ({pexp_desc=Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } as argExpr) + ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + let loc = match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl + ] in + printComments doc cmtTbl loc + + (* ~a: int (punned)*) + | ( + (Asttypes.Labelled lbl), + {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr, + typ + ); + pexp_loc; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) as attrs + } + ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + let loc = match attrs with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + {loc with loc_end = pexp_loc.loc_end} + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] in + printComments doc cmtTbl loc + (* ~a? (optional lbl punned)*) + | ( + (Asttypes.Optional lbl), + {pexp_desc=Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } + ) when lbl = name -> + let loc = match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl; + Doc.question; + ] in + printComments doc cmtTbl loc + | (_lbl, expr) -> + let (argLoc, expr) = match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> + expr.pexp_loc, expr + in + let printedLbl = match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.concat [ + printedLbl; + printedExpr; + ] in + printComments doc cmtTbl loc + +and printCases (cases: Parsetree.case list) cmtTbl = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.concat [ + Doc.line; + printList + ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with + loc_end = + match ParsetreeViewer.processBracesAttr n.Parsetree.pc_rhs with + | (None, _) -> n.pc_rhs.pexp_loc.loc_end + | (Some ({loc}, _), _) -> loc.Location.loc_end + }) + ~print:printCase + ~nodes:cases + cmtTbl + ]; + Doc.line; + Doc.rbrace; + ] + ) + +and printCase (case: Parsetree.case) cmtTbl = + let rhs = match case.pc_rhs.pexp_desc with + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_open _ + | Pexp_sequence _ -> + printExpressionBlock ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl + | _ -> + let doc = printExpressionWithComments case.pc_rhs cmtTbl in + begin match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc + end + + in + let guard = match case.pc_guard with + | None -> Doc.nil + | Some expr -> Doc.group ( + Doc.concat [ + Doc.line; + Doc.text "if "; + printExpressionWithComments expr cmtTbl; + ] + ) + in + let shouldInlineRhs = match case.pc_rhs.pexp_desc with + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_constant _ + | Pexp_ident _ -> true + | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true + | _ -> false + in + let shouldIndentPattern = match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true + in + let patternDoc = + let doc = printPattern case.pc_lhs cmtTbl in + match case.pc_lhs.ppat_desc with + | Ppat_constraint _ -> addParens doc + | _ -> doc + in + let content = Doc.concat [ + if shouldIndentPattern then Doc.indent patternDoc else patternDoc; + Doc.indent guard; + Doc.text " =>"; + Doc.indent ( + Doc.concat [ + if shouldInlineRhs then Doc.space else Doc.line; + rhs; + ] + ) + ] in + Doc.group ( + Doc.concat [ + Doc.text "| "; + content; + ] + ) + +and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters cmtTbl = + match parameters with + (* let f = _ => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {Parsetree.ppat_desc = Ppat_any} + }] when not uncurried -> + if hasConstraint then Doc.text "(_)" else Doc.text "_" + (* let f = a => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {Parsetree.ppat_desc = Ppat_var stringLoc} + }] when not uncurried -> + let txtDoc = + let var = printIdentLike stringLoc.txt in + if hasConstraint then addParens var else var + in + printComments txtDoc cmtTbl stringLoc.loc + (* let f = () => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {ppat_desc = Ppat_construct({txt = Longident.Lident "()"}, None)} + }] when not uncurried -> + Doc.text "()" + (* let f = (~greeting, ~from as hometown, ~x=?) => () *) + | parameters -> + let inCallback = match inCallback with + | FitsOnOneLine -> true + | _ -> false + in + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = Doc.concat [ + if shouldHug || inCallback then Doc.nil else Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun p -> printExpFunParameter p cmtTbl) parameters) + ] in + Doc.group ( + Doc.concat [ + lparen; + if shouldHug || inCallback then + printedParamaters + else + Doc.concat [ + Doc.indent printedParamaters; + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + ) + +and printExpFunParameter parameter cmtTbl = + match parameter with + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space (List.map (fun lbl -> + printComments (printIdentLike lbl.Asttypes.txt) cmtTbl lbl.Asttypes.loc + ) lbls) + ] + ) + | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> + let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = match defaultExpr with + | Some expr -> Doc.concat [ + Doc.text "="; + printExpressionWithComments expr cmtTbl + ] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = match (lbl, pattern) with + | (Asttypes.Nolabel, pattern) -> printPattern pattern cmtTbl + | ( + (Asttypes.Labelled lbl | Optional lbl), + {ppat_desc = Ppat_var stringLoc; + ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } + ) when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + ] + | ( + (Asttypes.Labelled lbl | Optional lbl), + ({ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); + ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + }) + ) when lbl = txt -> + (* ~d: e *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | ((Asttypes.Labelled lbl | Optional lbl), pattern) -> + (* ~b as c *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern pattern cmtTbl + ] + in + let optionalLabelSuffix = match (lbl, defaultExpr) with + | (Asttypes.Optional _, None) -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = Doc.group ( + Doc.concat [ + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; + ] + ) in + let cmtLoc = match defaultExpr with + | None -> + begin match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + {loc with loc_end = pattern.ppat_loc.loc_end} + | _ -> pattern.ppat_loc + end + | Some expr -> + let startPos = match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end + } + in + printComments doc cmtTbl cmtLoc + +and printExpressionBlock ~braces expr cmtTbl = + let rec collectRows acc expr = match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = Doc.concat [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr modExpr cmtTbl; + ] in + let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in + collectRows ((loc, letModuleDoc)::acc) expr2 + | Pexp_letexception (extensionConstructor, expr2) -> + let loc = + let loc = {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let letExceptionDoc = printExceptionDef extensionConstructor cmtTbl in + collectRows ((loc, letExceptionDoc)::acc) expr2 + | Pexp_open (overrideFlag, longidentLoc, expr2) -> + let openDoc = Doc.concat [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] in + let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in + collectRows ((loc, openDoc)::acc) expr2 + | Pexp_sequence (expr1, expr2) -> + let exprDoc = + let doc = printExpression expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc)::acc) expr2 + | Pexp_let (recFlag, valueBindings, expr2) -> + let loc = + let loc = match (valueBindings, List.rev valueBindings) with + | (vb::_, lastVb::_) -> {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + | _ -> Location.none + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = printValueBindings ~recFlag valueBindings cmtTbl in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + begin match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, letDoc)::acc) + | _ -> + collectRows ((loc, letDoc)::acc) expr2 + end + | _ -> + let exprDoc = + let doc = printExpression expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc)::acc) + in + let rows = collectRows [] expr in + let block = + printList + ~getLoc:fst + ~nodes:rows + ~print:(fun (_, doc) _ -> doc) + ~forceBreak:true + 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 + ) + +(* + * // user types: + * let f = (a, b) => { a + b } + * + * // printer: everything is on one line + * let f = (a, b) => { a + b } + * + * // user types: over multiple lines + * let f = (a, b) => { + * a + b + * } + * + * // printer: over multiple lines + * let f = (a, b) => { + * a + b + * } + *) +and printBraces doc expr bracesLoc = + let overMultipleLines = + let open Location in + bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum + in + match expr.Parsetree.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> + (* already has braces *) + doc + | _ -> + Doc.breakableGroup ~forceBreak:overMultipleLines ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + if Parens.bracedExpr expr then addParens doc else doc; + ] + ); + Doc.softLine; + Doc.rbrace; + ] + ) + +and printOverrideFlag overrideFlag = match overrideFlag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil + +and printDirectionFlag flag = match flag with + | Asttypes.Downto -> Doc.text " downto " + | Asttypes.Upto -> Doc.text " to " + +and printRecordRow (lbl, expr) cmtTbl = + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.group (Doc.concat [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in + printComments doc cmtTbl cmtLoc + +and printBsObjectRow (lbl, expr) cmtTbl = + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let lblDoc = + let doc = Doc.concat [ + Doc.text "\""; + printLongident lbl.txt; + Doc.text "\""; + ] in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.concat [ + lblDoc; + Doc.text ": "; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] in + printComments doc cmtTbl cmtLoc + +(* The optional loc indicates whether we need to print the attributes in + * relation to some location. In practise this means the following: + * `@attr type t = string` -> on the same line, print on the same line + * `@attr + * type t = string` -> attr is on prev line, print the attributes + * with a line break between, we respect the users' original layout *) +and printAttributes ?loc ?(inline=false) (attrs: Parsetree.attributes) cmtTbl = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> Doc.nil + | attrs -> + let lineBreak = match loc with + | None -> Doc.line + | Some loc -> begin match List.rev attrs with + | ({loc = firstLoc}, _)::_ when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine; + | _ -> Doc.line + end + in + Doc.concat [ + Doc.group (Doc.join ~sep:Doc.line (List.map (fun attr -> printAttribute attr cmtTbl) attrs)); + if inline then Doc.space else lineBreak; + ] + +and printPayload (payload : Parsetree.payload) cmtTbl = + match payload with + | PStr [] -> Doc.nil + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let exprDoc = printExpressionWithComments expr cmtTbl in + let needsParens = match attrs with | [] -> false | _ -> true in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then + Doc.concat [ + Doc.lparen; + printAttributes attrs cmtTbl; + if needsParens then addParens exprDoc else exprDoc; + Doc.rparen; + ] + else + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printAttributes attrs cmtTbl; + if needsParens then addParens exprDoc else exprDoc; + ] + ); + Doc.softLine; + Doc.rparen; + ] + | PStr [{pstr_desc = Pstr_value (_recFlag, _bindings)} as si] -> + addParens(printStructureItem si cmtTbl) + | PStr structure -> + addParens(printStructure structure cmtTbl) + | PTyp typ -> + Doc.concat [ + Doc.lparen; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + printTypExpr typ cmtTbl; + ]; + ); + Doc.softLine; + Doc.rparen; + ] + | PPat (pat, optExpr) -> + let whenDoc = match optExpr with + | Some expr -> + Doc.concat [ + Doc.line; + Doc.text "if "; + printExpressionWithComments expr cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.text "? "; + printPattern pat cmtTbl; + whenDoc; + ] + ); + Doc.softLine; + Doc.rparen; + ] + | PSig signature -> + Doc.concat [ + Doc.lparen; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + printSignature signature cmtTbl; + ]; + ); + Doc.softLine; + Doc.rparen; + ] + +and printAttribute ((id, payload) : Parsetree.attribute) cmtTbl = + Doc.group ( + Doc.concat [ + Doc.text "@"; + Doc.text (convertBsExternalAttribute id.txt); + printPayload payload cmtTbl + ] + ) + +and printModExpr modExpr cmtTbl = + let doc = match modExpr.pmod_desc with + | Pmod_ident longidentLoc -> + printLongidentLocation longidentLoc cmtTbl + | Pmod_structure [] -> + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printCommentsInside cmtTbl modExpr.pmod_loc; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmod_structure structure -> + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printStructure structure cmtTbl; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmod_unpack expr -> + let shouldHug = match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint ( + {pexp_desc = Pexp_let _ }, + {ptyp_desc = Ptyp_package _packageType} + ) -> true + | _ -> false + in + let (expr, moduleConstraint) = match expr.pexp_desc with + | Pexp_constraint ( + expr, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} + ) -> + let packageDoc = + let doc = printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = Doc.group (Doc.concat [ + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + packageDoc + ] + ) + ]) in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = Doc.group(Doc.concat [ + printExpressionWithComments expr cmtTbl; + moduleConstraint; + ]) in + Doc.group ( + Doc.concat [ + Doc.text "unpack("; + if shouldHug then unpackDoc + else + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + unpackDoc; + ] + ); + Doc.softLine; + ]; + Doc.rparen; + ] + ) + | Pmod_extension extension -> + printExtension ~atModuleLvl:false extension cmtTbl + | Pmod_apply _ -> + let (args, callExpr) = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let shouldHug = match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group ( + Doc.concat [ + printModExpr callExpr cmtTbl; + if isUnitSugar then + printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl + else + Doc.concat [ + Doc.lparen; + if shouldHug then + printModApplyArg (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 modArg cmtTbl) args + ) + ] + ); + if not shouldHug then + Doc.concat [ + Doc.trailingComma; + Doc.softLine; + ] + else Doc.nil; + Doc.rparen; + ] + ] + ) + | Pmod_constraint (modExpr, modType) -> + Doc.concat [ + printModExpr modExpr cmtTbl; + Doc.text ": "; + printModType modType cmtTbl; + ] + | Pmod_functor _ -> + printModFunctor modExpr cmtTbl + in + printComments doc cmtTbl modExpr.pmod_loc + +and printModFunctor modExpr cmtTbl = + let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor modExpr in + (* let shouldInline = match returnModExpr.pmod_desc with *) + (* | Pmod_structure _ | Pmod_ident _ -> true *) + (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) + (* | _ -> false *) + (* in *) + let (returnConstraint, returnModExpr) = match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) -> + let constraintDoc = + let doc = printModType modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [ + Doc.text ": "; + constraintDoc; + ] in + (modConstraint, printModExpr modExpr cmtTbl) + | _ -> (Doc.nil, printModExpr returnModExpr cmtTbl) + in + let parametersDoc = match parameters with + | [(attrs, {txt = "*"}, None)] -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.text "()" + ] + ) + | [([], {txt = lbl}, None)] -> Doc.text lbl + | parameters -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun param -> printModFunctorParam param cmtTbl) parameters + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + Doc.group ( + Doc.concat [ + parametersDoc; + returnConstraint; + Doc.text " => "; + returnModExpr + ] + ) + +and printModFunctorParam (attrs, lbl, optModType) cmtTbl = + let cmtLoc = match optModType with + | None -> lbl.Asttypes.loc + | Some modType -> {lbl.loc with loc_end = + modType.Parsetree.pmty_loc.loc_end + } + in + let attrs = printAttributes attrs cmtTbl in + let lblDoc = + let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.group ( + Doc.concat [ + attrs; + lblDoc; + (match optModType with + | None -> Doc.nil + | Some modType -> + Doc.concat [ + Doc.text ": "; + printModType modType cmtTbl + ]); + ] + ) in + printComments doc cmtTbl cmtLoc + +and printModApplyArg modExpr cmtTbl = + match modExpr.pmod_desc with + | Pmod_structure [] -> Doc.text "()" + | _ -> printModExpr modExpr cmtTbl + + +and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = + let kind = match constr.pext_kind with + | Pext_rebind longident -> Doc.indent ( + Doc.concat [ + Doc.text " ="; + Doc.line; + printLongidentLocation longident cmtTbl; + ] + ) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadtDoc = match gadt with + | Some typ -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl + ] + | None -> Doc.nil + in + Doc.concat [ + printConstructorArguments ~indent:false args cmtTbl; + gadtDoc + ] + in + let name = + printComments + (Doc.text constr.pext_name.txt) + cmtTbl + constr.pext_name.loc + in + let doc = Doc.group ( + Doc.concat [ + printAttributes constr.pext_attributes cmtTbl; + Doc.text "exception "; + name; + kind + ] + ) in + printComments doc cmtTbl constr.pext_loc + +and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl i = + let attrs = printAttributes constr.pext_attributes cmtTbl in + let bar = if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil + in + let kind = match constr.pext_kind with + | Pext_rebind longident -> Doc.indent ( + Doc.concat [ + Doc.text " ="; + Doc.line; + printLongidentLocation longident cmtTbl; + ] + ) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadtDoc = match gadt with + | Some typ -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat [ + printConstructorArguments ~indent:false args cmtTbl; + gadtDoc + ] + in + let name = + printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc + in + Doc.concat [ + bar; + Doc.group ( + Doc.concat [ + attrs; + name; + kind; + ] + ) + ] + +let printImplementation ~width (s: Parsetree.structure) ~comments = + let cmtTbl = CommentTable.make () in + CommentTable.walkStructure s cmtTbl comments; + (* CommentTable.log cmtTbl; *) + let doc = printStructure s cmtTbl in + (* Doc.debug doc; *) + Doc.toString ~width doc ^ "\n" + +let printInterface ~width (s: Parsetree.signature) ~comments = + let cmtTbl = CommentTable.make () in + CommentTable.walkSignature s cmtTbl comments; + Doc.toString ~width (printSignature s cmtTbl) ^ "\n" diff --git a/analysis/src/vendor/res_outcome_printer/res_printer.mli b/analysis/src/vendor/res_outcome_printer/res_printer.mli new file mode 100644 index 000000000..bfd0cd4d1 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_printer.mli @@ -0,0 +1,20 @@ +val convertBsExternalAttribute : string -> string +val convertBsExtension : string -> string + +val printTypeParams : + (Parsetree.core_type * Asttypes.variance) list -> Res_comments_table.t -> Res_doc.t + +val printLongident : Longident.t -> Res_doc.t + +val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t + +val addParens : Res_doc.t -> Res_doc.t + +val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t + +val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t [@@live] + +val printImplementation : + width:int -> Parsetree.structure -> comments:Res_comment.t list -> string +val printInterface : + width:int -> Parsetree.signature -> comments:Res_comment.t list -> string diff --git a/analysis/src/vendor/res_outcome_printer/res_reporting.ml b/analysis/src/vendor/res_outcome_printer/res_reporting.ml new file mode 100644 index 000000000..f5bd4fe7a --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_reporting.ml @@ -0,0 +1,12 @@ +module Token = Res_token +module Grammar = Res_grammar + +type problem = + | Unexpected of Token.t [@live] + | Expected of {token: Token.t; pos: Lexing.position; context: Grammar.t option} [@live] + | Message of string [@live] + | Uident [@live] + | Lident [@live] + | Unbalanced of Token.t [@live] + +type parseError = Lexing.position * problem diff --git a/analysis/src/vendor/res_outcome_printer/res_scanner.ml b/analysis/src/vendor/res_outcome_printer/res_scanner.ml new file mode 100644 index 000000000..b6855f6ce --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_scanner.ml @@ -0,0 +1,716 @@ +module Diagnostics = Res_diagnostics +module Token = Res_token +module Comment = Res_comment + +type mode = Jsx | Diamond + +(* We hide the implementation detail of the scanner reading character. Our char +will also contain the special -1 value to indicate end-of-file. This isn't +ideal; we should clean this up *) +let hackyEOFChar = Char.unsafe_chr (-1) +type charEncoding = Char.t + +type t = { + filename: string; + src: string; + mutable err: + startPos: Lexing.position + -> endPos: Lexing.position + -> Diagnostics.category + -> unit; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +let setDiamondMode scanner = + scanner.mode <- Diamond::scanner.mode + +let setJsxMode scanner = + scanner.mode <- Jsx::scanner.mode + +let popMode scanner mode = + match scanner.mode with + | m::ms when m = mode -> + scanner.mode <- ms + | _ -> () + +let inDiamondMode scanner = match scanner.mode with + | Diamond::_ -> true + | _ -> false + +let inJsxMode scanner = match scanner.mode with + | Jsx::_ -> true + | _ -> false + +let position scanner = Lexing.{ + pos_fname = scanner.filename; + (* line number *) + pos_lnum = scanner.lnum; + (* offset of the beginning of the line (number + of characters between the beginning of the scanner and the beginning + of the line) *) + pos_bol = scanner.lineOffset; + (* [pos_cnum] is the offset of the position (number of + characters between the beginning of the scanner and the position). *) + pos_cnum = scanner.offset; +} + +(* Small debugging util +❯ echo 'let msg = "hello"' | ./lib/rescript.exe +let msg = "hello" +^-^ let 0-3 +let msg = "hello" + ^-^ msg 4-7 +let msg = "hello" + ^ = 8-9 +let msg = "hello" + ^-----^ string "hello" 10-17 +let msg = "hello" + ^ eof 18-18 +let msg = "hello" +*) +let _printDebug ~startPos ~endPos scanner token = + let open Lexing in + print_string scanner.src; + print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' '); + print_char '^'; + (match endPos.pos_cnum - startPos.pos_cnum with + | 0 -> + if token = Token.Eof then () + else assert false + | 1 -> () + | n -> ( + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'; + )); + print_char ' '; + print_string (Res_token.toString token); + print_char ' '; + print_int startPos.pos_cnum; + print_char '-'; + print_int endPos.pos_cnum; + print_endline "" +[@@live] + +let next scanner = + let nextOffset = scanner.offset + 1 in + (match scanner.ch with + | '\n' -> + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1; + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) + | _ -> ()); + if nextOffset < String.length scanner.src then ( + scanner.offset <- nextOffset; + scanner.ch <- String.unsafe_get scanner.src scanner.offset; + ) else ( + scanner.offset <- String.length scanner.src; + scanner.ch <- hackyEOFChar + ) + +let next2 scanner = + next scanner; + next scanner + +let next3 scanner = + next scanner; + next scanner; + next scanner + +let peek scanner = + if scanner.offset + 1 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 1) + else + hackyEOFChar + +let peek2 scanner = + if scanner.offset + 2 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 2) + else + hackyEOFChar + +let make ~filename src = + { + filename; + src = src; + err = (fun ~startPos:_ ~endPos:_ _ -> ()); + ch = if src = "" then hackyEOFChar else String.unsafe_get src 0; + offset = 0; + lineOffset = 0; + lnum = 1; + mode = []; + } + + +(* generic helpers *) + +let isWhitespace ch = + match ch with + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false + +let rec skipWhitespace scanner = + if isWhitespace scanner.ch then ( + next scanner; + skipWhitespace scanner + ) + +let digitValue ch = + match ch with + | '0'..'9' -> (Char.code ch) - 48 + | 'a'..'f' -> + (Char.code ch) - (Char.code 'a') + 10 + | 'A'..'F' -> + (Char.code ch) + 32 - (Char.code 'a') + 10 + | _ -> 16 (* larger than any legal value *) + +let rec skipLowerCaseChars scanner = + match scanner.ch with + | 'a'..'z' -> next scanner; skipLowerCaseChars scanner + | _ -> () + + +(* scanning helpers *) + +let scanIdentifier scanner = + let startOff = scanner.offset in + let rec skipGoodChars scanner = + match scanner.ch with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> + next scanner; + skipGoodChars scanner + | _ -> () + in + skipGoodChars scanner; + let str = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in + if '{' == scanner.ch && str = "list" then begin + next scanner; + (* TODO: this isn't great *) + Token.lookupKeyword "list{" + end + else Token.lookupKeyword str + +let scanDigits scanner ~base = + if base <= 10 then + let rec loop scanner = + match scanner.ch with + | '0'..'9' | '_' -> next scanner; loop scanner + | _ -> () + in loop scanner + else + let rec loop scanner = + match scanner.ch with + (* hex *) + | '0'..'9' | 'a'..'f' | 'A'..'F' | '_' -> next scanner; loop scanner + | _ -> () + in loop scanner + +(* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) +let scanNumber scanner = + let startOff = scanner.offset in + + (* integer part *) + let base = match scanner.ch with + | '0' -> + (match peek scanner with + | 'x' | 'X' -> next2 scanner; 16 + | 'o' | 'O' -> next2 scanner; 8 + | 'b' | 'B' -> next2 scanner; 2 + | _ -> next scanner; 8) + | _ -> 10 + in + scanDigits scanner ~base; + + (* *) + let isFloat = if '.' == scanner.ch then ( + next scanner; + scanDigits scanner ~base; + true + ) else + false + in + + (* exponent part *) + let isFloat = + match scanner.ch with + | 'e' | 'E' | 'p' | 'P' -> + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true + | _ -> isFloat + in + let literal = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + in + + (* suffix *) + let suffix = + match scanner.ch with + | 'n' -> + let msg = + "Unsupported number type (nativeint). Did you mean `" + ^ literal + ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' + | 'g'..'z' | 'G'..'Z' as ch -> + next scanner; + Some ch + | _ -> + None + in + if isFloat then + Token.Float {f = literal; suffix} + else + Token.Int {i = literal; suffix} + +let scanExoticIdentifier scanner = + (* TODO: are we disregarding the current char...? Should be a quote *) + next scanner; + let buffer = Buffer.create 20 in + let startPos = position scanner in + + let rec scan () = + match scanner.ch with + | '"' -> next scanner + | '\n' | '\r' -> + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner + | ch when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?") + | ch -> + Buffer.add_char buffer ch; + next scanner; + scan () + in + scan (); + (* TODO: do we really need to create a new buffer instead of substring once? *) + Token.Lident (Buffer.contents buffer) + +let scanStringEscapeSequence ~startPos scanner = + let scan ~n ~base ~max = + let rec loop n x = + if n == 0 then x + else + let d = digitValue scanner.ch in + if d >= base then + let pos = position scanner in + let msg = + if scanner.ch == hackyEOFChar then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); + -1 + else + let () = next scanner in + loop (n - 1) (x * base + d) + in + let x = loop n 0 in + if x > max then + let pos = position scanner in + let msg = "invalid escape sequence (value too high)" in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + in + match scanner.ch with + (* \ already consumed *) + | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> + next scanner + | '0'..'9' -> + (* decimal *) + scan ~n:3 ~base:10 ~max:255 + | 'o' -> + (* octal *) + next scanner; + scan ~n:3 ~base:8 ~max:255 + | 'x' -> + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 + | _ -> + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* + let pos = position scanner in + let msg = + if ch == -1 then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + *) + () + +let scanString scanner = + (* assumption: we've just matched a quote *) + + let startPosWithQuote = position scanner in + next scanner; + let firstCharOffset = scanner.offset in + + let rec scan () = + match scanner.ch with + | '"' -> + let lastCharOffset = scanner.offset in + next scanner; + (String.sub [@doesNotRaise]) scanner.src firstCharOffset (lastCharOffset - firstCharOffset) + | '\\' -> + let startPos = position scanner in + next scanner; + scanStringEscapeSequence ~startPos scanner; + scan () + | ch when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; + (String.sub [@doesNotRaise]) scanner.src firstCharOffset (scanner.offset - firstCharOffset) + | _ -> + next scanner; + scan () + in + Token.String (scan ()) + +let scanEscape scanner = + let convertNumber scanner ~n ~base = + let x = ref 0 in + for _ = n downto 1 do + let d = digitValue scanner.ch in + x := (!x * base) + d; + next scanner + done; + (Char.chr [@doesNotRaise]) !x + in + (* let offset = scanner.offset in *) + let c = match scanner.ch with + | '0'..'9' -> convertNumber scanner ~n:3 ~base:10 + | 'b' -> next scanner; '\008' + | 'n' -> next scanner; '\010' + | 'r' -> next scanner; '\013' + | 't' -> next scanner; '\009' + | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16 + | 'o' -> next scanner; convertNumber scanner ~n:3 ~base:8 + | ch -> next scanner; ch + in + next scanner; (* Consume \' *) + (* TODO: do we know it's \' ? *) + Token.Character c + +let scanSingleLineComment scanner = + let startOff = scanner.offset in + let startPos = position scanner in + let rec skip scanner = + match scanner.ch with + | '\n' | '\r' -> () + | ch when ch == hackyEOFChar -> () + | _ -> + next scanner; + skip scanner + in + skip scanner; + let endPos = position scanner in + Token.Comment ( + Comment.makeSingleLineComment + ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false}) + ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff)) + ) + +let scanMultiLineComment scanner = + (* assumption: we're only ever using this helper in `scan` after detecting a comment *) + let contentStartOff = scanner.offset + 2 in + let startPos = position scanner in + let rec scan ~depth = + (* invariant: depth > 0 right after this match. See assumption *) + match scanner.ch, peek scanner with + | '/', '*' -> + next2 scanner; + scan ~depth:(depth + 1) + | '*', '/' -> + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) + | ch, _ when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment + | _ -> + next scanner; + scan ~depth + in + scan ~depth:0; + Token.Comment ( + Comment.makeMultiLineComment + ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false}) + ((String.sub [@doesNotRaise]) scanner.src contentStartOff (scanner.offset - 2 - contentStartOff)) + ) + +let scanTemplateLiteralToken scanner = + let startOff = scanner.offset in + + (* if starting } here, consume it *) + if scanner.ch == '}' then next scanner; + + let startPos = position scanner in + + let rec scan () = + match scanner.ch with + | '`' -> + next scanner; + Token.TemplateTail( + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 1 - startOff) + ) + | '$' -> + (match peek scanner with + | '{' -> + next2 scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 2 - startOff) + in + Token.TemplatePart contents + | _ -> + next scanner; + scan()) + | '\\' -> + (match peek scanner with + | '`' | '\\' | '$' + | '\n' | '\r' -> + (* line break *) + next2 scanner; + scan () + | _ -> + next scanner; + scan ()) + | ch when ch = hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + Token.TemplateTail( + (String.sub [@doesNotRaise]) scanner.src startOff (max (scanner.offset - 1 - startOff) 0) + ) + | _ -> + next scanner; + scan () + in + let token = scan () in + let endPos = position scanner in + (startPos, endPos, token) + +let rec scan scanner = + skipWhitespace scanner; + let startPos = position scanner in + + let token = match scanner.ch with + (* peeking 0 char *) + | 'A'..'Z' | 'a'..'z' -> scanIdentifier scanner + | '0'..'9' -> scanNumber scanner + | '`' -> next scanner; Token.Backtick + | '~' -> next scanner; Token.Tilde + | '?' -> next scanner; Token.Question + | ';' -> next scanner; Token.Semicolon + | '(' -> next scanner; Token.Lparen + | ')' -> next scanner; Token.Rparen + | '[' -> next scanner; Token.Lbracket + | ']' -> next scanner; Token.Rbracket + | '{' -> next scanner; Token.Lbrace + | '}' -> next scanner; Token.Rbrace + | ',' -> next scanner; Token.Comma + | '"' -> scanString scanner + + (* peeking 1 char *) + | '_' -> + (match peek scanner with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> scanIdentifier scanner + | _ -> next scanner; Token.Underscore) + | '#' -> + (match peek scanner with + | '=' -> next2 scanner; Token.HashEqual + | _ -> next scanner; Token.Hash) + | '*' -> + (match peek scanner with + | '*' -> next2 scanner; Token.Exponentiation + | '.' -> next2 scanner; Token.AsteriskDot + | _ -> next scanner; Token.Asterisk) + | '@' -> + (match peek scanner with + | '@' -> next2 scanner; Token.AtAt + | _ -> next scanner; Token.At) + | '%' -> + (match peek scanner with + | '%' -> next2 scanner; Token.PercentPercent + | _ -> next scanner; Token.Percent) + | '|' -> + (match peek scanner with + | '|' -> next2 scanner; Token.Lor + | '>' -> next2 scanner; Token.BarGreater + | _ -> next scanner; Token.Bar) + | '&' -> + (match peek scanner with + | '&' -> next2 scanner; Token.Land + | _ -> next scanner; Token.Band) + | ':' -> + (match peek scanner with + | '=' -> next2 scanner; Token.ColonEqual + | '>' -> next2 scanner; Token.ColonGreaterThan + | _ -> next scanner; Token.Colon) + | '\\' -> next scanner; scanExoticIdentifier scanner + | '/' -> + (match peek scanner with + | '/' -> next2 scanner; scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> next2 scanner; Token.ForwardslashDot + | _ -> next scanner; Token.Forwardslash) + | '-' -> + (match peek scanner with + | '.' -> next2 scanner; Token.MinusDot + | '>' -> next2 scanner; Token.MinusGreater + | _ -> next scanner; Token.Minus) + | '+' -> + (match peek scanner with + | '.' -> next2 scanner; Token.PlusDot + | '+' -> next2 scanner; Token.PlusPlus + | '=' -> next2 scanner; Token.PlusEqual + | _ -> next scanner; Token.Plus) + | '>' -> + (match peek scanner with + | '=' when not (inDiamondMode scanner) -> next2 scanner; Token.GreaterEqual + | _ -> next scanner; Token.GreaterThan) + | '<' when not (inJsxMode scanner) -> + (match peek scanner with + | '=' -> next2 scanner; Token.LessEqual + | _ -> next scanner; Token.LessThan) + (* special handling for JSX < *) + | '<' -> + (* Imagine the following:
< + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the next scanner; Token.LessThanSlash + | '=' -> next scanner; Token.LessEqual + | _ -> Token.LessThan) + + (* peeking 2 chars *) + | '.' -> + (match peek scanner, peek2 scanner with + | '.', '.' -> next3 scanner; Token.DotDotDot + | '.', _ -> next2 scanner; Token.DotDot + | _ -> next scanner; Token.Dot) + | '\'' -> + (match peek scanner, peek2 scanner with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; SingleQuote + | '\\', _ -> next2 scanner; scanEscape scanner + | ch, '\'' -> next3 scanner; Token.Character ch + | _ -> next scanner; SingleQuote) + | '!' -> + (match peek scanner, peek2 scanner with + | '=', '=' -> next3 scanner; Token.BangEqualEqual + | '=', _ -> next2 scanner; Token.BangEqual + | _ -> next scanner; Token.Bang) + | '=' -> + (match peek scanner, peek2 scanner with + | '=', '=' -> next3 scanner; Token.EqualEqualEqual + | '=', _ -> next2 scanner; Token.EqualEqual + | '>', _ -> next2 scanner; Token.EqualGreater + | _ -> next scanner; Token.Equal) + + (* special cases *) + | ch when ch == hackyEOFChar -> next scanner; Token.Eof + | ch -> + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let (_, _, token) = scan scanner in + token + in + let endPos = position scanner in + (* _printDebug ~startPos ~endPos scanner token; *) + (startPos, endPos, token) + + +(* misc helpers used elsewhere *) + +(* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) +let reconsiderLessThan scanner = + (* < consumed *) + skipWhitespace scanner; + if scanner.ch == '/' then + let () = next scanner in + Token.LessThanSlash + else + Token.LessThan + +(* If an operator has whitespace around both sides, it's a binary operator *) +(* TODO: this helper seems out of place *) +let isBinaryOp src startCnum endCnum = + if startCnum == 0 then false + else begin + (* we're gonna put some assertions and invariant checks here because this is + used outside of the scanner's normal invariant assumptions *) + assert (endCnum >= 0); + assert (startCnum > 0 && startCnum < String.length src); + let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in + (* we need some stronger confidence that endCnum is ok *) + let rightOk = endCnum >= String.length src || isWhitespace (String.unsafe_get src endCnum) in + leftOk && rightOk + end + +(* Assume `{` consumed, advances the scanner towards the ends of Reason quoted strings. (for conversion) + * In {| foo bar |} the scanner will be advanced until after the `|}` *) +let tryAdvanceQuotedString scanner = + let rec scanContents tag = + match scanner.ch with + | '|' -> + next scanner; + (match scanner.ch with + | 'a'..'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + in begin + if tag = suffix then ( + if scanner.ch = '}' then + next scanner + else + scanContents tag + ) else + scanContents tag + end + | '}' -> next scanner + | _ -> scanContents tag) + | ch when ch == hackyEOFChar -> + (* TODO: why is this place checking EOF and not others? *) + () + | _ -> + next scanner; + scanContents tag + in + match scanner.ch with + | 'a'..'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in + if scanner.ch = '|' then scanContents tag + | '|' -> + scanContents "" + | _ -> () diff --git a/analysis/src/vendor/res_outcome_printer/res_scanner.mli b/analysis/src/vendor/res_outcome_printer/res_scanner.mli new file mode 100644 index 000000000..777d171e6 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_scanner.mli @@ -0,0 +1,35 @@ +type mode = Jsx | Diamond + +type charEncoding + +type t = { + filename: string; + src: string; + mutable err: + startPos: Lexing.position + -> endPos: Lexing.position + -> Res_diagnostics.category + -> unit; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +val make: filename:string -> string -> t + +(* TODO: make this a record *) +val scan: t -> (Lexing.position * Lexing.position * Res_token.t) + +val isBinaryOp: string -> int -> int -> bool + +val setJsxMode: t -> unit +val setDiamondMode: t -> unit +val popMode: t -> mode -> unit + +val reconsiderLessThan: t -> Res_token.t + +val scanTemplateLiteralToken: t -> (Lexing.position * Lexing.position * Res_token.t) + +val tryAdvanceQuotedString: t -> unit From af5791173ebb75bac65bf27ca08cf40301393617 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 9 Mar 2022 17:12:08 +0100 Subject: [PATCH 02/41] Complete vendoring of necessary compiler libs. --- .../src/vendor/compiler-libs-406/parse.ml | 67 + .../src/vendor/compiler-libs-406/parse.mli | 24 + .../src/vendor/compiler-libs-406/pprintast.ml | 1498 +++++++++++++++++ .../src/vendor/compiler-libs-406/printast.ml | 918 ++++++++++ 4 files changed, 2507 insertions(+) create mode 100644 analysis/src/vendor/compiler-libs-406/parse.ml create mode 100644 analysis/src/vendor/compiler-libs-406/parse.mli create mode 100644 analysis/src/vendor/compiler-libs-406/pprintast.ml create mode 100644 analysis/src/vendor/compiler-libs-406/printast.ml diff --git a/analysis/src/vendor/compiler-libs-406/parse.ml b/analysis/src/vendor/compiler-libs-406/parse.ml new file mode 100644 index 000000000..ba89f0e2e --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/parse.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Entry points in the parser *) + +(* Skip tokens to the end of the phrase *) + +let rec skip_phrase lexbuf = + try + match Lexer.token lexbuf with + Parser.SEMISEMI | Parser.EOF -> () + | _ -> skip_phrase lexbuf + with + | Lexer.Error (Lexer.Unterminated_comment _, _) + | Lexer.Error (Lexer.Unterminated_string, _) + | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) + | Lexer.Error (Lexer.Illegal_character _, _) -> skip_phrase lexbuf +;; + +let maybe_skip_phrase lexbuf = + if Parsing.is_current_lookahead Parser.SEMISEMI + || Parsing.is_current_lookahead Parser.EOF + then () + else skip_phrase lexbuf + +let wrap parsing_fun lexbuf = + try + Docstrings.init (); + Lexer.init (); + let ast = parsing_fun Lexer.token lexbuf in + Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); + ast + with + | Lexer.Error(Lexer.Illegal_character _, _) as err + when !Location.input_name = "//toplevel//"-> + skip_phrase lexbuf; + raise err + | Syntaxerr.Error _ as err + when !Location.input_name = "//toplevel//" -> + maybe_skip_phrase lexbuf; + raise err + | Parsing.Parse_error | Syntaxerr.Escape_error -> + let loc = Location.curr lexbuf in + if !Location.input_name = "//toplevel//" + then maybe_skip_phrase lexbuf; + raise(Syntaxerr.Error(Syntaxerr.Other loc)) + +let implementation = wrap Parser.implementation +and interface = wrap Parser.interface +and toplevel_phrase = wrap Parser.toplevel_phrase +and use_file = wrap Parser.use_file +and core_type = wrap Parser.parse_core_type +and expression = wrap Parser.parse_expression +and pattern = wrap Parser.parse_pattern diff --git a/analysis/src/vendor/compiler-libs-406/parse.mli b/analysis/src/vendor/compiler-libs-406/parse.mli new file mode 100644 index 000000000..8e6eb4544 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/parse.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Entry points in the parser *) + +val implementation : Lexing.lexbuf -> Parsetree.structure +val interface : Lexing.lexbuf -> Parsetree.signature +val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase +val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list +val core_type : Lexing.lexbuf -> Parsetree.core_type +val expression : Lexing.lexbuf -> Parsetree.expression +val pattern : Lexing.lexbuf -> Parsetree.pattern diff --git a/analysis/src/vendor/compiler-libs-406/pprintast.ml b/analysis/src/vendor/compiler-libs-406/pprintast.ml new file mode 100644 index 000000000..4956e8dc6 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/pprintast.ml @@ -0,0 +1,1498 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree +open Ast_helper + +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function | `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || List.mem txt.[0] prefix_symbols + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + txt.[0]='*' || txt.[String.length txt - 1] = '*' + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil + | Pexp_construct ( {txt= Lident"::";_},Some _) -> + let rec loop exp acc = match exp with + | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + loop e2 (e1::acc) + | e -> (List.rev (e::acc),false) in + let (ls,b) = loop x [] in + if b then + `list ls + else `cons ls + | Pexp_construct (x,None) -> `simple (x.txt) + | _ -> `normal + +let is_simple_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs + +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last + +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let constant f = function + | Pconst_char i -> pp f "%C" i + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> + pp f "%s%c" i m) f (i,m) + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) + | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> + list_of_pattern (p2::acc) p1 + | x -> x::acc + in + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> (* *) + pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x + +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} + + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack (s) -> + pp f "(module@ %s)@ " s.txt + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left right + (expression ctxt) [i] rest + | _ -> false + end + | _ -> false + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" + (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = + List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l + +and attribute ctxt f (s, e) = + pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e + +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim + ) x + +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + let class_type_field f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + in + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list class_type_field ~sep:"@;") l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l + +and class_expr ctxt f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} + (attributes ctxt) x.pcl_attributes + end else + match x.pcl_desc with + | Pcl_structure (cs) -> class_structure ctxt f cs + | Pcl_fun (l, eo, p, e) -> + pp f "fun@ %a@ ->@ %a" + (label_exp ctxt) (l,eo,p) + (class_expr ctxt) e + | Pcl_let (rf, l, ce) -> + pp f "%a@ in@ %a" + (bindings ctxt) (rf,l) + (class_expr ctxt) ce + | Pcl_apply (ce, l) -> + pp f "((%a)@ %a)" (* Cf: #7200 *) + (class_expr ctxt) ce + (list (label_x_expression_param ctxt)) l + | Pcl_constr (li, l) -> + pp f "%a%a" + (fun f l-> if l <>[] then + pp f "[%a]@ " + (list (core_type ctxt) ~sep:",") l) l + longident_loc li + | Pcl_constraint (ce, ct) -> + pp f "(%a@ :@ %a)" + (class_expr ctxt) ce + (class_type ctxt) ct + | Pcl_extension e -> extension ctxt f e + | Pcl_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_expr ctxt) e + +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" + (module_type ctxt) mt1 (module_type ctxt) mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt + (module_type ctxt) mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 in + (match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> pp f "@[(%a@ with@ %a)@]" + (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class l -> + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_description "class") x + (list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + s.txt (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":"; core_type ctxt f x + | PSig x -> pp f ":"; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; pattern ctxt f x; + pp f " when "; expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, + {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); + ppat_attributes=[]}-> + Some (pat, args_tyvars, rt) + | _ -> None in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> + Some (List.rev tyvars, e, ct) + | _ -> None in + let gadt_exp = gadt_exp [] e in + match gadt_pattern, gadt_exp with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then + Some (p, pt_tyvars, e_ct, e) else None + | _ -> None in + if x.pexp_attributes <> [] + then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e + | Some (p, tyvars, ct, e) -> begin + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + end + | None -> begin + match p with + | {ppat_desc=Ppat_constraint(p ,ty); + ppat_attributes=[]} -> (* special case for the first*) + begin match ty with + | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + end + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class () -> () + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | _ -> assert false + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv + (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + +and directive_argument f x = + match x with + | Pdir_none -> () + | Pdir_string (s) -> pp f "@ %S" s + | Pdir_int (n, None) -> pp f "@ %s" n + | Pdir_int (n, Some m) -> pp f "@ %s%c" n m + | Pdir_ident (li) -> pp f "@ %a" longident li + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) + +let toplevel_phrase f x = + match x with + | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s + (* pp_open_hvbox f 0; *) + (* pp_print_list structure_item f s ; *) + (* pp_close_box f (); *) + | Ptop_dir (s, da) -> + pp f "@[#%s@ %a@]" s directive_argument da + (* pp f "@[#%s@ %a@]" s directive_argument da *) + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let top_phrase f x = + pp_print_newline f (); + toplevel_phrase f x; + pp f ";;"; + pp_print_newline f () + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt diff --git a/analysis/src/vendor/compiler-libs-406/printast.ml b/analysis/src/vendor/compiler-libs-406/printast.ml new file mode 100644 index 000000000..7e8e7bad4 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/printast.ml @@ -0,0 +1,918 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes;; +open Format;; +open Lexing;; +open Location;; +open Parsetree;; + +let fmt_position with_name f l = + let fname = if with_name then l.pos_fname else "" in + if l.pos_lnum = -1 + then fprintf f "%s[%d]" fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; + +let fmt_longident_loc f (x : Longident.t loc) = + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc; +;; + +let fmt_string_loc f (x : string loc) = + fprintf f "\"%s\" %a" x.txt fmt_location x.loc; +;; + +let fmt_char_option f = function + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +let fmt_constant f x = + match x with + | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; + | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); + | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; + | Pconst_string (s, Some delim) -> + fprintf f "PConst_string (%S,Some %S)" s delim; + | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; +;; + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; +;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; +;; + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; +;; + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; +;; + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f s (*...*) +;; + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n"; + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n"; +;; + +let option i f ppf x = + match x with + | None -> line i ppf "None\n"; + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x; +;; + +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; +let string i ppf s = line i ppf "\"%s\"\n" s;; +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s +;; + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + attributes i ppf x.ptyp_attributes; + let i = i+1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n"; + | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l, c) -> + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter ( + function + | Otag (l, attrs, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ptyp_class (li, l) -> + line i ppf "Ptyp_class %a\n" fmt_longident_loc li; + list i core_type ppf l + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl; + core_type i ppf ct; + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l; + | Ptyp_extension (s, arg) -> + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident_loc s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + attributes i ppf x.ppat_attributes; + let i = i+1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n"; + | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p; + | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Ppat_construct (li, po) -> + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i pattern ppf po; + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Ppat_record (l, c) -> + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; + | Ppat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct; + | Ppat_type (li) -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> + line i ppf "Ppat_unpack %a\n" fmt_string_loc s; + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_open (m,p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + attributes i ppf x.pexp_attributes; + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; + | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e; + | Pexp_function l -> + line i ppf "Pexp_function\n"; + list i case ppf l; + | Pexp_fun (l, eo, p, e) -> + line i ppf "Pexp_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + expression i ppf e; + | Pexp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l; + | Pexp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Pexp_construct (li, eo) -> + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo; + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li; + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2; + | Pexp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_for (p, e1, e2, df, e3) -> + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Pexp_constraint (e, ct) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct; + | Pexp_coerce (e, cto1, cto2) -> + line i ppf "Pexp_coerce\n"; + expression i ppf e; + option i core_type ppf cto1; + core_type i ppf cto2; + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e; + | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; + | Pexp_setinstvar (s, e) -> + line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + expression i ppf e; + | Pexp_override (l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; + module_expr i ppf me; + expression i ppf e; + | Pexp_letexception (cd, e) -> + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Pexp_assert (e) -> + line i ppf "Pexp_assert\n"; + expression i ppf e; + | Pexp_lazy (e) -> + line i ppf "Pexp_lazy\n"; + expression i ppf e; + | Pexp_poly (e, cto) -> + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object\n"; + class_structure i ppf s + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack\n"; + module_expr i ppf me + | Pexp_open (ovf, m, e) -> + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + expression i ppf e + | Pexp_extension (s, arg) -> + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_unreachable -> + line i ppf "Pexp_unreachable" + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; + attributes i ppf x.pval_attributes; + core_type (i+1) ppf x.pval_type; + list (i+1) string ppf x.pval_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; + attributes i ppf x.ptype_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.ptype_manifest + +and attributes i ppf l = + let i = i + 1 in + List.iter + (fun (s, arg) -> + line i ppf "attribute \"%s\"\n" s.txt; + payload (i + 1) ppf arg; + ) + l + +and payload i ppf = function + | PStr x -> structure i ppf x + | PSig x -> signature i ppf x + | PTyp x -> core_type i ppf x + | PPat (x, None) -> pattern i ppf x + | PPat (x, Some g) -> + pattern i ppf x; + line i ppf "\n"; + expression (i + 1) ppf g + + +and type_kind i ppf x = + match x with + | Ptype_abstract -> + line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) label_decl ppf l; + | Ptype_open -> + line i ppf "Ptype_open\n"; + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind; + +and extension_constructor_kind i ppf x = + match x with + Pext_decl(a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_longident_loc li; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.pcty_loc; + attributes i ppf x.pcty_attributes; + let i = i+1 in + match x.pcty_desc with + | Pcty_constr (li, l) -> + line i ppf "Pcty_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Pcty_arrow (l, co, cl) -> + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Pcty_extension (s, arg) -> + line i ppf "Pcty_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcty_open (ovf, m, e) -> + line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + class_type i ppf e + +and class_signature i ppf cs = + line i ppf "class_signature\n"; + core_type (i+1) ppf cs.pcsig_self; + list (i+1) class_type_field ppf cs.pcsig_fields; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; + let i = i+1 in + attributes i ppf x.pctf_attributes; + match x.pctf_desc with + | Pctf_inherit (ct) -> + line i ppf "Pctf_inherit\n"; + class_type i ppf ct; + | Pctf_val (s, mf, vf, ct) -> + line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_method (s, pf, vf, ct) -> + line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_constraint (ct1, ct2) -> + line i ppf "Pctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pctf_attribute (s, arg) -> + line i ppf "Pctf_attribute \"%s\"\n" s.txt; + payload i ppf arg + | Pctf_extension (s, arg) -> + line i ppf "Pctf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + attributes i ppf x.pcl_attributes; + let i = i+1 in + match x.pcl_desc with + | Pcl_constr (li, l) -> + line i ppf "Pcl_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Pcl_fun (l, eo, p, e) -> + line i ppf "Pcl_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; + | Pcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Pcl_let (rf, l, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + class_expr i ppf ce; + | Pcl_constraint (ce, ct) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Pcl_extension (s, arg) -> + line i ppf "Pcl_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcl_open (ovf, m, e) -> + line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + class_expr i ppf e + +and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.pcf_loc; + let i = i + 1 in + attributes i ppf x.pcf_attributes; + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, k) -> + line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_method (s, pf, k) -> + line i ppf "Pcf_method %a\n" fmt_private_flag pf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; + expression (i+1) ppf e; + | Pcf_attribute (s, arg) -> + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + payload i ppf arg + | Pcf_extension (s, arg) -> + line i ppf "Pcf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_field_kind i ppf = function + | Cfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Cfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.pci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + attributes i ppf x.pmty_attributes; + let i = i+1 in + match x.pmty_desc with + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; + | Pmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Pmty_functor (s, mt1, mt2) -> + line i ppf "Pmty_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2; + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l; + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + | Pmty_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i+1 in + match x.psig_desc with + | Psig_value vd -> + line i ppf "Psig_value\n"; + value_description i ppf vd; + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception ext -> + line i ppf "Psig_exception\n"; + extension_constructor i ppf ext; + | Psig_module pmd -> + line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls; + | Psig_modtype x -> + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_open od -> + line i ppf "Psig_open %a %a\n" + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Psig_include incl -> + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Psig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + | Psig_extension ((s, arg), attrs) -> + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Psig_attribute (s, arg) -> + line i ppf "Psig_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i+1) ppf mt + +and with_constraint i ppf x = + match x with + | Pwith_type (lid, td) -> + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_typesubst (lid, td) -> + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_module (lid1, lid2) -> + line i ppf "Pwith_module %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modsubst (lid1, lid2) -> + line i ppf "Pwith_modsubst %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + attributes i ppf x.pmod_attributes; + let i = i+1 in + match x.pmod_desc with + | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; + | Pmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Pmod_functor (s, mt, me) -> + line i ppf "Pmod_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me; + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Pmod_unpack (e) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + | Pmod_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i+1 in + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + | Pstr_primitive vd -> + line i ppf "Pstr_primitive\n"; + value_description i ppf vd; + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception ext -> + line i ppf "Pstr_exception\n"; + extension_constructor i ppf ext; + | Pstr_module x -> + line i ppf "Pstr_module\n"; + module_binding i ppf x + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings; + | Pstr_modtype x -> + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Pstr_open od -> + line i ppf "Pstr_open %a %a\n" + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Pstr_class () -> () + | Pstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l; + | Pstr_include incl -> + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod + | Pstr_extension ((s, arg), attrs) -> + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Pstr_attribute (s, arg) -> + line i ppf "Pstr_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and module_declaration i ppf pmd = + string_loc i ppf pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type (i+1) ppf pmd.pmd_type; + +and module_binding i ppf x = + string_loc i ppf x.pmb_name; + attributes i ppf x.pmb_attributes; + module_expr (i+1) ppf x.pmb_expr + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + line i ppf "%a\n" fmt_location pcd_loc; + line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + attributes i ppf pcd_attributes; + constructor_arguments (i+1) ppf pcd_args; + option (i+1) core_type ppf pcd_res + +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= + line i ppf "%a\n" fmt_location pld_loc; + attributes i ppf pld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i+1) ppf "%a" fmt_string_loc pld_name; + core_type (i+1) ppf pld_type + +and longident_x_pattern i ppf (li, p) = + line i ppf "%a\n" fmt_longident_loc li; + pattern (i+1) ppf p; + +and case i ppf {pc_lhs; pc_guard; pc_rhs} = + line i ppf "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + expression (i+1) ppf x.pvb_expr + +and string_x_expression i ppf (s, e) = + line i ppf " %a\n" fmt_string_loc s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, e) = + line i ppf "%a\n" fmt_longident_loc li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l,e) = + line i ppf "\n"; + arg_label i ppf l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x with + Rtag (l, attrs, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf attrs; + list (i+1) core_type ppf ctl + | Rinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct +;; + +let rec toplevel_phrase i ppf x = + match x with + | Ptop_def (s) -> + line i ppf "Ptop_def\n"; + structure (i+1) ppf s; + | Ptop_dir (s, da) -> + line i ppf "Ptop_dir \"%s\"\n" s; + directive_argument i ppf da; + +and directive_argument i ppf x = + match x with + | Pdir_none -> line i ppf "Pdir_none\n" + | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; + | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n; + | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m; + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; + | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); +;; + +let interface ppf x = list 0 signature_item ppf x;; + +let implementation ppf x = list 0 structure_item ppf x;; + +let top_phrase ppf x = toplevel_phrase 0 ppf x;; From 1d3515ed62482ee8a57cd697ee7a2cd6900f20b1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 9 Mar 2022 17:12:30 +0100 Subject: [PATCH 03/41] Add test command to parse a file. --- analysis/src/Commands.ml | 20 +++++++++++++++++++ analysis/tests/src/Completion.res | 2 ++ .../tests/src/DefinitionWithInterface.resi | 1 + .../tests/src/expected/Completion.res.txt | 3 +++ .../expected/DefinitionWithInterface.resi.txt | 3 +++ 5 files changed, 29 insertions(+) diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 74504e8ba..4cb9f269b 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -349,6 +349,26 @@ let test ~path = close_out cout; completion ~path ~line ~col ~currentFile; Sys.remove currentFile + | "par" -> + print_endline ("Parse " ^ path); + if Filename.check_suffix path ".res" then + let parser = + Res_driver.parsingEngine.parseImplementation ~forPrinter:false + in + let {Res_driver.parsetree = structure; diagnostics} = + parser ~filename:path + in + Printf.printf "structure items:%d diagnostics:%d \n" + (List.length structure) (List.length diagnostics) + else + let parser = + Res_driver.parsingEngine.parseInterface ~forPrinter:false + in + let {Res_driver.parsetree = signature; diagnostics} = + parser ~filename:path + in + Printf.printf "signature items:%d diagnostics:%d \n" + (List.length signature) (List.length diagnostics) | _ -> ()); print_newline ()) in diff --git a/analysis/tests/src/Completion.res b/analysis/tests/src/Completion.res index 0d433ad25..9c3ee4fee 100644 --- a/analysis/tests/src/Completion.res +++ b/analysis/tests/src/Completion.res @@ -100,3 +100,5 @@ let make = () => { } // ^com Obj.object[" + +// ^par diff --git a/analysis/tests/src/DefinitionWithInterface.resi b/analysis/tests/src/DefinitionWithInterface.resi index 8b357372c..9230148bf 100644 --- a/analysis/tests/src/DefinitionWithInterface.resi +++ b/analysis/tests/src/DefinitionWithInterface.resi @@ -2,3 +2,4 @@ let y: int // ^def type t +// ^par \ No newline at end of file diff --git a/analysis/tests/src/expected/Completion.res.txt b/analysis/tests/src/expected/Completion.res.txt index e9cb17fca..60617fdbd 100644 --- a/analysis/tests/src/expected/Completion.res.txt +++ b/analysis/tests/src/expected/Completion.res.txt @@ -744,3 +744,6 @@ Complete tests/src/Completion.res 100:3 "documentation": null }] +Parse tests/src/Completion.res +structure items:19 diagnostics:0 + diff --git a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt index 60c8ac515..614b2da0d 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt @@ -1,3 +1,6 @@ Definition tests/src/DefinitionWithInterface.resi 0:4 {"uri": "DefinitionWithInterface.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} +Parse tests/src/DefinitionWithInterface.resi +signature items:2 diagnostics:0 + From 8b3a4e7d29187e38d2205567b735bfca91fa7e1b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 10 Mar 2022 10:30:19 +0100 Subject: [PATCH 04/41] Separate parser test. --- analysis/src/Commands.ml | 39 +++++++++---------- analysis/tests/src/Completion.res | 2 - .../tests/src/DefinitionWithInterface.resi | 1 - analysis/tests/src/Parser.res | 2 + .../tests/src/expected/Completion.res.txt | 3 -- analysis/tests/src/expected/Debug.res.txt | 3 +- .../expected/DefinitionWithInterface.resi.txt | 3 -- analysis/tests/src/expected/Parser.res.txt | 3 ++ 8 files changed, 26 insertions(+), 30 deletions(-) create mode 100644 analysis/tests/src/Parser.res create mode 100644 analysis/tests/src/expected/Parser.res.txt diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 4cb9f269b..1dd652eb1 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -282,6 +282,24 @@ let rename ~path ~line ~col ~newName = in print_endline result +let parser ~path = + if Filename.check_suffix path ".res" then + let parser = + Res_driver.parsingEngine.parseImplementation ~forPrinter:false + in + let {Res_driver.parsetree = structure; diagnostics} = + parser ~filename:path + in + Printf.printf "structure items:%d diagnostics:%d \n" (List.length structure) + (List.length diagnostics) + else + let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in + let {Res_driver.parsetree = signature; diagnostics} = + parser ~filename:path + in + Printf.printf "signature items:%d diagnostics:%d \n" (List.length signature) + (List.length diagnostics) + let test ~path = Uri2.stripPath := true; match Files.readFile path with @@ -314,7 +332,6 @@ let test ~path = print_endline ("Hover " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - hover ~path ~line ~col | "ref" -> print_endline @@ -331,7 +348,6 @@ let test ~path = ("Rename " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col ^ " " ^ newName) in - rename ~path ~line ~col ~newName | "com" -> print_endline @@ -351,24 +367,7 @@ let test ~path = Sys.remove currentFile | "par" -> print_endline ("Parse " ^ path); - if Filename.check_suffix path ".res" then - let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false - in - let {Res_driver.parsetree = structure; diagnostics} = - parser ~filename:path - in - Printf.printf "structure items:%d diagnostics:%d \n" - (List.length structure) (List.length diagnostics) - else - let parser = - Res_driver.parsingEngine.parseInterface ~forPrinter:false - in - let {Res_driver.parsetree = signature; diagnostics} = - parser ~filename:path - in - Printf.printf "signature items:%d diagnostics:%d \n" - (List.length signature) (List.length diagnostics) + parser ~path | _ -> ()); print_newline ()) in diff --git a/analysis/tests/src/Completion.res b/analysis/tests/src/Completion.res index 9c3ee4fee..0d433ad25 100644 --- a/analysis/tests/src/Completion.res +++ b/analysis/tests/src/Completion.res @@ -100,5 +100,3 @@ let make = () => { } // ^com Obj.object[" - -// ^par diff --git a/analysis/tests/src/DefinitionWithInterface.resi b/analysis/tests/src/DefinitionWithInterface.resi index 9230148bf..8b357372c 100644 --- a/analysis/tests/src/DefinitionWithInterface.resi +++ b/analysis/tests/src/DefinitionWithInterface.resi @@ -2,4 +2,3 @@ let y: int // ^def type t -// ^par \ No newline at end of file diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res new file mode 100644 index 000000000..8f79691a2 --- /dev/null +++ b/analysis/tests/src/Parser.res @@ -0,0 +1,2 @@ +let _ = +// ^par \ No newline at end of file diff --git a/analysis/tests/src/expected/Completion.res.txt b/analysis/tests/src/expected/Completion.res.txt index 60617fdbd..e9cb17fca 100644 --- a/analysis/tests/src/expected/Completion.res.txt +++ b/analysis/tests/src/expected/Completion.res.txt @@ -744,6 +744,3 @@ Complete tests/src/Completion.res 100:3 "documentation": null }] -Parse tests/src/Completion.res -structure items:19 diagnostics:0 - diff --git a/analysis/tests/src/expected/Debug.res.txt b/analysis/tests/src/expected/Debug.res.txt index f63aaa815..180b6861e 100644 --- a/analysis/tests/src/expected/Debug.res.txt +++ b/analysis/tests/src/expected/Debug.res.txt @@ -4,7 +4,7 @@ Dependencies: @rescript/react Source directories: tests/node_modules/@rescript/react/src tests/node_modules/@rescript/react/src/legacy Source files: tests/node_modules/@rescript/react/src/React.res tests/node_modules/@rescript/react/src/ReactDOM.res tests/node_modules/@rescript/react/src/ReactDOMServer.res tests/node_modules/@rescript/react/src/ReactDOMStyle.res tests/node_modules/@rescript/react/src/ReactEvent.res tests/node_modules/@rescript/react/src/ReactEvent.resi tests/node_modules/@rescript/react/src/ReactTestUtils.res tests/node_modules/@rescript/react/src/ReactTestUtils.resi tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.res tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.resi tests/node_modules/@rescript/react/src/RescriptReactRouter.res tests/node_modules/@rescript/react/src/RescriptReactRouter.resi tests/node_modules/@rescript/react/src/legacy/ReactDOMRe.res tests/node_modules/@rescript/react/src/legacy/ReasonReact.res Source directories: tests/src tests/src/expected -Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res +Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Parser.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res Impl cmt:tests/lib/bs/src/Auto.cmt res:tests/src/Auto.res Impl cmt:tests/lib/bs/src/CompletePrioritize1.cmt res:tests/src/CompletePrioritize1.res Impl cmt:tests/lib/bs/src/CompletePrioritize2.cmt res:tests/src/CompletePrioritize2.res @@ -20,6 +20,7 @@ Impl cmt:tests/lib/bs/src/Hover.cmt res:tests/src/Hover.res IntfAndImpl cmti:tests/lib/bs/src/Jsx.cmti resi:tests/src/Jsx.resi cmt:tests/lib/bs/src/Jsx.cmt res:tests/src/Jsx.res Impl cmt:tests/lib/bs/src/LongIdentTest.cmt res:tests/src/LongIdentTest.res Impl cmt:tests/lib/bs/src/Obj.cmt res:tests/src/Obj.res +Impl cmt:tests/lib/bs/src/Parser.cmt res:tests/src/Parser.res Impl cmt:tests/lib/bs/src/Patterns.cmt res:tests/src/Patterns.res Impl cmt:tests/lib/bs/src/RecModules.cmt res:tests/src/RecModules.res Impl cmt:tests/lib/bs/src/RecordCompletion.cmt res:tests/src/RecordCompletion.res diff --git a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt index 614b2da0d..60c8ac515 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt @@ -1,6 +1,3 @@ Definition tests/src/DefinitionWithInterface.resi 0:4 {"uri": "DefinitionWithInterface.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} -Parse tests/src/DefinitionWithInterface.resi -signature items:2 diagnostics:0 - diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt new file mode 100644 index 000000000..ca76cf57b --- /dev/null +++ b/analysis/tests/src/expected/Parser.res.txt @@ -0,0 +1,3 @@ +Parse tests/src/Parser.res +structure items:1 diagnostics:0 + From e42016ca747706f242a29efc4c792fc7da1bdd3a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 10 Mar 2022 11:42:59 +0100 Subject: [PATCH 05/41] Add part of core logic to recognise JSX uppercase/lowercase, type arguments, binary operators. --- analysis/src/Commands.ml | 129 ++++++++++++++++++++- analysis/src/ProcessCmt.ml | 6 +- analysis/tests/src/Parser.res | 36 +++++- analysis/tests/src/expected/Parser.res.txt | 15 ++- 4 files changed, 177 insertions(+), 9 deletions(-) diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 1dd652eb1..f69989cd7 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -283,7 +283,7 @@ let rename ~path ~line ~col ~newName = print_endline result let parser ~path = - if Filename.check_suffix path ".res" then + if Filename.check_suffix path ".res" then ( let parser = Res_driver.parsingEngine.parseImplementation ~forPrinter:false in @@ -291,7 +291,132 @@ let parser ~path = parser ~filename:path in Printf.printf "structure items:%d diagnostics:%d \n" (List.length structure) - (List.length diagnostics) + (List.length diagnostics); + + let jsxName lident = + 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 + | _ -> acc + in + match lident with + | Longident.Lident txt -> txt + | _ as lident -> + let segments = flatten [] lident in + segments |> String.concat "." + in + let locToString (loc : Location.t) = + let lineStart, colStart = Utils.tupleOfLexing loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing loc.loc_end in + Printf.sprintf "(%d,%d)->(%d,%d)" lineStart colStart lineEnd colEnd + in + let rec processExpression (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) + when Res_parsetree_viewer.isJsxExpression expr -> + let rec isSelfClosing args = + match args with + | [] -> false + | [ + ( Asttypes.Labelled "children", + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + } ); + _; + ] -> + true + | _ :: rest -> isSelfClosing rest + in + Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) + (locToString pexp_loc); + (if not (isSelfClosing args) then + let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in + let size = if lineStart = lineEnd then colEnd - colStart else 0 in + let lineEndWhole, colEndWhole = + Utils.tupleOfLexing expr.pexp_loc.loc_end + in + if size > 0 && colEndWhole > size then + Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" lineEndWhole + (colEndWhole - size - 1) + lineEndWhole (colEndWhole - 1)); + args |> List.iter (fun (_lbl, e) -> processExpression e) + | Pexp_apply ({pexp_loc}, args) + when Res_parsetree_viewer.isBinaryExpression expr -> + Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); + args |> List.iter (fun (_lbl, e) -> processExpression e) + | Pexp_apply (f, args) -> + processExpression f; + args |> List.iter (fun (_lbl, e) -> processExpression e) + | Pexp_construct (_lidend, expOpt) -> processExpressionOption expOpt + | Pexp_tuple exprs -> exprs |> List.iter processExpression + | Pexp_ident _ -> () + | Pexp_constant _ -> () + | Pexp_unreachable -> assert false + | Pexp_let (_, _, _) -> assert false + | Pexp_function _ -> assert false + | Pexp_fun (_, _, _, _) -> assert false + | Pexp_match (_, _) -> assert false + | Pexp_try (_, _) -> assert false + | Pexp_variant (_, _) -> assert false + | Pexp_record (_, _) -> assert false + | Pexp_field (_, _) -> assert false + | Pexp_setfield (_, _, _) -> assert false + | Pexp_array _ -> assert false + | Pexp_ifthenelse (_, _, _) -> assert false + | Pexp_sequence (_, _) -> assert false + | Pexp_while (_, _) -> assert false + | Pexp_for (_, _, _, _, _) -> assert false + | Pexp_constraint (_, _) -> assert false + | Pexp_coerce (_, _, _) -> assert false + | Pexp_send (_, _) -> assert false + | Pexp_new _ -> assert false + | Pexp_setinstvar (_, _) -> assert false + | Pexp_override _ -> assert false + | Pexp_letmodule (_, _, _) -> assert false + | Pexp_letexception (_, _) -> assert false + | Pexp_assert _ -> assert false + | Pexp_lazy _ -> assert false + | Pexp_poly (_, _) -> assert false + | Pexp_object _ -> assert false + | Pexp_newtype (_, _) -> assert false + | Pexp_pack _ -> assert false + | Pexp_open (_, _, _) -> assert false + | Pexp_extension _ -> assert false + and processExpressionOption = function + | None -> () + | Some e -> processExpression e + in + + let processValueBinding (binding : Parsetree.value_binding) = + processExpression binding.pvb_expr + in + let rec processTypeArg (coreType : Parsetree.core_type) = + Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc); + processCoreType coreType + and processCoreType (coreType : Parsetree.core_type) = + match coreType.ptyp_desc with + | Ptyp_constr (_lident, args) -> args |> List.iter processTypeArg + | _ -> () + in + let processTypeDeclaration (typeDecl : Parsetree.type_declaration) = + match typeDecl.ptype_manifest with + | Some t -> processCoreType t + | None -> () + in + let processStructureItem (item : Parsetree.structure_item) = + match item.pstr_desc with + | Pstr_value (_recFlag, bindings) -> + bindings |> List.iter processValueBinding + | Pstr_type (_recFlat, typeDecls) -> + typeDecls |> List.iter processTypeDeclaration + | _ -> () + in + structure |> List.iter processStructureItem) else let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in let {Res_driver.parsetree = signature; diagnostics} = diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 91c94511d..a39d74e92 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -1276,10 +1276,8 @@ let rec resolvePath ~env ~path ~package = | Some file -> resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath ~package)) -let tupleOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = - (pos_lnum - 1, pos_cnum - pos_bol) - -let locationIsBefore {Location.loc_start} pos = tupleOfLexing loc_start <= pos +let locationIsBefore {Location.loc_start} pos = + Utils.tupleOfLexing loc_start <= pos let findInScope pos name iter stamps = (* Log.log("Find " ++ name ++ " with " ++ string_of_int(Hashtbl.length(stamps)) ++ " stamps"); *) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 8f79691a2..97f36a166 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -1,2 +1,34 @@ -let _ = -// ^par \ No newline at end of file +module M = { + module C = Component +} + +let _c = + +let _mc = + +let _d =
+ +let _d2 = +
+ {React.string("abc")} +
{React.string("abc")}
+ {React.string("abc")} + {React.string("abc")} +
+ +type pair<'x, 'y> = ('x, 'y) + +type looooooooooooooooooooooooooooooooooooooong_int = int + +type looooooooooooooooooooooooooooooooooooooong_string = string + +type pairIntString = list< + pair< + looooooooooooooooooooooooooooooooooooooong_int, + looooooooooooooooooooooooooooooooooooooong_string, + >, +> + +let _ = 3 < 4 || 3 > 4 + +// ^par diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index ca76cf57b..b6fbfec3f 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,3 +1,16 @@ Parse tests/src/Parser.res -structure items:1 diagnostics:0 +structure items:10 diagnostics:0 +JsxOpen: Component (4,10)->(4,19) +JsxOpen: M.C (6,11)->(6,14) +JsxOpen: div (8,10)->(8,13) +JsxOpen: div (11,3)->(11,6) +JsxClose: (16,4)->(16,7) +JsxOpen: div (13,5)->(13,8) +JsxClose: (13,34)->(13,37) +TypeArg: (25,2)->(28,3) +TypeArg: (26,4)->(26,50) +TypeArg: (27,4)->(27,53) +BinaryExp: (31,14)->(31,16) +BinaryExp: (31,10)->(31,11) +BinaryExp: (31,19)->(31,20) From 9b7d8d9d83fd35ce952ce1f092c96508da8cf0be Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 11 Mar 2022 10:18:53 +0100 Subject: [PATCH 06/41] Basic setup of extension analysis bin communication. From https://github.com/zth --- analysis/src/Cli.ml | 3 +- analysis/src/Commands.ml | 25 +++++++++++++++ server/src/server.ts | 66 ++++++++++++++++++++++++++-------------- 3 files changed, 71 insertions(+), 23 deletions(-) diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index cc08302ea..126335f0c 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -70,6 +70,7 @@ let main () = ~col:(int_of_string col) | _ :: "dump" :: files -> Commands.dump files | [_; "documentSymbol"; path] -> Commands.documentSymbol ~path + | [_; "semanticTokens"; _path] -> Commands.parserTest () | [_; "hover"; path; line; col] -> Commands.hover ~path ~line:(int_of_string line) ~col:(int_of_string col) | [_; "references"; path; line; col] -> @@ -83,6 +84,6 @@ let main () = | _ -> prerr_endline help; exit 1 - ;; + main () diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index f69989cd7..2b35bd26c 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -282,6 +282,31 @@ let rename ~path ~line ~col ~newName = in print_endline result +type tokenLegend = {tokenTypes : string array; tokenModifiers : string array} + +(* This needs to stay synced with the same legend in `server.ts` *) +let tokenLegend = {tokenTypes = [|"keyword"|]; tokenModifiers = [||]} + +(* These are not used yet, but taken from https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) +type tokenAtLoc = { + line : int; + startChar : int; + length : int; + tokenType : int; + tokenModifiers : int; +} + +type tokenAtDelta = { + deltaLine : int; + deltaStartChar : int; + length : int; + tokenType : int; + tokenModifiers : int; +} + +(* TEST: This will color the first 3 letters of any ReScript file as a keyword.*) +let parserTest () = Printf.printf "{\"data\":[0,0,3,0,0]}" + let parser ~path = if Filename.check_suffix path ".res" then ( let parser = diff --git a/server/src/server.ts b/server/src/server.ts index a31c2a6b1..4bb94bc73 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -15,10 +15,9 @@ import * as utils from "./utils"; import * as c from "./constants"; import * as chokidar from "chokidar"; import { assert } from "console"; -import { fileURLToPath, pathToFileURL } from "url"; +import { fileURLToPath } from "url"; import { ChildProcess } from "child_process"; import { WorkspaceEdit } from "vscode-languageserver"; -import { TextEdit } from "vscode-languageserver-types"; // https://microsoft.github.io/language-server-protocol/specification#initialize // According to the spec, there could be requests before the 'initialize' request. Link in comment tells how to handle them. @@ -38,17 +37,17 @@ let projectsFiles: Map< // ^ caching AND states AND distributed system. Why does LSP has to be stupid like this // will be properly defined later depending on the mode (stdio/node-rpc) -let send: (msg: m.Message) => void = (_) => { }; +let send: (msg: m.Message) => void = (_) => {}; interface CreateInterfaceRequestParams { uri: string; } -let createInterfaceRequest = - new v.RequestType< - CreateInterfaceRequestParams, - string, - void>("rescript-vscode.create_interface"); +let createInterfaceRequest = new v.RequestType< + CreateInterfaceRequestParams, + string, + void +>("rescript-vscode.create_interface"); interface OpenCompiledFileParams { uri: string; @@ -66,9 +65,8 @@ let sendUpdatedDiagnostics = () => { path.join(projectRootPath, c.compilerLogPartialPath), { encoding: "utf-8" } ); - let { done, result: filesAndErrors } = utils.parseCompilerLogOutput( - content - ); + let { done, result: filesAndErrors } = + utils.parseCompilerLogOutput(content); // diff Object.keys(filesAndErrors).forEach((file) => { @@ -290,7 +288,12 @@ function typeDefinition(msg: p.RequestMessage) { let filePath = fileURLToPath(params.textDocument.uri); let response = utils.runAnalysisCommand( filePath, - ["typeDefinition", filePath, params.position.line, params.position.character], + [ + "typeDefinition", + filePath, + params.position.line, + params.position.character, + ], msg ); return response; @@ -323,7 +326,7 @@ function prepareRename(msg: p.RequestMessage): m.ResponseMessage { ); let result: p.Range | null = null; if (locations !== null) { - locations.forEach(loc => { + locations.forEach((loc) => { if ( path.normalize(fileURLToPath(loc.uri)) === path.normalize(fileURLToPath(params.textDocument.uri)) @@ -337,14 +340,14 @@ function prepareRename(msg: p.RequestMessage): m.ResponseMessage { end.line >= pos.line ) { result = loc.range; - }; + } } }); - }; + } return { jsonrpc: c.jsonrpcVersion, id: msg.id, - result + result, }; } @@ -352,23 +355,22 @@ function rename(msg: p.RequestMessage) { // https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_rename let params = msg.params as p.RenameParams; let filePath = fileURLToPath(params.textDocument.uri); - let documentChanges: - | (p.RenameFile | p.TextDocumentEdit)[] - | null = utils.runAnalysisAfterSanityCheck(filePath, [ + let documentChanges: (p.RenameFile | p.TextDocumentEdit)[] | null = + utils.runAnalysisAfterSanityCheck(filePath, [ "rename", filePath, params.position.line, params.position.character, - params.newName + params.newName, ]); let result: WorkspaceEdit | null = null; if (documentChanges !== null) { result = { documentChanges }; - }; + } let response: m.ResponseMessage = { jsonrpc: c.jsonrpcVersion, id: msg.id, - result + result, }; return response; } @@ -385,6 +387,18 @@ function documentSymbol(msg: p.RequestMessage) { return response; } +function semanticTokens(msg: p.RequestMessage) { + // https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens + let params = msg.params as p.SemanticTokensParams; + let filePath = fileURLToPath(params.textDocument.uri); + let response = utils.runAnalysisCommand( + filePath, + ["semanticTokens", filePath], + msg + ); + return response; +} + function completion(msg: p.RequestMessage) { let params = msg.params as p.ReferenceParams; let filePath = fileURLToPath(params.textDocument.uri); @@ -739,6 +753,12 @@ function onMessage(msg: m.Message) { // disabled right now until we use the parser to show non-stale symbols per keystroke // documentSymbolProvider: true, completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, + semanticTokensProvider: { + legend: { tokenTypes: ["keyword"], tokenModifiers: [] }, + documentSelector: null, + // TODO: Support range for full, and add delta support + full: true, + }, }, }; let response: m.ResponseMessage = { @@ -797,6 +817,8 @@ function onMessage(msg: m.Message) { send(documentSymbol(msg)); } else if (msg.method === p.CompletionRequest.method) { send(completion(msg)); + } else if (msg.method === p.SemanticTokensRequest.method) { + send(semanticTokens(msg)); } else if (msg.method === p.DocumentFormattingRequest.method) { let responses = format(msg); responses.forEach((response) => send(response)); From d85477307e9311bafcc537ce69e05395d796c0b7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 11 Mar 2022 11:08:55 +0100 Subject: [PATCH 07/41] Simple token emitter --- analysis/src/Cli.ml | 2 +- analysis/src/Commands.ml | 53 +++++++++++++++++++++++++--------------- 2 files changed, 34 insertions(+), 21 deletions(-) diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index 126335f0c..9077a867f 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -70,7 +70,7 @@ let main () = ~col:(int_of_string col) | _ :: "dump" :: files -> Commands.dump files | [_; "documentSymbol"; path] -> Commands.documentSymbol ~path - | [_; "semanticTokens"; _path] -> Commands.parserTest () + | [_; "semanticTokens"; _path] -> Commands.semanticTokensTest () | [_; "hover"; path; line; col] -> Commands.hover ~path ~line:(int_of_string line) ~col:(int_of_string col) | [_; "references"; path; line; col] -> diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 2b35bd26c..3304449b8 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -282,30 +282,43 @@ let rename ~path ~line ~col ~newName = in print_endline result -type tokenLegend = {tokenTypes : string array; tokenModifiers : string array} +module Token = struct + type legend = {tokenTypes : string array; tokenModifiers : string array} -(* This needs to stay synced with the same legend in `server.ts` *) -let tokenLegend = {tokenTypes = [|"keyword"|]; tokenModifiers = [||]} + (* This needs to stay synced with the same legend in `server.ts` *) + (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) + type tokenType = Keyword + type tokenModifiers = NoModifier -(* These are not used yet, but taken from https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) -type tokenAtLoc = { - line : int; - startChar : int; - length : int; - tokenType : int; - tokenModifiers : int; -} + let tokenTypeToString = function Keyword -> "0" + let tokenModifiersToString = function NoModifier -> "0" -type tokenAtDelta = { - deltaLine : int; - deltaStartChar : int; - length : int; - tokenType : int; - tokenModifiers : int; -} + type emitter = { + buf : Buffer.t; + mutable lastLine : int; + mutable lastChar : int; + } -(* TEST: This will color the first 3 letters of any ReScript file as a keyword.*) -let parserTest () = Printf.printf "{\"data\":[0,0,3,0,0]}" + let createEmitter () = {buf = Buffer.create 0; lastLine = 0; lastChar = 0} + + let emit ~line ~char ~length ~type_ ?(modifiers = NoModifier) e = + let deltaLine = line - e.lastLine in + let deltaChar = char - e.lastChar in + e.lastLine <- line; + e.lastChar <- char; + if Buffer.length e.buf > 0 then Buffer.add_char e.buf ','; + Buffer.add_string e.buf + (string_of_int deltaLine ^ "," ^ string_of_int deltaChar ^ "," + ^ string_of_int length ^ "," ^ tokenTypeToString type_ ^ "," + ^ tokenModifiersToString modifiers); + () +end + +let semanticTokensTest () = + let emitter = Token.createEmitter () in + emitter |> Token.emit ~line:0 ~char:0 ~length:3 ~type_:Token.Keyword; + emitter |> Token.emit ~line:1 ~char:2 ~length:3 ~type_:Token.Keyword; + Printf.printf "{\"data\":[%s]}" (Buffer.contents emitter.buf) let parser ~path = if Filename.check_suffix path ".res" then ( From 5fb6fc2ab310a895e28540b5f1a02c689c719d90 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 11 Mar 2022 11:31:03 +0100 Subject: [PATCH 08/41] Pass current file contents to binary command. --- analysis/src/Cli.ml | 2 +- analysis/src/Commands.ml | 2 +- server/src/server.ts | 6 +++++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index 9077a867f..f9d0afd9b 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -70,7 +70,7 @@ let main () = ~col:(int_of_string col) | _ :: "dump" :: files -> Commands.dump files | [_; "documentSymbol"; path] -> Commands.documentSymbol ~path - | [_; "semanticTokens"; _path] -> Commands.semanticTokensTest () + | [_; "semanticTokens"; currentFile] -> Commands.semanticTokensTest ~currentFile | [_; "hover"; path; line; col] -> Commands.hover ~path ~line:(int_of_string line) ~col:(int_of_string col) | [_; "references"; path; line; col] -> diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 3304449b8..61e61a401 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -314,7 +314,7 @@ module Token = struct () end -let semanticTokensTest () = +let semanticTokensTest ~currentFile = let emitter = Token.createEmitter () in emitter |> Token.emit ~line:0 ~char:0 ~length:3 ~type_:Token.Keyword; emitter |> Token.emit ~line:1 ~char:2 ~length:3 ~type_:Token.Keyword; diff --git a/server/src/server.ts b/server/src/server.ts index 4bb94bc73..48cc39d0f 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -391,11 +391,15 @@ function semanticTokens(msg: p.RequestMessage) { // https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens let params = msg.params as p.SemanticTokensParams; let filePath = fileURLToPath(params.textDocument.uri); + let code = getOpenedFileContent(params.textDocument.uri); + let tmpname = utils.createFileInTempDir(); + fs.writeFileSync(tmpname, code, { encoding: "utf-8" }); let response = utils.runAnalysisCommand( filePath, - ["semanticTokens", filePath], + ["semanticTokens", tmpname], msg ); + fs.unlink(tmpname, () => null); return response; } From 6fca52b11d26ae160bb6b785dbe9f3a51acbfcab Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 11 Mar 2022 11:50:05 +0100 Subject: [PATCH 09/41] Use an ast mapper. --- analysis/src/Commands.ml | 199 ++++++++++++++------------------------- 1 file changed, 73 insertions(+), 126 deletions(-) diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 61e61a401..c3ba72c70 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -321,6 +321,76 @@ let semanticTokensTest ~currentFile = Printf.printf "{\"data\":[%s]}" (Buffer.contents emitter.buf) let parser ~path = + let jsxName lident = + 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 + | _ -> acc + in + match lident with + | Longident.Lident txt -> txt + | _ as lident -> + let segments = flatten [] lident in + segments |> String.concat "." + in + let locToString (loc : Location.t) = + let lineStart, colStart = Utils.tupleOfLexing loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing loc.loc_end in + Printf.sprintf "(%d,%d)->(%d,%d)" lineStart colStart lineEnd colEnd + in + let processTypeArg (coreType : Parsetree.core_type) = + Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) + in + + let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = + match coreType.ptyp_desc with + | Ptyp_constr (_lident, args) -> + args |> List.iter processTypeArg; + Ast_mapper.default_mapper.typ mapper coreType + | _ -> Ast_mapper.default_mapper.typ mapper coreType + in + let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) + when Res_parsetree_viewer.isJsxExpression e -> + let rec isSelfClosing args = + match args with + | [] -> false + | [ + ( Asttypes.Labelled "children", + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + } ); + _; + ] -> + true + | _ :: rest -> isSelfClosing rest + in + Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) + (locToString pexp_loc); + (if not (isSelfClosing args) then + let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in + let size = if lineStart = lineEnd then colEnd - colStart else 0 in + let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in + if size > 0 && colEndWhole > size then + Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" lineEndWhole + (colEndWhole - size - 1) + lineEndWhole (colEndWhole - 1)); + Ast_mapper.default_mapper.expr mapper e + | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e + -> + Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); + Ast_mapper.default_mapper.expr mapper e + | _ -> Ast_mapper.default_mapper.expr mapper e + in + + let mapper = {Ast_mapper.default_mapper with expr; typ} in + if Filename.check_suffix path ".res" then ( let parser = Res_driver.parsingEngine.parseImplementation ~forPrinter:false @@ -330,138 +400,15 @@ let parser ~path = in Printf.printf "structure items:%d diagnostics:%d \n" (List.length structure) (List.length diagnostics); - - let jsxName lident = - 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 - | _ -> acc - in - match lident with - | Longident.Lident txt -> txt - | _ as lident -> - let segments = flatten [] lident in - segments |> String.concat "." - in - let locToString (loc : Location.t) = - let lineStart, colStart = Utils.tupleOfLexing loc.loc_start in - let lineEnd, colEnd = Utils.tupleOfLexing loc.loc_end in - Printf.sprintf "(%d,%d)->(%d,%d)" lineStart colStart lineEnd colEnd - in - let rec processExpression (expr : Parsetree.expression) = - match expr.pexp_desc with - | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) - when Res_parsetree_viewer.isJsxExpression expr -> - let rec isSelfClosing args = - match args with - | [] -> false - | [ - ( Asttypes.Labelled "children", - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - } ); - _; - ] -> - true - | _ :: rest -> isSelfClosing rest - in - Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) - (locToString pexp_loc); - (if not (isSelfClosing args) then - let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in - let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in - let size = if lineStart = lineEnd then colEnd - colStart else 0 in - let lineEndWhole, colEndWhole = - Utils.tupleOfLexing expr.pexp_loc.loc_end - in - if size > 0 && colEndWhole > size then - Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" lineEndWhole - (colEndWhole - size - 1) - lineEndWhole (colEndWhole - 1)); - args |> List.iter (fun (_lbl, e) -> processExpression e) - | Pexp_apply ({pexp_loc}, args) - when Res_parsetree_viewer.isBinaryExpression expr -> - Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); - args |> List.iter (fun (_lbl, e) -> processExpression e) - | Pexp_apply (f, args) -> - processExpression f; - args |> List.iter (fun (_lbl, e) -> processExpression e) - | Pexp_construct (_lidend, expOpt) -> processExpressionOption expOpt - | Pexp_tuple exprs -> exprs |> List.iter processExpression - | Pexp_ident _ -> () - | Pexp_constant _ -> () - | Pexp_unreachable -> assert false - | Pexp_let (_, _, _) -> assert false - | Pexp_function _ -> assert false - | Pexp_fun (_, _, _, _) -> assert false - | Pexp_match (_, _) -> assert false - | Pexp_try (_, _) -> assert false - | Pexp_variant (_, _) -> assert false - | Pexp_record (_, _) -> assert false - | Pexp_field (_, _) -> assert false - | Pexp_setfield (_, _, _) -> assert false - | Pexp_array _ -> assert false - | Pexp_ifthenelse (_, _, _) -> assert false - | Pexp_sequence (_, _) -> assert false - | Pexp_while (_, _) -> assert false - | Pexp_for (_, _, _, _, _) -> assert false - | Pexp_constraint (_, _) -> assert false - | Pexp_coerce (_, _, _) -> assert false - | Pexp_send (_, _) -> assert false - | Pexp_new _ -> assert false - | Pexp_setinstvar (_, _) -> assert false - | Pexp_override _ -> assert false - | Pexp_letmodule (_, _, _) -> assert false - | Pexp_letexception (_, _) -> assert false - | Pexp_assert _ -> assert false - | Pexp_lazy _ -> assert false - | Pexp_poly (_, _) -> assert false - | Pexp_object _ -> assert false - | Pexp_newtype (_, _) -> assert false - | Pexp_pack _ -> assert false - | Pexp_open (_, _, _) -> assert false - | Pexp_extension _ -> assert false - and processExpressionOption = function - | None -> () - | Some e -> processExpression e - in - - let processValueBinding (binding : Parsetree.value_binding) = - processExpression binding.pvb_expr - in - let rec processTypeArg (coreType : Parsetree.core_type) = - Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc); - processCoreType coreType - and processCoreType (coreType : Parsetree.core_type) = - match coreType.ptyp_desc with - | Ptyp_constr (_lident, args) -> args |> List.iter processTypeArg - | _ -> () - in - let processTypeDeclaration (typeDecl : Parsetree.type_declaration) = - match typeDecl.ptype_manifest with - | Some t -> processCoreType t - | None -> () - in - let processStructureItem (item : Parsetree.structure_item) = - match item.pstr_desc with - | Pstr_value (_recFlag, bindings) -> - bindings |> List.iter processValueBinding - | Pstr_type (_recFlat, typeDecls) -> - typeDecls |> List.iter processTypeDeclaration - | _ -> () - in - structure |> List.iter processStructureItem) + mapper.structure mapper structure |> ignore) else let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in let {Res_driver.parsetree = signature; diagnostics} = parser ~filename:path in Printf.printf "signature items:%d diagnostics:%d \n" (List.length signature) - (List.length diagnostics) + (List.length diagnostics); + mapper.signature mapper signature |> ignore let test ~path = Uri2.stripPath := true; From 2bf41ca5b7024d22415dfc5ef00905a8fdf1060a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 11 Mar 2022 13:59:12 +0100 Subject: [PATCH 10/41] Semantic highlighting for JSX open and close. --- analysis/src/Cli.ml | 3 +- analysis/src/Commands.ml | 132 +------------------------- analysis/src/SemanticTokens.ml | 166 +++++++++++++++++++++++++++++++++ server/src/server.ts | 3 +- 4 files changed, 173 insertions(+), 131 deletions(-) create mode 100644 analysis/src/SemanticTokens.ml diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index f9d0afd9b..cf56d3bbc 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -70,7 +70,8 @@ let main () = ~col:(int_of_string col) | _ :: "dump" :: files -> Commands.dump files | [_; "documentSymbol"; path] -> Commands.documentSymbol ~path - | [_; "semanticTokens"; currentFile] -> Commands.semanticTokensTest ~currentFile + | [_; "semanticTokens"; currentFile] -> + SemanticTokens.testCommand ~currentFile | [_; "hover"; path; line; col] -> Commands.hover ~path ~line:(int_of_string line) ~col:(int_of_string col) | [_; "references"; path; line; col] -> diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index c3ba72c70..a9945d469 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -282,134 +282,6 @@ let rename ~path ~line ~col ~newName = in print_endline result -module Token = struct - type legend = {tokenTypes : string array; tokenModifiers : string array} - - (* This needs to stay synced with the same legend in `server.ts` *) - (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword - type tokenModifiers = NoModifier - - let tokenTypeToString = function Keyword -> "0" - let tokenModifiersToString = function NoModifier -> "0" - - type emitter = { - buf : Buffer.t; - mutable lastLine : int; - mutable lastChar : int; - } - - let createEmitter () = {buf = Buffer.create 0; lastLine = 0; lastChar = 0} - - let emit ~line ~char ~length ~type_ ?(modifiers = NoModifier) e = - let deltaLine = line - e.lastLine in - let deltaChar = char - e.lastChar in - e.lastLine <- line; - e.lastChar <- char; - if Buffer.length e.buf > 0 then Buffer.add_char e.buf ','; - Buffer.add_string e.buf - (string_of_int deltaLine ^ "," ^ string_of_int deltaChar ^ "," - ^ string_of_int length ^ "," ^ tokenTypeToString type_ ^ "," - ^ tokenModifiersToString modifiers); - () -end - -let semanticTokensTest ~currentFile = - let emitter = Token.createEmitter () in - emitter |> Token.emit ~line:0 ~char:0 ~length:3 ~type_:Token.Keyword; - emitter |> Token.emit ~line:1 ~char:2 ~length:3 ~type_:Token.Keyword; - Printf.printf "{\"data\":[%s]}" (Buffer.contents emitter.buf) - -let parser ~path = - let jsxName lident = - 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 - | _ -> acc - in - match lident with - | Longident.Lident txt -> txt - | _ as lident -> - let segments = flatten [] lident in - segments |> String.concat "." - in - let locToString (loc : Location.t) = - let lineStart, colStart = Utils.tupleOfLexing loc.loc_start in - let lineEnd, colEnd = Utils.tupleOfLexing loc.loc_end in - Printf.sprintf "(%d,%d)->(%d,%d)" lineStart colStart lineEnd colEnd - in - let processTypeArg (coreType : Parsetree.core_type) = - Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) - in - - let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = - match coreType.ptyp_desc with - | Ptyp_constr (_lident, args) -> - args |> List.iter processTypeArg; - Ast_mapper.default_mapper.typ mapper coreType - | _ -> Ast_mapper.default_mapper.typ mapper coreType - in - let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) - when Res_parsetree_viewer.isJsxExpression e -> - let rec isSelfClosing args = - match args with - | [] -> false - | [ - ( Asttypes.Labelled "children", - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - } ); - _; - ] -> - true - | _ :: rest -> isSelfClosing rest - in - Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) - (locToString pexp_loc); - (if not (isSelfClosing args) then - let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in - let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in - let size = if lineStart = lineEnd then colEnd - colStart else 0 in - let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in - if size > 0 && colEndWhole > size then - Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" lineEndWhole - (colEndWhole - size - 1) - lineEndWhole (colEndWhole - 1)); - Ast_mapper.default_mapper.expr mapper e - | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e - -> - Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); - Ast_mapper.default_mapper.expr mapper e - | _ -> Ast_mapper.default_mapper.expr mapper e - in - - let mapper = {Ast_mapper.default_mapper with expr; typ} in - - if Filename.check_suffix path ".res" then ( - let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false - in - let {Res_driver.parsetree = structure; diagnostics} = - parser ~filename:path - in - Printf.printf "structure items:%d diagnostics:%d \n" (List.length structure) - (List.length diagnostics); - mapper.structure mapper structure |> ignore) - else - let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in - let {Res_driver.parsetree = signature; diagnostics} = - parser ~filename:path - in - Printf.printf "signature items:%d diagnostics:%d \n" (List.length signature) - (List.length diagnostics); - mapper.signature mapper signature |> ignore - let test ~path = Uri2.stripPath := true; match Files.readFile path with @@ -477,7 +349,9 @@ let test ~path = Sys.remove currentFile | "par" -> print_endline ("Parse " ^ path); - parser ~path + SemanticTokens.parser ~debug:true + ~emitter:(SemanticTokens.Token.createEmitter ()) + ~path | _ -> ()); print_newline ()) in diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml new file mode 100644 index 000000000..b5d4c43a6 --- /dev/null +++ b/analysis/src/SemanticTokens.ml @@ -0,0 +1,166 @@ +module Token = struct + type legend = {tokenTypes : string array; tokenModifiers : string array} + + (* This needs to stay synced with the same legend in `server.ts` *) + (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) + type tokenType = Keyword + type tokenModifiers = NoModifier + + let tokenTypeToString = function Keyword -> "0" + let tokenModifiersToString = function NoModifier -> "0" + + type token = int * int * int * tokenType * tokenModifiers + + type emitter = { + mutable tokens : token list; + mutable lastLine : int; + mutable lastChar : int; + } + + let createEmitter () = {tokens = []; lastLine = 0; lastChar = 0} + + let add ~line ~char ~length ~type_ ?(modifiers = NoModifier) e = + e.tokens <- (line, char, length, type_, modifiers) :: e.tokens + + let emitToken buf (line, char, length, type_, modifiers) e = + let deltaLine = line - e.lastLine in + let deltaChar = if deltaLine = 0 then char - e.lastChar else char in + e.lastLine <- line; + e.lastChar <- char; + if Buffer.length buf > 0 then Buffer.add_char buf ','; + Buffer.add_string buf + (string_of_int deltaLine ^ "," ^ string_of_int deltaChar ^ "," + ^ string_of_int length ^ "," ^ tokenTypeToString type_ ^ "," + ^ tokenModifiersToString modifiers) + + let emit e = + let sortedTokens = + e.tokens + |> List.sort (fun (l1, c1, _, _, _) (l2, c2, _, _, _) -> + if l1 = l2 then compare c1 c2 else compare l1 l2) + in + let buf = Buffer.create 1 in + sortedTokens |> List.iter (fun t -> e |> emitToken buf t); + Buffer.contents buf +end + +let locToPositions (loc : Location.t) = + (Utils.tupleOfLexing loc.loc_start, Utils.tupleOfLexing loc.loc_end) + +let posToString (loc, col) = Printf.sprintf "(%d,%d)" loc col + +let locToString (loc : Location.t) = + let posStart, posEnd = locToPositions loc in + Printf.sprintf "%s->%s" (posToString posStart) (posToString posEnd) + +let emitFromLoc loc emitter = + let posStart, posEnd = locToPositions loc in + let length = + if fst posStart = fst posEnd then snd posEnd - snd posStart else 0 + in + if length > 0 then + emitter + |> Token.add ~line:(fst posStart) ~char:(snd posStart) ~length + ~type_:Token.Keyword + +let parser ~debug ~emitter ~path = + let jsxName lident = + 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 + | _ -> acc + in + match lident with + | Longident.Lident txt -> txt + | _ as lident -> + let segments = flatten [] lident in + segments |> String.concat "." + in + let processTypeArg (coreType : Parsetree.core_type) = + if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) + in + + let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = + match coreType.ptyp_desc with + | Ptyp_constr (_lident, args) -> + args |> List.iter processTypeArg; + Ast_mapper.default_mapper.typ mapper coreType + | _ -> Ast_mapper.default_mapper.typ mapper coreType + in + let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) + when Res_parsetree_viewer.isJsxExpression e -> + let rec isSelfClosing args = + match args with + | [] -> false + | [ + ( Asttypes.Labelled "children", + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + } ); + _; + ] -> + true + | _ :: rest -> isSelfClosing rest + in + + if debug then + Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) + (locToString pexp_loc); + emitter |> emitFromLoc pexp_loc; + + (if not (isSelfClosing args) then + let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in + let length = if lineStart = lineEnd then colEnd - colStart else 0 in + let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in + if length > 0 && colEndWhole > length then ( + let line = lineEndWhole in + let char = colEndWhole - length - 1 in + + if debug then + Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" line char lineEndWhole + (colEndWhole - 1); + emitter |> Token.add ~line ~char ~length ~type_:Token.Keyword)); + + Ast_mapper.default_mapper.expr mapper e + | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e + -> + if debug then Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); + Ast_mapper.default_mapper.expr mapper e + | _ -> Ast_mapper.default_mapper.expr mapper e + in + + let mapper = {Ast_mapper.default_mapper with expr; typ} in + + if Filename.check_suffix path ".res" then ( + let parser = + Res_driver.parsingEngine.parseImplementation ~forPrinter:false + in + let {Res_driver.parsetree = structure; diagnostics} = + parser ~filename:path + in + if debug then + Printf.printf "structure items:%d diagnostics:%d \n" + (List.length structure) (List.length diagnostics); + mapper.structure mapper structure |> ignore) + else + let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in + let {Res_driver.parsetree = signature; diagnostics} = + parser ~filename:path + in + if debug then + Printf.printf "signature items:%d diagnostics:%d \n" + (List.length signature) (List.length diagnostics); + mapper.signature mapper signature |> ignore + +let testCommand ~currentFile = + let emitter = Token.createEmitter () in + parser ~emitter ~debug:false ~path:currentFile; + (* emitter |> Token.add ~line:0 ~char:0 ~length:3 ~type_:Token.Keyword; *) + Printf.printf "{\"data\":[%s]}" (Token.emit emitter) diff --git a/server/src/server.ts b/server/src/server.ts index 48cc39d0f..c5ab3d767 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -392,7 +392,8 @@ function semanticTokens(msg: p.RequestMessage) { let params = msg.params as p.SemanticTokensParams; let filePath = fileURLToPath(params.textDocument.uri); let code = getOpenedFileContent(params.textDocument.uri); - let tmpname = utils.createFileInTempDir(); + let extension = path.extname(params.textDocument.uri); + let tmpname = utils.createFileInTempDir(extension); fs.writeFileSync(tmpname, code, { encoding: "utf-8" }); let response = utils.runAnalysisCommand( filePath, From 7d18906ec53dbbdb5414b4f8c47f468712cf88b7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 12 Mar 2022 13:06:43 +0100 Subject: [PATCH 11/41] Emit variables. --- analysis/src/SemanticTokens.ml | 61 ++++++++++++++-------- analysis/tests/src/expected/Parser.res.txt | 7 +++ 2 files changed, 47 insertions(+), 21 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index b5d4c43a6..36051613d 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -53,15 +53,30 @@ let locToString (loc : Location.t) = let posStart, posEnd = locToPositions loc in Printf.sprintf "%s->%s" (posToString posStart) (posToString posEnd) -let emitFromLoc loc emitter = - let posStart, posEnd = locToPositions loc in +let emitFromPos posStart posEnd ~type_ emitter = let length = if fst posStart = fst posEnd then snd posEnd - snd posStart else 0 in if length > 0 then emitter - |> Token.add ~line:(fst posStart) ~char:(snd posStart) ~length - ~type_:Token.Keyword + |> Token.add ~line:(fst posStart) ~char:(snd posStart) ~length ~type_ + +let emitFromLoc ~loc ~type_ emitter = + let posStart, posEnd = locToPositions loc in + emitter |> emitFromPos posStart posEnd ~type_ + +let emitJsxOpen ~id ~debug ~loc emitter = + if debug then Printf.printf "JsxOpen: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Token.Keyword + +let emitVariable ~id ~debug ~loc emitter = + if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Token.Keyword + +let emitJsxClose ~debug ~posStart ~posEnd emitter = + let l1, c1 = posStart and l2, c2 = posEnd in + if debug then Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" l1 c1 l2 c2; + emitter |> emitFromPos posStart posEnd ~type_:Token.Keyword let parser ~debug ~emitter ~path = let jsxName lident = @@ -82,7 +97,10 @@ let parser ~debug ~emitter ~path = let processTypeArg (coreType : Parsetree.core_type) = if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) in - + let isLowercaseId id = + let c = id.[0] in + c == '_' || (c >= 'a' && c <= 'z') + in let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = match coreType.ptyp_desc with | Ptyp_constr (_lident, args) -> @@ -90,8 +108,18 @@ let parser ~debug ~emitter ~path = Ast_mapper.default_mapper.typ mapper coreType | _ -> Ast_mapper.default_mapper.typ mapper coreType in + let pat (mapper : Ast_mapper.mapper) (p : Parsetree.pattern) = + match p.ppat_desc with + | Ppat_var {loc; txt = id} -> + if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc; + Ast_mapper.default_mapper.pat mapper p + | _ -> Ast_mapper.default_mapper.pat mapper p + in let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = match e.pexp_desc with + | Pexp_ident {txt = Lident id; loc} -> + if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc; + Ast_mapper.default_mapper.expr mapper e | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) when Res_parsetree_viewer.isJsxExpression e -> let rec isSelfClosing args = @@ -108,26 +136,17 @@ let parser ~debug ~emitter ~path = true | _ :: rest -> isSelfClosing rest in - - if debug then - Printf.printf "JsxOpen: %s %s\n" (jsxName lident.txt) - (locToString pexp_loc); - emitter |> emitFromLoc pexp_loc; - + emitter |> emitJsxOpen ~id:(jsxName lident.txt) ~debug ~loc:pexp_loc; (if not (isSelfClosing args) then let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in let length = if lineStart = lineEnd then colEnd - colStart else 0 in let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in - if length > 0 && colEndWhole > length then ( - let line = lineEndWhole in - let char = colEndWhole - length - 1 in - - if debug then - Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" line char lineEndWhole - (colEndWhole - 1); - emitter |> Token.add ~line ~char ~length ~type_:Token.Keyword)); - + if length > 0 && colEndWhole > length then + emitter + |> emitJsxClose ~debug + ~posStart:(lineEndWhole, colEndWhole - length - 1) + ~posEnd:(lineEndWhole, colEndWhole - 1)); Ast_mapper.default_mapper.expr mapper e | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e -> @@ -136,7 +155,7 @@ let parser ~debug ~emitter ~path = | _ -> Ast_mapper.default_mapper.expr mapper e in - let mapper = {Ast_mapper.default_mapper with expr; typ} in + let mapper = {Ast_mapper.default_mapper with expr; pat; typ} in if Filename.check_suffix path ".res" then ( let parser = diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index b6fbfec3f..5d11b373f 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,12 +1,19 @@ Parse tests/src/Parser.res structure items:10 diagnostics:0 JsxOpen: Component (4,10)->(4,19) +Variable: _c (4,4)->(4,6) JsxOpen: M.C (6,11)->(6,14) +Variable: _mc (6,4)->(6,7) JsxOpen: div (8,10)->(8,13) +Variable: div (8,10)->(8,13) +Variable: _d (8,4)->(8,6) JsxOpen: div (11,3)->(11,6) JsxClose: (16,4)->(16,7) JsxOpen: div (13,5)->(13,8) JsxClose: (13,34)->(13,37) +Variable: div (13,5)->(13,8) +Variable: div (11,3)->(11,6) +Variable: _d2 (10,4)->(10,7) TypeArg: (25,2)->(28,3) TypeArg: (26,4)->(26,50) TypeArg: (27,4)->(27,53) From 142d03d351badeb93d05b0baf1285bea1ee6c88c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 12 Mar 2022 13:12:11 +0100 Subject: [PATCH 12/41] Add token type "variable". --- analysis/src/SemanticTokens.ml | 6 +++--- server/src/server.ts | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 36051613d..51dd8d712 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,10 +3,10 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword + type tokenType = Keyword | Variable type tokenModifiers = NoModifier - let tokenTypeToString = function Keyword -> "0" + let tokenTypeToString = function Keyword -> "0" | Variable -> "1" let tokenModifiersToString = function NoModifier -> "0" type token = int * int * int * tokenType * tokenModifiers @@ -71,7 +71,7 @@ let emitJsxOpen ~id ~debug ~loc emitter = let emitVariable ~id ~debug ~loc emitter = if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); - emitter |> emitFromLoc ~loc ~type_:Token.Keyword + emitter |> emitFromLoc ~loc ~type_:Token.Variable let emitJsxClose ~debug ~posStart ~posEnd emitter = let l1, c1 = posStart and l2, c2 = posEnd in diff --git a/server/src/server.ts b/server/src/server.ts index c5ab3d767..880b168c8 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -759,7 +759,7 @@ function onMessage(msg: m.Message) { // documentSymbolProvider: true, completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { - legend: { tokenTypes: ["keyword"], tokenModifiers: [] }, + legend: { tokenTypes: ["keyword", "variable"], tokenModifiers: [] }, documentSelector: null, // TODO: Support range for full, and add delta support full: true, From 547ae25c489f357c030396796bd2c6b43e378ca0 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 12 Mar 2022 13:26:31 +0100 Subject: [PATCH 13/41] Emitting types too. --- analysis/src/SemanticTokens.ml | 27 ++++++++++++++++++---- analysis/tests/src/expected/Parser.res.txt | 10 ++++++++ server/src/server.ts | 5 +++- 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 51dd8d712..d1d790b68 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,10 +3,14 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword | Variable + type tokenType = Keyword | Variable | Type type tokenModifiers = NoModifier - let tokenTypeToString = function Keyword -> "0" | Variable -> "1" + let tokenTypeToString = function + | Keyword -> "0" + | Variable -> "1" + | Type -> "2" + let tokenModifiersToString = function NoModifier -> "0" type token = int * int * int * tokenType * tokenModifiers @@ -73,6 +77,10 @@ let emitVariable ~id ~debug ~loc emitter = if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); emitter |> emitFromLoc ~loc ~type_:Token.Variable +let emitType ~id ~debug ~loc emitter = + if debug then Printf.printf "Type: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Token.Type + let emitJsxClose ~debug ~posStart ~posEnd emitter = let l1, c1 = posStart and l2, c2 = posEnd in if debug then Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" l1 c1 l2 c2; @@ -103,11 +111,20 @@ let parser ~debug ~emitter ~path = in let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = match coreType.ptyp_desc with - | Ptyp_constr (_lident, args) -> + | Ptyp_constr ({txt; loc}, args) -> + (match txt with + | Lident id -> emitter |> emitType ~id ~debug ~loc + | _ -> ()); args |> List.iter processTypeArg; Ast_mapper.default_mapper.typ mapper coreType | _ -> Ast_mapper.default_mapper.typ mapper coreType in + let type_declaration (mapper : Ast_mapper.mapper) + (tydecl : Parsetree.type_declaration) = + emitter + |> emitType ~id:tydecl.ptype_name.txt ~debug ~loc:tydecl.ptype_name.loc; + Ast_mapper.default_mapper.type_declaration mapper tydecl + in let pat (mapper : Ast_mapper.mapper) (p : Parsetree.pattern) = match p.ppat_desc with | Ppat_var {loc; txt = id} -> @@ -155,7 +172,9 @@ let parser ~debug ~emitter ~path = | _ -> Ast_mapper.default_mapper.expr mapper e in - let mapper = {Ast_mapper.default_mapper with expr; pat; typ} in + let mapper = + {Ast_mapper.default_mapper with expr; pat; typ; type_declaration} + in if Filename.check_suffix path ".res" then ( let parser = diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 5d11b373f..abff69a1b 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -14,9 +14,19 @@ JsxClose: (13,34)->(13,37) Variable: div (13,5)->(13,8) Variable: div (11,3)->(11,6) Variable: _d2 (10,4)->(10,7) +Type: pair (18,5)->(18,9) +Type: looooooooooooooooooooooooooooooooooooooong_int (20,5)->(20,51) +Type: int (20,54)->(20,57) +Type: looooooooooooooooooooooooooooooooooooooong_string (22,5)->(22,54) +Type: string (22,57)->(22,63) +Type: pairIntString (24,5)->(24,18) +Type: list (24,21)->(24,25) TypeArg: (25,2)->(28,3) +Type: pair (25,2)->(25,6) TypeArg: (26,4)->(26,50) TypeArg: (27,4)->(27,53) +Type: looooooooooooooooooooooooooooooooooooooong_int (26,4)->(26,50) +Type: looooooooooooooooooooooooooooooooooooooong_string (27,4)->(27,53) BinaryExp: (31,14)->(31,16) BinaryExp: (31,10)->(31,11) BinaryExp: (31,19)->(31,20) diff --git a/server/src/server.ts b/server/src/server.ts index 880b168c8..4d8952268 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -759,7 +759,10 @@ function onMessage(msg: m.Message) { // documentSymbolProvider: true, completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { - legend: { tokenTypes: ["keyword", "variable"], tokenModifiers: [] }, + legend: { + tokenTypes: ["keyword", "variable", "type"], + tokenModifiers: [], + }, documentSelector: null, // TODO: Support range for full, and add delta support full: true, From 3c5119bdfe92a65bfa2db1cc80ba52850c87c0d5 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 12 Mar 2022 14:00:01 +0100 Subject: [PATCH 14/41] add sample highlight files --- .../src/syntax/sample-highlighting.res | 43 ++++++++++++++++++ .../src/syntax/sample-highlighting.rs | 31 +++++++++++++ .../src/syntax/sample-highlighting.tsx | 44 +++++++++++++++++++ 3 files changed, 118 insertions(+) create mode 100644 analysis/examples/example-project/src/syntax/sample-highlighting.res create mode 100644 analysis/examples/example-project/src/syntax/sample-highlighting.rs create mode 100644 analysis/examples/example-project/src/syntax/sample-highlighting.tsx diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.res b/analysis/examples/example-project/src/syntax/sample-highlighting.res new file mode 100644 index 000000000..814c7faed --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.res @@ -0,0 +1,43 @@ +// Bindings +let numberBinding = 123 + +let someFunction = (param: int): int => { + let innerBinding = param + 2 + innerBinding +} + +// Types +type someRecord<'typeParameter> = { + someField: int, + someOtherField: string, + theParam: typeParameter, +} + +type someEnum = + | SomeMember + | AnotherMember + | SomeMemberWithPayload(someRecord) + +// Destructuring +let destructuring = () => { + let someVar = (1, 2, 3) + let (one, two, three) = someVar + let someObj: someRecord = { + someField: 1, + someOtherField: "hello", + theParam: 2, + } + let {someField, someOtherField, theParam} = someObj + + someField +} + +// JSX +module SomeComponent = { + @react.component + let make = () => { + React.null + } +} + +let jsx =
diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.rs b/analysis/examples/example-project/src/syntax/sample-highlighting.rs new file mode 100644 index 000000000..7131ba600 --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.rs @@ -0,0 +1,31 @@ +// Bindings +fn some_function(param: usize) -> usize { + let innerBinding = param + 2; + innerBinding +} + +// Types +struct someRecord { + someField: usize, + someOtherField: String, + theParam: typeParameter, +} + +enum someEnum { + SomeMember, + AnotherMember, + SomeMemberWithPayload(someRecord), +} + +// Destructuring +fn destructuring() -> usize { + let someVar = (1, 2, 3); + let (one, two, three) = someVar; + let someObj = someRecord:: { + someField: 1, + someOtherField: String::new("HEllo"), + theParam: 2, + }; + + someObj.someField +} diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx new file mode 100644 index 000000000..1919f6fc4 --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx @@ -0,0 +1,44 @@ +// Bindings +let numberBinding = 123; + +let someFunction = (param: number): number => { + let innerBinding = param + 2; + return innerBinding; +}; + +// Types +type someRecord = { + someField: number; + someOtherField: string; + theParam: typeParameter; +}; + +enum someEnum { + SomeMember, + AnotherMember, +} + +// Destructuring +let destructuring = () => { + let someVar = [1, 2, 3]; + let [one, two, three] = someVar; + let someObj: someRecord = { + someField: 1, + someOtherField: "hello", + theParam: 2, + }; + let { someField, someOtherField, theParam } = someObj; + + return someField; +}; + +// JSX +const SomeComponent = () => { + return null; +}; + +let jsx = ( +
+ +
+); From 31b603e14a8618194d3dc5b20b5dfb8990ce20df Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 12 Mar 2022 14:00:30 +0100 Subject: [PATCH 15/41] add explicit semantic token for JSX tag --- analysis/src/SemanticTokens.ml | 7 ++++--- package.json | 7 +++++++ server/src/server.ts | 2 +- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index d1d790b68..7c7d6ec2b 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,13 +3,14 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword | Variable | Type + type tokenType = Keyword | Variable | Type | JsxTag type tokenModifiers = NoModifier let tokenTypeToString = function | Keyword -> "0" | Variable -> "1" | Type -> "2" + | JsxTag -> "3" let tokenModifiersToString = function NoModifier -> "0" @@ -71,7 +72,7 @@ let emitFromLoc ~loc ~type_ emitter = let emitJsxOpen ~id ~debug ~loc emitter = if debug then Printf.printf "JsxOpen: %s %s\n" id (locToString loc); - emitter |> emitFromLoc ~loc ~type_:Token.Keyword + emitter |> emitFromLoc ~loc ~type_:Token.JsxTag let emitVariable ~id ~debug ~loc emitter = if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); @@ -84,7 +85,7 @@ let emitType ~id ~debug ~loc emitter = let emitJsxClose ~debug ~posStart ~posEnd emitter = let l1, c1 = posStart and l2, c2 = posEnd in if debug then Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" l1 c1 l2 c2; - emitter |> emitFromPos posStart posEnd ~type_:Token.Keyword + emitter |> emitFromPos posStart posEnd ~type_:Token.JsxTag let parser ~debug ~emitter ~path = let jsxName lident = diff --git a/package.json b/package.json index 637b453b1..b8707b19a 100644 --- a/package.json +++ b/package.json @@ -28,6 +28,13 @@ ], "main": "./client/out/extension", "contributes": { + "semanticTokenScopes": [ + { + "scopes": { + "jsx-tag": ["entity.name.tag"] + } + } + ], "jsonValidation": [ { "fileMatch": "bsconfig.json", diff --git a/server/src/server.ts b/server/src/server.ts index 4d8952268..d6962b1e8 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -760,7 +760,7 @@ function onMessage(msg: m.Message) { completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { legend: { - tokenTypes: ["keyword", "variable", "type"], + tokenTypes: ["keyword", "variable", "type", "jsx-tag"], tokenModifiers: [], }, documentSelector: null, From 77dae25c66840e8082808ba6ccbafc4eeeefb243 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 12 Mar 2022 20:16:17 +0100 Subject: [PATCH 16/41] Emit long idents in expressions, patterns, and jsx labels, uniformly. With upper case ids, emit Token.JsxTag With lower case ids, emit Token.Variable Still need to do module declarations and expressions (and e.g. open M etc). --- analysis/src/SemanticTokens.ml | 106 ++++++++++++++------- analysis/tests/src/expected/Parser.res.txt | 34 ++++--- 2 files changed, 90 insertions(+), 50 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 7c7d6ec2b..232ec296d 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -58,6 +58,14 @@ let locToString (loc : Location.t) = let posStart, posEnd = locToPositions loc in Printf.sprintf "%s->%s" (posToString posStart) (posToString posEnd) +let isLowercaseId id = + let c = id.[0] in + c == '_' || (c >= 'a' && c <= 'z') + +let isUppercaseId id = + let c = id.[0] in + c >= 'A' && c <= 'Z' + let emitFromPos posStart posEnd ~type_ emitter = let length = if fst posStart = fst posEnd then snd posEnd - snd posStart else 0 @@ -70,46 +78,64 @@ let emitFromLoc ~loc ~type_ emitter = let posStart, posEnd = locToPositions loc in emitter |> emitFromPos posStart posEnd ~type_ -let emitJsxOpen ~id ~debug ~loc emitter = - if debug then Printf.printf "JsxOpen: %s %s\n" id (locToString loc); - emitter |> emitFromLoc ~loc ~type_:Token.JsxTag +let emitLongident ~backwards ~pos ~jsx ~lid ~debug emitter = + let rec flatten acc lid = + match lid with + | Longident.Lident txt -> txt :: acc + | Ldot (lid, txt) -> + let acc = if jsx && txt = "createElement" then acc else txt :: acc in + flatten acc lid + | _ -> acc + in + let rec loop pos segments = + match segments with + | [id] when isUppercaseId id || isLowercaseId id -> + if debug then Printf.printf "Lident: %s %s\n" id (posToString pos); + emitter + |> emitFromPos pos + (fst pos, snd pos + String.length id) + ~type_:(if isUppercaseId id then Token.JsxTag else Token.Variable) + | id :: segments when isUppercaseId id || isLowercaseId id -> + if debug then Printf.printf "Ldot: %s %s\n" id (posToString pos); + let length = String.length id in + emitter + |> emitFromPos pos + (fst pos, snd pos + length) + ~type_:(if isUppercaseId id then Token.JsxTag else Token.Variable); + loop (fst pos, snd pos + length + 1) segments + | _ -> () + in + let segments = flatten [] lid in + let segments = if backwards then List.rev segments else segments in + if backwards then ( + let totalLength = segments |> String.concat "." |> String.length in + if snd pos >= totalLength then + loop (fst pos, snd pos - totalLength) segments) + else loop pos segments let emitVariable ~id ~debug ~loc emitter = - if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); - emitter |> emitFromLoc ~loc ~type_:Token.Variable + emitter + |> emitLongident ~backwards:false + ~pos:(Utils.tupleOfLexing loc.Location.loc_start) + ~jsx:false ~lid:(Longident.Lident id) ~debug + +let emitJsxOpen ~lid ~debug ~loc emitter = + emitter + |> emitLongident ~backwards:false + ~pos:(Utils.tupleOfLexing loc.Location.loc_start) + ~lid ~jsx:true ~debug + +let emitJsxClose ~lid ~debug ~pos emitter = + emitter |> emitLongident ~backwards:true ~pos ~lid ~jsx:true ~debug let emitType ~id ~debug ~loc emitter = if debug then Printf.printf "Type: %s %s\n" id (locToString loc); emitter |> emitFromLoc ~loc ~type_:Token.Type -let emitJsxClose ~debug ~posStart ~posEnd emitter = - let l1, c1 = posStart and l2, c2 = posEnd in - if debug then Printf.printf "JsxClose: (%d,%d)->(%d,%d)\n" l1 c1 l2 c2; - emitter |> emitFromPos posStart posEnd ~type_:Token.JsxTag - let parser ~debug ~emitter ~path = - let jsxName lident = - 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 - | _ -> acc - in - match lident with - | Longident.Lident txt -> txt - | _ as lident -> - let segments = flatten [] lident in - segments |> String.concat "." - in let processTypeArg (coreType : Parsetree.core_type) = if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) in - let isLowercaseId id = - let c = id.[0] in - c == '_' || (c >= 'a' && c <= 'z') - in let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = match coreType.ptyp_desc with | Ptyp_constr ({txt; loc}, args) -> @@ -135,8 +161,11 @@ let parser ~debug ~emitter ~path = in let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_ident {txt = Lident id; loc} -> - if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc; + | Pexp_ident {txt = lid; loc} -> + emitter + |> emitLongident ~backwards:false + ~pos:(Utils.tupleOfLexing loc.loc_start) + ~lid ~jsx:false ~debug; Ast_mapper.default_mapper.expr mapper e | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) when Res_parsetree_viewer.isJsxExpression e -> @@ -154,7 +183,7 @@ let parser ~debug ~emitter ~path = true | _ :: rest -> isSelfClosing rest in - emitter |> emitJsxOpen ~id:(jsxName lident.txt) ~debug ~loc:pexp_loc; + emitter |> emitJsxOpen ~lid:lident.txt ~debug ~loc:pexp_loc; (if not (isSelfClosing args) then let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in @@ -162,10 +191,15 @@ let parser ~debug ~emitter ~path = let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in if length > 0 && colEndWhole > length then emitter - |> emitJsxClose ~debug - ~posStart:(lineEndWhole, colEndWhole - length - 1) - ~posEnd:(lineEndWhole, colEndWhole - 1)); - Ast_mapper.default_mapper.expr mapper e + |> emitJsxClose ~debug ~lid:lident.txt + ~pos:(lineEndWhole, colEndWhole - 1)); + (* only process again arguments, not the jsx label *) + let _ = + args + |> List.map (fun (_lbl, arg) -> + Ast_mapper.default_mapper.expr mapper arg) + in + e | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e -> if debug then Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index abff69a1b..58dc57c4a 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,19 +1,25 @@ Parse tests/src/Parser.res structure items:10 diagnostics:0 -JsxOpen: Component (4,10)->(4,19) -Variable: _c (4,4)->(4,6) -JsxOpen: M.C (6,11)->(6,14) -Variable: _mc (6,4)->(6,7) -JsxOpen: div (8,10)->(8,13) -Variable: div (8,10)->(8,13) -Variable: _d (8,4)->(8,6) -JsxOpen: div (11,3)->(11,6) -JsxClose: (16,4)->(16,7) -JsxOpen: div (13,5)->(13,8) -JsxClose: (13,34)->(13,37) -Variable: div (13,5)->(13,8) -Variable: div (11,3)->(11,6) -Variable: _d2 (10,4)->(10,7) +Lident: Component (4,10) +Lident: _c (4,4) +Ldot: M (6,11) +Lident: C (6,13) +Lident: _mc (6,4) +Lident: div (8,10) +Lident: _d (8,4) +Lident: div (11,3) +Lident: div (16,4) +Ldot: React (12,5) +Lident: string (12,11) +Lident: div (13,5) +Lident: div (13,34) +Ldot: React (13,11) +Lident: string (13,17) +Ldot: React (14,5) +Lident: string (14,11) +Ldot: React (15,5) +Lident: string (15,11) +Lident: _d2 (10,4) Type: pair (18,5)->(18,9) Type: looooooooooooooooooooooooooooooooooooooong_int (20,5)->(20,51) Type: int (20,54)->(20,57) From 40a151118243bd30a075ba211242172cb0def70e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 09:09:14 +0100 Subject: [PATCH 17/41] Rename JsxTag to Module. --- analysis/src/SemanticTokens.ml | 8 ++++---- package.json | 2 +- server/src/server.ts | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 232ec296d..dec4fd63f 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,14 +3,14 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword | Variable | Type | JsxTag + type tokenType = Keyword | Variable | Type | Module type tokenModifiers = NoModifier let tokenTypeToString = function | Keyword -> "0" | Variable -> "1" | Type -> "2" - | JsxTag -> "3" + | Module -> "3" let tokenModifiersToString = function NoModifier -> "0" @@ -94,14 +94,14 @@ let emitLongident ~backwards ~pos ~jsx ~lid ~debug emitter = emitter |> emitFromPos pos (fst pos, snd pos + String.length id) - ~type_:(if isUppercaseId id then Token.JsxTag else Token.Variable) + ~type_:(if isUppercaseId id then Module else Token.Variable) | id :: segments when isUppercaseId id || isLowercaseId id -> if debug then Printf.printf "Ldot: %s %s\n" id (posToString pos); let length = String.length id in emitter |> emitFromPos pos (fst pos, snd pos + length) - ~type_:(if isUppercaseId id then Token.JsxTag else Token.Variable); + ~type_:(if isUppercaseId id then Module else Token.Variable); loop (fst pos, snd pos + length + 1) segments | _ -> () in diff --git a/package.json b/package.json index b8707b19a..aa5f2b60b 100644 --- a/package.json +++ b/package.json @@ -31,7 +31,7 @@ "semanticTokenScopes": [ { "scopes": { - "jsx-tag": ["entity.name.tag"] + "module-tag": ["entity.name.tag"] } } ], diff --git a/server/src/server.ts b/server/src/server.ts index d6962b1e8..2f6f919da 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -760,7 +760,7 @@ function onMessage(msg: m.Message) { completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { legend: { - tokenTypes: ["keyword", "variable", "type", "jsx-tag"], + tokenTypes: ["keyword", "variable", "type", "module-tag"], tokenModifiers: [], }, documentSelector: null, From 73879ae4331b1d03135ec5b76abc48fa859481f1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 09:51:40 +0100 Subject: [PATCH 18/41] Other cases of module declarations and expressions. --- analysis/src/SemanticTokens.ml | 74 +++++++++++++++++++--- analysis/tests/src/Parser.res | 22 +++++++ analysis/tests/src/expected/Parser.res.txt | 18 +++++- 3 files changed, 105 insertions(+), 9 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index dec4fd63f..8896f3c00 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -78,7 +78,7 @@ let emitFromLoc ~loc ~type_ emitter = let posStart, posEnd = locToPositions loc in emitter |> emitFromPos posStart posEnd ~type_ -let emitLongident ~backwards ~pos ~jsx ~lid ~debug emitter = +let emitLongident ?(backwards = false) ?(jsx = false) ~pos ~lid ~debug emitter = let rec flatten acc lid = match lid with | Longident.Lident txt -> txt :: acc @@ -115,13 +115,13 @@ let emitLongident ~backwards ~pos ~jsx ~lid ~debug emitter = let emitVariable ~id ~debug ~loc emitter = emitter - |> emitLongident ~backwards:false + |> emitLongident ~pos:(Utils.tupleOfLexing loc.Location.loc_start) - ~jsx:false ~lid:(Longident.Lident id) ~debug + ~lid:(Longident.Lident id) ~debug let emitJsxOpen ~lid ~debug ~loc emitter = emitter - |> emitLongident ~backwards:false + |> emitLongident ~pos:(Utils.tupleOfLexing loc.Location.loc_start) ~lid ~jsx:true ~debug @@ -163,9 +163,7 @@ let parser ~debug ~emitter ~path = match e.pexp_desc with | Pexp_ident {txt = lid; loc} -> emitter - |> emitLongident ~backwards:false - ~pos:(Utils.tupleOfLexing loc.loc_start) - ~lid ~jsx:false ~debug; + |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; Ast_mapper.default_mapper.expr mapper e | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) when Res_parsetree_viewer.isJsxExpression e -> @@ -206,9 +204,69 @@ let parser ~debug ~emitter ~path = Ast_mapper.default_mapper.expr mapper e | _ -> Ast_mapper.default_mapper.expr mapper e in + let module_expr (mapper : Ast_mapper.mapper) (me : Parsetree.module_expr) = + match me.pmod_desc with + | Pmod_ident {txt = lid; loc} -> + emitter + |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; + Ast_mapper.default_mapper.module_expr mapper me + | _ -> Ast_mapper.default_mapper.module_expr mapper me + in + let module_binding (mapper : Ast_mapper.mapper) + (mb : Parsetree.module_binding) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing mb.pmb_name.loc.loc_start) + ~lid:(Longident.Lident mb.pmb_name.txt) ~debug; + Ast_mapper.default_mapper.module_binding mapper mb + in + let module_declaration (mapper : Ast_mapper.mapper) + (md : Parsetree.module_declaration) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing md.pmd_name.loc.loc_start) + ~lid:(Longident.Lident md.pmd_name.txt) ~debug; + Ast_mapper.default_mapper.module_declaration mapper md + in + let module_type (mapper : Ast_mapper.mapper) (mt : Parsetree.module_type) = + match mt.pmty_desc with + | Pmty_ident {txt = lid; loc} -> + emitter + |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; + Ast_mapper.default_mapper.module_type mapper mt + | _ -> Ast_mapper.default_mapper.module_type mapper mt + in + let module_type_declaration (mapper : Ast_mapper.mapper) + (mtd : Parsetree.module_type_declaration) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing mtd.pmtd_name.loc.loc_start) + ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug; + Ast_mapper.default_mapper.module_type_declaration mapper mtd + in + let open_description (mapper : Ast_mapper.mapper) + (od : Parsetree.open_description) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing od.popen_lid.loc.loc_start) + ~lid:od.popen_lid.txt ~debug; + Ast_mapper.default_mapper.open_description mapper od + in let mapper = - {Ast_mapper.default_mapper with expr; pat; typ; type_declaration} + { + Ast_mapper.default_mapper with + expr; + module_declaration; + module_binding; + module_expr; + module_type; + module_type_declaration; + open_description; + pat; + typ; + type_declaration; + } in if Filename.check_suffix path ".res" then ( diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 97f36a166..631e9f303 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -31,4 +31,26 @@ type pairIntString = list< let _ = 3 < 4 || 3 > 4 +module type MT = { + module DDF: { + + } +} + +module DDF: MT = { + module DDF = { + + } +} + +module XX = { + module YY = { + type t = int + } +} + +open XX.YY + +type tt = t + // ^par diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 58dc57c4a..9e40a855b 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,5 +1,8 @@ Parse tests/src/Parser.res -structure items:10 diagnostics:0 +structure items:15 diagnostics:0 +Lident: M (0,7) +Lident: C (1,9) +Lident: Component (1,13) Lident: Component (4,10) Lident: _c (4,4) Ldot: M (6,11) @@ -36,4 +39,17 @@ Type: looooooooooooooooooooooooooooooooooooooong_string (27,4)->(27,53) BinaryExp: (31,14)->(31,16) BinaryExp: (31,10)->(31,11) BinaryExp: (31,19)->(31,20) +Lident: MT (33,12) +Lident: DDF (34,9) +Lident: DDF (39,7) +Lident: MT (39,12) +Lident: DDF (40,9) +Lident: XX (45,7) +Lident: YY (46,9) +Type: t (47,9)->(47,10) +Type: int (47,13)->(47,16) +Ldot: XX (51,5) +Lident: YY (51,8) +Type: tt (53,5)->(53,7) +Type: t (53,10)->(53,11) From ede6f86a3227fa07e04d212cc2fee093e6e4bc35 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 10:07:44 +0100 Subject: [PATCH 19/41] For module types, use Token.Type. --- analysis/src/SemanticTokens.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 8896f3c00..d853a41e2 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -78,7 +78,8 @@ let emitFromLoc ~loc ~type_ emitter = let posStart, posEnd = locToPositions loc in emitter |> emitFromPos posStart posEnd ~type_ -let emitLongident ?(backwards = false) ?(jsx = false) ~pos ~lid ~debug emitter = +let emitLongident ?(backwards = false) ?(jsx = false) + ?(moduleToken = Token.Module) ~pos ~lid ~debug emitter = let rec flatten acc lid = match lid with | Longident.Lident txt -> txt :: acc @@ -94,14 +95,14 @@ let emitLongident ?(backwards = false) ?(jsx = false) ~pos ~lid ~debug emitter = emitter |> emitFromPos pos (fst pos, snd pos + String.length id) - ~type_:(if isUppercaseId id then Module else Token.Variable) + ~type_:(if isUppercaseId id then moduleToken else Variable) | id :: segments when isUppercaseId id || isLowercaseId id -> if debug then Printf.printf "Ldot: %s %s\n" id (posToString pos); let length = String.length id in emitter |> emitFromPos pos (fst pos, snd pos + length) - ~type_:(if isUppercaseId id then Module else Token.Variable); + ~type_:(if isUppercaseId id then moduleToken else Variable); loop (fst pos, snd pos + length + 1) segments | _ -> () in @@ -232,14 +233,16 @@ let parser ~debug ~emitter ~path = match mt.pmty_desc with | Pmty_ident {txt = lid; loc} -> emitter - |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; + |> emitLongident ~moduleToken:Token.Type + ~pos:(Utils.tupleOfLexing loc.loc_start) + ~lid ~debug; Ast_mapper.default_mapper.module_type mapper mt | _ -> Ast_mapper.default_mapper.module_type mapper mt in let module_type_declaration (mapper : Ast_mapper.mapper) (mtd : Parsetree.module_type_declaration) = emitter - |> emitLongident + |> emitLongident ~moduleToken:Token.Type ~pos:(Utils.tupleOfLexing mtd.pmtd_name.loc.loc_start) ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug; Ast_mapper.default_mapper.module_type_declaration mapper mtd From 8658618bfaec3068a01204695748abe7a6bd3dbe Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 10:11:47 +0100 Subject: [PATCH 20/41] Add token type to debug print. --- analysis/src/SemanticTokens.ml | 26 +++++---- analysis/tests/src/expected/Parser.res.txt | 64 +++++++++++----------- 2 files changed, 48 insertions(+), 42 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index d853a41e2..a449422c5 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -12,6 +12,12 @@ module Token = struct | Type -> "2" | Module -> "3" + let tokenTypeDebug = function + | Keyword -> "Keyword" + | Variable -> "Variable" + | Type -> "Type" + | Module -> "Module" + let tokenModifiersToString = function NoModifier -> "0" type token = int * int * int * tokenType * tokenModifiers @@ -91,18 +97,18 @@ let emitLongident ?(backwards = false) ?(jsx = false) let rec loop pos segments = match segments with | [id] when isUppercaseId id || isLowercaseId id -> - if debug then Printf.printf "Lident: %s %s\n" id (posToString pos); - emitter - |> emitFromPos pos - (fst pos, snd pos + String.length id) - ~type_:(if isUppercaseId id then moduleToken else Variable) + let type_ = if isUppercaseId id then moduleToken else Variable in + if debug then + Printf.printf "Lident: %s %s %s\n" id (posToString pos) + (Token.tokenTypeDebug type_); + emitter |> emitFromPos pos (fst pos, snd pos + String.length id) ~type_ | id :: segments when isUppercaseId id || isLowercaseId id -> - if debug then Printf.printf "Ldot: %s %s\n" id (posToString pos); + let type_ = if isUppercaseId id then moduleToken else Variable in + if debug then + Printf.printf "Ldot: %s %s %s\n" id (posToString pos) + (Token.tokenTypeDebug type_); let length = String.length id in - emitter - |> emitFromPos pos - (fst pos, snd pos + length) - ~type_:(if isUppercaseId id then moduleToken else Variable); + emitter |> emitFromPos pos (fst pos, snd pos + length) ~type_; loop (fst pos, snd pos + length + 1) segments | _ -> () in diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 9e40a855b..c410c3585 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,28 +1,28 @@ Parse tests/src/Parser.res structure items:15 diagnostics:0 -Lident: M (0,7) -Lident: C (1,9) -Lident: Component (1,13) -Lident: Component (4,10) -Lident: _c (4,4) -Ldot: M (6,11) -Lident: C (6,13) -Lident: _mc (6,4) -Lident: div (8,10) -Lident: _d (8,4) -Lident: div (11,3) -Lident: div (16,4) -Ldot: React (12,5) -Lident: string (12,11) -Lident: div (13,5) -Lident: div (13,34) -Ldot: React (13,11) -Lident: string (13,17) -Ldot: React (14,5) -Lident: string (14,11) -Ldot: React (15,5) -Lident: string (15,11) -Lident: _d2 (10,4) +Lident: M (0,7) Module +Lident: C (1,9) Module +Lident: Component (1,13) Module +Lident: Component (4,10) Module +Lident: _c (4,4) Variable +Ldot: M (6,11) Module +Lident: C (6,13) Module +Lident: _mc (6,4) Variable +Lident: div (8,10) Variable +Lident: _d (8,4) Variable +Lident: div (11,3) Variable +Lident: div (16,4) Variable +Ldot: React (12,5) Module +Lident: string (12,11) Variable +Lident: div (13,5) Variable +Lident: div (13,34) Variable +Ldot: React (13,11) Module +Lident: string (13,17) Variable +Ldot: React (14,5) Module +Lident: string (14,11) Variable +Ldot: React (15,5) Module +Lident: string (15,11) Variable +Lident: _d2 (10,4) Variable Type: pair (18,5)->(18,9) Type: looooooooooooooooooooooooooooooooooooooong_int (20,5)->(20,51) Type: int (20,54)->(20,57) @@ -39,17 +39,17 @@ Type: looooooooooooooooooooooooooooooooooooooong_string (27,4)->(27,53) BinaryExp: (31,14)->(31,16) BinaryExp: (31,10)->(31,11) BinaryExp: (31,19)->(31,20) -Lident: MT (33,12) -Lident: DDF (34,9) -Lident: DDF (39,7) -Lident: MT (39,12) -Lident: DDF (40,9) -Lident: XX (45,7) -Lident: YY (46,9) +Lident: MT (33,12) Type +Lident: DDF (34,9) Module +Lident: DDF (39,7) Module +Lident: MT (39,12) Type +Lident: DDF (40,9) Module +Lident: XX (45,7) Module +Lident: YY (46,9) Module Type: t (47,9)->(47,10) Type: int (47,13)->(47,16) -Ldot: XX (51,5) -Lident: YY (51,8) +Ldot: XX (51,5) Module +Lident: YY (51,8) Module Type: tt (53,5)->(53,7) Type: t (53,10)->(53,11) From 4faa239dcd36f293f691b6988deee38746932d93 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 10:26:23 +0100 Subject: [PATCH 21/41] Use JsxTag for lower-case jsx, and Namespace for modules. --- analysis/src/SemanticTokens.ml | 15 +++++--- analysis/tests/src/expected/Parser.res.txt | 44 +++++++++++----------- package.json | 2 +- server/src/server.ts | 2 +- 4 files changed, 33 insertions(+), 30 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index a449422c5..b48e9a5f4 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,20 +3,22 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword | Variable | Type | Module + type tokenType = Keyword | Variable | Type | JsxTag | Namespace type tokenModifiers = NoModifier let tokenTypeToString = function | Keyword -> "0" | Variable -> "1" | Type -> "2" - | Module -> "3" + | JsxTag -> "3" + | Namespace -> "4" let tokenTypeDebug = function | Keyword -> "Keyword" | Variable -> "Variable" | Type -> "Type" - | Module -> "Module" + | JsxTag -> "JsxTag" + | Namespace -> "Namespace" let tokenModifiersToString = function NoModifier -> "0" @@ -85,7 +87,8 @@ let emitFromLoc ~loc ~type_ emitter = emitter |> emitFromPos posStart posEnd ~type_ let emitLongident ?(backwards = false) ?(jsx = false) - ?(moduleToken = Token.Module) ~pos ~lid ~debug emitter = + ?(moduleToken = Token.Namespace) ~pos ~lid ~debug emitter = + let variableToken = if jsx then Token.JsxTag else Variable in let rec flatten acc lid = match lid with | Longident.Lident txt -> txt :: acc @@ -97,13 +100,13 @@ let emitLongident ?(backwards = false) ?(jsx = false) let rec loop pos segments = match segments with | [id] when isUppercaseId id || isLowercaseId id -> - let type_ = if isUppercaseId id then moduleToken else Variable in + let type_ = if isUppercaseId id then moduleToken else variableToken in if debug then Printf.printf "Lident: %s %s %s\n" id (posToString pos) (Token.tokenTypeDebug type_); emitter |> emitFromPos pos (fst pos, snd pos + String.length id) ~type_ | id :: segments when isUppercaseId id || isLowercaseId id -> - let type_ = if isUppercaseId id then moduleToken else Variable in + let type_ = if isUppercaseId id then moduleToken else variableToken in if debug then Printf.printf "Ldot: %s %s %s\n" id (posToString pos) (Token.tokenTypeDebug type_); diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index c410c3585..6d5b89d7e 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,26 +1,26 @@ Parse tests/src/Parser.res structure items:15 diagnostics:0 -Lident: M (0,7) Module -Lident: C (1,9) Module -Lident: Component (1,13) Module -Lident: Component (4,10) Module +Lident: M (0,7) Namespace +Lident: C (1,9) Namespace +Lident: Component (1,13) Namespace +Lident: Component (4,10) Namespace Lident: _c (4,4) Variable -Ldot: M (6,11) Module -Lident: C (6,13) Module +Ldot: M (6,11) Namespace +Lident: C (6,13) Namespace Lident: _mc (6,4) Variable -Lident: div (8,10) Variable +Lident: div (8,10) JsxTag Lident: _d (8,4) Variable -Lident: div (11,3) Variable -Lident: div (16,4) Variable -Ldot: React (12,5) Module +Lident: div (11,3) JsxTag +Lident: div (16,4) JsxTag +Ldot: React (12,5) Namespace Lident: string (12,11) Variable -Lident: div (13,5) Variable -Lident: div (13,34) Variable -Ldot: React (13,11) Module +Lident: div (13,5) JsxTag +Lident: div (13,34) JsxTag +Ldot: React (13,11) Namespace Lident: string (13,17) Variable -Ldot: React (14,5) Module +Ldot: React (14,5) Namespace Lident: string (14,11) Variable -Ldot: React (15,5) Module +Ldot: React (15,5) Namespace Lident: string (15,11) Variable Lident: _d2 (10,4) Variable Type: pair (18,5)->(18,9) @@ -40,16 +40,16 @@ BinaryExp: (31,14)->(31,16) BinaryExp: (31,10)->(31,11) BinaryExp: (31,19)->(31,20) Lident: MT (33,12) Type -Lident: DDF (34,9) Module -Lident: DDF (39,7) Module +Lident: DDF (34,9) Namespace +Lident: DDF (39,7) Namespace Lident: MT (39,12) Type -Lident: DDF (40,9) Module -Lident: XX (45,7) Module -Lident: YY (46,9) Module +Lident: DDF (40,9) Namespace +Lident: XX (45,7) Namespace +Lident: YY (46,9) Namespace Type: t (47,9)->(47,10) Type: int (47,13)->(47,16) -Ldot: XX (51,5) Module -Lident: YY (51,8) Module +Ldot: XX (51,5) Namespace +Lident: YY (51,8) Namespace Type: tt (53,5)->(53,7) Type: t (53,10)->(53,11) diff --git a/package.json b/package.json index aa5f2b60b..b8707b19a 100644 --- a/package.json +++ b/package.json @@ -31,7 +31,7 @@ "semanticTokenScopes": [ { "scopes": { - "module-tag": ["entity.name.tag"] + "jsx-tag": ["entity.name.tag"] } } ], diff --git a/server/src/server.ts b/server/src/server.ts index 2f6f919da..bfece5d47 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -760,7 +760,7 @@ function onMessage(msg: m.Message) { completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { legend: { - tokenTypes: ["keyword", "variable", "type", "module-tag"], + tokenTypes: ["keyword", "variable", "type", "jsx-tag", "namespace"], tokenModifiers: [], }, documentSelector: null, From 8ec7e315c8a1222ee1da99b5ce834f3e132de461 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 11:15:55 +0100 Subject: [PATCH 22/41] Extend example file. --- analysis/tests/src/Parser.res | 12 +++++++++++- analysis/tests/src/expected/Parser.res.txt | 9 ++++++++- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 631e9f303..4a94df57e 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -53,4 +53,14 @@ open XX.YY type tt = t -// ^par +// ^par + +module T = { + type someRecord<'typeParameter> = { + someField: int, + someOtherField: string, + theParam: 'typeParameter, + } +} + +let foo = x => x.T.someField diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 6d5b89d7e..79904df9b 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,5 +1,5 @@ Parse tests/src/Parser.res -structure items:15 diagnostics:0 +structure items:17 diagnostics:0 Lident: M (0,7) Namespace Lident: C (1,9) Namespace Lident: Component (1,13) Namespace @@ -52,4 +52,11 @@ Ldot: XX (51,5) Namespace Lident: YY (51,8) Namespace Type: tt (53,5)->(53,7) Type: t (53,10)->(53,11) +Lident: T (57,7) Namespace +Type: someRecord (58,7)->(58,17) +Type: int (59,15)->(59,18) +Type: string (60,20)->(60,26) +Lident: x (65,15) Variable +Lident: x (65,10) Variable +Lident: foo (65,4) Variable From 6645df7322953811f6182523a062a84e319711a5 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 11:17:04 +0100 Subject: [PATCH 23/41] Extend example. --- analysis/tests/src/Parser.res | 2 ++ analysis/tests/src/expected/Parser.res.txt | 7 ++++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 4a94df57e..2014244e4 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -61,6 +61,8 @@ module T = { someOtherField: string, theParam: 'typeParameter, } + + type someEnum = A | B | C } let foo = x => x.T.someField diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 79904df9b..4037b1301 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -56,7 +56,8 @@ Lident: T (57,7) Namespace Type: someRecord (58,7)->(58,17) Type: int (59,15)->(59,18) Type: string (60,20)->(60,26) -Lident: x (65,15) Variable -Lident: x (65,10) Variable -Lident: foo (65,4) Variable +Type: someEnum (64,7)->(64,15) +Lident: x (67,15) Variable +Lident: x (67,10) Variable +Lident: foo (67,4) Variable From cc4a0d3e812187cc9adcf7b9dd80215e8086423f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 11:49:11 +0100 Subject: [PATCH 24/41] Emit record labels as "property". --- analysis/src/SemanticTokens.ml | 52 +++++++++++++++++++--- analysis/tests/src/expected/Parser.res.txt | 5 +++ server/src/server.ts | 10 ++++- 3 files changed, 59 insertions(+), 8 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index b48e9a5f4..956bedeec 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -3,7 +3,15 @@ module Token = struct (* This needs to stay synced with the same legend in `server.ts` *) (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) - type tokenType = Keyword | Variable | Type | JsxTag | Namespace + type tokenType = + | Keyword + | Variable + | Type + | JsxTag + | Namespace + | EnumMember + | Property + type tokenModifiers = NoModifier let tokenTypeToString = function @@ -12,6 +20,8 @@ module Token = struct | Type -> "2" | JsxTag -> "3" | Namespace -> "4" + | EnumMember -> "5" + | Property -> "6" let tokenTypeDebug = function | Keyword -> "Keyword" @@ -19,6 +29,8 @@ module Token = struct | Type -> "Type" | JsxTag -> "JsxTag" | Namespace -> "Namespace" + | EnumMember -> "EnumMember" + | Property -> "Property" let tokenModifiersToString = function NoModifier -> "0" @@ -87,8 +99,8 @@ let emitFromLoc ~loc ~type_ emitter = emitter |> emitFromPos posStart posEnd ~type_ let emitLongident ?(backwards = false) ?(jsx = false) - ?(moduleToken = Token.Namespace) ~pos ~lid ~debug emitter = - let variableToken = if jsx then Token.JsxTag else Variable in + ?(lowerCaseToken = if jsx then Token.JsxTag else Variable) + ?(upperCaseToken = Token.Namespace) ~pos ~lid ~debug emitter = let rec flatten acc lid = match lid with | Longident.Lident txt -> txt :: acc @@ -100,13 +112,13 @@ let emitLongident ?(backwards = false) ?(jsx = false) let rec loop pos segments = match segments with | [id] when isUppercaseId id || isLowercaseId id -> - let type_ = if isUppercaseId id then moduleToken else variableToken in + let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in if debug then Printf.printf "Lident: %s %s %s\n" id (posToString pos) (Token.tokenTypeDebug type_); emitter |> emitFromPos pos (fst pos, snd pos + String.length id) ~type_ | id :: segments when isUppercaseId id || isLowercaseId id -> - let type_ = if isUppercaseId id then moduleToken else variableToken in + let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in if debug then Printf.printf "Ldot: %s %s %s\n" id (posToString pos) (Token.tokenTypeDebug type_); @@ -142,6 +154,12 @@ let emitType ~id ~debug ~loc emitter = if debug then Printf.printf "Type: %s %s\n" id (locToString loc); emitter |> emitFromLoc ~loc ~type_:Token.Type +let emitRecordLabel ~(label : Longident.t Location.loc) ~debug emitter = + emitter + |> emitLongident ~lowerCaseToken:Token.Property + ~pos:(Utils.tupleOfLexing label.loc.loc_start) + ~lid:label.txt ~debug + let parser ~debug ~emitter ~path = let processTypeArg (coreType : Parsetree.core_type) = if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) @@ -167,6 +185,10 @@ let parser ~debug ~emitter ~path = | Ppat_var {loc; txt = id} -> if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc; Ast_mapper.default_mapper.pat mapper p + | Ppat_record (cases, _) -> + cases + |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); + Ast_mapper.default_mapper.pat mapper p | _ -> Ast_mapper.default_mapper.pat mapper p in let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = @@ -212,6 +234,13 @@ let parser ~debug ~emitter ~path = -> if debug then Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); Ast_mapper.default_mapper.expr mapper e + | Pexp_record (cases, _) -> + cases + |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); + Ast_mapper.default_mapper.expr mapper e + | Pexp_field (_, label) | Pexp_setfield (_, label, _) -> + emitter |> emitRecordLabel ~label ~debug; + Ast_mapper.default_mapper.expr mapper e | _ -> Ast_mapper.default_mapper.expr mapper e in let module_expr (mapper : Ast_mapper.mapper) (me : Parsetree.module_expr) = @@ -242,7 +271,7 @@ let parser ~debug ~emitter ~path = match mt.pmty_desc with | Pmty_ident {txt = lid; loc} -> emitter - |> emitLongident ~moduleToken:Token.Type + |> emitLongident ~upperCaseToken:Token.Type ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; Ast_mapper.default_mapper.module_type mapper mt @@ -251,7 +280,7 @@ let parser ~debug ~emitter ~path = let module_type_declaration (mapper : Ast_mapper.mapper) (mtd : Parsetree.module_type_declaration) = emitter - |> emitLongident ~moduleToken:Token.Type + |> emitLongident ~upperCaseToken:Token.Type ~pos:(Utils.tupleOfLexing mtd.pmtd_name.loc.loc_start) ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug; Ast_mapper.default_mapper.module_type_declaration mapper mtd @@ -264,11 +293,20 @@ let parser ~debug ~emitter ~path = ~lid:od.popen_lid.txt ~debug; Ast_mapper.default_mapper.open_description mapper od in + let label_declaration (mapper : Ast_mapper.mapper) + (ld : Parsetree.label_declaration) = + emitter + |> emitRecordLabel + ~label:{loc = ld.pld_name.loc; txt = Longident.Lident ld.pld_name.txt} + ~debug; + Ast_mapper.default_mapper.label_declaration mapper ld + in let mapper = { Ast_mapper.default_mapper with expr; + label_declaration; module_declaration; module_binding; module_expr; diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 4037b1301..40e8e109c 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -54,9 +54,14 @@ Type: tt (53,5)->(53,7) Type: t (53,10)->(53,11) Lident: T (57,7) Namespace Type: someRecord (58,7)->(58,17) +Lident: someField (59,4) Property Type: int (59,15)->(59,18) +Lident: someOtherField (60,4) Property Type: string (60,20)->(60,26) +Lident: theParam (61,4) Property Type: someEnum (64,7)->(64,15) +Ldot: T (67,17) Namespace +Lident: someField (67,19) Property Lident: x (67,15) Variable Lident: x (67,10) Variable Lident: foo (67,4) Variable diff --git a/server/src/server.ts b/server/src/server.ts index bfece5d47..1d0656c10 100644 --- a/server/src/server.ts +++ b/server/src/server.ts @@ -760,7 +760,15 @@ function onMessage(msg: m.Message) { completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, semanticTokensProvider: { legend: { - tokenTypes: ["keyword", "variable", "type", "jsx-tag", "namespace"], + tokenTypes: [ + "keyword", + "variable", + "type", + "jsx-tag", + "namespace", + "enumMember", + "property", + ], tokenModifiers: [], }, documentSelector: null, From a91494f43452ab3e04391c51099a4bcecf0ce32b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 12:04:20 +0100 Subject: [PATCH 25/41] Emit variants as enumMember. --- analysis/src/SemanticTokens.ml | 21 +++++++++++++++++++++ analysis/tests/src/expected/Parser.res.txt | 3 +++ 2 files changed, 24 insertions(+) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 956bedeec..abed444e6 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -160,6 +160,12 @@ let emitRecordLabel ~(label : Longident.t Location.loc) ~debug emitter = ~pos:(Utils.tupleOfLexing label.loc.loc_start) ~lid:label.txt ~debug +let emitVariant ~(name : Longident.t Location.loc) ~debug emitter = + emitter + |> emitLongident ~upperCaseToken:Token.EnumMember + ~pos:(Utils.tupleOfLexing name.loc.loc_start) + ~lid:name.txt ~debug + let parser ~debug ~emitter ~path = let processTypeArg (coreType : Parsetree.core_type) = if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) @@ -189,6 +195,9 @@ let parser ~debug ~emitter ~path = cases |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); Ast_mapper.default_mapper.pat mapper p + | Ppat_construct (name, _) -> + emitter |> emitVariant ~name ~debug; + Ast_mapper.default_mapper.pat mapper p | _ -> Ast_mapper.default_mapper.pat mapper p in let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = @@ -241,6 +250,9 @@ let parser ~debug ~emitter ~path = | Pexp_field (_, label) | Pexp_setfield (_, label, _) -> emitter |> emitRecordLabel ~label ~debug; Ast_mapper.default_mapper.expr mapper e + | Pexp_construct (name, _) -> + emitter |> emitVariant ~name ~debug; + Ast_mapper.default_mapper.expr mapper e | _ -> Ast_mapper.default_mapper.expr mapper e in let module_expr (mapper : Ast_mapper.mapper) (me : Parsetree.module_expr) = @@ -301,10 +313,19 @@ let parser ~debug ~emitter ~path = ~debug; Ast_mapper.default_mapper.label_declaration mapper ld in + let constructor_declaration (mapper : Ast_mapper.mapper) + (cd : Parsetree.constructor_declaration) = + emitter + |> emitVariant + ~name:{loc = cd.pcd_name.loc; txt = Longident.Lident cd.pcd_name.txt} + ~debug; + Ast_mapper.default_mapper.constructor_declaration mapper cd + in let mapper = { Ast_mapper.default_mapper with + constructor_declaration; expr; label_declaration; module_declaration; diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 40e8e109c..922e05aba 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -60,6 +60,9 @@ Lident: someOtherField (60,4) Property Type: string (60,20)->(60,26) Lident: theParam (61,4) Property Type: someEnum (64,7)->(64,15) +Lident: A (64,18) EnumMember +Lident: B (64,22) EnumMember +Lident: C (64,26) EnumMember Ldot: T (67,17) Namespace Lident: someField (67,19) Property Lident: x (67,15) Variable From d4ceba1f5256d36abb4cedbd19b2b87850cc6d83 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 14 Mar 2022 12:07:26 +0100 Subject: [PATCH 26/41] change let coloring to keyword, not control --- grammars/rescript.tmLanguage.json | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 5932d7eae..10c5b46cb 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -15,7 +15,11 @@ }, "RE_KEYWORDS": { "name": "keyword.control", - "match": "\\b(and|as|assert|constraint|downto|else|exception|external|false|for|if|in|include|lazy|let|module|mutable|of|open|rec|switch|to|true|try|type|when|while|with)\\b" + "match": "\\b(and|as|assert|constraint|downto|else|exception|external|false|for|if|in|include|lazy|module|mutable|of|open|rec|switch|to|true|try|type|when|while|with)\\b" + }, + "RE_LET": { + "name": "keyword", + "match": "\\b(let)\\b" }, "RE_LITERAL": { "name": "constant.language", @@ -91,6 +95,9 @@ "patterns": [ { "include": "#RE_KEYWORDS" + }, + { + "include": "#RE_LET" } ] }, From a9de07c7038a0e5f6e4eb39f3f49b5dcdab0379b Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 14 Mar 2022 12:30:49 +0100 Subject: [PATCH 27/41] more samples --- .../src/syntax/sample-highlighting.res | 23 +++++++++++++++++-- .../src/syntax/sample-highlighting.tsx | 21 +++++++++++++++-- 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.res b/analysis/examples/example-project/src/syntax/sample-highlighting.res index 814c7faed..35ea24dca 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.res +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.res @@ -18,6 +18,13 @@ type someEnum = | AnotherMember | SomeMemberWithPayload(someRecord) +type somePolyEnum = [ + | #someMember + | #AnotherMember + | #SomeMemberWithPayload(someRecord) + | #"fourth Member" +] + // Destructuring let destructuring = () => { let someVar = (1, 2, 3) @@ -32,12 +39,24 @@ let destructuring = () => { someField } +module SomeModule = { + type t = Some | Value | Here +} + // JSX module SomeComponent = { @react.component - let make = () => { + let make = ( + ~someProp: int, + ~otherProp: string, + ~thirdProp: SomeModule.t, + ~fourth: somePolyEnum=#"fourth member", + ) => { React.null } } -let jsx =
+let jsx = +
+ +
diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx index 1919f6fc4..004a33c46 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx @@ -32,13 +32,30 @@ let destructuring = () => { return someField; }; +namespace SomeModule { + export enum t { + Some, + Value, + Here, + } +} + // JSX -const SomeComponent = () => { +interface Props { + someProp: number; + otherProp: string; + thirdProp: SomeModule.t; +} +const SomeComponent = ({ someProp, otherProp, thirdProp }: Props) => { return null; }; let jsx = (
- +
); From e12db8d49868bf7f0b6a50b1c019d07e2a959dbd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 15:01:01 +0100 Subject: [PATCH 28/41] Fix issue with function definitions that use labeled arguments. --- analysis/src/SemanticTokens.ml | 11 +++++------ analysis/tests/src/Parser.res | 2 ++ analysis/tests/src/expected/Parser.res.txt | 20 +++++++++++++------- 3 files changed, 20 insertions(+), 13 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index abed444e6..99bcff2a3 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -136,10 +136,8 @@ let emitLongident ?(backwards = false) ?(jsx = false) else loop pos segments let emitVariable ~id ~debug ~loc emitter = - emitter - |> emitLongident - ~pos:(Utils.tupleOfLexing loc.Location.loc_start) - ~lid:(Longident.Lident id) ~debug + if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Variable let emitJsxOpen ~lid ~debug ~loc emitter = emitter @@ -188,8 +186,9 @@ let parser ~debug ~emitter ~path = in let pat (mapper : Ast_mapper.mapper) (p : Parsetree.pattern) = match p.ppat_desc with - | Ppat_var {loc; txt = id} -> - if isLowercaseId id then emitter |> emitVariable ~id ~debug ~loc; + | Ppat_var {txt = id} -> + if isLowercaseId id then + emitter |> emitVariable ~id ~debug ~loc:p.ppat_loc; Ast_mapper.default_mapper.pat mapper p | Ppat_record (cases, _) -> cases diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 2014244e4..f7770e68e 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -66,3 +66,5 @@ module T = { } let foo = x => x.T.someField + +let add = (~hello, ~world) => hello + world diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 922e05aba..95a5d9712 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,15 +1,15 @@ Parse tests/src/Parser.res -structure items:17 diagnostics:0 +structure items:18 diagnostics:0 Lident: M (0,7) Namespace Lident: C (1,9) Namespace Lident: Component (1,13) Namespace Lident: Component (4,10) Namespace -Lident: _c (4,4) Variable +Variable: _c (4,4)->(4,6) Ldot: M (6,11) Namespace Lident: C (6,13) Namespace -Lident: _mc (6,4) Variable +Variable: _mc (6,4)->(6,7) Lident: div (8,10) JsxTag -Lident: _d (8,4) Variable +Variable: _d (8,4)->(8,6) Lident: div (11,3) JsxTag Lident: div (16,4) JsxTag Ldot: React (12,5) Namespace @@ -22,7 +22,7 @@ Ldot: React (14,5) Namespace Lident: string (14,11) Variable Ldot: React (15,5) Namespace Lident: string (15,11) Variable -Lident: _d2 (10,4) Variable +Variable: _d2 (10,4)->(10,7) Type: pair (18,5)->(18,9) Type: looooooooooooooooooooooooooooooooooooooong_int (20,5)->(20,51) Type: int (20,54)->(20,57) @@ -66,6 +66,12 @@ Lident: C (64,26) EnumMember Ldot: T (67,17) Namespace Lident: someField (67,19) Property Lident: x (67,15) Variable -Lident: x (67,10) Variable -Lident: foo (67,4) Variable +Variable: x (67,10)->(67,11) +Variable: foo (67,4)->(67,7) +BinaryExp: (69,36)->(69,37) +Lident: hello (69,30) Variable +Lident: world (69,38) Variable +Variable: world (69,19)->(69,25) +Variable: hello (69,11)->(69,17) +Variable: add (69,4)->(69,7) From 61408d54227d5f0cbaef4fc6c19e804ccb57cbe7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 16:08:41 +0100 Subject: [PATCH 29/41] tweak example file --- analysis/tests/src/Parser.res | 6 +++++- analysis/tests/src/expected/Parser.res.txt | 14 ++++++++------ 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index f7770e68e..7a44217f4 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -67,4 +67,8 @@ module T = { let foo = x => x.T.someField -let add = (~hello, ~world) => hello + world +let add = (~hello as x, ~world) => x + world + +let _ = add(~hello=3) + +let _ =
diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 95a5d9712..63606f94a 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,5 +1,5 @@ Parse tests/src/Parser.res -structure items:18 diagnostics:0 +structure items:20 diagnostics:0 Lident: M (0,7) Namespace Lident: C (1,9) Namespace Lident: Component (1,13) Namespace @@ -68,10 +68,12 @@ Lident: someField (67,19) Property Lident: x (67,15) Variable Variable: x (67,10)->(67,11) Variable: foo (67,4)->(67,7) -BinaryExp: (69,36)->(69,37) -Lident: hello (69,30) Variable -Lident: world (69,38) Variable -Variable: world (69,19)->(69,25) -Variable: hello (69,11)->(69,17) +BinaryExp: (69,37)->(69,38) +Lident: x (69,35) Variable +Lident: world (69,39) Variable +Variable: world (69,24)->(69,30) +Variable: x (69,21)->(69,22) Variable: add (69,4)->(69,7) +Lident: add (71,8) Variable +Lident: div (73,9) JsxTag From 36d67474369843fb8bc09316ab8804d326b01f06 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 14 Mar 2022 16:09:36 +0100 Subject: [PATCH 30/41] Fix recursion in jsx props and children. --- analysis/src/SemanticTokens.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 99bcff2a3..0c1164b24 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -232,11 +232,7 @@ let parser ~debug ~emitter ~path = |> emitJsxClose ~debug ~lid:lident.txt ~pos:(lineEndWhole, colEndWhole - 1)); (* only process again arguments, not the jsx label *) - let _ = - args - |> List.map (fun (_lbl, arg) -> - Ast_mapper.default_mapper.expr mapper arg) - in + let _ = args |> List.map (fun (_lbl, arg) -> mapper.expr mapper arg) in e | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e -> From 1dba34a7eaef75ce6ad2370caf26c3a5aba6e23d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 15 Mar 2022 17:43:12 +0100 Subject: [PATCH 31/41] Mark identifiers as `variable` by default. This handles the case of labels whose location is not recoverable just from the AST: - function definitions `(~label as name)` - function calls `~label = 10` - component props `prop = 42` --- grammars/rescript.tmLanguage.json | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 10c5b46cb..cd4ff79e6 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -206,6 +206,14 @@ } ] }, + "defaultIdIsVariable": { + "patterns": [ + { + "match": "[A-Za-z_][A-Za-z0-9]*", + "name": "variable" + } + ] + }, "number": { "patterns": [ { @@ -501,6 +509,9 @@ }, { "include": "#punctuations" + }, + { + "include": "#defaultIdIsVariable" } ] } From 3efe0790a873b9c9c90e9e3c4303c3e311c77211 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 15 Mar 2022 17:44:18 +0100 Subject: [PATCH 32/41] Update rescript.tmLanguage.json --- grammars/rescript.tmLanguage.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index cd4ff79e6..4a25fc8f6 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -209,7 +209,7 @@ "defaultIdIsVariable": { "patterns": [ { - "match": "[A-Za-z_][A-Za-z0-9]*", + "match": "[A-Za-z][A-Za-z0-9]*", "name": "variable" } ] From bbe1622635b6bb500cce58ad7719ea90559a093d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 15 Mar 2022 17:50:44 +0100 Subject: [PATCH 33/41] Tweak example. --- analysis/tests/src/Parser.res | 2 +- analysis/tests/src/expected/Parser.res.txt | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 7a44217f4..0bd74f449 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -71,4 +71,4 @@ let add = (~hello as x, ~world) => x + world let _ = add(~hello=3) -let _ =
+let _ =
diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 63606f94a..cf2b066ef 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -76,4 +76,6 @@ Variable: x (69,21)->(69,22) Variable: add (69,4)->(69,7) Lident: add (71,8) Variable Lident: div (73,9) JsxTag +Lident: div (73,36) JsxTag +Lident: div (73,27) JsxTag From 14f76404c6744de6d7d97007df9457682a04a233 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 15 Mar 2022 20:56:59 +0100 Subject: [PATCH 34/41] set explicit scope for true/false --- grammars/rescript.tmLanguage.json | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 4a25fc8f6..1ef1fce64 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -17,6 +17,10 @@ "name": "keyword.control", "match": "\\b(and|as|assert|constraint|downto|else|exception|external|false|for|if|in|include|lazy|module|mutable|of|open|rec|switch|to|true|try|type|when|while|with)\\b" }, + "RE_CONSTANTS_BOOL": { + "name": "constant.language.boolean", + "match": "\\b(false|true)\\b" + }, "RE_LET": { "name": "keyword", "match": "\\b(let)\\b" @@ -105,6 +109,9 @@ "patterns": [ { "include": "#RE_LITERAL" + }, + { + "include": "#RE_CONSTANTS_BOOL" } ] }, From 7a168b1486674b8aa0796fe79a1e03895e6caf93 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 15 Mar 2022 20:59:44 +0100 Subject: [PATCH 35/41] add nested sample --- .../example-project/src/syntax/sample-highlighting.res | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.res b/analysis/examples/example-project/src/syntax/sample-highlighting.res index 35ea24dca..be45a21c0 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.res +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.res @@ -54,9 +54,17 @@ module SomeComponent = { ) => { React.null } + + module Nested = { + @react.component + let make = (~children) => { + <> {children} + } + } } let jsx =
+ {React.string("Nested")}
From d0daa2b2d5d57dda305b0d09eccf04cc0a76447d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 15 Mar 2022 21:03:55 +0100 Subject: [PATCH 36/41] add nested sample to TS file as well --- .../example-project/src/syntax/sample-highlighting.tsx | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx index 004a33c46..92e654e96 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx @@ -1,6 +1,10 @@ // Bindings let numberBinding = 123; +const SomeComp = { + Nested: () => null, +}; + let someFunction = (param: number): number => { let innerBinding = param + 2; return innerBinding; From 0db650c79cb62a7a2d5a93829c88327af5e989b1 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 15 Mar 2022 21:11:03 +0100 Subject: [PATCH 37/41] samples for interpolated strings --- .../example-project/src/syntax/sample-highlighting.res | 3 +++ .../example-project/src/syntax/sample-highlighting.tsx | 3 +++ 2 files changed, 6 insertions(+) diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.res b/analysis/examples/example-project/src/syntax/sample-highlighting.res index be45a21c0..b3fd724d0 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.res +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.res @@ -43,6 +43,9 @@ module SomeModule = { type t = Some | Value | Here } +// Strings +let interpolated = `${numberBinding} ${"123"}` + // JSX module SomeComponent = { @react.component diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx index 92e654e96..4aa092c8a 100644 --- a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx @@ -44,6 +44,9 @@ namespace SomeModule { } } +// Strings +let interpolated = `${numberBinding} ${"123"}`; + // JSX interface Props { someProp: number; From 779c890027854f8f96a9c8e9e3ce36741f4c43c3 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 15 Mar 2022 21:14:02 +0100 Subject: [PATCH 38/41] set template-expression scope for interpolated strings --- grammars/rescript.tmLanguage.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 1ef1fce64..8df12ebc9 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -161,13 +161,13 @@ "begin": "\\$\\{", "beginCaptures": { "0": { - "name": "punctuation.section.interpolation.begin" + "name": "punctuation.definition.template-expression.begin" } }, "end": "\\}", "endCaptures": { "0": { - "name": "punctuation.section.interpolation.end" + "name": "punctuation.definition.template-expression.end" } }, "patterns": [ From 228374ce3fdb3ad8385863e459cdec33b31d607b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 16 Mar 2022 10:05:02 +0100 Subject: [PATCH 39/41] Tweak test: nested. --- analysis/tests/src/Parser.res | 11 +++++++++++ analysis/tests/src/expected/Parser.res.txt | 12 +++++++++++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res index 0bd74f449..c5f548da8 100644 --- a/analysis/tests/src/Parser.res +++ b/analysis/tests/src/Parser.res @@ -72,3 +72,14 @@ let add = (~hello as x, ~world) => x + world let _ = add(~hello=3) let _ =
+ +module SomeComponent = { + module Nested = { + @react.component + let make = (~children) => { + <> {children} + } + } +} + +let _ =
diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index cf2b066ef..057957748 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -1,5 +1,5 @@ Parse tests/src/Parser.res -structure items:20 diagnostics:0 +structure items:22 diagnostics:0 Lident: M (0,7) Namespace Lident: C (1,9) Namespace Lident: Component (1,13) Namespace @@ -78,4 +78,14 @@ Lident: add (71,8) Variable Lident: div (73,9) JsxTag Lident: div (73,36) JsxTag Lident: div (73,27) JsxTag +Lident: SomeComponent (75,7) Namespace +Lident: Nested (76,9) Namespace +Lident: children (79,10) Variable +Variable: children (78,16)->(78,25) +Variable: make (78,8)->(78,12) +Ldot: SomeComponent (84,9) Namespace +Lident: Nested (84,23) Namespace +Ldot: Nested (84,41) Namespace +Lident: SomeComponent (84,48) Namespace +Lident: div (84,32) JsxTag From b44828c675d0b586772f628efcfdf9942161ebd9 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 16 Mar 2022 10:05:39 +0100 Subject: [PATCH 40/41] Fix issue with closing tag of nested components. --- analysis/src/SemanticTokens.ml | 1 - analysis/tests/src/expected/Parser.res.txt | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 0c1164b24..05519cdcb 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -128,7 +128,6 @@ let emitLongident ?(backwards = false) ?(jsx = false) | _ -> () in let segments = flatten [] lid in - let segments = if backwards then List.rev segments else segments in if backwards then ( let totalLength = segments |> String.concat "." |> String.length in if snd pos >= totalLength then diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index 057957748..c1cfa3d6f 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -85,7 +85,7 @@ Variable: children (78,16)->(78,25) Variable: make (78,8)->(78,12) Ldot: SomeComponent (84,9) Namespace Lident: Nested (84,23) Namespace -Ldot: Nested (84,41) Namespace -Lident: SomeComponent (84,48) Namespace +Ldot: SomeComponent (84,41) Namespace +Lident: Nested (84,55) Namespace Lident: div (84,32) JsxTag From 9db5562b3e931cd96c75583beaf597c8ae16333f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 16 Mar 2022 09:52:56 +0100 Subject: [PATCH 41/41] Semantic highlighting: show brackets in jsx like TypeScript does. This is done in two places: The textmate grammar handles the cases that can be figured out locally: - "<" in "
" - "<>" - "" Semantic highlighting handles the cases that cannot be figured out locally: - ">" in "
" - ">" in "
" These cases can't be figures out locally as on the lhs of ">" there could be pretty much anything. --- analysis/src/SemanticTokens.ml | 27 ++++++++++++++++--- analysis/tests/src/expected/Parser.res.txt | 26 ++++++++++++------- grammars/rescript.tmLanguage.json | 30 ++++++++++++++++++++-- package.json | 2 +- 4 files changed, 69 insertions(+), 16 deletions(-) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 05519cdcb..a1c049257 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -99,8 +99,8 @@ let emitFromLoc ~loc ~type_ emitter = emitter |> emitFromPos posStart posEnd ~type_ let emitLongident ?(backwards = false) ?(jsx = false) - ?(lowerCaseToken = if jsx then Token.JsxTag else Variable) - ?(upperCaseToken = Token.Namespace) ~pos ~lid ~debug emitter = + ?(lowerCaseToken = Token.Variable) ?(upperCaseToken = Token.Namespace) ~pos + ~lid ~debug emitter = let rec flatten acc lid = match lid with | Longident.Lident txt -> txt :: acc @@ -147,6 +147,10 @@ let emitJsxOpen ~lid ~debug ~loc emitter = let emitJsxClose ~lid ~debug ~pos emitter = emitter |> emitLongident ~backwards:true ~pos ~lid ~jsx:true ~debug +let emitJsxTag ~debug ~pos emitter = + if debug then Printf.printf "JsxTag >: %s\n" (posToString pos); + emitter |> emitFromPos pos (fst pos, snd pos + 1) ~type_:Token.JsxTag + let emitType ~id ~debug ~loc emitter = if debug then Printf.printf "Type: %s %s\n" id (locToString loc); emitter |> emitFromLoc ~loc ~type_:Token.Type @@ -226,10 +230,25 @@ let parser ~debug ~emitter ~path = let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in let length = if lineStart = lineEnd then colEnd - colStart else 0 in let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in - if length > 0 && colEndWhole > length then + if length > 0 && colEndWhole > length then ( emitter |> emitJsxClose ~debug ~lid:lident.txt - ~pos:(lineEndWhole, colEndWhole - 1)); + ~pos:(lineEndWhole, colEndWhole - 1); + + let rec emitGreatherthanAfterProps args = + match args with + | (Asttypes.Labelled "children", {Parsetree.pexp_loc = {loc_start}}) + :: _ -> + emitter |> emitJsxTag ~debug ~pos:(Utils.tupleOfLexing loc_start) + | _ :: args -> emitGreatherthanAfterProps args + | [] -> () + in + emitGreatherthanAfterProps args (* <-- *); + emitter (* ... <-- *) + |> emitJsxTag ~debug + ~pos: + (let pos = Utils.tupleOfLexing e.pexp_loc.loc_end in + (fst pos, snd pos - 1)))); (* only process again arguments, not the jsx label *) let _ = args |> List.map (fun (_lbl, arg) -> mapper.expr mapper arg) in e diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt index c1cfa3d6f..9b19c2199 100644 --- a/analysis/tests/src/expected/Parser.res.txt +++ b/analysis/tests/src/expected/Parser.res.txt @@ -8,14 +8,18 @@ Variable: _c (4,4)->(4,6) Ldot: M (6,11) Namespace Lident: C (6,13) Namespace Variable: _mc (6,4)->(6,7) -Lident: div (8,10) JsxTag +Lident: div (8,10) Variable Variable: _d (8,4)->(8,6) -Lident: div (11,3) JsxTag -Lident: div (16,4) JsxTag +Lident: div (11,3) Variable +Lident: div (16,4) Variable +JsxTag >: (11,6) +JsxTag >: (16,7) Ldot: React (12,5) Namespace Lident: string (12,11) Variable -Lident: div (13,5) JsxTag -Lident: div (13,34) JsxTag +Lident: div (13,5) Variable +Lident: div (13,34) Variable +JsxTag >: (13,8) +JsxTag >: (13,37) Ldot: React (13,11) Namespace Lident: string (13,17) Variable Ldot: React (14,5) Namespace @@ -75,9 +79,11 @@ Variable: world (69,24)->(69,30) Variable: x (69,21)->(69,22) Variable: add (69,4)->(69,7) Lident: add (71,8) Variable -Lident: div (73,9) JsxTag -Lident: div (73,36) JsxTag -Lident: div (73,27) JsxTag +Lident: div (73,9) Variable +Lident: div (73,36) Variable +JsxTag >: (73,24) +JsxTag >: (73,39) +Lident: div (73,27) Variable Lident: SomeComponent (75,7) Namespace Lident: Nested (76,9) Namespace Lident: children (79,10) Variable @@ -87,5 +93,7 @@ Ldot: SomeComponent (84,9) Namespace Lident: Nested (84,23) Namespace Ldot: SomeComponent (84,41) Namespace Lident: Nested (84,55) Namespace -Lident: div (84,32) JsxTag +JsxTag >: (84,29) +JsxTag >: (84,61) +Lident: div (84,32) Variable diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 8df12ebc9..232ec7fa1 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -344,22 +344,48 @@ "jsx": { "patterns": [ { - "match": "<>||/>" + "match": "<>||/>", + "name": "punctuation.definition.tag" }, { "match": "