diff --git a/analysis/reanalyze/src/RunConfig.ml b/analysis/reanalyze/src/RunConfig.ml index 64a9ed101..3c33f7990 100644 --- a/analysis/reanalyze/src/RunConfig.ml +++ b/analysis/reanalyze/src/RunConfig.ml @@ -30,4 +30,4 @@ let dce () = runConfig.dce <- true let exception_ () = runConfig.exception_ <- true let termination () = runConfig.termination <- true -let transitive b = runConfig.transitive <- b \ No newline at end of file +let transitive b = runConfig.transitive <- b diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index e8a66ea0f..e0d79bccf 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -566,7 +566,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text = in let attribute (iterator : Ast_iterator.iterator) ((id, payload) : Parsetree.attribute) = - (if String.length id.txt >= 3 && String.sub id.txt 0 3 = "ns." then + (if String.length id.txt >= 4 && String.sub id.txt 0 4 = "res." then (* skip: internal parser attribute *) () else if id.loc.loc_ghost then () else if id.loc |> Loc.hasPos ~pos:posBeforeCursor then diff --git a/analysis/src/CompletionJsx.ml b/analysis/src/CompletionJsx.ml index d9ff3f489..aede04516 100644 --- a/analysis/src/CompletionJsx.ml +++ b/analysis/src/CompletionJsx.ml @@ -894,7 +894,7 @@ let extractJsxProps ~(compName : Longident.t Location.loc) ~args = | ((Labelled s | Optional s), (eProp : Parsetree.expression)) :: rest -> ( let namedArgLoc = eProp.pexp_attributes - |> List.find_opt (fun ({Asttypes.txt}, _) -> txt = "ns.namedArgLoc") + |> List.find_opt (fun ({Asttypes.txt}, _) -> txt = "res.namedArgLoc") in match namedArgLoc with | Some ({loc}, _) -> @@ -911,4 +911,4 @@ let extractJsxProps ~(compName : Longident.t Location.loc) ~args = | None -> processProps ~acc rest) | _ -> thisCaseShouldNotHappen in - args |> processProps ~acc:[] \ No newline at end of file + args |> processProps ~acc:[] diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index e502c4c7b..227d70f38 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -1,9 +1,8 @@ open SharedTypes -type inlayHintKind = Type | Parameter +type inlayHintKind = Type let inlayKindToNumber = function | Type -> 1 - | Parameter -> 2 let locItemToTypeHint ~full:{file; package} locItem = match locItem.locType with diff --git a/analysis/src/Markdown.ml b/analysis/src/Markdown.ml index 54b95872f..0f82050fb 100644 --- a/analysis/src/Markdown.ml +++ b/analysis/src/Markdown.ml @@ -20,4 +20,4 @@ let goToDefinitionText ~env ~pos = label = "Type definition"; file = Uri.toString env.SharedTypes.QueryEnv.file.uri; startPos = {line = startLine; character = startCol}; - } \ No newline at end of file + } diff --git a/analysis/src/Protocol.ml b/analysis/src/Protocol.ml index b9b82b08f..1f23f522e 100644 --- a/analysis/src/Protocol.ml +++ b/analysis/src/Protocol.ml @@ -34,11 +34,10 @@ type signatureHelp = { } (* https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#insertTextFormat *) -type insertTextFormat = PlainText | Snippet +type insertTextFormat = Snippet let insertTextFormatToInt f = match f with - | PlainText -> 1 | Snippet -> 2 type completionItem = { diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index c84aabf25..524661503 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -354,8 +354,7 @@ module Completion = struct detail: string option; } - let create ~kind ~env ?(docstring = []) ?filterText ?insertText ?deprecated - ?detail name = + let create ~kind ~env ?(docstring = []) ?insertText ?deprecated ?detail name = { name; env; @@ -365,12 +364,12 @@ module Completion = struct sortText = None; insertText; insertTextFormat = None; - filterText; + filterText = None; detail; } let createWithSnippet ~name ?insertText ~kind ~env ?sortText ?deprecated - ?filterText ?(docstring = []) () = + ?(docstring = []) () = { name; env; @@ -380,7 +379,7 @@ module Completion = struct sortText; insertText; insertTextFormat = Some Protocol.Snippet; - filterText; + filterText = None; detail = None; } @@ -793,7 +792,7 @@ let extractExpApplyArgs ~args = :: rest -> ( let namedArgLoc = e.pexp_attributes - |> List.find_opt (fun ({Asttypes.txt}, _) -> txt = "ns.namedArgLoc") + |> List.find_opt (fun ({Asttypes.txt}, _) -> txt = "res.namedArgLoc") in match namedArgLoc with | Some ({loc}, _) -> diff --git a/analysis/src/Utils.ml b/analysis/src/Utils.ml index c7f66b66c..ff3e0fc43 100644 --- a/analysis/src/Utils.ml +++ b/analysis/src/Utils.ml @@ -137,22 +137,6 @@ let identifyPpat pat = | Ppat_extension _ -> "Ppat_extension" | Ppat_open _ -> "Ppat_open" -let identifyType type_desc = - match type_desc with - | Types.Tvar _ -> "Tvar" - | Tarrow _ -> "Tarrow" - | Ttuple _ -> "Ttuple" - | Tconstr _ -> "Tconstr" - | Tobject _ -> "Tobject" - | Tfield _ -> "Tfield" - | Tnil -> "Tnil" - | Tlink _ -> "Tlink" - | Tsubst _ -> "Tsubst" - | Tvariant _ -> "Tvariant" - | Tunivar _ -> "Tunivar" - | Tpoly _ -> "Tpoly" - | Tpackage _ -> "Tpackage" - let rec skipWhite text i = if i < 0 then 0 else @@ -161,7 +145,7 @@ let rec skipWhite text i = | _ -> i let hasBraces attributes = - attributes |> List.exists (fun (loc, _) -> loc.Location.txt = "ns.braces") + attributes |> List.exists (fun (loc, _) -> loc.Location.txt = "res.braces") let rec unwrapIfOption (t : Types.type_expr) = match t.desc with diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index dd4f1b395..915b47273 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -146,7 +146,7 @@ module AddBracesToFn = struct }; } in - (Location.mkloc "ns.braces" loc, Parsetree.PStr []) + (Location.mkloc "res.braces" loc, Parsetree.PStr []) in let isFunction = function | {Parsetree.pexp_desc = Pexp_fun _} -> true diff --git a/analysis/src/dune b/analysis/src/dune index 1c3d71145..bc16552c3 100644 --- a/analysis/src/dune +++ b/analysis/src/dune @@ -6,4 +6,4 @@ (flags (-w "+6+26+27+32+33+39")) ; Depends on: - (libraries unix str ext ml jsonlib outcomeprinter reanalyze)) + (libraries unix str ext ml jsonlib syntax reanalyze)) diff --git a/analysis/vendor/.ocamlformat b/analysis/vendor/.ocamlformat new file mode 100644 index 000000000..593b6a1ff --- /dev/null +++ b/analysis/vendor/.ocamlformat @@ -0,0 +1 @@ +disable diff --git a/analysis/vendor/dune b/analysis/vendor/dune index 5d23f6980..e125ef55f 100644 --- a/analysis/vendor/dune +++ b/analysis/vendor/dune @@ -1 +1 @@ -(dirs compiler-libs-406 ext ml res_outcome_printer json) +(dirs ext ml res_syntax json) diff --git a/analysis/vendor/res_outcome_printer/dune b/analysis/vendor/res_outcome_printer/dune deleted file mode 100644 index c44781e52..000000000 --- a/analysis/vendor/res_outcome_printer/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name outcomeprinter) - (wrapped false) - (flags - (-w "+26+27+32+33+39")) - (libraries ml ext)) diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml b/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml deleted file mode 100644 index d4bbcd5bd..000000000 --- a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml +++ /dev/null @@ -1,1233 +0,0 @@ -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/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli b/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli deleted file mode 100644 index da60a051c..000000000 --- a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* - 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/vendor/res_outcome_printer/res_js_ffi.ml b/analysis/vendor/res_outcome_printer/res_js_ffi.ml deleted file mode 100644 index 3d02fb105..000000000 --- a/analysis/vendor/res_outcome_printer/res_js_ffi.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* 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/vendor/res_syntax/dune b/analysis/vendor/res_syntax/dune new file mode 100644 index 000000000..7765dcbf6 --- /dev/null +++ b/analysis/vendor/res_syntax/dune @@ -0,0 +1,6 @@ +(library + (name syntax) + (wrapped false) + (flags + (:standard -w +a-4-42-40-9-48-70)) + (libraries ml)) diff --git a/analysis/vendor/res_outcome_printer/react_jsx_common.ml b/analysis/vendor/res_syntax/react_jsx_common.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/react_jsx_common.ml rename to analysis/vendor/res_syntax/react_jsx_common.ml diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx.ml b/analysis/vendor/res_syntax/reactjs_jsx_ppx.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/reactjs_jsx_ppx.ml rename to analysis/vendor/res_syntax/reactjs_jsx_ppx.ml diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx.mli b/analysis/vendor/res_syntax/reactjs_jsx_ppx.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/reactjs_jsx_ppx.mli rename to analysis/vendor/res_syntax/reactjs_jsx_ppx.mli diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_v3.ml b/analysis/vendor/res_syntax/reactjs_jsx_v3.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/reactjs_jsx_v3.ml rename to analysis/vendor/res_syntax/reactjs_jsx_v3.ml diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_v4.ml b/analysis/vendor/res_syntax/reactjs_jsx_v4.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/reactjs_jsx_v4.ml rename to analysis/vendor/res_syntax/reactjs_jsx_v4.ml diff --git a/analysis/vendor/res_outcome_printer/res_ast_conversion.ml b/analysis/vendor/res_syntax/res_ast_conversion.ml similarity index 83% rename from analysis/vendor/res_outcome_printer/res_ast_conversion.ml rename to analysis/vendor/res_syntax/res_ast_conversion.ml index 419e8ae78..b8c419b80 100644 --- a/analysis/vendor/res_outcome_printer/res_ast_conversion.ml +++ b/analysis/vendor/res_syntax/res_ast_conversion.ml @@ -77,96 +77,6 @@ let rec rewritePpatOpen longidentOpen pat = {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 = - (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)); - pat = - (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); - } - let escapeTemplateLiteral s = let len = String.length s in let b = Buffer.create len in @@ -558,7 +468,7 @@ let normalize = }; ] ) -> let ternaryMarker = - (Location.mknoloc "ns.ternary", Parsetree.PStr []) + (Location.mknoloc "res.ternary", Parsetree.PStr []) in { Parsetree.pexp_loc = expr.pexp_loc; @@ -671,14 +581,6 @@ let normalize = | _ -> default_mapper.value_binding mapper vb); } -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 diff --git a/analysis/vendor/res_outcome_printer/res_ast_conversion.mli b/analysis/vendor/res_syntax/res_ast_conversion.mli similarity index 79% rename from analysis/vendor/res_outcome_printer/res_ast_conversion.mli rename to analysis/vendor/res_syntax/res_ast_conversion.mli index 8c868f44b..32163e8ce 100644 --- a/analysis/vendor/res_outcome_printer/res_ast_conversion.mli +++ b/analysis/vendor/res_syntax/res_ast_conversion.mli @@ -12,12 +12,6 @@ val replaceStringLiteralStructure : 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 diff --git a/analysis/vendor/res_outcome_printer/res_ast_debugger.ml b/analysis/vendor/res_syntax/res_ast_debugger.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_ast_debugger.ml rename to analysis/vendor/res_syntax/res_ast_debugger.ml diff --git a/analysis/vendor/res_outcome_printer/res_ast_debugger.mli b/analysis/vendor/res_syntax/res_ast_debugger.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_ast_debugger.mli rename to analysis/vendor/res_syntax/res_ast_debugger.mli diff --git a/analysis/vendor/res_outcome_printer/res_cli.ml b/analysis/vendor/res_syntax/res_cli.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_cli.ml rename to analysis/vendor/res_syntax/res_cli.ml diff --git a/analysis/vendor/res_outcome_printer/res_comment.ml b/analysis/vendor/res_syntax/res_comment.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_comment.ml rename to analysis/vendor/res_syntax/res_comment.ml diff --git a/analysis/vendor/res_outcome_printer/res_comment.mli b/analysis/vendor/res_syntax/res_comment.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_comment.mli rename to analysis/vendor/res_syntax/res_comment.mli diff --git a/analysis/vendor/res_outcome_printer/res_comments_table.ml b/analysis/vendor/res_syntax/res_comments_table.ml similarity index 95% rename from analysis/vendor/res_outcome_printer/res_comments_table.ml rename to analysis/vendor/res_syntax/res_comments_table.ml index 5ae962ae6..d12ace528 100644 --- a/analysis/vendor/res_outcome_printer/res_comments_table.ml +++ b/analysis/vendor/res_syntax/res_comments_table.ml @@ -1,5 +1,6 @@ module Comment = Res_comment module Doc = Res_doc +module ParsetreeViewer = Res_parsetree_viewer type t = { leading: (Location.t, Comment.t list) Hashtbl.t; @@ -344,16 +345,22 @@ let getLoc node = let open Parsetree in match node with | Case case -> - {case.pc_lhs.ppat_loc with loc_end = case.pc_rhs.pexp_loc.loc_end} + { + case.pc_lhs.ppat_loc with + loc_end = + (match ParsetreeViewer.processBracesAttr case.pc_rhs with + | None, _ -> case.pc_rhs.pexp_loc.loc_end + | Some ({loc}, _), _ -> loc.Location.loc_end); + } | CoreType ct -> ct.ptyp_loc | ExprArgument expr -> ( match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> {loc with loc_end = expr.pexp_loc.loc_end} | _ -> expr.pexp_loc) | Expression e -> ( match e.pexp_attributes with - | ({txt = "ns.braces"; loc}, _) :: _ -> loc + | ({txt = "res.braces" | "ns.braces"; loc}, _) :: _ -> loc | _ -> e.pexp_loc) | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} | ExtensionConstructor ec -> ec.pext_loc @@ -692,9 +699,11 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = | Ptype_abstract | Ptype_open -> rest | Ptype_record labelDeclarations -> let () = - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) - t rest + if labelDeclarations = [] then attach t.inside td.ptype_loc rest + else + walkList + (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) + t rest in [] | Ptype_variant constructorDeclarations -> @@ -1023,22 +1032,26 @@ and walkExpression expr t comments = | Pexp_array exprs | Pexp_tuple exprs -> walkList (exprs |> List.map (fun e -> Expression e)) 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; - walkExpression expr t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - attach t.trailing expr.pexp_loc afterExpr; - rest - in - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments + if rows = [] then attach t.inside expr.pexp_loc comments + else + 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; + walkExpression expr t inside; + let afterExpr, rest = + partitionAdjacentTrailing expr.pexp_loc trailing + in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + t comments | Pexp_field (expr, longident) -> let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in let trailing = @@ -1274,7 +1287,7 @@ and walkExpression expr t comments = Longident.Lident ( ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "++" | "^" - | "*" | "*." | "/" | "/." | "**" | "|." | "<>" ); + | "*" | "*." | "/" | "/." | "**" | "|." | "|.u" | "<>" ); }; }, [(Nolabel, operand1); (Nolabel, operand2)] ) -> @@ -1290,6 +1303,17 @@ and walkExpression expr t comments = walkExpression operand2 t inside; (* (List.concat [inside; after]); *) attach t.trailing operand2.pexp_loc after + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> + walkList [Expression parentExpr; Expression memberExpr] t comments + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) + -> + walkList + [Expression parentExpr; Expression memberExpr; Expression targetExpr] + t comments | Pexp_apply (callExpr, arguments) -> let before, inside, after = partitionByLoc comments callExpr.pexp_loc in let after = @@ -1304,9 +1328,43 @@ and walkExpression expr t comments = walkExpression callExpr t inside; after) in - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest + if ParsetreeViewer.isJsxExpression expr then ( + let props = + arguments + |> List.filter (fun (label, _) -> + match label with + | Asttypes.Labelled "children" -> false + | Asttypes.Nolabel -> false + | _ -> true) + in + let maybeChildren = + arguments + |> List.find_opt (fun (label, _) -> + label = Asttypes.Labelled "children") + in + match maybeChildren with + (* There is no need to deal with this situation as the children cannot be NONE *) + | None -> () + | Some (_, children) -> + let leading, inside, _ = partitionByLoc after children.pexp_loc in + if props = [] then + (* All comments inside a tag are trailing comments of the tag if there are no props + + *) + let afterExpr, _ = + partitionAdjacentTrailing callExpr.pexp_loc after + in + attach t.trailing callExpr.pexp_loc afterExpr + else + walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; + walkExpression children t inside) + else + let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in + attach t.trailing callExpr.pexp_loc afterExpr; + walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( let _, parameters, returnExpr = funExpr expr in let comments = @@ -1316,7 +1374,7 @@ and walkExpression expr t comments = let open Parsetree in let startPos = match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> loc.loc_start | _ -> pattern.ppat_loc.loc_start in @@ -1375,7 +1433,7 @@ and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = and walkExprArgument expr t comments = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> let leading, trailing = partitionLeadingTrailing comments loc in attach t.leading loc leading; let afterLabel, rest = partitionAdjacentTrailing loc trailing in @@ -1783,7 +1841,7 @@ and walkTypeParameters typeParameters t comments = visitListButContinueWithRemainingComments ~getLoc:(fun (_, _, typexpr) -> match typexpr.Parsetree.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> {loc with loc_end = typexpr.ptyp_loc.loc_end} | _ -> typexpr.ptyp_loc) ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t diff --git a/analysis/vendor/res_outcome_printer/res_core.ml b/analysis/vendor/res_syntax/res_core.ml similarity index 93% rename from analysis/vendor/res_outcome_printer/res_core.ml rename to analysis/vendor/res_syntax/res_core.ml index ba0e4d4de..6f52e1d60 100644 --- a/analysis/vendor/res_outcome_printer/res_core.ml +++ b/analysis/vendor/res_syntax/res_core.ml @@ -7,6 +7,13 @@ module ResPrinter = Res_printer module Scanner = Res_scanner module Parser = Res_parser +module LoopProgress = struct + let listRest list = + match list with + | [] -> assert false + | _ :: rest -> rest +end + let mkLoc startLoc endLoc = Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} @@ -50,7 +57,7 @@ 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 \ + middle would create new lists; out of performance concern, our pattern \ matching currently guarantees to never create new intermediate data." let recordPatternSpread = @@ -81,15 +88,6 @@ module ErrorMessages = struct ...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)" @@ -157,10 +155,10 @@ module ErrorMessages = struct 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 optionalAttr = (Location.mknoloc "ns.optional", Parsetree.PStr []) +let uncurriedAppAttr = (Location.mknoloc "res.uapp", Parsetree.PStr []) +let ternaryAttr = (Location.mknoloc "res.ternary", Parsetree.PStr []) +let ifLetAttr = (Location.mknoloc "res.iflet", Parsetree.PStr []) +let optionalAttr = (Location.mknoloc "res.optional", Parsetree.PStr []) let makeAwaitAttr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) let makeAsyncAttr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) @@ -178,9 +176,25 @@ let suppressFragileMatchWarningAttr = Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None))); ] ) -let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) +let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) + +type argument = { + dotted: bool; + label: Asttypes.arg_label; + expr: Parsetree.expression; +} + +type typeParameter = { + dotted: bool; + attrs: Ast_helper.attrs; + label: Asttypes.arg_label; + typ: Parsetree.core_type; + startPos: Lexing.position; +} + type typDefOrExt = | TypeDef of { recFlag: Asttypes.rec_flag; @@ -190,7 +204,7 @@ type typDefOrExt = type labelledParameter = | TermParameter of { - uncurried: bool; + dotted: bool; attrs: Parsetree.attributes; label: Asttypes.arg_label; expr: Parsetree.expression option; @@ -198,7 +212,7 @@ type labelledParameter = pos: Lexing.position; } | TypeParameter of { - uncurried: bool; + dotted: bool; attrs: Parsetree.attributes; locs: string Location.loc list; pos: Lexing.position; @@ -239,9 +253,13 @@ let rec goToClosing closingToken state = (* Madness *) let isEs6ArrowExpression ~inTernary p = Parser.lookahead p (fun state -> - (match state.Parser.token with - | Lident "async" -> Parser.next state - | _ -> ()); + let async = + match state.Parser.token with + | Lident "async" -> + Parser.next state; + true + | _ -> false + in match state.Parser.token with | Lident _ | Underscore -> ( Parser.next state; @@ -282,7 +300,7 @@ let isEs6ArrowExpression ~inTernary p = | EqualGreater -> true | _ -> false) | Dot (* uncurried *) -> true - | Tilde -> true + | Tilde when not async -> true | Backtick -> false (* (` always indicates the start of an expr, can't be es6 parameter *) @@ -365,9 +383,10 @@ let buildLongident words = | [] -> assert false | hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl -let makeInfixOperator p token startPos endPos = +let makeInfixOperator (p : Parser.t) token startPos endPos = let stringifiedToken = - if token = Token.MinusGreater then "|." + if token = Token.MinusGreater then + if p.uncurried_config |> Res_uncurried.isDefault then "|.u" else "|." else if token = Token.PlusPlus then "^" else if token = Token.BangEqual then "<>" else if token = Token.BangEqualEqual then "!=" @@ -510,11 +529,13 @@ let processUnderscoreApplication args = | _ -> arg in let args = List.map check_arg args in - let wrap exp_apply = + let wrap (exp_apply : Parsetree.expression) = match !exp_question with | Some {pexp_loc = loc} -> let pattern = - Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc + Ast_helper.Pat.mk + (Ppat_var (Location.mkloc hidden_var loc)) + ~loc:Location.none in Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc | None -> exp_apply @@ -1456,14 +1477,52 @@ and parseTernaryExpr leftOperand p = (Some falseBranch) | _ -> leftOperand -and parseEs6ArrowExpression ?context ?parameters p = +and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context + ?parameters p = let startPos = p.Parser.startPos in Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; + (* Parsing function parameters and attributes: + 1. Basically, attributes outside of `(...)` are added to the function, except + the uncurried attribute `(.)` is added to the function. e.g. async, uncurried + + 2. Attributes inside `(...)` are added to the arguments regardless of whether + labeled, optional or nolabeled *) let parameters = match parameters with | Some params -> params | None -> parseParameters p in + let parameters = + let updateAttrs attrs = arrowAttrs @ attrs in + let updatePos pos = + match arrowStartPos with + | Some startPos -> startPos + | None -> pos + in + match parameters with + | TermParameter p :: rest -> + TermParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} + :: rest + | TypeParameter p :: rest -> + TypeParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} + :: rest + | [] -> parameters + in + let parameters = + (* Propagate any dots from type parameters to the first term *) + let rec loop ~dotInType params = + match params with + | (TypeParameter {dotted} as p) :: _ -> + let rest = LoopProgress.listRest params in + (* Tell termination checker about progress *) + p :: loop ~dotInType:(dotInType || dotted) rest + | TermParameter termParam :: rest -> + TermParameter {termParam with dotted = dotInType || termParam.dotted} + :: rest + | [] -> [] + in + loop ~dotInType:false parameters + in let returnType = match p.Parser.token with | Colon -> @@ -1483,31 +1542,76 @@ and parseEs6ArrowExpression ?context ?parameters p = in Parser.eatBreadcrumb p; let endPos = p.prevEndPos in - let arrowExpr = + let termParameters = + parameters + |> List.filter (function + | TermParameter _ -> true + | TypeParameter _ -> false) + in + let bodyNeedsBraces = + let isFun = + match body.pexp_desc with + | Pexp_fun _ -> true + | _ -> false + in + match termParameters with + | TermParameter {dotted} :: _ + when p.uncurried_config |> Res_uncurried.fromDotted ~dotted && isFun -> + true + | TermParameter _ :: rest + when (not (p.uncurried_config |> Res_uncurried.isDefault)) && isFun -> + rest + |> List.exists (function + | TermParameter {dotted} -> dotted + | _ -> false) + | _ -> false + in + let body = + if bodyNeedsBraces then + { + body with + pexp_attributes = makeBracesAttr body.pexp_loc :: body.pexp_attributes; + } + else body + in + let _paramNum, arrowExpr, _arity = List.fold_right - (fun parameter expr -> + (fun parameter (termParamNum, expr, arity) -> match parameter with | TermParameter { - uncurried; + dotted; 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 + let loc = mkLoc startPos endPos in + let funExpr = + Ast_helper.Exp.fun_ ~loc ~attrs lbl defaultExpr pat expr + in + let uncurried = + p.uncurried_config |> Res_uncurried.fromDotted ~dotted + in + if + uncurried + && (termParamNum = 1 + || not (p.uncurried_config |> Res_uncurried.isDefault)) + then + (termParamNum - 1, Ast_uncurried.uncurriedFun ~loc ~arity funExpr, 1) + else (termParamNum - 1, funExpr, arity + 1) + | TypeParameter {dotted = _; attrs; locs = newtypes; pos = startPos} -> + ( termParamNum, + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr, + arity )) + parameters + (List.length termParameters, body, 1) in {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} (* - * uncurried_parameter ::= + * dotted_parameter ::= * | . parameter * * parameter ::= @@ -1531,18 +1635,12 @@ and parseParameter p = || 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 dotted = Parser.optional p Token.Dot in 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})) + Some (TypeParameter {dotted; attrs; locs = lidents; pos = startPos})) else let attrs, lbl, pat = match p.Parser.token with @@ -1550,14 +1648,14 @@ and parseParameter p = Parser.next p; let lblName, loc = parseLident p in let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in 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 + Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc (Location.mkloc lblName loc) ) | Colon -> let lblEnd = p.prevEndPos in @@ -1567,25 +1665,30 @@ and parseParameter p = 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 + Ast_helper.Pat.constraint_ ~attrs:(propLocAttr :: attrs) ~loc pat + typ in - (attrs, Asttypes.Labelled lblName, pat) + ([], Asttypes.Labelled lblName, pat) | As -> Parser.next p; let pat = let pat = parseConstrainedPattern p in - {pat with ppat_attributes = propLocAttr :: pat.ppat_attributes} + { + pat with + ppat_attributes = (propLocAttr :: attrs) @ pat.ppat_attributes; + } in - (attrs, Asttypes.Labelled lblName, pat) + ([], 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) )) + Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc + (Location.mkloc lblName loc) )) | _ -> let pattern = parseConstrainedPattern p in - let attrs = List.concat [attrs; pattern.ppat_attributes] in + let attrs = List.concat [pattern.ppat_attributes; attrs] in ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) in match p.Parser.token with @@ -1611,13 +1714,13 @@ and parseParameter p = Parser.next p; Some (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) | _ -> let expr = parseConstrainedOrCoercedExpr p in Some (TermParameter { - uncurried; + dotted; attrs; label = lbl; expr = Some expr; @@ -1627,7 +1730,7 @@ and parseParameter p = | _ -> Some (TermParameter - {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) else None and parseParameterList p = @@ -1654,7 +1757,7 @@ and parseParameters p = [ TermParameter { - uncurried = false; + dotted = false; attrs = []; label = Asttypes.Nolabel; expr = None; @@ -1668,7 +1771,7 @@ and parseParameters p = [ TermParameter { - uncurried = false; + dotted = false; attrs = []; label = Asttypes.Nolabel; expr = None; @@ -1690,7 +1793,7 @@ and parseParameters p = [ TermParameter { - uncurried = false; + dotted = false; attrs = []; label = Asttypes.Nolabel; expr = None; @@ -1712,7 +1815,7 @@ and parseParameters p = [ TermParameter { - uncurried = true; + dotted = true; attrs = []; label = Asttypes.Nolabel; expr = None; @@ -1722,25 +1825,10 @@ and parseParameters p = ] | _ -> ( 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 + | TermParameter p :: rest -> + TermParameter {p with dotted = true; pos = startPos} :: rest + | TypeParameter p :: rest -> + TypeParameter {p with dotted = true; pos = startPos} :: rest | parameters -> parameters)) | _ -> parseParameterList p) | token -> @@ -2023,7 +2111,7 @@ and parseUnaryExpr p = * the operands of the binary expression with opeartor `+` *) and parseOperandExpr ~context p = let startPos = p.Parser.startPos in - let attrs = parseAttributes p in + let attrs = ref (parseAttributes p) in let expr = match p.Parser.token with | Assert -> @@ -2039,7 +2127,9 @@ and parseOperandExpr ~context p = *) when isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p -> - parseAsyncArrowExpression p + let arrowAttrs = !attrs in + let () = attrs := [] in + parseAsyncArrowExpression ~arrowAttrs p | Await -> parseAwaitExpression p | Lazy -> Parser.next p; @@ -2055,13 +2145,16 @@ and parseOperandExpr ~context p = if context != WhenExpr && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - then parseEs6ArrowExpression ~context p + then + let arrowAttrs = !attrs in + let () = attrs := [] in + parseEs6ArrowExpression ~arrowAttrs ~context p else parseUnaryExpr p in (* let endPos = p.Parser.prevEndPos in *) { expr with - pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; attrs]; + pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; !attrs]; (* pexp_loc = mkLoc startPos endPos *) } @@ -2107,7 +2200,11 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = let startPos = p.startPos in Parser.next p; let endPos = p.prevEndPos in - let b = parseBinaryExpr ~context p (tokenPrec + 1) in + let tokenPrec = + (* exponentiation operator is right-associative *) + if token = Exponentiation then tokenPrec else tokenPrec + 1 + in + let b = parseBinaryExpr ~context p tokenPrec in let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in let expr = Ast_helper.Exp.apply ~loc @@ -2589,7 +2686,7 @@ and parseJsxProp p = let optional = Parser.optional p Question in let name, loc = parseLident p in let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in (* optional punning: *) if optional then @@ -2628,14 +2725,14 @@ and parseJsxProp p = Parser.next p; let loc = mkLoc p.Parser.startPos p.prevEndPos in let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + let e = parsePrimaryExpr ~operand:(parseExpr p) p in {e with pexp_attributes = propLocAttr :: e.pexp_attributes} in (* using label "spreadProps" to distinguish from others *) - let label = Asttypes.Labelled "spreadProps" in + let label = Asttypes.Labelled "_spreadProps" in match p.Parser.token with | Rbrace -> Parser.next p; @@ -2836,11 +2933,11 @@ and parseBracedOrRecordExpr p = [ TermParameter { - uncurried = false; + dotted = false; attrs = []; label = Asttypes.Nolabel; expr = None; - pat = Ast_helper.Pat.var ident; + pat = Ast_helper.Pat.var ~loc:ident.loc ident; pos = startPos; }; ] @@ -3120,22 +3217,19 @@ and parseExprBlock ?first p = Parser.eatBreadcrumb p; overParseConstrainedOrCoercedOrArrowExpression p blockExpr -and parseAsyncArrowExpression p = +and parseAsyncArrowExpression ?(arrowAttrs = []) p = let startPos = p.Parser.startPos in Parser.expect (Lident "async") p; let asyncAttr = makeAsyncAttr (mkLoc startPos p.prevEndPos) in - let expr = parseEs6ArrowExpression p in - { - expr with - pexp_attributes = asyncAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = startPos}; - } + parseEs6ArrowExpression ~arrowAttrs:(asyncAttr :: arrowAttrs) + ~arrowStartPos:(Some startPos) p and parseAwaitExpression p = let awaitLoc = mkLoc p.Parser.startPos p.endPos in let awaitAttr = makeAwaitAttr awaitLoc in Parser.expect Await p; - let expr = parseUnaryExpr p in + let tokenPrec = Token.precedence MinusGreater in + let expr = parseBinaryExpr ~context:OrdinaryExpr p tokenPrec in { expr with pexp_attributes = awaitAttr :: expr.pexp_attributes; @@ -3402,10 +3496,10 @@ and parseSwitchExpression p = * | ~ label-name = ? _ (* syntax sugar *) * | ~ label-name = ? expr : type * - * uncurried_argument ::= + * dotted_argument ::= * | . argument *) -and parseArgument p = +and parseArgument p : argument option = if p.Parser.token = Token.Tilde || p.token = Dot || p.token = Underscore @@ -3413,7 +3507,7 @@ and parseArgument p = then match p.Parser.token with | Dot -> ( - let uncurried = true in + let dotted = true in Parser.next p; match p.token with (* apply(.) *) @@ -3423,21 +3517,21 @@ and parseArgument p = (Location.mknoloc (Longident.Lident "()")) None in - Some (uncurried, Asttypes.Nolabel, unitExpr) - | _ -> parseArgument2 p ~uncurried) - | _ -> parseArgument2 p ~uncurried:false + Some {dotted; label = Asttypes.Nolabel; expr = unitExpr} + | _ -> parseArgument2 p ~dotted) + | _ -> parseArgument2 p ~dotted:false else None -and parseArgument2 p ~uncurried = +and parseArgument2 p ~dotted : argument option = 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 = + let expr = Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) in - Some (uncurried, Asttypes.Nolabel, exp) + Some {dotted; label = Nolabel; expr} | Tilde -> ( Parser.next p; (* TODO: nesting of pattern matches not intuitive for error recovery *) @@ -3448,7 +3542,7 @@ and parseArgument2 p ~uncurried = let endPos = p.prevEndPos in let loc = mkLoc startPos endPos in let propLocAttr = - (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc @@ -3457,7 +3551,7 @@ and parseArgument2 p ~uncurried = match p.Parser.token with | Question -> Parser.next p; - Some (uncurried, Asttypes.Optional ident, identExpr) + Some {dotted; label = Optional ident; expr = identExpr} | Equal -> Parser.next p; let label = @@ -3478,7 +3572,7 @@ and parseArgument2 p ~uncurried = let expr = parseConstrainedOrCoercedExpr p in {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} in - Some (uncurried, label, expr) + Some {dotted; label; expr} | Colon -> Parser.next p; let typ = parseTypExpr p in @@ -3486,12 +3580,12 @@ and parseArgument2 p ~uncurried = let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in - Some (uncurried, Labelled ident, expr) - | _ -> Some (uncurried, Labelled ident, identExpr)) + Some {dotted; label = Labelled ident; expr} + | _ -> Some {dotted; label = Labelled ident; expr = identExpr}) | t -> Parser.err p (Diagnostics.lident t); - Some (uncurried, Nolabel, Recover.defaultExpr ())) - | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) + Some {dotted; label = Nolabel; expr = Recover.defaultExpr ()}) + | _ -> Some {dotted; label = Nolabel; expr = parseConstrainedOrCoercedExpr p} and parseCallExpr p funExpr = Parser.expect Lparen p; @@ -3508,20 +3602,26 @@ and parseCallExpr p funExpr = 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 ); + { + dotted = false; + label = Nolabel; + expr = + 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) ); + { + dotted = true; + label = Nolabel; + expr = + { + 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, @@ -3537,41 +3637,46 @@ and parseCallExpr p funExpr = * 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"))) ); + { + dotted = true; + label = Nolabel; + expr = + 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) + | {dotted = d; label = lbl; expr} :: args -> + let group (grp, acc) {dotted; label = lbl; expr} = + let _d, grp = grp in + if dotted == true then ((true, [(lbl, expr)]), (_d, List.rev grp) :: acc) + else ((_d, (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) + let (_d, grp), acc = List.fold_left group ((d, [(lbl, expr)]), []) args in + List.rev ((_d, List.rev grp) :: acc) | [] -> [] in let apply = List.fold_left (fun callBody group -> - let uncurried, args = group in + let dotted, args = group in let args, wrap = processUnderscoreApplication args in let exp = + let uncurried = + p.uncurried_config |> Res_uncurried.fromDotted ~dotted + in if uncurried then - let attrs = [uncurryAttr] in + let attrs = [uncurriedAppAttr] in Ast_helper.Exp.apply ~loc ~attrs callBody args else Ast_helper.Exp.apply ~loc callBody args in @@ -3703,37 +3808,60 @@ and parseTupleExpr ~first ~startPos p = let loc = mkLoc startPos p.prevEndPos in Ast_helper.Exp.tuple ~loc exprs -and parseSpreadExprRegion p = +and parseSpreadExprRegionWithLoc p = + let startPos = p.Parser.prevEndPos in match p.Parser.token with | DotDotDot -> Parser.next p; let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr) + Some (true, expr, startPos, p.prevEndPos) | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p) + Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) | _ -> None and parseListExpr ~startPos p = - let listExprs = + let split_by_spread exprs = + List.fold_left + (fun acc curr -> + match (curr, acc) with + | (true, expr, startPos, endPos), _ -> + (* find a spread expression, prepend a new sublist *) + ([], Some expr, startPos, endPos) :: acc + | ( (false, expr, startPos, _endPos), + (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, startPos, accEndPos) :: acc + | (false, expr, startPos, endPos), [] -> + (* find a non-spread expression, and the accumulated is empty *) + [([expr], None, startPos, endPos)]) + [] exprs + in + let make_sub_expr = function + | exprs, Some spread, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs (Some spread) + | exprs, None, startPos, endPos -> + makeListExpression (mkLoc startPos endPos) exprs None + in + let listExprsRev = parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace - ~f:parseSpreadExprRegion + ~f:parseSpreadExprRegionWithLoc 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) + match split_by_spread listExprsRev with + | [] -> makeListExpression loc [] None + | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) + | [(exprs, None, _, _)] -> makeListExpression loc exprs None | 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 + let listExprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] (* Overparse ... and give a nice error message *) and parseNonSpreadExp ~msg p = @@ -3791,7 +3919,10 @@ and parsePolyTypeExpr 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 + let tFun = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in + if p.uncurried_config |> Res_uncurried.isDefault then + Ast_uncurried.uncurriedType ~loc ~arity:1 tFun + else tFun | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) | _ -> parseTypExpr p @@ -3997,7 +4128,7 @@ and parseTypeAlias p typ = * | attrs ~ident: type_expr -> attrs are on the arrow * | attrs type_expr -> attrs are here part of the type_expr * - * uncurried_type_parameter ::= + * dotted_type_parameter ::= * | . type_parameter *) and parseTypeParameter p = @@ -4007,14 +4138,14 @@ and parseTypeParameter p = || Grammar.isTypExprStart p.token then let startPos = p.Parser.startPos in - let uncurried = Parser.optional p Dot in + let dotted = 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 []) + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = @@ -4025,8 +4156,8 @@ and parseTypeParameter p = | Equal -> Parser.next p; Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) + Some {dotted; attrs; label = Optional name; typ; startPos} + | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) | Lident _ -> ( let name, loc = parseLident p in match p.token with @@ -4044,8 +4175,8 @@ and parseTypeParameter p = | Equal -> Parser.next p; Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)) + Some {dotted; attrs; label = Optional name; typ; startPos} + | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) | _ -> let constr = Location.mkloc (Longident.Lident name) loc in let args = parseTypeConstructorArgs ~constrName:constr p in @@ -4057,13 +4188,14 @@ and parseTypeParameter p = let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in let typ = parseTypeAlias p typ in - Some (uncurried, [], Asttypes.Nolabel, typ, startPos)) + Some {dotted; attrs = []; label = Nolabel; typ; startPos}) | _ -> let typ = parseTypExpr p in let typWithAttributes = {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} in - Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) + Some + {dotted; attrs = []; label = Nolabel; typ = typWithAttributes; startPos} else None (* (int, ~x:string, float) *) @@ -4076,7 +4208,7 @@ and parseTypeParameters 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)] + [{dotted = false; attrs = []; label = Nolabel; typ; startPos}] | _ -> let params = parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen @@ -4091,7 +4223,9 @@ and parseEs6ArrowType ~attrs p = | Tilde -> Parser.next p; let name, loc = parseLident p in - let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + let lblLocAttr = + (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) + in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = let typ = parseTypExpr ~alias:false ~es6Arrow:false p in @@ -4114,12 +4248,37 @@ and parseEs6ArrowType ~attrs p = Parser.expect EqualGreater p; let returnType = parseTypExpr ~alias:false p in let endPos = p.prevEndPos in - let typ = + let returnTypeArity = + match parameters with + | _ when p.uncurried_config |> Res_uncurried.isDefault -> 0 + | _ -> + if parameters |> List.exists (function {dotted; typ = _} -> dotted) + then 0 + else + let _, args, _ = Res_parsetree_viewer.arrowType returnType in + List.length args + in + let _paramNum, typ, _arity = 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 + (fun {dotted; attrs; label = argLbl; typ; startPos} (paramNum, t, arity) -> + let uncurried = + p.uncurried_config |> Res_uncurried.fromDotted ~dotted + in + if + uncurried + && (paramNum = 1 + || not (p.uncurried_config |> Res_uncurried.isDefault)) + then + let loc = mkLoc startPos endPos in + let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in + (paramNum - 1, Ast_uncurried.uncurriedType ~loc ~arity tArg, 1) + else + ( paramNum - 1, + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl + typ t, + arity + 1 )) + parameters + (List.length parameters, returnType, returnTypeArity + 1) in { typ with @@ -4173,7 +4332,10 @@ and parseArrowTypeRest ~es6Arrow ~startPos typ 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 + let arrowTyp = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in + if p.uncurried_config |> Res_uncurried.isDefault then + Ast_uncurried.uncurriedType ~loc ~arity:1 arrowTyp + else arrowTyp | _ -> typ and parseTypExprRegion p = @@ -5376,7 +5538,7 @@ and parseStructureItemRegion p = Parser.next p; Some (Ast_helper.Str.attribute ~loc - ( {txt = "ns.doc"; loc}, + ( {txt = "res.doc"; loc}, PStr [ Ast_helper.Str.eval ~loc @@ -5409,7 +5571,7 @@ and parseStructureItemRegion p = Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) | _ -> None) - [@@progress Parser.next, Parser.expect] + [@@progress Parser.next, Parser.expect, LoopProgress.listRest] (* include-statement ::= include module-expr *) and parseIncludeStatement ~attrs p = @@ -6008,7 +6170,7 @@ and parseSignatureItemRegion p = Parser.next p; Some (Ast_helper.Sig.attribute ~loc - ( {txt = "ns.doc"; loc}, + ( {txt = "res.doc"; loc}, PStr [ Ast_helper.Str.eval ~loc @@ -6026,7 +6188,7 @@ and parseSignatureItemRegion p = (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); Some Recover.defaultSignatureItem | _ -> None) - [@@progress Parser.next, Parser.expect] + [@@progress Parser.next, Parser.expect, LoopProgress.listRest] (* module rec module-name : module-type { and module-name: module-type } *) and parseRecModuleSpec ~attrs ~startPos p = @@ -6223,7 +6385,7 @@ and parseAttribute p = | DocComment (loc, s) -> Parser.next p; Some - ( {txt = "ns.doc"; loc}, + ( {txt = "res.doc"; loc}, PStr [ Ast_helper.Str.eval ~loc @@ -6241,9 +6403,16 @@ and parseAttributes p = *) and parseStandaloneAttribute p = let startPos = p.startPos in - (* XX *) Parser.expect AtAt p; let attrId = parseAttributeId ~startPos p in + let attrId = + match attrId.txt with + | "uncurried" -> + p.uncurried_config <- Res_uncurried.Default; + attrId + | "toUncurried" -> {attrId with txt = "uncurried"} + | _ -> attrId + in let payload = parsePayload p in (attrId, payload) diff --git a/analysis/vendor/res_outcome_printer/res_core.mli b/analysis/vendor/res_syntax/res_core.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_core.mli rename to analysis/vendor/res_syntax/res_core.mli diff --git a/analysis/vendor/res_outcome_printer/res_diagnostics.ml b/analysis/vendor/res_syntax/res_diagnostics.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_diagnostics.ml rename to analysis/vendor/res_syntax/res_diagnostics.ml diff --git a/analysis/vendor/res_outcome_printer/res_diagnostics.mli b/analysis/vendor/res_syntax/res_diagnostics.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_diagnostics.mli rename to analysis/vendor/res_syntax/res_diagnostics.mli diff --git a/analysis/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml b/analysis/vendor/res_syntax/res_diagnostics_printing_utils.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml rename to analysis/vendor/res_syntax/res_diagnostics_printing_utils.ml diff --git a/analysis/vendor/res_outcome_printer/res_doc.ml b/analysis/vendor/res_syntax/res_doc.ml similarity index 97% rename from analysis/vendor/res_outcome_printer/res_doc.ml rename to analysis/vendor/res_syntax/res_doc.ml index f997f4e41..125ac7725 100644 --- a/analysis/vendor/res_outcome_printer/res_doc.ml +++ b/analysis/vendor/res_syntax/res_doc.ml @@ -133,6 +133,15 @@ let join ~sep docs = in concat (loop [] sep docs) +let joinWithSep docsWithSep = + let rec loop acc docs = + match docs with + | [] -> List.rev acc + | [(x, _sep)] -> List.rev (x :: acc) + | (x, sep) :: xs -> loop (sep :: x :: acc) xs + in + concat (loop [] docsWithSep) + let fits w stack = let width = ref w in let result = ref None in diff --git a/analysis/vendor/res_outcome_printer/res_doc.mli b/analysis/vendor/res_syntax/res_doc.mli similarity index 94% rename from analysis/vendor/res_outcome_printer/res_doc.mli rename to analysis/vendor/res_syntax/res_doc.mli index cfb79fe31..f1a0c6ea6 100644 --- a/analysis/vendor/res_outcome_printer/res_doc.mli +++ b/analysis/vendor/res_syntax/res_doc.mli @@ -20,6 +20,9 @@ val customLayout : t list -> t val breakParent : t val join : sep:t -> t list -> t +(* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) +val joinWithSep : (t * t) list -> t + val space : t val comma : t val dot : t diff --git a/analysis/vendor/res_outcome_printer/res_driver.ml b/analysis/vendor/res_syntax/res_driver.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_driver.ml rename to analysis/vendor/res_syntax/res_driver.ml diff --git a/analysis/vendor/res_outcome_printer/res_driver.mli b/analysis/vendor/res_syntax/res_driver.mli similarity index 98% rename from analysis/vendor/res_outcome_printer/res_driver.mli rename to analysis/vendor/res_syntax/res_driver.mli index 8211487ef..fe44722a6 100644 --- a/analysis/vendor/res_outcome_printer/res_driver.mli +++ b/analysis/vendor/res_syntax/res_driver.mli @@ -24,12 +24,14 @@ val parseImplementationFromSource : displayFilename:string -> source:string -> (Parsetree.structure, Res_diagnostics.t list) parseResult + [@@live] val parseInterfaceFromSource : forPrinter:bool -> displayFilename:string -> source:string -> (Parsetree.signature, Res_diagnostics.t list) parseResult + [@@live] type printEngine = { printImplementation: diff --git a/analysis/vendor/res_outcome_printer/res_driver_binary.ml b/analysis/vendor/res_syntax/res_driver_binary.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_driver_binary.ml rename to analysis/vendor/res_syntax/res_driver_binary.ml diff --git a/analysis/vendor/res_outcome_printer/res_driver_binary.mli b/analysis/vendor/res_syntax/res_driver_binary.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_driver_binary.mli rename to analysis/vendor/res_syntax/res_driver_binary.mli diff --git a/analysis/vendor/res_outcome_printer/res_driver_ml_parser.ml b/analysis/vendor/res_syntax/res_driver_ml_parser.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_driver_ml_parser.ml rename to analysis/vendor/res_syntax/res_driver_ml_parser.ml diff --git a/analysis/vendor/res_outcome_printer/res_driver_ml_parser.mli b/analysis/vendor/res_syntax/res_driver_ml_parser.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_driver_ml_parser.mli rename to analysis/vendor/res_syntax/res_driver_ml_parser.mli diff --git a/analysis/vendor/res_outcome_printer/res_grammar.ml b/analysis/vendor/res_syntax/res_grammar.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_grammar.ml rename to analysis/vendor/res_syntax/res_grammar.ml diff --git a/analysis/vendor/res_outcome_printer/res_io.ml b/analysis/vendor/res_syntax/res_io.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_io.ml rename to analysis/vendor/res_syntax/res_io.ml diff --git a/analysis/vendor/res_outcome_printer/res_io.mli b/analysis/vendor/res_syntax/res_io.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_io.mli rename to analysis/vendor/res_syntax/res_io.mli diff --git a/analysis/vendor/res_outcome_printer/res_minibuffer.ml b/analysis/vendor/res_syntax/res_minibuffer.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_minibuffer.ml rename to analysis/vendor/res_syntax/res_minibuffer.ml diff --git a/analysis/vendor/res_outcome_printer/res_minibuffer.mli b/analysis/vendor/res_syntax/res_minibuffer.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_minibuffer.mli rename to analysis/vendor/res_syntax/res_minibuffer.mli diff --git a/analysis/vendor/res_outcome_printer/res_multi_printer.ml b/analysis/vendor/res_syntax/res_multi_printer.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_multi_printer.ml rename to analysis/vendor/res_syntax/res_multi_printer.ml diff --git a/analysis/vendor/res_outcome_printer/res_multi_printer.mli b/analysis/vendor/res_syntax/res_multi_printer.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_multi_printer.mli rename to analysis/vendor/res_syntax/res_multi_printer.mli diff --git a/analysis/vendor/res_outcome_printer/res_outcome_printer.ml b/analysis/vendor/res_syntax/res_outcome_printer.ml similarity index 98% rename from analysis/vendor/res_outcome_printer/res_outcome_printer.ml rename to analysis/vendor/res_syntax/res_outcome_printer.ml index 97560bf22..6cea0b955 100644 --- a/analysis/vendor/res_outcome_printer/res_outcome_printer.ml +++ b/analysis/vendor/res_syntax/res_outcome_printer.ml @@ -34,12 +34,6 @@ let isValidNumericPolyvarNumber (x : string) = | _ -> false) else a >= 48 -(* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *) -let isArityIdent ident = - if String.length ident >= 6 then - (String.sub [@doesNotRaise]) ident 0 5 = "arity" - else false - type identifierStyle = ExoticIdent | NormalIdent let classifyIdentContent ~allowUident txt = @@ -210,18 +204,18 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = Doc.text aliasTxt; Doc.rparen; ] - | Otyp_constr - ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), - (* Js.Fn.arity0 *) - [typ] ) -> - (* Js.Fn.arity0 -> (.) => t *) + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), [typ]) + -> + (* Compatibility with compiler up to v10.x *) Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] | Otyp_constr - ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), ident), - (* Js.Fn.arity2 *) - [(Otyp_arrow _ as arrowType)] (* (int, int) => int *) ) - when isArityIdent ident -> - (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*) + ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), _), + [(Otyp_arrow _ as arrowType)] ) -> + (* Compatibility with compiler up to v10.x *) + printOutArrowType ~uncurried:true arrowType + | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrowType); _arity]) + -> + (* function$<(int, int) => int, [#2]> -> (. int, int) => int *) printOutArrowType ~uncurried:true arrowType | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent | Otyp_manifest (typ1, typ2) -> diff --git a/analysis/vendor/res_outcome_printer/res_outcome_printer.mli b/analysis/vendor/res_syntax/res_outcome_printer.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_outcome_printer.mli rename to analysis/vendor/res_syntax/res_outcome_printer.mli diff --git a/analysis/vendor/res_outcome_printer/res_parens.ml b/analysis/vendor/res_syntax/res_parens.ml similarity index 93% rename from analysis/vendor/res_outcome_printer/res_parens.ml rename to analysis/vendor/res_syntax/res_parens.ml index c18b7565e..d6628c872 100644 --- a/analysis/vendor/res_outcome_printer/res_parens.ml +++ b/analysis/vendor/res_syntax/res_parens.ml @@ -15,6 +15,16 @@ let expr expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) +let exprRecordRowRhs e = + let kind = expr e in + match kind with + | Nothing when Res_parsetree_viewer.hasOptionalAttribute e.pexp_attributes + -> ( + match e.pexp_desc with + | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized + | _ -> kind) + | _ -> kind + let callExpr expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with @@ -175,7 +185,11 @@ let flattenOperandRhs parentOperator rhs = | _ when ParsetreeViewer.isTernaryExpr rhs -> true | _ -> false -let lazyOrAssertOrAwaitExprRhs expr = +let binaryOperatorInsideAwaitNeedsParens operator = + ParsetreeViewer.operatorPrecedence operator + < ParsetreeViewer.operatorPrecedence "|." + +let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -186,7 +200,14 @@ let lazyOrAssertOrAwaitExprRhs expr = | _ :: _ -> true | [] -> false -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | { + pexp_desc = + Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, _); + } + when ParsetreeViewer.isBinaryExpression expr -> + if inAwait && not (binaryOperatorInsideAwaitNeedsParens operator) then + Nothing + else Parenthesized | { pexp_desc = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); @@ -202,7 +223,9 @@ let lazyOrAssertOrAwaitExprRhs expr = | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ + when (not inAwait) + && ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> Parenthesized | _ -> Nothing) @@ -278,8 +301,8 @@ let ternaryOperand expr = } -> Nothing | {pexp_desc = Pexp_constraint _} -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> ( - let _attrsOnArrow, _parameters, returnExpr = + | _ when Res_parsetree_viewer.isFunNewtype expr -> ( + let _uncurried, _attrsOnArrow, _parameters, returnExpr = ParsetreeViewer.funExpr expr in match returnExpr.pexp_desc with diff --git a/analysis/vendor/res_outcome_printer/res_parens.mli b/analysis/vendor/res_syntax/res_parens.mli similarity index 85% rename from analysis/vendor/res_outcome_printer/res_parens.mli rename to analysis/vendor/res_syntax/res_parens.mli index cedf98e13..9b60b815f 100644 --- a/analysis/vendor/res_outcome_printer/res_parens.mli +++ b/analysis/vendor/res_syntax/res_parens.mli @@ -10,7 +10,8 @@ val subBinaryExprOperand : string -> string -> bool val rhsBinaryExprOperand : string -> Parsetree.expression -> bool val flattenOperandRhs : string -> Parsetree.expression -> bool -val lazyOrAssertOrAwaitExprRhs : Parsetree.expression -> kind +val binaryOperatorInsideAwaitNeedsParens : string -> bool +val lazyOrAssertOrAwaitExprRhs : ?inAwait:bool -> Parsetree.expression -> kind val fieldExpr : Parsetree.expression -> kind @@ -34,3 +35,5 @@ val includeModExpr : Parsetree.module_expr -> bool val arrowReturnTypExpr : Parsetree.core_type -> bool val patternRecordRowRhs : Parsetree.pattern -> bool + +val exprRecordRowRhs : Parsetree.expression -> kind diff --git a/analysis/vendor/res_outcome_printer/res_parser.ml b/analysis/vendor/res_syntax/res_parser.ml similarity index 96% rename from analysis/vendor/res_outcome_printer/res_parser.ml rename to analysis/vendor/res_syntax/res_parser.ml index 9fcdc3c5c..1d1026398 100644 --- a/analysis/vendor/res_outcome_printer/res_parser.ml +++ b/analysis/vendor/res_syntax/res_parser.ml @@ -22,6 +22,7 @@ type t = { mutable diagnostics: Diagnostics.t list; mutable comments: Comment.t list; mutable regions: regionStatus ref list; + mutable uncurried_config: Res_uncurried.config; } let err ?startPos ?endPos p error = @@ -121,6 +122,7 @@ let make ?(mode = ParseForTypeChecker) src filename = diagnostics = []; comments = []; regions = [ref Report]; + uncurried_config = Res_uncurried.init; } in parserState.scanner.err <- @@ -168,6 +170,7 @@ let lookahead p callback = let errors = p.errors in let diagnostics = p.diagnostics in let comments = p.comments in + let uncurried_config = p.uncurried_config in let res = callback p in @@ -185,5 +188,6 @@ let lookahead p callback = p.errors <- errors; p.diagnostics <- diagnostics; p.comments <- comments; + p.uncurried_config <- uncurried_config; res diff --git a/analysis/vendor/res_outcome_printer/res_parser.mli b/analysis/vendor/res_syntax/res_parser.mli similarity index 96% rename from analysis/vendor/res_outcome_printer/res_parser.mli rename to analysis/vendor/res_syntax/res_parser.mli index 09b0b455f..8a00c722e 100644 --- a/analysis/vendor/res_outcome_printer/res_parser.mli +++ b/analysis/vendor/res_syntax/res_parser.mli @@ -21,6 +21,7 @@ type t = { mutable diagnostics: Diagnostics.t list; mutable comments: Comment.t list; mutable regions: regionStatus ref list; + mutable uncurried_config: Res_uncurried.config; } val make : ?mode:mode -> string -> string -> t diff --git a/analysis/vendor/res_outcome_printer/res_parsetree_viewer.ml b/analysis/vendor/res_syntax/res_parsetree_viewer.ml similarity index 78% rename from analysis/vendor/res_outcome_printer/res_parsetree_viewer.ml rename to analysis/vendor/res_syntax/res_parsetree_viewer.ml index c22dfb23c..1d2b43804 100644 --- a/analysis/vendor/res_outcome_printer/res_parsetree_viewer.ml +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.ml @@ -1,20 +1,22 @@ open Parsetree -let arrowType ct = - let rec process attrsBefore acc typ = +let arrowType ?(arity = max_int) ct = + let rec process attrsBefore acc typ arity = match typ with + | typ when arity <= 0 -> (attrsBefore, List.rev acc, typ) | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + process attrsBefore (arg :: acc) typ2 (arity - 1) | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = [({txt = "bs" | "res.async"}, _)] as attrs; + ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); + ptyp_attributes = [({txt = "bs"}, _)]; } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + (* stop here, the uncurried attribute always indicates the beginning of an arrow function + * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) + (attrsBefore, List.rev acc, typ) | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> let args = List.rev acc in @@ -24,14 +26,14 @@ let arrowType ct = ptyp_attributes = attrs; } -> let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + process attrsBefore (arg :: acc) typ2 (arity - 1) | typ -> (attrsBefore, List.rev acc, typ) in match ct with | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> - process attrs [] {typ with ptyp_attributes = []} - | typ -> process [] [] typ + process attrs [] {typ with ptyp_attributes = []} arity + | typ -> process [] [] typ arity let functorType modtype = let rec process acc modtype = @@ -46,29 +48,43 @@ let functorType modtype = in process [] modtype -let processUncurriedAttribute attrs = - let rec process uncurriedSpotted acc attrs = +let processBsAttribute attrs = + let rec process bsSpotted acc attrs = match attrs with - | [] -> (uncurriedSpotted, List.rev acc) + | [] -> (bsSpotted, List.rev acc) | ({Location.txt = "bs"}, _) :: rest -> process true acc rest - | attr :: rest -> process uncurriedSpotted (attr :: acc) rest + | attr :: rest -> process bsSpotted (attr :: acc) rest + in + process false [] attrs + +let processUncurriedAppAttribute attrs = + let rec process uncurriedApp acc attrs = + match attrs with + | [] -> (uncurriedApp, List.rev acc) + | ( { + Location.txt = + "bs" (* still support @bs to convert .ml files *) | "res.uapp"; + }, + _ ) + :: rest -> + process true acc rest + | attr :: rest -> process uncurriedApp (attr :: acc) rest in process false [] attrs type functionAttributesInfo = { async: bool; - uncurried: bool; + bs: bool; attributes: Parsetree.attributes; } let processFunctionAttributes attrs = - let rec process async uncurried acc attrs = + let rec process async bs acc attrs = match attrs with - | [] -> {async; uncurried; attributes = List.rev acc} + | [] -> {async; bs; attributes = List.rev acc} | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest - | ({Location.txt = "res.async"}, _) :: rest -> - process true uncurried acc rest - | attr :: rest -> process async uncurried (attr :: acc) rest + | ({Location.txt = "res.async"}, _) :: rest -> process true bs acc rest + | attr :: rest -> process async bs (attr :: acc) rest in process false false [] attrs @@ -135,7 +151,7 @@ let funExpr expr = collectNewTypes (stringLoc :: acc) returnExpr | returnExpr -> (List.rev acc, returnExpr) in - let rec collect attrsBefore acc expr = + let rec collect ~uncurried ~nFun attrsBefore acc expr = match expr with | { pexp_desc = @@ -145,44 +161,39 @@ let funExpr expr = {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; defaultExpr; pat = pattern} in - collect attrsBefore (parameter :: acc) returnExpr + (uncurried, attrsBefore, List.rev acc, rewriteUnderscoreApply expr) | {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 + collect ~uncurried ~nFun attrsBefore (param :: acc) returnExpr | { pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = [({txt = "bs"}, _)] as attrs; - } -> - let parameter = Parameter {attrs; lbl; defaultExpr; pat = pattern} in - collect attrsBefore (parameter :: acc) returnExpr - | { - pexp_desc = - Pexp_fun - (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); - pexp_attributes = attrs; + pexp_attributes = []; } -> - let parameter = Parameter {attrs; lbl; defaultExpr; pat = pattern} in - collect attrsBefore (parameter :: acc) returnExpr - | expr -> (attrsBefore, List.rev acc, expr) + let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in + collect ~uncurried ~nFun:(nFun + 1) attrsBefore (parameter :: acc) + returnExpr + (* If a fun has an attribute, then it stops here and makes currying. + i.e attributes outside of (...), uncurried `(.)` and `async` make currying *) + | {pexp_desc = Pexp_fun _} -> (uncurried, attrsBefore, List.rev acc, expr) + | expr when nFun = 0 && Ast_uncurried.exprIsUncurriedFun expr -> + let expr = Ast_uncurried.exprExtractUncurriedFun expr in + collect ~uncurried:true ~nFun attrsBefore acc expr + | expr -> (uncurried, attrsBefore, List.rev acc, expr) in 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 + | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> + collect ~uncurried:false ~nFun:0 expr.pexp_attributes [] + {expr with pexp_attributes = []} + | _ when Ast_uncurried.exprIsUncurriedFun expr -> + let expr = Ast_uncurried.exprExtractUncurriedFun expr in + collect ~uncurried:true ~nFun:0 expr.pexp_attributes [] + {expr with pexp_attributes = []} + | _ -> collect ~uncurried:false ~nFun:0 [] [] expr let processBracesAttr expr = match expr.pexp_attributes with - | (({txt = "ns.braces"}, _) as attr) :: attrs -> + | (({txt = "res.braces" | "ns.braces"}, _) as attr) :: attrs -> (Some attr, {expr with pexp_attributes = attrs}) | _ -> (None, expr) @@ -192,9 +203,9 @@ let filterParsingAttrs attrs = match attr with | ( { Location.txt = - ( "bs" | "ns.braces" | "ns.iflet" | "ns.namedArgLoc" - | "ns.optional" | "ns.ternary" | "res.async" | "res.await" - | "res.template" ); + ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces" + | "res.iflet" | "res.namedArgLoc" | "res.optional" | "res.ternary" + | "res.async" | "res.await" | "res.template" ); }, _ ) -> false @@ -264,7 +275,7 @@ let operatorPrecedence operator = | "+" | "+." | "-" | "-." | "^" -> 5 | "*" | "*." | "/" | "/." -> 6 | "**" -> 7 - | "#" | "##" | "|." -> 8 + | "#" | "##" | "|." | "|.u" -> 8 | _ -> 0 let isUnaryOperator operator = @@ -286,7 +297,7 @@ let isBinaryOperator operator = match operator with | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." - | "<>" -> + | "|.u" | "<>" -> true | _ -> false @@ -309,6 +320,11 @@ let isEqualityOperator operator = | "=" | "==" | "<>" | "!=" -> true | _ -> false +let isRhsBinaryOperator operator = + match operator with + | "**" -> true + | _ -> false + let flattenableOperators parentOperator childOperator = let precParent = operatorPrecedence parentOperator in let precChild = operatorPrecedence childOperator in @@ -319,7 +335,7 @@ let flattenableOperators parentOperator childOperator = let rec hasIfLetAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.iflet"}, _) :: _ -> true + | ({Location.txt = "res.iflet"}, _) :: _ -> true | _ :: attrs -> hasIfLetAttribute attrs let isIfLetExpr expr = @@ -332,7 +348,7 @@ let isIfLetExpr expr = let rec hasOptionalAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.optional"}, _) :: _ -> true + | ({Location.txt = "ns.optional" | "res.optional"}, _) :: _ -> true | _ :: attrs -> hasOptionalAttribute attrs let hasAttributes attrs = @@ -341,8 +357,9 @@ let hasAttributes attrs = match attr with | ( { Location.txt = - ( "bs" | "ns.braces" | "ns.iflet" | "ns.ternary" | "res.async" - | "res.await" | "res.template" ); + ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces" + | "res.iflet" | "res.ternary" | "res.async" | "res.await" + | "res.template" ); }, _ ) -> false @@ -410,7 +427,7 @@ let collectIfExpressions expr = let rec hasTernaryAttribute attrs = match attrs with | [] -> false - | ({Location.txt = "ns.ternary"}, _) :: _ -> true + | ({Location.txt = "res.ternary"}, _) :: _ -> true | _ :: attrs -> hasTernaryAttribute attrs let isTernaryExpr expr = @@ -444,7 +461,7 @@ let filterTernaryAttributes attrs = List.filter (fun attr -> match attr with - | {Location.txt = "ns.ternary"}, _ -> false + | {Location.txt = "res.ternary"}, _ -> false | _ -> true) attrs @@ -523,8 +540,9 @@ let isPrintableAttribute attr = match attr with | ( { Location.txt = - ( "bs" | "ns.iflet" | "ns.braces" | "JSX" | "res.async" | "res.await" - | "res.template" | "ns.ternary" ); + ( "bs" | "res.uapp" | "res.arity" | "res.iflet" | "res.braces" + | "ns.braces" | "JSX" | "res.async" | "res.await" | "res.template" + | "res.ternary" ); }, _ ) -> false @@ -537,12 +555,17 @@ let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs let partitionPrintableAttributes attrs = List.partition isPrintableAttribute attrs +let isFunNewtype expr = + match expr.pexp_desc with + | Pexp_fun _ | Pexp_newtype _ -> true + | _ -> Ast_uncurried.exprIsUncurriedFun expr + 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 + | [(_, expr)] when isFunNewtype expr -> true + | (_, expr) :: _ when isFunNewtype expr -> false | _ :: rest -> loop rest in loop args @@ -551,12 +574,12 @@ let requiresSpecialCallbackPrintingFirstArg args = let rec loop args = match args with | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: _ -> false + | (_, expr) :: _ when isFunNewtype expr -> false | _ :: rest -> loop rest in match args with - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _}) :: rest -> loop rest + | [(_, expr)] when isFunNewtype expr -> false + | (_, expr) :: rest when isFunNewtype expr -> loop rest | _ -> false let modExprApply modExpr = @@ -608,6 +631,25 @@ let isTemplateLiteral expr = | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true | _ -> false +let hasSpreadAttr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.spread"}, _ -> true + | _ -> false) + attrs + +let isSpreadBeltListConcat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); + } -> + hasSpreadAttr expr.pexp_attributes + | _ -> false + (* Blue | Red | Green -> [Blue; Red; Green] *) let collectOrPatternChain pat = let rec loop pattern chain = @@ -633,14 +675,14 @@ let isSinglePipeExpr expr = let isPipeExpr expr = match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, + ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> true | _ -> false in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>")}}, + ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, [(Nolabel, operand1); (Nolabel, _operand2)] ) when not (isPipeExpr operand1) -> true diff --git a/analysis/vendor/res_outcome_printer/res_parsetree_viewer.mli b/analysis/vendor/res_syntax/res_parsetree_viewer.mli similarity index 93% rename from analysis/vendor/res_outcome_printer/res_parsetree_viewer.mli rename to analysis/vendor/res_syntax/res_parsetree_viewer.mli index f1f5fa329..1cc0f5995 100644 --- a/analysis/vendor/res_outcome_printer/res_parsetree_viewer.mli +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.mli @@ -2,6 +2,7 @@ * The parsetree contains: a => b => c => d, for printing purposes * we restructure the tree into (a, b, c) and its returnType d *) val arrowType : + ?arity:int -> Parsetree.core_type -> Parsetree.attributes * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list @@ -14,12 +15,14 @@ val functorType : * Parsetree.module_type (* filters @bs out of the provided attributes *) -val processUncurriedAttribute : +val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes + +val processUncurriedAppAttribute : Parsetree.attributes -> bool * Parsetree.attributes type functionAttributesInfo = { async: bool; - uncurried: bool; + bs: bool; attributes: Parsetree.attributes; } @@ -55,7 +58,7 @@ type funParamKind = val funExpr : Parsetree.expression -> - Parsetree.attributes * funParamKind list * Parsetree.expression + bool * Parsetree.attributes * funParamKind list * Parsetree.expression (* example: * `makeCoordinate({ @@ -74,6 +77,7 @@ val operatorPrecedence : string -> int val isUnaryExpression : Parsetree.expression -> bool val isBinaryOperator : string -> bool val isBinaryExpression : Parsetree.expression -> bool +val isRhsBinaryOperator : string -> bool val flattenableOperators : string -> string -> bool @@ -132,6 +136,8 @@ val isBlockExpr : Parsetree.expression -> bool val isTemplateLiteral : Parsetree.expression -> bool val hasTemplateLiteralAttr : Parsetree.attributes -> bool +val isSpreadBeltListConcat : Parsetree.expression -> bool + val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list val processBracesAttr : @@ -152,3 +158,5 @@ val isUnderscoreApplySugar : Parsetree.expression -> bool val hasIfLetAttribute : Parsetree.attributes -> bool val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool + +val isFunNewtype : Parsetree.expression -> bool diff --git a/analysis/vendor/res_outcome_printer/res_printer.ml b/analysis/vendor/res_syntax/res_printer.ml similarity index 74% rename from analysis/vendor/res_outcome_printer/res_printer.ml rename to analysis/vendor/res_syntax/res_printer.ml index b22d5cc9a..995d12c72 100644 --- a/analysis/vendor/res_outcome_printer/res_printer.ml +++ b/analysis/vendor/res_syntax/res_printer.ml @@ -113,6 +113,16 @@ let hasNestedJsxOrMoreThanOneChild expr = in loop false expr +let hasCommentsInside tbl loc = + match Hashtbl.find_opt tbl.CommentTable.inside loc with + | None -> false + | _ -> true + +let hasTrailingComments tbl loc = + match Hashtbl.find_opt tbl.CommentTable.trailing loc with + | None -> false + | _ -> true + let printMultilineCommentContent txt = (* Turns * |* first line @@ -228,7 +238,40 @@ let printLeadingComment ?nextComment comment = in Doc.concat [content; separator] +(* This function is used for printing comments inside an empty block *) let printCommentsInside cmtTbl loc = + let printComment comment = + let singleLine = Comment.isSingleLineComment comment in + let txt = Comment.txt comment in + if singleLine then Doc.text ("//" ^ txt) + else printMultilineCommentContent txt + in + let forceBreak = + loc.Location.loc_start.pos_lnum <> loc.Location.loc_end.pos_lnum + in + let rec loop acc comments = + match comments with + | [] -> Doc.nil + | [comment] -> + let cmtDoc = printComment comment in + let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let doc = + Doc.breakableGroup ~forceBreak + (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) + in + doc + | comment :: rest -> + let cmtDoc = Doc.concat [printComment comment; Doc.line] 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; + loop [] comments + +(* This function is used for printing comments inside an empty file *) +let printCommentsInsideFile cmtTbl = let rec loop acc comments = match comments with | [] -> Doc.nil @@ -242,10 +285,10 @@ let printCommentsInside cmtTbl loc = let cmtDoc = printLeadingComment ~nextComment comment in loop (cmtDoc :: acc) rest in - match Hashtbl.find cmtTbl.CommentTable.inside loc with + match Hashtbl.find cmtTbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; + Hashtbl.remove cmtTbl.inside Location.none; Doc.group (loop [] comments) let printLeadingComments node tbl loc = @@ -510,7 +553,7 @@ let printConstant ?(templateLiteral = false) c = | Pconst_float (s, _) -> Doc.text s | Pconst_char c -> let str = - match Char.chr c with + match Char.unsafe_chr c with | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" @@ -521,7 +564,7 @@ let printConstant ?(templateLiteral = false) c = let s = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set s 0 c; Bytes.unsafe_to_string s - | c -> Res_utf8.encodeCodePoint (Obj.magic c) + | _ -> Res_utf8.encodeCodePoint c in Doc.text ("'" ^ str ^ "'") @@ -529,19 +572,29 @@ let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" else Doc.nil -let customLayoutThreshold = 2 +module State = struct + let customLayoutThreshold = 2 + + type t = {customLayout: int; mutable uncurried_config: Res_uncurried.config} + + let init = {customLayout = 0; uncurried_config = Res_uncurried.init} + + let nextCustomLayout t = {t with customLayout = t.customLayout + 1} -let rec printStructure ~customLayout (s : Parsetree.structure) t = + let shouldBreakCallback t = t.customLayout > customLayoutThreshold +end + +let rec printStructure ~state (s : Parsetree.structure) t = match s with - | [] -> printCommentsInside t Location.none + | [] -> printCommentsInsideFile t | structure -> printList ~getLoc:(fun s -> s.Parsetree.pstr_loc) ~nodes:structure - ~print:(printStructureItem ~customLayout) + ~print:(printStructureItem ~state) t -and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = +and printStructureItem ~state (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> let recFlag = @@ -549,58 +602,56 @@ and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + printValueBindings ~state ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> let recFlag = match recFlag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~state valueDescription cmtTbl | Pstr_eval (expr, attrs) -> let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.structureExpr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] + Doc.concat [printAttributes ~state attrs cmtTbl; exprDoc] | Pstr_attribute attr -> - printAttribute ~customLayout ~standalone:true attr cmtTbl + fst (printAttribute ~state ~standalone:true attr cmtTbl) | Pstr_extension (extension, attrs) -> Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + printAttributes ~state attrs cmtTbl; + Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; ] | Pstr_include includeDeclaration -> - printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + printIncludeDeclaration ~state includeDeclaration cmtTbl | Pstr_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~state openDescription cmtTbl | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~state modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~state ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> printListi ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) ~nodes:moduleBindings - ~print:(printModuleBinding ~customLayout ~isRec:true) + ~print:(printModuleBinding ~state ~isRec:true) cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl - | Pstr_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printExceptionDef ~state extensionConstructor cmtTbl + | Pstr_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil -and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = +and printTypeExtension ~state (te : Parsetree.type_extension) cmtTbl = let prefix = Doc.text "type " in let name = printLidentPath te.ptyext_path cmtTbl in - let typeParams = printTypeParams ~customLayout te.ptyext_params cmtTbl in + let typeParams = printTypeParams ~state te.ptyext_params cmtTbl in let extensionConstructors = let ecs = te.ptyext_constructors in let forceBreak = @@ -618,7 +669,7 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let rows = printListi ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~print:(printExtensionConstructor ~customLayout) + ~print:(printExtensionConstructor ~state) ~nodes:ecs ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak @@ -636,8 +687,8 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~customLayout ~loc:te.ptyext_path.loc - te.ptyext_attributes cmtTbl; + printAttributes ~state ~loc:te.ptyext_path.loc te.ptyext_attributes + cmtTbl; prefix; name; typeParams; @@ -645,7 +696,7 @@ and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = extensionConstructors; ]) -and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = +and printModuleBinding ~state ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat @@ -655,9 +706,9 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( printModExpr ~customLayout modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) - | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) + ( printModExpr ~state modExpr cmtTbl, + Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl] ) + | modExpr -> (printModExpr ~state modExpr cmtTbl, Doc.nil) in let modName = let doc = Doc.text moduleBinding.pmb_name.Location.txt in @@ -666,7 +717,7 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let doc = Doc.concat [ - printAttributes ~customLayout ~loc:moduleBinding.pmb_name.loc + printAttributes ~state ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes cmtTbl; prefix; modName; @@ -677,7 +728,7 @@ and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = in printComments doc cmtTbl moduleBinding.pmb_loc -and printModuleTypeDeclaration ~customLayout +and printModuleTypeDeclaration ~state (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = let modName = let doc = Doc.text modTypeDecl.pmtd_name.txt in @@ -685,39 +736,36 @@ and printModuleTypeDeclaration ~customLayout in Doc.concat [ - printAttributes ~customLayout modTypeDecl.pmtd_attributes cmtTbl; + printAttributes ~state modTypeDecl.pmtd_attributes cmtTbl; Doc.text "module type "; modName; (match modTypeDecl.pmtd_type with | None -> Doc.nil | Some modType -> - Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); + Doc.concat [Doc.text " = "; printModType ~state modType cmtTbl]); ] -and printModType ~customLayout modType cmtTbl = +and printModType ~state modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> Doc.concat [ - printAttributes ~customLayout ~loc:longident.loc - modType.pmty_attributes cmtTbl; + printAttributes ~state ~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; - ]) + if hasCommentsInside cmtTbl modType.pmty_loc then + let doc = printCommentsInside cmtTbl modType.pmty_loc in + Doc.concat [Doc.lbrace; doc; Doc.rbrace] + else + 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.softLine; Doc.softLine; Doc.rbrace]) | Pmty_signature signature -> let signatureDoc = Doc.breakableGroup ~forceBreak:true @@ -725,17 +773,13 @@ and printModType ~customLayout modType cmtTbl = [ Doc.lbrace; Doc.indent - (Doc.concat - [Doc.line; printSignature ~customLayout signature cmtTbl]); + (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); Doc.line; Doc.rbrace; ]) in Doc.concat - [ - printAttributes ~customLayout modType.pmty_attributes cmtTbl; - signatureDoc; - ] + [printAttributes ~state modType.pmty_attributes cmtTbl; signatureDoc] | Pmty_functor _ -> let parameters, returnType = ParsetreeViewer.functorType modType in let parametersDoc = @@ -745,10 +789,8 @@ and printModType ~customLayout modType cmtTbl = let cmtLoc = {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in - let attrs = printAttributes ~customLayout attrs cmtTbl in - let doc = - Doc.concat [attrs; printModType ~customLayout modType cmtTbl] - in + let attrs = printAttributes ~state attrs cmtTbl in + let doc = Doc.concat [attrs; printModType ~state modType cmtTbl] in printComments doc cmtTbl cmtLoc | params -> Doc.group @@ -774,7 +816,7 @@ and printModType ~customLayout modType cmtTbl = } in let attrs = - printAttributes ~customLayout attrs cmtTbl + printAttributes ~state attrs cmtTbl in let lblDoc = if lbl.Location.txt = "_" || lbl.txt = "*" then @@ -795,8 +837,7 @@ and printModType ~customLayout modType cmtTbl = [ (if lbl.txt = "_" then Doc.nil else Doc.text ": "); - printModType ~customLayout modType - cmtTbl; + printModType ~state modType cmtTbl; ]); ] in @@ -809,7 +850,7 @@ and printModType ~customLayout modType cmtTbl = ]) in let returnDoc = - let doc = printModType ~customLayout returnType cmtTbl in + let doc = printModType ~state returnType cmtTbl in if Parens.modTypeFunctorReturn returnType then addParens doc else doc in Doc.group @@ -820,14 +861,14 @@ and printModType ~customLayout modType cmtTbl = ]) | Pmty_typeof modExpr -> Doc.concat - [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] + [Doc.text "module type of "; printModExpr ~state modExpr cmtTbl] | Pmty_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~state ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] | Pmty_with (modType, withConstraints) -> let operand = - let doc = printModType ~customLayout modType cmtTbl in + let doc = printModType ~state modType cmtTbl in if Parens.modTypeWithOperand modType then addParens doc else doc in Doc.group @@ -836,10 +877,7 @@ and printModType ~customLayout modType cmtTbl = operand; Doc.indent (Doc.concat - [ - Doc.line; - printWithConstraints ~customLayout withConstraints cmtTbl; - ]); + [Doc.line; printWithConstraints ~state withConstraints cmtTbl]); ]) in let attrsAlreadyPrinted = @@ -851,13 +889,13 @@ and printModType ~customLayout modType cmtTbl = Doc.concat [ (if attrsAlreadyPrinted then Doc.nil - else printAttributes ~customLayout modType.pmty_attributes cmtTbl); + else printAttributes ~state modType.pmty_attributes cmtTbl); modTypeDoc; ] in printComments doc cmtTbl modType.pmty_loc -and printWithConstraints ~customLayout withConstraints cmtTbl = +and printWithConstraints ~state withConstraints cmtTbl = let rows = List.mapi (fun i withConstraint -> @@ -865,19 +903,19 @@ and printWithConstraints ~customLayout withConstraints cmtTbl = (Doc.concat [ (if i == 0 then Doc.text "with " else Doc.text "and "); - printWithConstraint ~customLayout withConstraint cmtTbl; + printWithConstraint ~state withConstraint cmtTbl; ])) withConstraints in Doc.join ~sep:Doc.line rows -and printWithConstraint ~customLayout - (withConstraint : Parsetree.with_constraint) cmtTbl = +and printWithConstraint ~state (withConstraint : Parsetree.with_constraint) + cmtTbl = match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> Doc.group - (printTypeDeclaration ~customLayout + (printTypeDeclaration ~state ~name:(printLidentPath longident cmtTbl) ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) @@ -892,7 +930,7 @@ and printWithConstraint ~customLayout (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> Doc.group - (printTypeDeclaration ~customLayout + (printTypeDeclaration ~state ~name:(printLidentPath longident cmtTbl) ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> @@ -904,60 +942,58 @@ and printWithConstraint ~customLayout Doc.indent (Doc.concat [Doc.line; printLongident longident2]); ] -and printSignature ~customLayout signature cmtTbl = +and printSignature ~state signature cmtTbl = match signature with - | [] -> printCommentsInside cmtTbl Location.none + | [] -> printCommentsInsideFile cmtTbl | signature -> printList ~getLoc:(fun s -> s.Parsetree.psig_loc) ~nodes:signature - ~print:(printSignatureItem ~customLayout) + ~print:(printSignatureItem ~state) cmtTbl -and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = +and printSignatureItem ~state (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription ~customLayout valueDescription cmtTbl + printValueDescription ~state valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> let recFlag = match recFlag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl - | Psig_typext typeExtension -> - printTypeExtension ~customLayout typeExtension cmtTbl + printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl + | Psig_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~state extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration ~customLayout moduleDeclaration cmtTbl + printModuleDeclaration ~state moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + printRecModuleDeclarations ~state moduleDeclarations cmtTbl | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + printModuleTypeDeclaration ~state modTypeDecl cmtTbl | Psig_open openDescription -> - printOpenDescription ~customLayout openDescription cmtTbl + printOpenDescription ~state openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription ~customLayout includeDescription cmtTbl + printIncludeDescription ~state includeDescription cmtTbl | Psig_attribute attr -> - printAttribute ~customLayout ~standalone:true attr cmtTbl + fst (printAttribute ~state ~standalone:true attr cmtTbl) | Psig_extension (extension, attrs) -> Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; - Doc.concat - [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; + printAttributes ~state attrs cmtTbl; + Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; ] | Psig_class _ | Psig_class_type _ -> Doc.nil -and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = +and printRecModuleDeclarations ~state moduleDeclarations cmtTbl = printListi ~getLoc:(fun n -> n.Parsetree.pmd_loc) ~nodes:moduleDeclarations - ~print:(printRecModuleDeclaration ~customLayout) + ~print:(printRecModuleDeclaration ~state) cmtTbl -and printRecModuleDeclaration ~customLayout md cmtTbl i = +and printRecModuleDeclaration ~state md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> @@ -969,7 +1005,7 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = | _ -> false in let modTypeDoc = - let doc = printModType ~customLayout md.pmd_type cmtTbl in + let doc = printModType ~state md.pmd_type cmtTbl in if needsParens then addParens doc else doc in Doc.concat [Doc.text ": "; modTypeDoc] @@ -977,34 +1013,32 @@ and printRecModuleDeclaration ~customLayout md cmtTbl i = let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~state ~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 ~customLayout (md : Parsetree.module_declaration) - cmtTbl = +and printModuleDeclaration ~state (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 ~customLayout md.pmd_type cmtTbl] + | _ -> Doc.concat [Doc.text ": "; printModType ~state md.pmd_type cmtTbl] in Doc.concat [ - printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~state ~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 ~customLayout - (openDescription : Parsetree.open_description) cmtTbl = +and printOpenDescription ~state (openDescription : Parsetree.open_description) + cmtTbl = Doc.concat [ - printAttributes ~customLayout openDescription.popen_attributes cmtTbl; + printAttributes ~state openDescription.popen_attributes cmtTbl; Doc.text "open"; (match openDescription.popen_override with | Asttypes.Fresh -> Doc.space @@ -1012,45 +1046,45 @@ and printOpenDescription ~customLayout printLongidentLocation openDescription.popen_lid cmtTbl; ] -and printIncludeDescription ~customLayout +and printIncludeDescription ~state (includeDescription : Parsetree.include_description) cmtTbl = Doc.concat [ - printAttributes ~customLayout includeDescription.pincl_attributes cmtTbl; + printAttributes ~state includeDescription.pincl_attributes cmtTbl; Doc.text "include "; - printModType ~customLayout includeDescription.pincl_mod cmtTbl; + printModType ~state includeDescription.pincl_mod cmtTbl; ] -and printIncludeDeclaration ~customLayout +and printIncludeDeclaration ~state (includeDeclaration : Parsetree.include_declaration) cmtTbl = Doc.concat [ - printAttributes ~customLayout includeDeclaration.pincl_attributes cmtTbl; + printAttributes ~state includeDeclaration.pincl_attributes cmtTbl; Doc.text "include "; (let includeDoc = - printModExpr ~customLayout includeDeclaration.pincl_mod cmtTbl + printModExpr ~state includeDeclaration.pincl_mod cmtTbl in if Parens.includeModExpr includeDeclaration.pincl_mod then addParens includeDoc else includeDoc); ] -and printValueBindings ~customLayout ~recFlag - (vbs : Parsetree.value_binding list) cmtTbl = +and printValueBindings ~state ~recFlag (vbs : Parsetree.value_binding list) + cmtTbl = printListi ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) ~nodes:vbs - ~print:(printValueBinding ~customLayout ~recFlag) + ~print:(printValueBinding ~state ~recFlag) cmtTbl -and printValueDescription ~customLayout valueDescription cmtTbl = +and printValueDescription ~state valueDescription cmtTbl = let isExternal = match valueDescription.pval_prim with | [] -> false | _ -> true in let attrs = - printAttributes ~customLayout ~loc:valueDescription.pval_name.loc + printAttributes ~state ~loc:valueDescription.pval_name.loc valueDescription.pval_attributes cmtTbl in let header = if isExternal then "external " else "let " in @@ -1063,7 +1097,7 @@ and printValueDescription ~customLayout valueDescription cmtTbl = (printIdentLike valueDescription.pval_name.txt) cmtTbl valueDescription.pval_name.loc; Doc.text ": "; - printTypExpr ~customLayout valueDescription.pval_type cmtTbl; + printTypExpr ~state valueDescription.pval_type cmtTbl; (if isExternal then Doc.group (Doc.concat @@ -1084,11 +1118,11 @@ and printValueDescription ~customLayout valueDescription cmtTbl = else Doc.nil); ]) -and printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl = +and printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl = printListi ~getLoc:(fun n -> n.Parsetree.ptype_loc) ~nodes:typeDeclarations - ~print:(printTypeDeclaration2 ~customLayout ~recFlag) + ~print:(printTypeDeclaration2 ~state ~recFlag) cmtTbl (* @@ -1123,16 +1157,16 @@ and printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl = * (* Invariant: non-empty list *) * | Ptype_open *) -and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i +and printTypeDeclaration ~state ~name ~equalSign ~recFlag i (td : Parsetree.type_declaration) cmtTbl = let attrs = - printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl + printAttributes ~state ~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 ~customLayout td.ptype_params cmtTbl in + let typeParams = printTypeParams ~state td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( @@ -1143,7 +1177,7 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ]) | Ptype_open -> Doc.concat @@ -1160,7 +1194,7 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] in Doc.concat @@ -1168,7 +1202,7 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i manifest; Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; + printRecordDeclaration ~state lds cmtTbl; ] | Ptype_variant cds -> let manifest = @@ -1178,39 +1212,37 @@ and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] in Doc.concat [ manifest; Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; + printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds + cmtTbl; ] in - let constraints = - printTypeDefinitionConstraints ~customLayout td.ptype_cstrs - in + let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in Doc.group (Doc.concat [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) -and printTypeDeclaration2 ~customLayout ~recFlag - (td : Parsetree.type_declaration) cmtTbl i = +and printTypeDeclaration2 ~state ~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 ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl + printAttributes ~state ~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 ~customLayout td.ptype_params cmtTbl in + let typeParams = printTypeParams ~state td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( @@ -1221,7 +1253,7 @@ and printTypeDeclaration2 ~customLayout ~recFlag [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ]) | Ptype_open -> Doc.concat @@ -1231,23 +1263,34 @@ and printTypeDeclaration2 ~customLayout ~recFlag 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 ~customLayout typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~customLayout lds cmtTbl; - ] + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equalSign; + Doc.space; + Doc.lbrace; + printCommentsInside cmtTbl td.ptype_loc; + Doc.rbrace; + ] + else + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr ~state typ cmtTbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration ~state lds cmtTbl; + ] | Ptype_variant cds -> let manifest = match td.ptype_manifest with @@ -1256,25 +1299,23 @@ and printTypeDeclaration2 ~customLayout ~recFlag Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] in Doc.concat [ manifest; Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~customLayout - ~privateFlag:td.ptype_private cds cmtTbl; + printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds + cmtTbl; ] in - let constraints = - printTypeDefinitionConstraints ~customLayout td.ptype_cstrs - in + let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in Doc.group (Doc.concat [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) -and printTypeDefinitionConstraints ~customLayout cstrs = +and printTypeDefinitionConstraints ~state cstrs = match cstrs with | [] -> Doc.nil | cstrs -> @@ -1285,20 +1326,18 @@ and printTypeDefinitionConstraints ~customLayout cstrs = Doc.line; Doc.group (Doc.join ~sep:Doc.line - (List.map - (printTypeDefinitionConstraint ~customLayout) - cstrs)); + (List.map (printTypeDefinitionConstraint ~state) cstrs)); ])) -and printTypeDefinitionConstraint ~customLayout +and printTypeDefinitionConstraint ~state ((typ1, typ2, _loc) : Parsetree.core_type * Parsetree.core_type * Location.t) = Doc.concat [ Doc.text "constraint "; - printTypExpr ~customLayout typ1 CommentTable.empty; + printTypExpr ~state typ1 CommentTable.empty; Doc.text " = "; - printTypExpr ~customLayout typ2 CommentTable.empty; + printTypExpr ~state typ2 CommentTable.empty; ] and printPrivateFlag (flag : Asttypes.private_flag) = @@ -1306,7 +1345,7 @@ and printPrivateFlag (flag : Asttypes.private_flag) = | Private -> Doc.text "private " | Public -> Doc.nil -and printTypeParams ~customLayout typeParams cmtTbl = +and printTypeParams ~state typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> @@ -1322,9 +1361,7 @@ and printTypeParams ~customLayout typeParams cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typeParam -> - let doc = - printTypeParam ~customLayout typeParam cmtTbl - in + let doc = printTypeParam ~state typeParam cmtTbl in printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc) typeParams); @@ -1334,8 +1371,8 @@ and printTypeParams ~customLayout typeParams cmtTbl = Doc.greaterThan; ]) -and printTypeParam ~customLayout - (param : Parsetree.core_type * Asttypes.variance) cmtTbl = +and printTypeParam ~state (param : Parsetree.core_type * Asttypes.variance) + cmtTbl = let typ, variance = param in let printedVariance = match variance with @@ -1343,10 +1380,10 @@ and printTypeParam ~customLayout | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] + Doc.concat [printedVariance; printTypExpr ~state typ cmtTbl] -and printRecordDeclaration ~customLayout - (lds : Parsetree.label_declaration list) cmtTbl = +and printRecordDeclaration ~state (lds : Parsetree.label_declaration list) + cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> @@ -1365,9 +1402,7 @@ and printRecordDeclaration ~customLayout ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in + let doc = printLabelDeclaration ~state ld cmtTbl in printComments doc cmtTbl ld.Parsetree.pld_loc) lds); ]); @@ -1376,7 +1411,7 @@ and printRecordDeclaration ~customLayout Doc.rbrace; ]) -and printConstructorDeclarations ~customLayout ~privateFlag +and printConstructorDeclarations ~state ~privateFlag (cds : Parsetree.constructor_declaration list) cmtTbl = let forceBreak = match (cds, List.rev cds) with @@ -1394,16 +1429,16 @@ and printConstructorDeclarations ~customLayout ~privateFlag ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) ~nodes:cds ~print:(fun cd cmtTbl i -> - let doc = printConstructorDeclaration2 ~customLayout i cd cmtTbl in + let doc = printConstructorDeclaration2 ~state 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 ~customLayout i +and printConstructorDeclaration2 ~state i (cd : Parsetree.constructor_declaration) cmtTbl = - let attrs = printAttributes ~customLayout cd.pcd_attributes cmtTbl in + let attrs = printAttributes ~state cd.pcd_attributes cmtTbl in let bar = if i > 0 || cd.pcd_attributes <> [] then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil @@ -1413,14 +1448,13 @@ and printConstructorDeclaration2 ~customLayout i printComments doc cmtTbl cd.pcd_name.loc in let constrArgs = - printConstructorArguments ~customLayout ~indent:true cd.pcd_args cmtTbl + printConstructorArguments ~state ~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 ~customLayout typ cmtTbl]) + Doc.indent (Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl]) in Doc.concat [ @@ -1436,7 +1470,7 @@ and printConstructorDeclaration2 ~customLayout i ]); ] -and printConstructorArguments ~customLayout ~indent +and printConstructorArguments ~state ~indent (cdArgs : Parsetree.constructor_arguments) cmtTbl = match cdArgs with | Pcstr_tuple [] -> Doc.nil @@ -1452,7 +1486,7 @@ and printConstructorArguments ~customLayout ~indent Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + (fun typexpr -> printTypExpr ~state typexpr cmtTbl) types); ]); Doc.trailingComma; @@ -1476,9 +1510,7 @@ and printConstructorArguments ~customLayout ~indent ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = - printLabelDeclaration ~customLayout ld cmtTbl - in + let doc = printLabelDeclaration ~state ld cmtTbl in printComments doc cmtTbl ld.Parsetree.pld_loc) lds); ]); @@ -1490,10 +1522,9 @@ and printConstructorArguments ~customLayout ~indent in if indent then Doc.indent args else args -and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) - cmtTbl = +and printLabelDeclaration ~state (ld : Parsetree.label_declaration) cmtTbl = let attrs = - printAttributes ~customLayout ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl + printAttributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl in let mutableFlag = match ld.pld_mutable with @@ -1513,17 +1544,97 @@ and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) name; optional; Doc.text ": "; - printTypExpr ~customLayout ld.pld_type cmtTbl; + printTypExpr ~state ld.pld_type cmtTbl; ]) -and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = +and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = + let printArrow ~uncurried ?(arity = max_int) typExpr = + let attrsBefore, args, returnType = + ParsetreeViewer.arrowType ~arity typExpr + in + let dotted, attrsBefore = + let dotted = + state.uncurried_config |> Res_uncurried.getDotted ~uncurried + in + (* Converting .ml code to .res requires processing uncurried attributes *) + let hasBs, attrs = ParsetreeViewer.processBsAttribute attrsBefore in + (dotted || hasBs, attrs) + in + let returnTypeNeedsParens = + match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr ~state returnType cmtTbl in + if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not dotted -> + let hasAttrsBefore = not (attrsBefore = []) in + let attrs = + if hasAttrsBefore then + printAttributes ~state ~inline:true attrsBefore cmtTbl + else Doc.nil + in + let typDoc = + let doc = printTypExpr ~state n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ when Ast_uncurried.typeIsUncurriedFun n -> 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 ~state ~inline:true attrsBefore cmtTbl in + let renderedArgs = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.softLine; + (if dotted then Doc.concat [Doc.dot; Doc.space] else Doc.nil); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> printTypeParameter ~state tp cmtTbl) + args); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + in 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 ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~state ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> let typ = (* Technically type t = (string, float) => unit as 'x, doesn't require @@ -1535,14 +1646,18 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = | Ptyp_arrow _ -> true | _ -> false in - let doc = printTypExpr ~customLayout typ cmtTbl in + let doc = printTypExpr ~state 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 ~customLayout ~inline:false fields openFlag cmtTbl + printObject ~state ~inline:false fields openFlag cmtTbl + | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr + | Ptyp_constr _ when Ast_uncurried.typeIsUncurriedFun typExpr -> + let arity, tArg = Ast_uncurried.typeExtractUncurriedFun typExpr in + printArrow ~uncurried:true ~arity tArg | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1552,7 +1667,7 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = [ constrName; Doc.lessThan; - printObject ~customLayout ~inline:true fields openFlag cmtTbl; + printObject ~state ~inline:true fields openFlag cmtTbl; Doc.greaterThan; ] | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> @@ -1562,7 +1677,7 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = [ constrName; Doc.lessThan; - printTupleType ~customLayout ~inline:true tuple cmtTbl; + printTupleType ~state ~inline:true tuple cmtTbl; Doc.greaterThan; ]) | Ptyp_constr (longidentLoc, constrArgs) -> ( @@ -1582,89 +1697,15 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> - printTypExpr ~customLayout typexpr cmtTbl) + (fun typexpr -> printTypExpr ~state typexpr cmtTbl) constrArgs); ]); Doc.trailingComma; Doc.softLine; Doc.greaterThan; ])) - | 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 ~customLayout returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let isUncurried, attrs = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~customLayout ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~customLayout 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 ~customLayout ~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 ~customLayout tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) - | Ptyp_tuple types -> - printTupleType ~customLayout ~inline:false types cmtTbl - | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl + | Ptyp_tuple types -> printTupleType ~state ~inline:false types cmtTbl + | Ptyp_poly ([], typ) -> printTypExpr ~state typ cmtTbl | Ptyp_poly (stringLocs, typ) -> Doc.concat [ @@ -1676,11 +1717,11 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = stringLocs); Doc.dot; Doc.space; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] | Ptyp_package packageType -> - printPackageType ~customLayout ~printModuleKeywordAndParens:true - packageType cmtTbl + printPackageType ~state ~printModuleKeywordAndParens:true packageType + cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> let forceBreak = @@ -1693,7 +1734,7 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; Doc.concat [Doc.text "#"; printPolyVarIdent txt]; ]) in @@ -1701,10 +1742,9 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = | Rtag ({txt}, attrs, truth, types) -> let doType t = match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | Ptyp_tuple _ -> printTypExpr ~state t cmtTbl | _ -> - Doc.concat - [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] + Doc.concat [Doc.lparen; printTypExpr ~state t cmtTbl; Doc.rparen] in let printedTypes = List.map doType types in let cases = @@ -1716,11 +1756,11 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; Doc.concat [Doc.text "#"; printPolyVarIdent txt]; cases; ]) - | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl + | Rinherit coreType -> printTypExpr ~state coreType cmtTbl in let docs = List.map printRowField rowFields in let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in @@ -1766,13 +1806,12 @@ and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) + Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; renderedType]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc -and printObject ~customLayout ~inline fields openFlag cmtTbl = +and printObject ~state ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> @@ -1803,7 +1842,7 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun field -> printObjectField ~customLayout field cmtTbl) + (fun field -> printObjectField ~state field cmtTbl) fields); ]); Doc.trailingComma; @@ -1813,8 +1852,7 @@ and printObject ~customLayout ~inline fields openFlag cmtTbl = in if inline then doc else Doc.group doc -and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) - cmtTbl = +and printTupleType ~state ~inline (types : Parsetree.core_type list) cmtTbl = let tuple = Doc.concat [ @@ -1826,7 +1864,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + (fun typexpr -> printTypExpr ~state typexpr cmtTbl) types); ]); Doc.trailingComma; @@ -1836,7 +1874,7 @@ and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) in if inline == false then Doc.group tuple else tuple -and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = +and printObjectField ~state (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> let lbl = @@ -1846,26 +1884,25 @@ and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = let doc = Doc.concat [ - printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; + printAttributes ~state ~loc:labelLoc.loc attrs cmtTbl; lbl; Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state 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 ~customLayout typexpr cmtTbl] + Doc.concat [Doc.dotdotdot; printTypExpr ~state typexpr cmtTbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) -and printTypeParameter ~customLayout (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 ~customLayout attrs cmtTbl in +and printTypeParameter ~state (attrs, lbl, typ) cmtTbl = + (* Converting .ml code to .res requires processing uncurried attributes *) + let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in + let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes ~state attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil @@ -1881,7 +1918,7 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = in let loc, typ = match typ.ptyp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> ( {loc with loc_end = typ.ptyp_loc.loc_end}, {typ with ptyp_attributes = attrs} ) | _ -> (typ.ptyp_loc, typ) @@ -1890,20 +1927,18 @@ and printTypeParameter ~customLayout (attrs, lbl, typ) cmtTbl = Doc.group (Doc.concat [ - uncurried; + dotted; attrs; label; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; optionalIndicator; ]) in printComments doc cmtTbl loc -and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) - cmtTbl i = +and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = let attrs = - printAttributes ~customLayout ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes - cmtTbl + printAttributes ~state ~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 " @@ -1917,7 +1952,9 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) }; pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _attrs, parameters, returnExpr = ParsetreeViewer.funExpr expr in + let _uncurried, _attrs, parameters, returnExpr = + ParsetreeViewer.funExpr expr + in let abstractType = match parameters with | [NewTypes {locs = vars}] -> @@ -1937,7 +1974,7 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) [ attrs; header; - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; Doc.text ":"; Doc.indent (Doc.concat @@ -1945,13 +1982,10 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) Doc.line; abstractType; Doc.space; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; Doc.text " ="; Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; + [Doc.line; printExpressionWithComments ~state expr cmtTbl]; ]); ]) | _ -> @@ -1964,7 +1998,7 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) [ attrs; header; - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; Doc.text ":"; Doc.indent (Doc.concat @@ -1972,25 +2006,22 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) Doc.line; abstractType; Doc.space; - printTypExpr ~customLayout patTyp cmtTbl; + printTypExpr ~state patTyp cmtTbl; Doc.text " ="; Doc.concat - [ - Doc.line; - printExpressionWithComments ~customLayout expr cmtTbl; - ]; + [Doc.line; printExpressionWithComments ~state expr cmtTbl]; ]); ])) | _ -> let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in let printedExpr = - let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in + let doc = printExpressionWithComments ~state 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 ~customLayout vb.pvb_pat cmtTbl in + let patternDoc = printPattern ~state vb.pvb_pat cmtTbl in (* * we want to optimize the layout of one pipe: * let tbl = data->Js.Array2.reduce((map, curr) => { @@ -2030,7 +2061,7 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) || match vb.pvb_expr with | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (ifExpr, _, _); } -> ParsetreeViewer.isBinaryExpression ifExpr @@ -2052,7 +2083,7 @@ and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) else Doc.concat [Doc.space; printedExpr]); ]) -and printPackageType ~customLayout ~printModuleKeywordAndParens +and printPackageType ~state ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with @@ -2063,7 +2094,7 @@ and printPackageType ~customLayout ~printModuleKeywordAndParens (Doc.concat [ printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~customLayout packageConstraints cmtTbl; + printPackageConstraints ~state packageConstraints cmtTbl; Doc.softLine; ]) in @@ -2071,7 +2102,7 @@ and printPackageType ~customLayout ~printModuleKeywordAndParens Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc -and printPackageConstraints ~customLayout packageConstraints cmtTbl = +and printPackageConstraints ~state packageConstraints cmtTbl = Doc.concat [ Doc.text " with"; @@ -2089,25 +2120,23 @@ and printPackageConstraints ~customLayout packageConstraints cmtTbl = loc_end = typexpr.Parsetree.ptyp_loc.loc_end; } in - let doc = - printPackageConstraint ~customLayout i cmtTbl pc - in + let doc = printPackageConstraint ~state i cmtTbl pc in printComments doc cmtTbl cmtLoc) packageConstraints); ]); ] -and printPackageConstraint ~customLayout i cmtTbl (longidentLoc, typ) = +and printPackageConstraint ~state 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 ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] -and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = +and printExtension ~state ~atModuleLvl (stringLoc, payload) cmtTbl = let txt = convertBsExtension stringLoc.Location.txt in let extName = let doc = @@ -2120,9 +2149,9 @@ and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) + Doc.group (Doc.concat [extName; printPayload ~state payload cmtTbl]) -and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = +and printPattern ~state (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = match p.ppat_desc with | Ppat_any -> Doc.text "_" @@ -2144,7 +2173,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) + (fun pat -> printPattern ~state pat cmtTbl) patterns); ]); Doc.trailingComma; @@ -2166,7 +2195,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) + (fun pat -> printPattern ~state pat cmtTbl) patterns); ]); Doc.trailingComma; @@ -2195,15 +2224,12 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = (if shouldHug then Doc.nil else Doc.softLine); Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) - patterns); + (List.map (fun pat -> printPattern ~state pat cmtTbl) patterns); (match tail.Parsetree.ppat_desc with | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil | _ -> let doc = - Doc.concat - [Doc.text "..."; printPattern ~customLayout tail cmtTbl] + Doc.concat [Doc.text "..."; printPattern ~state tail cmtTbl] in let tail = printComments doc cmtTbl tail.ppat_loc in Doc.concat [Doc.text ","; Doc.line; tail]); @@ -2236,17 +2262,10 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = 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; - ] + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2258,7 +2277,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) + (fun pat -> printPattern ~state pat cmtTbl) patterns); ]); Doc.trailingComma; @@ -2266,7 +2285,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.rparen; ] | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in + let argDoc = printPattern ~state arg cmtTbl in let shouldHug = ParsetreeViewer.isHuggablePattern arg in Doc.concat [ @@ -2294,17 +2313,10 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = -> Doc.text "()" | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat - [ - Doc.lparen; - Doc.softLine; - printCommentsInside cmtTbl loc; - Doc.rparen; - ] + Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat - [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] + Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2316,7 +2328,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun pat -> printPattern ~customLayout pat cmtTbl) + (fun pat -> printPattern ~state pat cmtTbl) patterns); ]); Doc.trailingComma; @@ -2324,7 +2336,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.rparen; ] | Some arg -> - let argDoc = printPattern ~customLayout arg cmtTbl in + let argDoc = printPattern ~state arg cmtTbl in let shouldHug = ParsetreeViewer.isHuggablePattern arg in Doc.concat [ @@ -2355,8 +2367,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> - printPatternRecordRow ~customLayout row cmtTbl) + (fun row -> printPatternRecordRow ~state row cmtTbl) rows); (match openFlag with | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] @@ -2373,7 +2384,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | _ -> false in let pat = - let p = printPattern ~customLayout p cmtTbl in + let p = printPattern ~state 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]) @@ -2383,7 +2394,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let docs = List.mapi (fun i pat -> - let patternDoc = printPattern ~customLayout pat cmtTbl in + let patternDoc = printPattern ~state pat cmtTbl in Doc.concat [ (if i == 0 then Doc.nil @@ -2402,8 +2413,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | _ -> false in Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) - | Ppat_extension ext -> - printExtension ~customLayout ~atModuleLvl:false ext cmtTbl + | Ppat_extension ext -> printExtension ~state ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> let needsParens = match p.ppat_desc with @@ -2411,7 +2421,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | _ -> false in let pat = - let p = printPattern ~customLayout p cmtTbl in + let p = printPattern ~state p cmtTbl in if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat [Doc.text "lazy "; pat] @@ -2422,7 +2432,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | _ -> false in let renderedPattern = - let p = printPattern ~customLayout p cmtTbl in + let p = printPattern ~state p cmtTbl in if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat @@ -2438,7 +2448,7 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; Doc.text ": "; printComments - (printPackageType ~customLayout ~printModuleKeywordAndParens:false + (printPackageType ~state ~printModuleKeywordAndParens:false packageType cmtTbl) cmtTbl ptyp_loc; Doc.rparen; @@ -2446,9 +2456,9 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | Ppat_constraint (pattern, typ) -> Doc.concat [ - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) @@ -2469,13 +2479,11 @@ and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = | attrs -> Doc.group (Doc.concat - [ - printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; - ]) + [printAttributes ~state attrs cmtTbl; patternWithoutAttributes]) in printComments doc cmtTbl p.ppat_loc -and printPatternRecordRow ~customLayout row cmtTbl = +and printPatternRecordRow ~state row cmtTbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), @@ -2484,7 +2492,7 @@ and printPatternRecordRow ~customLayout row cmtTbl = Doc.concat [ printOptionalLabel ppat_attributes; - printAttributes ~customLayout ppat_attributes cmtTbl; + printAttributes ~state ppat_attributes cmtTbl; printLidentPath longident cmtTbl; ] | longident, pattern -> @@ -2492,7 +2500,7 @@ and printPatternRecordRow ~customLayout row cmtTbl = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in let rhsDoc = - let doc = printPattern ~customLayout pattern cmtTbl in + let doc = printPattern ~state pattern cmtTbl in let doc = if Parens.patternRecordRowRhs pattern then addParens doc else doc in @@ -2511,11 +2519,11 @@ and printPatternRecordRow ~customLayout row cmtTbl = in printComments doc cmtTbl locForComments -and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = - let doc = printExpression ~customLayout expr cmtTbl in +and printExpressionWithComments ~state expr cmtTbl : Doc.t = + let doc = printExpression ~state expr cmtTbl in printComments doc cmtTbl expr.Parsetree.pexp_loc -and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = +and printIfChain ~state pexp_attributes ifs elseExpr cmtTbl = let ifDocs = Doc.join ~sep:Doc.space (List.mapi @@ -2526,11 +2534,9 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = | ParsetreeViewer.If ifExpr -> let condition = if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl + printExpressionBlock ~state ~braces:true ifExpr cmtTbl else - let doc = - printExpressionWithComments ~customLayout ifExpr cmtTbl - in + let doc = printExpressionWithComments ~state ifExpr cmtTbl in match Parens.expr ifExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc ifExpr braces @@ -2547,14 +2553,12 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = | Some _, expr -> expr | _ -> thenExpr in - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl); + printExpressionBlock ~state ~braces:true thenExpr cmtTbl); ] | IfLet (pattern, conditionExpr) -> let conditionDoc = let doc = - printExpressionWithComments ~customLayout conditionExpr - cmtTbl + printExpressionWithComments ~state conditionExpr cmtTbl in match Parens.expr conditionExpr with | Parens.Parenthesized -> addParens doc @@ -2565,12 +2569,11 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = [ ifTxt; Doc.text "let "; - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; Doc.text " = "; conditionDoc; Doc.space; - printExpressionBlock ~customLayout ~braces:true thenExpr - cmtTbl; + printExpressionBlock ~state ~braces:true thenExpr cmtTbl; ] in printLeadingComments doc cmtTbl.leading outerLoc) @@ -2582,20 +2585,105 @@ and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = | Some expr -> Doc.concat [ - Doc.text " else "; - printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + Doc.text " else "; printExpressionBlock ~state ~braces:true expr cmtTbl; ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] + Doc.concat [printAttributes ~state attrs cmtTbl; ifDocs; elseDoc] -and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = +and printExpression ~state (e : Parsetree.expression) cmtTbl = + let printArrow e = + let uncurried, attrsOnArrow, parameters, returnExpr = + ParsetreeViewer.funExpr e + in + let ParsetreeViewer.{async; bs; attributes = attrs} = + ParsetreeViewer.processFunctionAttributes attrsOnArrow + in + let uncurried = uncurried || bs 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 ~state ~inCallback:NoCallback ~uncurried ~async + ~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 ~state 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 ~state typ cmtTbl in + if Parens.arrowReturnTypExpr typ then addParens doc else doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes ~state attrs cmtTbl in + Doc.group + (Doc.concat + [attrs; parametersDoc; typConstraintDoc; Doc.text " =>"; returnExprDoc]) + in let printedExpression = match e.pexp_desc with + | Pexp_fun + ( Nolabel, + None, + {ppat_desc = Ppat_var {txt = "__x"}}, + {pexp_desc = Pexp_apply _} ) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments ~state + (ParsetreeViewer.rewriteUnderscoreApply e) + cmtTbl + | _ when Ast_uncurried.exprIsUncurriedFun e -> printArrow e + | Pexp_fun _ | Pexp_newtype _ -> printArrow e | Parsetree.Pexp_constant c -> printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~customLayout e cmtTbl + printJsxFragment ~state e cmtTbl | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> Doc.concat @@ -2610,9 +2698,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.text ","; Doc.line; Doc.dotdotdot; - (let doc = - printExpressionWithComments ~customLayout expr cmtTbl - in + (let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2633,8 +2719,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (List.map (fun expr -> let doc = - printExpressionWithComments ~customLayout expr - cmtTbl + printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -2660,7 +2745,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + (let doc = printExpressionWithComments ~state arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2680,8 +2765,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (List.map (fun expr -> let doc = - printExpressionWithComments ~customLayout expr - cmtTbl + printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -2695,7 +2779,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ] | Some arg -> let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in + let doc = printExpressionWithComments ~state arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2732,8 +2816,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (List.map (fun expr -> let doc = - printExpressionWithComments ~customLayout expr - cmtTbl + printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -2762,8 +2845,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (List.map (fun expr -> let doc = - printExpressionWithComments ~customLayout expr - cmtTbl + printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -2788,7 +2870,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments ~customLayout arg cmtTbl in + (let doc = printExpressionWithComments ~state arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2808,8 +2890,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (List.map (fun expr -> let doc = - printExpressionWithComments ~customLayout expr - cmtTbl + printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -2823,7 +2904,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ] | Some arg -> let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in + let doc = printExpressionWithComments ~state arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2846,59 +2927,61 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = 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 ~customLayout 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 - let punningAllowed = - match (spreadExpr, rows) with - | None, [_] -> false (* disallow punning for single-element records *) - | _ -> true - 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 -> - printExpressionRecordRow ~customLayout row cmtTbl - punningAllowed) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) + if rows = [] then + Doc.concat + [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + else + let spread = + match spreadExpr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.dotdotdot; + (let doc = printExpressionWithComments ~state 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 + let punningAllowed = + match (spreadExpr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) + | _ -> true + 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 -> + printExpressionRecordRow ~state row cmtTbl + punningAllowed) + rows); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) | Pexp_extension extension -> ( match extension with | ( {txt = "bs.obj" | "obj"}, @@ -2927,28 +3010,29 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> - printBsObjectRow ~customLayout row cmtTbl) + (fun row -> printBsObjectRow ~state row cmtTbl) rows); ]); Doc.trailingComma; Doc.softLine; Doc.rbrace; ]) - | extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) + | extension -> printExtension ~state ~atModuleLvl:false extension cmtTbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) + when ParsetreeViewer.isSpreadBeltListConcat e -> + printBeltListConcatApply ~state subLists cmtTbl | Pexp_apply _ -> if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~customLayout e cmtTbl + printUnaryExpression ~state e cmtTbl else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~customLayout e cmtTbl + printTemplateLiteral ~state e cmtTbl else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~customLayout e cmtTbl - else printPexpApply ~customLayout e cmtTbl + printBinaryExpression ~state e cmtTbl + else printPexpApply ~state e cmtTbl | Pexp_unreachable -> Doc.dot | Pexp_field (expr, longidentLoc) -> let lhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.fieldExpr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2956,7 +3040,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = in Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 + printSetFieldExpr ~state e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> @@ -2967,7 +3051,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.group (Doc.concat [ - printTernaryOperand ~customLayout condition1 cmtTbl; + printTernaryOperand ~state condition1 cmtTbl; Doc.indent (Doc.concat [ @@ -2976,8 +3060,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (Doc.concat [ Doc.text "? "; - printTernaryOperand ~customLayout consequent1 - cmtTbl; + printTernaryOperand ~state consequent1 cmtTbl; ]); Doc.concat (List.map @@ -2986,18 +3069,15 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = [ Doc.line; Doc.text ": "; - printTernaryOperand ~customLayout condition - cmtTbl; + printTernaryOperand ~state condition cmtTbl; Doc.line; Doc.text "? "; - printTernaryOperand ~customLayout consequent - cmtTbl; + printTernaryOperand ~state consequent cmtTbl; ]) rest); Doc.line; Doc.text ": "; - Doc.indent - (printTernaryOperand ~customLayout alternate cmtTbl); + Doc.indent (printTernaryOperand ~state alternate cmtTbl); ]); ]) | _ -> Doc.nil @@ -3010,15 +3090,15 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = in Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; (if needsParens then addParens ternaryDoc else ternaryDoc); ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl | Pexp_while (expr1, expr2) -> let condition = - let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in + let doc = printExpressionWithComments ~state expr1 cmtTbl in match Parens.expr expr1 with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr1 braces @@ -3031,32 +3111,28 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (if ParsetreeViewer.isBlockExpr expr1 then condition else Doc.group (Doc.ifBreaks (addParens condition) condition)); Doc.space; - printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; + printExpressionBlock ~state ~braces:true expr2 cmtTbl; ]) | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> Doc.breakableGroup ~forceBreak:true (Doc.concat [ Doc.text "for "; - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; Doc.text " in "; - (let doc = - printExpressionWithComments ~customLayout fromExpr cmtTbl - in + (let doc = printExpressionWithComments ~state 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 ~customLayout toExpr cmtTbl - in + (let doc = printExpressionWithComments ~state toExpr cmtTbl in match Parens.expr toExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc toExpr braces | Nothing -> doc); Doc.space; - printExpressionBlock ~customLayout ~braces:true body cmtTbl; + printExpressionBlock ~state ~braces:true body cmtTbl; ]) | Pexp_constraint ( {pexp_desc = Pexp_pack modExpr}, @@ -3069,10 +3145,10 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = (Doc.concat [ Doc.softLine; - printModExpr ~customLayout modExpr cmtTbl; + printModExpr ~state modExpr cmtTbl; Doc.text ": "; printComments - (printPackageType ~customLayout + (printPackageType ~state ~printModuleKeywordAndParens:false packageType cmtTbl) cmtTbl ptyp_loc; ]); @@ -3081,20 +3157,20 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = ]) | Pexp_constraint (expr, typ) -> let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state 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 ~customLayout typ cmtTbl] + Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~state typ cmtTbl] | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~state ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~state ~braces:true e cmtTbl | Pexp_assert expr -> let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.lazyOrAssertOrAwaitExprRhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -3103,7 +3179,7 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.concat [Doc.text "assert "; rhs] | Pexp_lazy expr -> let rhs = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.lazyOrAssertOrAwaitExprRhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -3111,112 +3187,22 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = in Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl + printExpressionBlock ~state ~braces:true e cmtTbl | Pexp_pack modExpr -> Doc.group (Doc.concat [ Doc.text "module("; Doc.indent - (Doc.concat - [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); + (Doc.concat [Doc.softLine; printModExpr ~state modExpr cmtTbl]); Doc.softLine; Doc.rparen; ]) - | Pexp_sequence _ -> - printExpressionBlock ~customLayout ~braces:true e cmtTbl - | Pexp_let _ -> printExpressionBlock ~customLayout ~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 ~customLayout - (ParsetreeViewer.rewriteUnderscoreApply e) - cmtTbl - | Pexp_fun _ | Pexp_newtype _ -> - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes 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 ~customLayout ~inCallback:NoCallback ~uncurried - ~async ~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 ~customLayout 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 ~customLayout typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [Doc.text ": "; typDoc] - | _ -> Doc.nil - in - let attrs = printAttributes ~customLayout attrs cmtTbl in - Doc.group - (Doc.concat - [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ]) + | Pexp_sequence _ -> printExpressionBlock ~state ~braces:true e cmtTbl + | Pexp_let _ -> printExpressionBlock ~state ~braces:true e cmtTbl | Pexp_try (expr, cases) -> let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -3227,43 +3213,37 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = Doc.text "try "; exprDoc; Doc.text " catch "; - printCases ~customLayout cases cmtTbl; + printCases ~state cases cmtTbl; ] | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl + printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> let exprDoc = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state 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 ~customLayout cases cmtTbl; - ] + [Doc.text "switch "; exprDoc; Doc.space; printCases ~state cases cmtTbl] | Pexp_function cases -> - Doc.concat - [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] + Doc.concat [Doc.text "x => switch x "; printCases ~state cases cmtTbl] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in - let docTyp = printTypExpr ~customLayout typ cmtTbl in + let docExpr = printExpressionWithComments ~state expr cmtTbl in + let docTyp = printTypExpr ~state typ cmtTbl in let ofType = match typOpt with | None -> Doc.nil | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] + Doc.concat [Doc.text ": "; printTypExpr ~state typ1 cmtTbl] in Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] | Pexp_send (parentExpr, label) -> let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + let doc = printExpressionWithComments ~state parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3274,23 +3254,23 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = 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" + | Pexp_new _ -> Doc.text "Pexp_new not implemented in printer" + | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not implemented in printer" + | Pexp_override _ -> Doc.text "Pexp_override not implemented in printer" + | Pexp_poly _ -> Doc.text "Pexp_poly not implemented in printer" + | Pexp_object _ -> Doc.text "Pexp_object not implemented in printer" in let exprWithAwait = if ParsetreeViewer.hasAwaitAttribute e.pexp_attributes then let rhs = match - Parens.lazyOrAssertOrAwaitExprRhs + Parens.lazyOrAssertOrAwaitExprRhs ~inAwait:true { e with pexp_attributes = List.filter (function - | {Location.txt = "res.await" | "ns.braces"}, _ -> false + | {Location.txt = "res.braces" | "ns.braces"}, _ -> false | _ -> true) e.pexp_attributes; } @@ -3315,15 +3295,17 @@ and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = match e.pexp_attributes with | [] -> exprWithAwait | attrs when not shouldPrintItsOwnAttributes -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprWithAwait]) + Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; exprWithAwait]) | _ -> exprWithAwait -and printPexpFun ~customLayout ~inCallback e cmtTbl = - let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in - let ParsetreeViewer.{async; uncurried; attributes = attrs} = +and printPexpFun ~state ~inCallback e cmtTbl = + let uncurried, attrsOnArrow, parameters, returnExpr = + ParsetreeViewer.funExpr e + in + let ParsetreeViewer.{async; bs; attributes = attrs} = ParsetreeViewer.processFunctionAttributes attrsOnArrow in + let uncurried = bs || uncurried in let returnExpr, typConstraint = match returnExpr.pexp_desc with | Pexp_constraint (expr, typ) -> @@ -3336,7 +3318,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | _ -> (returnExpr, None) in let parametersDoc = - printExprFunParameters ~customLayout ~inCallback ~async ~uncurried + printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint: (match typConstraint with | Some _ -> true @@ -3363,7 +3345,7 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = | _ -> false in let returnDoc = - let doc = printExpressionWithComments ~customLayout returnExpr cmtTbl in + let doc = printExpressionWithComments ~state returnExpr cmtTbl in match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc returnExpr braces @@ -3384,36 +3366,35 @@ and printPexpFun ~customLayout ~inCallback e cmtTbl = in let typConstraintDoc = match typConstraint with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] | _ -> Doc.nil in Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; parametersDoc; typConstraintDoc; Doc.text " =>"; returnExprDoc; ] -and printTernaryOperand ~customLayout expr cmtTbl = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in +and printTernaryOperand ~state expr cmtTbl = + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.ternaryOperand expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc -and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = +and printSetFieldExpr ~state attrs lhs longidentLoc rhs loc cmtTbl = let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + let doc = printExpressionWithComments ~state 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 ~customLayout lhs cmtTbl in + let doc = printExpressionWithComments ~state lhs cmtTbl in match Parens.fieldExpr lhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc lhs braces @@ -3436,12 +3417,11 @@ and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = let doc = match attrs with | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) in printComments doc cmtTbl loc -and printTemplateLiteral ~customLayout expr cmtTbl = +and printTemplateLiteral ~state expr cmtTbl = let tag = ref "js" in let rec walkExpr expr = let open Parsetree in @@ -3456,7 +3436,7 @@ and printTemplateLiteral ~customLayout expr cmtTbl = tag := prefix; printStringContents txt | _ -> - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in let content = walkExpr expr in @@ -3468,7 +3448,7 @@ and printTemplateLiteral ~customLayout expr cmtTbl = Doc.text "`"; ] -and printUnaryExpression ~customLayout expr cmtTbl = +and printUnaryExpression ~state expr cmtTbl = let printUnaryOperator op = Doc.text (match op with @@ -3484,7 +3464,7 @@ and printUnaryExpression ~customLayout expr cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, operand)] ) -> let printedOperand = - let doc = printExpressionWithComments ~customLayout operand cmtTbl in + let doc = printExpressionWithComments ~state operand cmtTbl in match Parens.unaryExprOperand operand with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc operand braces @@ -3494,11 +3474,11 @@ and printUnaryExpression ~customLayout expr cmtTbl = printComments doc cmtTbl expr.pexp_loc | _ -> assert false -and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = +and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = let printBinaryOperator ~inlineRhs operator = let operatorTxt = match operator with - | "|." -> "->" + | "|." | "|.u" -> "->" | "^" -> "++" | "=" -> "==" | "==" -> "===" @@ -3507,12 +3487,12 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = | txt -> txt in let spacingBeforeOperator = - if operator = "|." then Doc.softLine + if operator = "|." || operator = "|.u" then Doc.softLine else if operator = "|>" then Doc.line else Doc.space in let spacingAfterOperator = - if operator = "|." then Doc.nil + if operator = "|." || operator = "|.u" then Doc.nil else if operator = "|>" then Doc.space else if inlineRhs then Doc.space else Doc.line @@ -3541,7 +3521,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = right.pexp_attributes in let doc = - printExpressionWithComments ~customLayout + printExpressionWithComments ~state {right with pexp_attributes = rightInternalAttrs} cmtTbl in @@ -3552,23 +3532,40 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = in let doc = Doc.concat - [ - printAttributes ~customLayout rightPrinteableAttrs cmtTbl; - doc; - ] + [printAttributes ~state rightPrinteableAttrs cmtTbl; doc] in match rightPrinteableAttrs with | [] -> doc | _ -> addParens doc in + let isAwait = + ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + in let doc = - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] + if isAwait then + let parens = + Res_parens.binaryOperatorInsideAwaitNeedsParens operator + in + Doc.concat + [ + Doc.lparen; + Doc.text "await "; + (if parens then Doc.lparen else Doc.nil); + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + (if parens then Doc.rparen else Doc.nil); + Doc.rparen; + ] + else + 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] @@ -3580,7 +3577,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes in let doc = - printExpressionWithComments ~customLayout + printExpressionWithComments ~state {expr with pexp_attributes = internalAttrs} cmtTbl in @@ -3593,8 +3590,7 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat - [printAttributes ~customLayout printeableAttrs cmtTbl; doc] + Doc.concat [printAttributes ~state printeableAttrs cmtTbl; doc] | _ -> assert false else match expr.pexp_desc with @@ -3602,19 +3598,19 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~customLayout expr cmtTbl in + let doc = printTemplateLiteral ~state expr cmtTbl in printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> let doc = - printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + printSetFieldExpr ~state 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 ~customLayout rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in + let rhsDoc = printExpressionWithComments ~state rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~state lhs cmtTbl in (* TODO: unify indentation of "=" *) let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in let doc = @@ -3632,12 +3628,11 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = match expr.pexp_attributes with | [] -> doc | attrs -> - Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) + Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) in if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.binaryExprOperand ~isLhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -3647,24 +3642,26 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = in match expr.pexp_desc with | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + ( { + pexp_desc = + Pexp_ident {txt = Longident.Lident (("|." | "|.u" | "|>") as op)}; + }, [(Nolabel, lhs); (Nolabel, rhs)] ) when not (ParsetreeViewer.isBinaryExpression lhs || ParsetreeViewer.isBinaryExpression rhs - || printAttributes ~customLayout expr.pexp_attributes cmtTbl - <> Doc.nil) -> + || printAttributes ~state expr.pexp_attributes cmtTbl <> Doc.nil) -> 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 [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; lhsDoc; (match (lhsHasCommentBelow, op) with - | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] - | false, "|." -> Doc.text "->" + | true, ("|." | "|.u") -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, ("|." | "|.u") -> Doc.text "->" | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] | false, "|>" -> Doc.text " |> " | _ -> Doc.nil); @@ -3675,7 +3672,11 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = [(Nolabel, lhs); (Nolabel, rhs)] ) -> let right = let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in + let rhsDoc = + printOperand + ~isLhs:(ParsetreeViewer.isRhsBinaryOperator operator) + rhs operator + in Doc.concat [ printBinaryOperator @@ -3689,12 +3690,19 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = else operatorWithRhs in let doc = - Doc.group (Doc.concat [printOperand ~isLhs:true lhs operator; right]) + Doc.group + (Doc.concat + [ + printOperand + ~isLhs:(not @@ ParsetreeViewer.isRhsBinaryOperator operator) + lhs operator; + right; + ]) in Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; (match Parens.binaryExpr { @@ -3710,14 +3718,69 @@ and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = ]) | _ -> Doc.nil +and printBeltListConcatApply ~state subLists cmtTbl = + let makeSpreadDoc commaBeforeSpread = function + | Some expr -> + Doc.concat + [ + commaBeforeSpread; + Doc.dotdotdot; + (let doc = printExpressionWithComments ~state expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + let makeSubListDoc (expressions, spread) = + let commaBeforeSpread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = printExpressionWithComments ~state expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + expressions); + spreadDoc; + ] + 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 makeSubListDoc + (List.map ParsetreeViewer.collectListExpressions subLists)); + ]); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + (* callExpr(arg1, arg2) *) -and printPexpApply ~customLayout expr cmtTbl = +and printPexpApply ~state 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 ~customLayout parentExpr cmtTbl in + let doc = printExpressionWithComments ~state parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3728,14 +3791,14 @@ and printPexpApply ~customLayout expr cmtTbl = match memberExpr.pexp_desc with | Pexp_ident lident -> printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl + | _ -> printExpressionWithComments ~state memberExpr cmtTbl in Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] in Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3745,7 +3808,7 @@ and printPexpApply ~customLayout expr cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( let rhsDoc = - let doc = printExpressionWithComments ~customLayout rhs cmtTbl in + let doc = printExpressionWithComments ~state rhs cmtTbl in match Parens.expr rhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc rhs braces @@ -3760,7 +3823,7 @@ and printPexpApply ~customLayout expr cmtTbl = Doc.group (Doc.concat [ - printExpressionWithComments ~customLayout lhs cmtTbl; + printExpressionWithComments ~state lhs cmtTbl; Doc.text " ="; (if shouldIndent then Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) @@ -3769,8 +3832,8 @@ and printPexpApply ~customLayout expr cmtTbl = in match expr.pexp_attributes with | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) + | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) + ) | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) @@ -3778,7 +3841,7 @@ and printPexpApply ~customLayout expr cmtTbl = (* 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 ~customLayout memberExpr cmtTbl in + let doc = printExpressionWithComments ~state memberExpr cmtTbl in match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc memberExpr braces @@ -3795,7 +3858,7 @@ and printPexpApply ~customLayout expr cmtTbl = [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] in let parentDoc = - let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in + let doc = printExpressionWithComments ~state parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3804,7 +3867,7 @@ and printPexpApply ~customLayout expr cmtTbl = Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3816,7 +3879,7 @@ and printPexpApply ~customLayout expr cmtTbl = -> let member = let memberDoc = - let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in + let doc = printExpressionWithComments ~state memberExpr cmtTbl in match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc memberExpr braces @@ -3839,7 +3902,7 @@ and printPexpApply ~customLayout expr cmtTbl = || match targetExpr with | { - pexp_attributes = [({Location.txt = "ns.ternary"}, _)]; + pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (ifExpr, _, _); } -> ParsetreeViewer.isBinaryExpression ifExpr @@ -3850,14 +3913,14 @@ and printPexpApply ~customLayout expr cmtTbl = || ParsetreeViewer.isArrayAccess e in let targetExpr = - let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in + let doc = printExpressionWithComments ~state 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 ~customLayout parentExpr cmtTbl in + let doc = printExpressionWithComments ~state parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3866,7 +3929,7 @@ and printPexpApply ~customLayout expr cmtTbl = Doc.group (Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3879,7 +3942,7 @@ and printPexpApply ~customLayout expr cmtTbl = (* TODO: cleanup, are those branches even remotely performant? *) | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~customLayout lident args cmtTbl + printJsxExpression ~state lident args cmtTbl | Pexp_apply (callExpr, args) -> let args = List.map @@ -3887,10 +3950,11 @@ and printPexpApply ~customLayout expr cmtTbl = args in let uncurried, attrs = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + ParsetreeViewer.processUncurriedAppAttribute expr.pexp_attributes in + let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in let callExprDoc = - let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in + let doc = printExpressionWithComments ~state callExpr cmtTbl in match Parens.callExpr callExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc callExpr braces @@ -3898,15 +3962,12 @@ and printPexpApply ~customLayout expr cmtTbl = in if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args - cmtTbl + printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then let argsDoc = - printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl + printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl in (* * Fixes the following layout (the `[` and `]` should break): @@ -3928,35 +3989,61 @@ and printPexpApply ~customLayout expr cmtTbl = Doc.concat [ maybeBreakParent; - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc; ] else - let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in - Doc.concat - [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] + let argsDoc = printArguments ~state ~dotted args cmtTbl in + Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] | _ -> assert false -and printJsxExpression ~customLayout lident args cmtTbl = +and printJsxExpression ~state lident args cmtTbl = let name = printJsxName lident in - let formattedProps, children = printJsxProps ~customLayout args cmtTbl in + let formattedProps, children = printJsxProps ~state args cmtTbl in (*
*) + let hasChildren = + match children with + | Some + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + } -> + false + | None -> false + | _ -> true + in let isSelfClosing = match children with | Some { Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); + pexp_loc = loc; } -> - true + not (hasCommentsInside cmtTbl loc) | _ -> false in - let lineSep = - match children with - | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line - | None -> Doc.line + let printChildren children = + let lineSep = + match children with + | Some expr -> + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + | None -> Doc.line + in + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + (match children with + | Some childrenExpression -> + printJsxChildren ~state childrenExpression ~sep:lineSep cmtTbl + | None -> Doc.nil); + ]); + lineSep; + ] in Doc.group (Doc.concat @@ -3973,37 +4060,42 @@ and printJsxExpression ~customLayout lident args cmtTbl = { Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); - pexp_loc = loc; - } -> - let doc = - Doc.concat [printCommentsInside cmtTbl loc; Doc.text "/>"] - in - Doc.concat [Doc.line; printComments doc cmtTbl loc] - | _ -> Doc.nil); + } + when isSelfClosing -> + Doc.text "/>" + | _ -> + (* if tag A has trailing comments then put > on the next line + + + *) + if hasTrailingComments cmtTbl lident.Asttypes.loc then + Doc.concat [Doc.softLine; Doc.greaterThan] + else Doc.greaterThan); ]); (if isSelfClosing then Doc.nil else Doc.concat [ - Doc.greaterThan; - Doc.indent - (Doc.concat - [ - Doc.line; - (match children with - | Some childrenExpression -> - printJsxChildren ~customLayout childrenExpression - ~sep:lineSep cmtTbl - | None -> Doc.nil); - ]); - lineSep; + (if hasChildren then printChildren children + else + match children with + | Some + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + pexp_loc = loc; + } -> + printCommentsInside cmtTbl loc + | _ -> Doc.nil); Doc.text "" in let closing = Doc.text "" in let lineSep = @@ -4018,16 +4110,12 @@ and printJsxFragment ~customLayout expr cmtTbl = | _ -> Doc.indent (Doc.concat - [ - Doc.line; - printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; - ])); + [Doc.line; printJsxChildren ~state expr ~sep:lineSep cmtTbl])); lineSep; closing; ]) -and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep - cmtTbl = +and printJsxChildren ~state (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, _) -> let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in @@ -4038,9 +4126,7 @@ and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in - let exprDoc = - printExpressionWithComments ~customLayout expr cmtTbl - in + let exprDoc = printExpressionWithComments ~state expr cmtTbl in let addParensOrBraces exprDoc = (* {(20: int)} make sure that we also protect the expression inside *) let innerDoc = @@ -4059,9 +4145,7 @@ and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep let leadingLineCommentPresent = hasLeadingLineComment cmtTbl childrenExpr.pexp_loc in - let exprDoc = - printExpressionWithComments ~customLayout childrenExpr cmtTbl - in + let exprDoc = printExpressionWithComments ~state childrenExpr cmtTbl in Doc.concat [ Doc.dotdotdot; @@ -4076,8 +4160,28 @@ and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep | Nothing -> exprDoc); ] -and printJsxProps ~customLayout args cmtTbl : - Doc.t * Parsetree.expression option = +and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = + (* This function was introduced because we have different formatting behavior for self-closing tags and other tags + we always put /> on a new line for self-closing tag when it breaks + + + + + + we should remove this function once the format is unified + *) + let isSelfClosing children = + match children with + | { + Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); + pexp_loc = loc; + } -> + not (hasCommentsInside cmtTbl loc) + | _ -> false + in let rec loop props args = match args with | [] -> (Doc.nil, None) @@ -4089,27 +4193,56 @@ and printJsxProps ~customLayout args cmtTbl : Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> + let doc = if isSelfClosing children then Doc.line else Doc.nil in + (doc, Some children) + | ((_, expr) as lastProp) + :: [ + (Asttypes.Labelled "children", children); + ( Asttypes.Nolabel, + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "()"}, None); + } ); + ] -> + let loc = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + let trailingCommentsPresent = hasTrailingComments cmtTbl loc in + let propDoc = printJsxProp ~state lastProp cmtTbl in let formattedProps = - Doc.indent - (match props with - | [] -> Doc.nil - | props -> - Doc.concat - [Doc.line; Doc.group (Doc.join ~sep:Doc.line (props |> List.rev))]) + Doc.concat + [ + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + ]); + (* print > on new line if the last prop has trailing comments *) + (match (isSelfClosing children, trailingCommentsPresent) with + (* we always put /> on a new line when a self-closing tag breaks *) + | true, _ -> Doc.line + | false, true -> Doc.softLine + | false, false -> Doc.nil); + ] in (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp ~customLayout arg cmtTbl in + let propDoc = printJsxProp ~state arg cmtTbl in loop (propDoc :: props) args in loop [] args -and printJsxProp ~customLayout arg cmtTbl = +and printJsxProp ~state arg cmtTbl = match arg with | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { Parsetree.pexp_attributes = - [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + [({Location.txt = "res.namedArgLoc"; loc = argLoc}, _)]; pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) when lblTxt = ident (* jsx punning *) -> ( @@ -4129,10 +4262,13 @@ and printJsxProp ~customLayout arg cmtTbl = | Nolabel -> Doc.nil | Labelled _lbl -> printIdentLike ident | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) + | Asttypes.Labelled "_spreadProps", expr -> + let doc = printExpressionWithComments ~state expr cmtTbl in + Doc.concat [Doc.lbrace; Doc.dotdotdot; doc; Doc.rbrace] | lbl, expr -> let argLoc, expr = match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> (loc, {expr with pexp_attributes = attrs}) | _ -> (Location.none, expr) in @@ -4150,7 +4286,7 @@ and printJsxProp ~customLayout arg cmtTbl = let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.jsxPropExpr expr with | Parenthesized | Braced _ -> (* {(20: int)} make sure that we also protect the expression inside *) @@ -4180,12 +4316,11 @@ and printJsxName {txt = lident} = let segments = flatten [] lident in Doc.join ~sep:Doc.dot (List.map Doc.text segments) -and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args - cmtTbl = +and printArgumentsWithCallbackInFirstPosition ~dotted ~state 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 customLayout = customLayout + 1 in + let state = State.nextCustomLayout state in let cmtTblCopy = CommentTable.copy cmtTbl in let callback, printedArgs = match args with @@ -4200,17 +4335,14 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args in let callback = Doc.concat - [ - lblDoc; - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; - ] + [lblDoc; printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl] in let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in let printedArgs = lazy (Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) + (List.map (fun arg -> printArgument ~state arg cmtTbl) args)) in (callback, printedArgs) | _ -> assert false @@ -4225,7 +4357,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args lazy (Doc.concat [ - (if uncurried then Doc.text "(. " else Doc.lparen); + (if dotted then Doc.text "(. " else Doc.lparen); Lazy.force callback; Doc.comma; Doc.line; @@ -4241,9 +4373,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args * arg3, * ) *) - let breakAllArgs = - lazy (printArguments ~customLayout ~uncurried args cmtTblCopy) - in + let breakAllArgs = lazy (printArguments ~state ~dotted 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. @@ -4260,16 +4390,15 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if customLayout > customLayoutThreshold then Lazy.force breakAllArgs + if state |> State.shouldBreakCallback then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] -and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args - cmtTbl = +and printArgumentsWithCallbackInLastPosition ~state ~dotted 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 customLayout = customLayout + 1 in + let state = state |> State.nextCustomLayout in let cmtTblCopy = CommentTable.copy cmtTbl in let cmtTblCopy2 = CommentTable.copy cmtTbl in let rec loop acc args = @@ -4287,7 +4416,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let callbackFitsOnOneLine = lazy (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl in let doc = Doc.concat [lblDoc; pexpFunDoc] in printComments doc cmtTbl expr.pexp_loc) @@ -4295,7 +4424,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args let callbackArgumentsFitsOnOneLine = lazy (let pexpFunDoc = - printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + printPexpFun ~state ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy in let doc = Doc.concat [lblDoc; pexpFunDoc] in @@ -4305,7 +4434,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args callbackFitsOnOneLine, callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument ~customLayout arg cmtTbl in + let argDoc = printArgument ~state arg cmtTbl in loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in @@ -4315,7 +4444,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args lazy (Doc.concat [ - (if uncurried then Doc.text "(." else Doc.lparen); + (if dotted then Doc.text "(." else Doc.lparen); Lazy.force printedArgs; Lazy.force callback; Doc.rparen; @@ -4330,7 +4459,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args lazy (Doc.concat [ - (if uncurried then Doc.text "(." else Doc.lparen); + (if dotted then Doc.text "(." else Doc.lparen); Lazy.force printedArgs; Doc.breakableGroup ~forceBreak:true (Lazy.force callback2); Doc.rparen; @@ -4344,9 +4473,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args * (param1, parm2) => doStuff(param1, parm2) * ) *) - let breakAllArgs = - lazy (printArguments ~customLayout ~uncurried args cmtTblCopy2) - in + let breakAllArgs = lazy (printArguments ~state ~dotted 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. @@ -4363,7 +4490,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if customLayout > customLayoutThreshold then Lazy.force breakAllArgs + if state |> State.shouldBreakCallback then Lazy.force breakAllArgs else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs else Doc.customLayout @@ -4373,7 +4500,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args Lazy.force breakAllArgs; ] -and printArguments ~customLayout ~uncurried +and printArguments ~state ~dotted (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = match args with | [ @@ -4386,34 +4513,32 @@ and printArguments ~customLayout ~uncurried (* See "parseCallExpr", ghost unit expression is used the implement * arity zero vs arity one syntax. * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (uncurried, loc.loc_ghost) with + match (dotted, loc.loc_ghost) with | true, true -> Doc.text "(.)" (* arity zero *) | true, false -> Doc.text "(. ())" (* arity one *) | _ -> Doc.text "()") | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> let argDoc = - let doc = printExpressionWithComments ~customLayout arg cmtTbl in + let doc = printExpressionWithComments ~state 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] + [(if dotted then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] | args -> Doc.group (Doc.concat [ - (if uncurried then Doc.text "(." else Doc.lparen); + (if dotted then Doc.text "(." else Doc.lparen); Doc.indent (Doc.concat [ - (if uncurried then Doc.line else Doc.softLine); + (if dotted then Doc.line else Doc.softLine); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun arg -> printArgument ~customLayout arg cmtTbl) - args); + (List.map (fun arg -> printArgument ~state arg cmtTbl) args); ]); Doc.trailingComma; Doc.softLine; @@ -4434,18 +4559,18 @@ and printArguments ~customLayout ~uncurried * | ~ label-name = ? expr * | ~ label-name = ? _ (* syntax sugar *) * | ~ label-name = ? expr : type *) -and printArgument ~customLayout (argLbl, arg) cmtTbl = +and printArgument ~state (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"}, _)]; + pexp_attributes = [] | [({Location.txt = "res.namedArgLoc"}, _)]; } as argExpr) ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> let loc = match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc | _ -> arg.pexp_loc in let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in @@ -4459,12 +4584,12 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = typ ); pexp_loc; pexp_attributes = - ([] | [({Location.txt = "ns.namedArgLoc"}, _)]) as attrs; + ([] | [({Location.txt = "res.namedArgLoc"}, _)]) as attrs; } ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> let loc = match attrs with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> {loc with loc_end = pexp_loc.loc_end} | _ -> arg.pexp_loc in @@ -4474,7 +4599,7 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = Doc.tilde; printIdentLike lbl; Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] in printComments doc cmtTbl loc @@ -4482,12 +4607,12 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = | ( Asttypes.Optional lbl, { pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; + pexp_attributes = [] | [({Location.txt = "res.namedArgLoc"}, _)]; } ) when lbl = name -> let loc = match arg.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc | _ -> arg.pexp_loc in let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in @@ -4495,7 +4620,7 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = | _lbl, expr -> let argLoc, expr = match expr.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: attrs -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> (loc, {expr with pexp_attributes = attrs}) | _ -> (expr.pexp_loc, expr) in @@ -4512,7 +4637,7 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = printComments doc cmtTbl argLoc in let printedExpr = - let doc = printExpressionWithComments ~customLayout expr cmtTbl in + let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4522,7 +4647,7 @@ and printArgument ~customLayout (argLbl, arg) cmtTbl = let doc = Doc.concat [printedLbl; printedExpr] in printComments doc cmtTbl loc -and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = +and printCases ~state (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true (Doc.concat [ @@ -4534,24 +4659,27 @@ and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = ~getLoc:(fun n -> { n.Parsetree.pc_lhs.ppat_loc with - loc_end = n.pc_rhs.pexp_loc.loc_end; + loc_end = + (match ParsetreeViewer.processBracesAttr n.pc_rhs with + | None, _ -> n.pc_rhs.pexp_loc.loc_end + | Some ({loc}, _), _ -> loc.Location.loc_end); }) - ~print:(printCase ~customLayout) ~nodes:cases cmtTbl; + ~print:(printCase ~state) ~nodes:cases cmtTbl; ]; Doc.line; Doc.rbrace; ]) -and printCase ~customLayout (case : Parsetree.case) cmtTbl = +and printCase ~state (case : Parsetree.case) cmtTbl = let rhs = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~customLayout + printExpressionBlock ~state ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl | _ -> ( - let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in + let doc = printExpressionWithComments ~state case.pc_rhs cmtTbl in match Parens.expr case.pc_rhs with | Parenthesized -> addParens doc | _ -> doc) @@ -4566,7 +4694,7 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = [ Doc.line; Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; + printExpressionWithComments ~state expr cmtTbl; ]) in let shouldInlineRhs = @@ -4583,7 +4711,7 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = | _ -> true in let patternDoc = - let doc = printPattern ~customLayout case.pc_lhs cmtTbl in + let doc = printPattern ~state case.pc_lhs cmtTbl in match case.pc_lhs.ppat_desc with | Ppat_constraint _ -> addParens doc | _ -> doc @@ -4600,8 +4728,9 @@ and printCase ~customLayout (case : Parsetree.case) cmtTbl = in Doc.group (Doc.concat [Doc.text "| "; content]) -and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried - ~hasConstraint parameters cmtTbl = +and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint + parameters cmtTbl = + let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in match parameters with (* let f = _ => () *) | [ @@ -4613,7 +4742,7 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; }; ] - when not uncurried -> + when not dotted -> let any = let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in printComments doc cmtTbl ppat_loc @@ -4626,14 +4755,24 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_var stringLoc}; + pat = + { + Parsetree.ppat_desc = Ppat_var stringLoc; + Parsetree.ppat_attributes = attrs; + }; }; ] - when not uncurried -> + when not dotted -> let txtDoc = let var = printIdentLike stringLoc.txt in - let var = if hasConstraint then addParens var else var in - if async then addAsync (Doc.concat [Doc.lparen; var; Doc.rparen]) else var + let var = + match attrs with + | [] -> if hasConstraint then addParens var else var + | attrs -> + let attrs = printAttributes ~state attrs cmtTbl in + addParens (Doc.concat [attrs; var]) + in + if async then addAsync var else var in printComments txtDoc cmtTbl stringLoc.loc (* let f = () => () *) @@ -4647,7 +4786,7 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; }; ] - when not uncurried -> + when not dotted -> let doc = let lparenRparen = Doc.text "()" in if async then addAsync lparenRparen else lparenRparen @@ -4661,7 +4800,7 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried | _ -> false in let maybeAsyncLparen = - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + let lparen = if dotted then Doc.text "(. " else Doc.lparen in if async then addAsync lparen else lparen in let shouldHug = ParsetreeViewer.parametersShouldHug parameters in @@ -4672,7 +4811,7 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun p -> printExpFunParameter ~customLayout p cmtTbl) + (fun p -> printExpFunParameter ~state p cmtTbl) parameters); ] in @@ -4687,14 +4826,15 @@ and printExprFunParameters ~customLayout ~inCallback ~async ~uncurried Doc.rparen; ]) -and printExpFunParameter ~customLayout parameter cmtTbl = +and printExpFunParameter ~state parameter cmtTbl = match parameter with | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> Doc.group (Doc.concat [ - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; Doc.text "type "; + (* XX *) Doc.join ~sep:Doc.space (List.map (fun lbl -> @@ -4704,45 +4844,46 @@ and printExpFunParameter ~customLayout parameter cmtTbl = 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 ~customLayout attrs cmtTbl in + let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in + let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes ~state attrs cmtTbl in (* =defaultValue *) let defaultExprDoc = match defaultExpr with | Some expr -> Doc.concat - [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] + [Doc.text "="; printExpressionWithComments ~state expr cmtTbl] | None -> Doc.nil in (* ~from as hometown * ~from -> punning *) let labelWithPattern = match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl + | Asttypes.Nolabel, pattern -> printPattern ~state pattern cmtTbl | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_var stringLoc; - ppat_attributes = [] | [({Location.txt = "ns.namedArgLoc"}, _)]; - } ) + {ppat_desc = Ppat_var stringLoc; ppat_attributes} ) when lbl = stringLoc.txt -> (* ~d *) - Doc.concat [Doc.text "~"; printIdentLike lbl] + Doc.concat + [ + printAttributes ~state ppat_attributes cmtTbl; + 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"}, _)]; + ppat_attributes; } ) when lbl = txt -> (* ~d: e *) Doc.concat [ + printAttributes ~state ppat_attributes cmtTbl; Doc.text "~"; printIdentLike lbl; Doc.text ": "; - printTypExpr ~customLayout typ cmtTbl; + printTypExpr ~state typ cmtTbl; ] | (Asttypes.Labelled lbl | Optional lbl), pattern -> (* ~b as c *) @@ -4751,7 +4892,7 @@ and printExpFunParameter ~customLayout parameter cmtTbl = Doc.text "~"; printIdentLike lbl; Doc.text " as "; - printPattern ~customLayout pattern cmtTbl; + printPattern ~state pattern cmtTbl; ] in let optionalLabelSuffix = @@ -4763,24 +4904,20 @@ and printExpFunParameter ~customLayout parameter cmtTbl = Doc.group (Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; + dotted; attrs; labelWithPattern; defaultExprDoc; optionalLabelSuffix; ]) in let cmtLoc = match defaultExpr with | None -> ( match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> {loc with loc_end = pattern.ppat_loc.loc_end} | _ -> pattern.ppat_loc) | Some expr -> let startPos = match pattern.ppat_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _) :: _ -> loc.loc_start + | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc.loc_start | _ -> pattern.ppat_loc.loc_start in { @@ -4791,7 +4928,7 @@ and printExpFunParameter ~customLayout parameter cmtTbl = in printComments doc cmtTbl cmtLoc -and printExpressionBlock ~customLayout ~braces expr cmtTbl = +and printExpressionBlock ~state ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> @@ -4805,7 +4942,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = Doc.text "module "; name; Doc.text " = "; - printModExpr ~customLayout modExpr cmtTbl; + printModExpr ~state modExpr cmtTbl; ] in let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in @@ -4822,7 +4959,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = {cmtLoc with loc_end = loc.loc_end} in let letExceptionDoc = - printExceptionDef ~customLayout extensionConstructor cmtTbl + printExceptionDef ~state extensionConstructor cmtTbl in collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> @@ -4839,7 +4976,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> let exprDoc = - let doc = printExpression ~customLayout expr1 cmtTbl in + let doc = printExpression ~state expr1 cmtTbl in match Parens.expr expr1 with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr1 braces @@ -4866,9 +5003,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - let letDoc = - printValueBindings ~customLayout ~recFlag valueBindings cmtTbl - in + let letDoc = printValueBindings ~state ~recFlag valueBindings cmtTbl in (* let () = { * let () = foo() * () @@ -4881,7 +5016,7 @@ and printExpressionBlock ~customLayout ~braces expr cmtTbl = | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> let exprDoc = - let doc = printExpression ~customLayout expr cmtTbl in + let doc = printExpression ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4958,7 +5093,7 @@ and printDirectionFlag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = +and printExpressionRecordRow ~state (lbl, expr) cmtTbl punningAllowed = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group @@ -4968,7 +5103,7 @@ and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = (* print punned field *) Doc.concat [ - printAttributes ~customLayout expr.pexp_attributes cmtTbl; + printAttributes ~state expr.pexp_attributes cmtTbl; printOptionalLabel expr.pexp_attributes; printLidentPath lbl cmtTbl; ] @@ -4978,8 +5113,8 @@ and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = printLidentPath lbl cmtTbl; Doc.text ": "; printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in - match Parens.expr expr with + (let doc = printExpressionWithComments ~state expr cmtTbl in + match Parens.exprRecordRowRhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc); @@ -4987,7 +5122,7 @@ and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = in printComments doc cmtTbl cmtLoc -and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = +and printBsObjectRow ~state (lbl, expr) cmtTbl = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let lblDoc = let doc = @@ -5000,7 +5135,7 @@ and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = [ lblDoc; Doc.text ": "; - (let doc = printExpressionWithComments ~customLayout expr cmtTbl in + (let doc = printExpressionWithComments ~state expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -5015,8 +5150,8 @@ and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = * `@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) ~customLayout - (attrs : Parsetree.attributes) cmtTbl = +and printAttributes ?loc ?(inline = false) ~state (attrs : Parsetree.attributes) + cmtTbl = match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> @@ -5033,18 +5168,16 @@ and printAttributes ?loc ?(inline = false) ~customLayout Doc.concat [ Doc.group - (Doc.join ~sep:Doc.line - (List.map - (fun attr -> printAttribute ~customLayout attr cmtTbl) - attrs)); + (Doc.joinWithSep + (List.map (fun attr -> printAttribute ~state attr cmtTbl) attrs)); (if inline then Doc.space else lineBreak); ] -and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = +and printPayload ~state (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in + let exprDoc = printExpressionWithComments ~state expr cmtTbl in let needsParens = match attrs with | [] -> false @@ -5055,7 +5188,7 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = Doc.concat [ Doc.lparen; - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; (if needsParens then addParens exprDoc else exprDoc); Doc.rparen; ] @@ -5067,22 +5200,21 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - printAttributes ~customLayout attrs cmtTbl; + printAttributes ~state attrs cmtTbl; (if needsParens then addParens exprDoc else exprDoc); ]); Doc.softLine; Doc.rparen; ] | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~customLayout si cmtTbl) - | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) + addParens (printStructureItem ~state si cmtTbl) + | PStr structure -> addParens (printStructure ~state structure cmtTbl) | PTyp typ -> Doc.concat [ Doc.lparen; Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); + Doc.indent (Doc.concat [Doc.line; printTypExpr ~state typ cmtTbl]); Doc.softLine; Doc.rparen; ] @@ -5094,7 +5226,7 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = [ Doc.line; Doc.text "if "; - printExpressionWithComments ~customLayout expr cmtTbl; + printExpressionWithComments ~state expr cmtTbl; ] | None -> Doc.nil in @@ -5106,7 +5238,7 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = [ Doc.softLine; Doc.text "? "; - printPattern ~customLayout pat cmtTbl; + printPattern ~state pat cmtTbl; whenDoc; ]); Doc.softLine; @@ -5118,15 +5250,15 @@ and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = Doc.lparen; Doc.text ":"; Doc.indent - (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); + (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); Doc.softLine; Doc.rparen; ] -and printAttribute ?(standalone = false) ~customLayout +and printAttribute ?(standalone = false) ~state ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with - | ( {txt = "ns.doc"}, + | ( {txt = "res.doc"}, PStr [ { @@ -5134,22 +5266,34 @@ and printAttribute ?(standalone = false) ~customLayout Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); }; ] ) -> - Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ] + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hardLine ) | _ -> - Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~customLayout payload cmtTbl; - ]) + let id = + match id.txt with + | "uncurried" -> + state.uncurried_config <- Res_uncurried.Default; + id + | "toUncurried" -> + state.uncurried_config <- Res_uncurried.Default; + {id with txt = "uncurried"} + | _ -> id + in + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text (convertBsExternalAttribute id.txt); + printPayload ~state payload cmtTbl; + ]), + Doc.line ) -and printModExpr ~customLayout modExpr cmtTbl = +and printModExpr ~state modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl @@ -5159,14 +5303,7 @@ and printModExpr ~customLayout modExpr cmtTbl = in Doc.breakableGroup ~forceBreak:shouldBreak (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.softLine; printCommentsInside cmtTbl modExpr.pmod_loc]); - Doc.softLine; - Doc.rbrace; - ]) + [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) | Pmod_structure structure -> Doc.breakableGroup ~forceBreak:true (Doc.concat @@ -5174,7 +5311,7 @@ and printModExpr ~customLayout modExpr cmtTbl = Doc.lbrace; Doc.indent (Doc.concat - [Doc.softLine; printStructure ~customLayout structure cmtTbl]); + [Doc.softLine; printStructure ~state structure cmtTbl]); Doc.softLine; Doc.rbrace; ]) @@ -5194,7 +5331,7 @@ and printModExpr ~customLayout modExpr cmtTbl = (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> let packageDoc = let doc = - printPackageType ~customLayout ~printModuleKeywordAndParens:false + printPackageType ~state ~printModuleKeywordAndParens:false packageType cmtTbl in printComments doc cmtTbl ptyp_loc @@ -5210,10 +5347,7 @@ and printModExpr ~customLayout modExpr cmtTbl = let unpackDoc = Doc.group (Doc.concat - [ - printExpressionWithComments ~customLayout expr cmtTbl; - moduleConstraint; - ]) + [printExpressionWithComments ~state expr cmtTbl; moduleConstraint]) in Doc.group (Doc.concat @@ -5229,7 +5363,7 @@ and printModExpr ~customLayout modExpr cmtTbl = Doc.rparen; ]) | Pmod_extension extension -> - printExtension ~customLayout ~atModuleLvl:false extension cmtTbl + printExtension ~state ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> let args, callExpr = ParsetreeViewer.modExprApply modExpr in let isUnitSugar = @@ -5245,17 +5379,15 @@ and printModExpr ~customLayout modExpr cmtTbl = Doc.group (Doc.concat [ - printModExpr ~customLayout callExpr cmtTbl; + printModExpr ~state callExpr cmtTbl; (if isUnitSugar then - printModApplyArg ~customLayout - (List.hd args [@doesNotRaise]) - cmtTbl + printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl else Doc.concat [ Doc.lparen; (if shouldHug then - printModApplyArg ~customLayout + printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl else @@ -5267,7 +5399,7 @@ and printModExpr ~customLayout modExpr cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun modArg -> - printModApplyArg ~customLayout modArg cmtTbl) + printModApplyArg ~state modArg cmtTbl) args); ])); (if not shouldHug then @@ -5279,15 +5411,15 @@ and printModExpr ~customLayout modExpr cmtTbl = | Pmod_constraint (modExpr, modType) -> Doc.concat [ - printModExpr ~customLayout modExpr cmtTbl; + printModExpr ~state modExpr cmtTbl; Doc.text ": "; - printModType ~customLayout modType cmtTbl; + printModType ~state modType cmtTbl; ] - | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl + | Pmod_functor _ -> printModFunctor ~state modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc -and printModFunctor ~customLayout modExpr cmtTbl = +and printModFunctor ~state modExpr cmtTbl = let parameters, returnModExpr = ParsetreeViewer.modExprFunctor modExpr in (* let shouldInline = match returnModExpr.pmod_desc with *) (* | Pmod_structure _ | Pmod_ident _ -> true *) @@ -5298,18 +5430,18 @@ and printModFunctor ~customLayout modExpr cmtTbl = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> let constraintDoc = - let doc = printModType ~customLayout modType cmtTbl in + let doc = printModType ~state modType cmtTbl in if Parens.modExprFunctorConstraint modType then addParens doc else doc in let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~customLayout modExpr cmtTbl) - | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) + (modConstraint, printModExpr ~state modExpr cmtTbl) + | _ -> (Doc.nil, printModExpr ~state returnModExpr cmtTbl) in let parametersDoc = match parameters with | [(attrs, {txt = "*"}, None)] -> Doc.group - (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) + (Doc.concat [printAttributes ~state attrs cmtTbl; Doc.text "()"]) | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> Doc.group @@ -5323,8 +5455,7 @@ and printModFunctor ~customLayout modExpr cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun param -> - printModFunctorParam ~customLayout param cmtTbl) + (fun param -> printModFunctorParam ~state param cmtTbl) parameters); ]); Doc.trailingComma; @@ -5336,14 +5467,14 @@ and printModFunctor ~customLayout modExpr cmtTbl = (Doc.concat [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) -and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = +and printModFunctorParam ~state (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 ~customLayout attrs cmtTbl in + let attrs = printAttributes ~state attrs cmtTbl in let lblDoc = let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in printComments doc cmtTbl lbl.loc @@ -5357,19 +5488,17 @@ and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat - [Doc.text ": "; printModType ~customLayout modType cmtTbl]); + Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl]); ]) in printComments doc cmtTbl cmtLoc -and printModApplyArg ~customLayout modExpr cmtTbl = +and printModApplyArg ~state modExpr cmtTbl = match modExpr.pmod_desc with | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr ~customLayout modExpr cmtTbl + | _ -> printModExpr ~state modExpr cmtTbl -and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) - cmtTbl = +and printExceptionDef ~state (constr : Parsetree.extension_constructor) cmtTbl = let kind = match constr.pext_kind with | Pext_rebind longident -> @@ -5380,15 +5509,11 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) | Pext_decl (args, gadt) -> let gadtDoc = match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] | None -> Doc.nil in Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + [printConstructorArguments ~state ~indent:false args cmtTbl; gadtDoc] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -5397,7 +5522,7 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) Doc.group (Doc.concat [ - printAttributes ~customLayout constr.pext_attributes cmtTbl; + printAttributes ~state constr.pext_attributes cmtTbl; Doc.text "exception "; name; kind; @@ -5405,9 +5530,9 @@ and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) in printComments doc cmtTbl constr.pext_loc -and printExtensionConstructor ~customLayout - (constr : Parsetree.extension_constructor) cmtTbl i = - let attrs = printAttributes ~customLayout constr.pext_attributes cmtTbl in +and printExtensionConstructor ~state (constr : Parsetree.extension_constructor) + cmtTbl i = + let attrs = printAttributes ~state constr.pext_attributes cmtTbl in let bar = if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil in @@ -5421,37 +5546,33 @@ and printExtensionConstructor ~customLayout | Pext_decl (args, gadt) -> let gadtDoc = match gadt with - | Some typ -> - Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] + | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] | None -> Doc.nil in Doc.concat - [ - printConstructorArguments ~customLayout ~indent:false args cmtTbl; - gadtDoc; - ] + [printConstructorArguments ~state ~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 printTypeParams = printTypeParams ~customLayout:0 -let printTypExpr = printTypExpr ~customLayout:0 -let printExpression = printExpression ~customLayout:0 -let printPattern = printPattern ~customLayout:0 +let printTypeParams = printTypeParams ~state:State.init +let printTypExpr = printTypExpr ~state:State.init +let printExpression = printExpression ~state:State.init +let printPattern = printPattern ~state:State.init let printImplementation ~width (s : Parsetree.structure) ~comments = let cmtTbl = CommentTable.make () in CommentTable.walkStructure s cmtTbl comments; (* CommentTable.log cmtTbl; *) - let doc = printStructure ~customLayout:0 s cmtTbl in + let doc = printStructure ~state:State.init 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 ~customLayout:0 s cmtTbl) ^ "\n" + Doc.toString ~width (printSignature ~state:State.init s cmtTbl) ^ "\n" -let printStructure = printStructure ~customLayout:0 +let printStructure = printStructure ~state:State.init diff --git a/analysis/vendor/res_outcome_printer/res_printer.mli b/analysis/vendor/res_syntax/res_printer.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_printer.mli rename to analysis/vendor/res_syntax/res_printer.mli diff --git a/analysis/vendor/res_outcome_printer/res_reporting.ml b/analysis/vendor/res_syntax/res_reporting.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_reporting.ml rename to analysis/vendor/res_syntax/res_reporting.ml diff --git a/analysis/vendor/res_outcome_printer/res_scanner.ml b/analysis/vendor/res_syntax/res_scanner.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_scanner.ml rename to analysis/vendor/res_syntax/res_scanner.ml diff --git a/analysis/vendor/res_outcome_printer/res_scanner.mli b/analysis/vendor/res_syntax/res_scanner.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_scanner.mli rename to analysis/vendor/res_syntax/res_scanner.mli diff --git a/analysis/vendor/res_outcome_printer/res_string.ml b/analysis/vendor/res_syntax/res_string.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_string.ml rename to analysis/vendor/res_syntax/res_string.ml diff --git a/analysis/vendor/res_outcome_printer/res_token.ml b/analysis/vendor/res_syntax/res_token.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_token.ml rename to analysis/vendor/res_syntax/res_token.ml diff --git a/analysis/vendor/res_syntax/res_uncurried.ml b/analysis/vendor/res_syntax/res_uncurried.ml new file mode 100644 index 000000000..d3c666c4d --- /dev/null +++ b/analysis/vendor/res_syntax/res_uncurried.ml @@ -0,0 +1,17 @@ +type config = Legacy | Default + +let init = Legacy + +let isDefault = function + | Legacy -> false + | Default -> true + +(* For parsing *) +let fromDotted ~dotted = function + | Legacy -> dotted + | Default -> not dotted + +(* For printing *) +let getDotted ~uncurried = function + | Legacy -> uncurried + | Default -> not uncurried diff --git a/analysis/vendor/res_outcome_printer/res_utf8.ml b/analysis/vendor/res_syntax/res_utf8.ml similarity index 100% rename from analysis/vendor/res_outcome_printer/res_utf8.ml rename to analysis/vendor/res_syntax/res_utf8.ml diff --git a/analysis/vendor/res_outcome_printer/res_utf8.mli b/analysis/vendor/res_syntax/res_utf8.mli similarity index 100% rename from analysis/vendor/res_outcome_printer/res_utf8.mli rename to analysis/vendor/res_syntax/res_utf8.mli