diff --git a/Makefile b/Makefile index 21bf4b9cd..dd56cd9b3 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,12 @@ clean: test: make -C analysis test +format: + make -C analysis format + +checkformat: + make -C analysis checkformat + .DEFAULT_GOAL := build .PHONY: build clean test diff --git a/analysis/Makefile b/analysis/Makefile index 87d58e842..069dbbbe4 100644 --- a/analysis/Makefile +++ b/analysis/Makefile @@ -33,6 +33,9 @@ clean: make -C tests clean make -C reanalyze clean +checkformat: + dune build @fmt + .DEFAULT_GOAL := build .PHONY: build-analysis-binary build-reanalyze build-tests dce clean format test diff --git a/analysis/dune-project b/analysis/dune-project index bd2faafcc..df2dfc688 100644 --- a/analysis/dune-project +++ b/analysis/dune-project @@ -1,3 +1,13 @@ (lang dune 2.0) -(name rescript-vscode) +(package + (name rescript-vscode) + (synopsis "ReScript vscode support") + (depends + (ocaml + (>= 4.10)) + (ocamlformat + (= 0.22.4)) + (reanalyze + (= 2.23.0)) + dune)) diff --git a/analysis/reanalyze/src/EmitJson.ml b/analysis/reanalyze/src/EmitJson.ml index 0fde1eadf..c90e7f99c 100644 --- a/analysis/reanalyze/src/EmitJson.ml +++ b/analysis/reanalyze/src/EmitJson.ml @@ -1,6 +1,6 @@ let items = ref 0 let start () = Printf.printf "[" -let finish ()= Printf.printf "\n]\n" +let finish () = Printf.printf "\n]\n" let emitClose () = "\n}" let emitItem ~ppf ~name ~kind ~file ~range ~message = diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index 6743221a3..2973c3946 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -249,10 +249,7 @@ let traverseAst () = case.c_guard |> iterExprOpt self; case.c_rhs |> iterExpr self) in - let isRaise s = - s = "Pervasives.raise" - || s = "Pervasives.raise_notrace" - in + let isRaise s = s = "Pervasives.raise" || s = "Pervasives.raise_notrace" in let raiseArgs args = match args with | [(_, Some {Typedtree.exp_desc = Texp_construct ({txt}, _, _)})] -> diff --git a/analysis/dummy.opam b/analysis/rescript-vscode.opam similarity index 100% rename from analysis/dummy.opam rename to analysis/rescript-vscode.opam diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index 7e0f1bb77..6d57cb5bc 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -93,8 +93,7 @@ let main () = Commands.codeAction ~path ~pos:(int_of_string line, int_of_string col) ~currentFile ~debug:false - | [_; "diagnosticSyntax"; path;] -> - Commands.diagnosticSyntax ~path + | [_; "diagnosticSyntax"; path] -> Commands.diagnosticSyntax ~path | _ :: "reanalyze" :: _ -> let len = Array.length Sys.argv in for i = 1 to len - 2 do diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 48c4d6338..ee0f54283 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -258,8 +258,7 @@ let format ~path = else "" let diagnosticSyntax ~path = - print_endline - (Diagnostics.document_syntax ~path |> Protocol.array) + print_endline (Diagnostics.document_syntax ~path |> Protocol.array) let test ~path = Uri.stripPath := true; diff --git a/analysis/src/Diagnostics.ml b/analysis/src/Diagnostics.ml index 5ef3673dd..b4c073425 100644 --- a/analysis/src/Diagnostics.ml +++ b/analysis/src/Diagnostics.ml @@ -30,4 +30,4 @@ let document_syntax ~path = Res_driver.parsingEngine.parseInterface ~forPrinter:false ~filename:path in get_diagnostics parseInterface.diagnostics - else [] \ No newline at end of file + else [] diff --git a/analysis/src/Protocol.ml b/analysis/src/Protocol.ml index 4a03b1508..4d179b038 100644 --- a/analysis/src/Protocol.ml +++ b/analysis/src/Protocol.ml @@ -10,16 +10,12 @@ type completionItem = { documentation: markupContent option; } -type location = {uri : string; range : range} -type documentSymbolItem = {name : string; kind : int; location : location} -type renameFile = {oldUri : string; newUri : string} -type textEdit = {range : range; newText : string} - -type diagnostic = { - range : range; - message : string; - severity : int; -} +type location = {uri: string; range: range} +type documentSymbolItem = {name: string; kind: int; location: location} +type renameFile = {oldUri: string; newUri: string} +type textEdit = {range: range; newText: string} + +type diagnostic = {range: range; message: string; severity: int} type optionalVersionedTextDocumentIdentifier = { version: int option; @@ -134,11 +130,11 @@ let stringifyCodeAction ca = (* https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#diagnostic *) let stringifyDiagnostic d = - Printf.sprintf {|{ + Printf.sprintf + {|{ "range": %s, "message": "%s", "severity": %d, "source": "ReScript" }|} - (stringifyRange d.range) (Json.escape d.message) - d.severity \ No newline at end of file + (stringifyRange d.range) (Json.escape d.message) d.severity diff --git a/analysis/tests/src/Completion.res b/analysis/tests/src/Completion.res index adb937ae8..4f3f46c04 100644 --- a/analysis/tests/src/Completion.res +++ b/analysis/tests/src/Completion.res @@ -391,3 +391,17 @@ let _ = _ => { // ^com () } + +let red = "#ff0000" + +let header1 = ` + color: ${red}; ` +// ^com + +let header2 = ` + color: ${red}; + background-color: ${red}; ` +// ^com + +// let _ = `color: ${r +// ^com diff --git a/analysis/tests/src/expected/Completion.res.txt b/analysis/tests/src/expected/Completion.res.txt index 4b7b2c1ac..31c21dc01 100644 --- a/analysis/tests/src/expected/Completion.res.txt +++ b/analysis/tests/src/expected/Completion.res.txt @@ -937,9 +937,9 @@ Completable: Cpath Value[ForAuto, a] Complete src/Completion.res 234:34 posCursor:[234:34] posNoWhite:[234:33] Found expr:[234:18->234:36] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[234:18->234:34], ...[234:34->234:36]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[234:18->234:34], ...[234:34->234:35]) posCursor:[234:34] posNoWhite:[234:33] Found expr:[234:18->234:34] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[234:18->234:32], ...[234:32->234:34]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[234:18->234:30], ...[234:32->234:34]) posCursor:[234:34] posNoWhite:[234:33] Found expr:[234:32->234:34] Pexp_ident na:[234:32->234:34] Completable: Cpath Value[na] @@ -1434,9 +1434,9 @@ Completable: Cpath Value[AndThatOther, T] Complete src/Completion.res 378:24 posCursor:[378:24] posNoWhite:[378:23] Found expr:[378:12->378:26] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[378:12->378:24], ...[378:24->378:26]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[378:12->378:24], ...[378:24->378:25]) posCursor:[378:24] posNoWhite:[378:23] Found expr:[378:12->378:24] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[378:12->378:16], ...[378:16->378:24]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[378:12->378:14], ...[378:16->378:24]) posCursor:[378:24] posNoWhite:[378:23] Found expr:[378:16->378:24] Pexp_ident ForAuto.:[378:16->378:24] Completable: Cpath Value[ForAuto, ""] @@ -1456,9 +1456,9 @@ Completable: Cpath Value[ForAuto, ""] Complete src/Completion.res 381:38 posCursor:[381:38] posNoWhite:[381:37] Found expr:[381:12->381:41] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[381:12->381:39], ...[381:39->381:41]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[381:12->381:39], ...[381:39->381:40]) posCursor:[381:38] posNoWhite:[381:37] Found expr:[381:12->381:39] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[381:12->381:19], ...[381:19->381:39]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[381:12->381:17], ...[381:19->381:39]) posCursor:[381:38] posNoWhite:[381:37] Found expr:[381:19->381:39] Pexp_send [381:38->381:38] e:[381:19->381:36] Completable: Cpath Value[FAO, forAutoObject][""] @@ -1478,9 +1478,9 @@ Completable: Cpath Value[FAO, forAutoObject][""] Complete src/Completion.res 384:24 posCursor:[384:24] posNoWhite:[384:23] Found expr:[384:11->384:26] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:11->384:24], ...[384:24->384:26]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:11->384:24], ...[384:24->384:25]) posCursor:[384:24] posNoWhite:[384:23] Found expr:[384:11->384:24] -Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:11->384:14], ...[384:14->384:24]) +Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:11->384:12], ...[384:14->384:24]) posCursor:[384:24] posNoWhite:[384:23] Found expr:[384:14->384:24] Pexp_field [384:14->384:23] _:[384:24->384:24] Completable: Cpath Value[funRecord]."" @@ -1518,3 +1518,63 @@ Completable: Cpath array->ma "documentation": null }] +Complete src/Completion.res 397:14 +posCursor:[397:14] posNoWhite:[397:13] Found expr:[396:14->397:20] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[396:14->397:16], ...[397:16->397:19]) +posCursor:[397:14] posNoWhite:[397:13] Found expr:[396:14->397:16] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[396:14->397:11], ...[397:13->397:16]) +posCursor:[397:14] posNoWhite:[397:13] Found expr:[397:13->397:16] +Pexp_ident red:[397:13->397:16] +Completable: Cpath Value[red] +[{ + "label": "red", + "kind": 12, + "tags": [], + "detail": "string", + "documentation": null + }] + +Complete src/Completion.res 402:25 +posCursor:[402:25] posNoWhite:[402:24] Found expr:[400:14->402:31] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[400:14->402:27], ...[402:27->402:30]) +posCursor:[402:25] posNoWhite:[402:24] Found expr:[400:14->402:27] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[400:14->402:22], ...[402:24->402:27]) +posCursor:[402:25] posNoWhite:[402:24] Found expr:[402:24->402:27] +Pexp_ident red:[402:24->402:27] +Completable: Cpath Value[red] +[{ + "label": "red", + "kind": 12, + "tags": [], + "detail": "string", + "documentation": null + }] + +Complete src/Completion.res 405:22 +posCursor:[405:22] posNoWhite:[405:21] Found expr:[405:11->408:0] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[405:11->405:22], ...[408:0->408:0]) +posCursor:[405:22] posNoWhite:[405:21] Found expr:[405:11->405:22] +Pexp_apply ...__ghost__[0:-1->0:-1] (...[405:11->405:19], ...[405:21->405:22]) +posCursor:[405:22] posNoWhite:[405:21] Found expr:[405:21->405:22] +Pexp_ident r:[405:21->405:22] +Completable: Cpath Value[r] +[{ + "label": "red", + "kind": 12, + "tags": [], + "detail": "string", + "documentation": null + }, { + "label": "retAA", + "kind": 12, + "tags": [], + "detail": "unit => aa", + "documentation": null + }, { + "label": "r", + "kind": 12, + "tags": [], + "detail": "rAlias", + "documentation": null + }] + diff --git a/analysis/tests/src/expected/Dce.res.txt b/analysis/tests/src/expected/Dce.res.txt index 082df6ce4..308ef678c 100644 --- a/analysis/tests/src/expected/Dce.res.txt +++ b/analysis/tests/src/expected/Dce.res.txt @@ -1,3 +1,3 @@ DCE src/Dce.res -issues:233 +issues:235 diff --git a/analysis/vendor/dune b/analysis/vendor/dune new file mode 100644 index 000000000..c4e8b807b --- /dev/null +++ b/analysis/vendor/dune @@ -0,0 +1 @@ +(dirs compiler-libs-406 ext res_outcome_printer json) diff --git a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml b/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml index 87a08ed59..d4bbcd5bd 100644 --- a/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml +++ b/analysis/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml @@ -4,7 +4,9 @@ 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 rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l let nolabel = Nolabel @@ -12,26 +14,40 @@ let labelled str = Labelled str let optional str = Optional str -let isOptional str = match str with Optional _ -> true | _ -> false +let isOptional str = + match str with + | Optional _ -> true + | _ -> false -let isLabelled str = match str with Labelled _ -> true | _ -> false +let isLabelled str = + match str with + | Labelled _ -> true + | _ -> false -let getLabel str = match str with Optional str | Labelled str -> str | Nolabel -> "" +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 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 + 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" } [] ] +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 } +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 = @@ -39,12 +55,16 @@ let transformChildrenIfListUpper ~loc ~mapper theList = (* 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) + | {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 [] @@ -54,9 +74,14 @@ let transformChildrenIfList ~loc ~mapper theList = (* 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) + | {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 [] @@ -65,23 +90,40 @@ 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") + | [(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 + 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") + (* 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 unerasableIgnore loc = + ( {loc; txt = "warning"}, + PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) -let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) +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" @@ -90,55 +132,84 @@ let hasAttr (loc, _) = loc.txt = "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 +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.") + | {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.") + | {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)) + | {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 + 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.") + | 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_) +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 = + 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 @@ -150,7 +221,8 @@ let makeModuleName fileName nestedModules fnName = | "", nestedModules, "make" -> nestedModules | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) + | fileName, nestedModules, fnName -> + fileName :: List.rev (fnName :: nestedModules) in let fullModuleName = String.concat "$" fullModuleName in fullModuleName @@ -165,28 +237,50 @@ let makeModuleName fileName nestedModules fnName = 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) + 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] @@ -194,36 +288,52 @@ let rec recursivelyMakeNamedArgsForExternal list args = let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = let propsName = fnName ^ "Props" in { - pval_name = { txt = propsName; loc }; + 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 = [] } + { + ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); + ptyp_loc = loc; + ptyp_attributes = []; + } propsType); - pval_prim = [ "" ]; - pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; + 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) } + { + 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) } + { + 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 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_) +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)) + 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 = @@ -237,23 +347,30 @@ let jsxMapper () = let jsxVersion = ref None in let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = - let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + 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)) + 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 = [] -> [] + @ (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) ] + (* 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 @@ -264,27 +381,38 @@ let jsxMapper () = let ident = match modulePath with | Lident _ -> Ldot (modulePath, "make") - | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, "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") + | _ -> + raise + (Invalid_argument + "JSX name can't be the result of function applications") + in + let props = + Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args in - let props = 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) ] + 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) ] + 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 @@ -297,39 +425,49 @@ let jsxMapper () = (* [@JSX] div(~children=[a]), coming from
a
*) | { pexp_desc = - ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) - | Pexp_construct ({ txt = Lident "[]" }, None) ); + ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) + | Pexp_construct ({txt = Lident "[]"}, None) ); } -> - "createDOMElementVariadic" + "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.") + 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) ] + | [_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); - ] + 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 + 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) }) + (Exp.ident ~loc + {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) args [@@raises Invalid_argument] in @@ -339,86 +477,125 @@ let jsxMapper () = 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!") + 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 -> ( + 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 = 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 + | 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) + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list) | Pexp_fun ( Nolabel, _, - { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, + {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, _expression ) -> - (list, Some txt) + (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." + 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 {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 + ( 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 + ( 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 + ( getLabel name, + [], + { + ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types | _ -> types [@@raises Invalid_argument] in @@ -426,7 +603,9 @@ let jsxMapper () = 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 + | name when isOptional name -> + (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) + :: types | _ -> types in @@ -436,279 +615,413 @@ let jsxMapper () = (* external *) | { pstr_loc; - pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); + 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 + 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 - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + 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 newStructure = + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = { pval_type with ptyp_desc = newExternalType }; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; + exp with + pexp_attributes = + unerasableIgnore emptyLoc :: exp.pexp_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 -> + (* 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, { - 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 + expression with + pexp_desc = Pexp_sequence (wrapperExpression, exp); + } ) + | e -> ((fun a -> a), false, e) in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] - (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) + let wrapExpression, hasUnit, expression = + spelunkForFunExpression expression 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)) + (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 - (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 + ( 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 - (externs, binding @ bindings, newBindings) + (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 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 + 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 @@ -720,48 +1033,63 @@ let jsxMapper () = 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") ) + | { + 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 @@ -774,77 +1102,111 @@ let jsxMapper () = 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.") + 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 + 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 + 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 ) + | {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_construct + ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) + | Pexp_construct ({txt = Lident "[]"; loc}, None) ); pexp_attributes; } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes + let 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 - 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 ) + 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] @@ -857,7 +1219,7 @@ let jsxMapper () = mapped [@@raises Failure] in - { default_mapper with structure; expr; signature; module_binding } + {default_mapper with structure; expr; signature; module_binding} [@@raises Invalid_argument, Failure] let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = diff --git a/analysis/vendor/res_outcome_printer/res_cli.ml b/analysis/vendor/res_outcome_printer/res_cli.ml index 5ec9875ce..df7ee6a0d 100644 --- a/analysis/vendor/res_outcome_printer/res_cli.ml +++ b/analysis/vendor/res_outcome_printer/res_cli.ml @@ -35,7 +35,6 @@ module Color = struct | Magenta | Cyan | White [@live] - ;; type style = | FG of color (* foreground *) @@ -62,40 +61,36 @@ module Color = struct | Dim -> "2" let ansi_of_style_l l = - let s = match l with + let s = + match l with | [] -> code_of_style Reset | [s] -> code_of_style s | _ -> String.concat ";" (List.map code_of_style l) in "\x1b[" ^ s ^ "m" - type styles = { - error: style list; - warning: style list; - loc: style list; - } + type styles = {error: style list; warning: style list; loc: style list} - let default_styles = { - warning = [Bold; FG Magenta]; - error = [Bold; FG Red]; - loc = [Bold]; - } + let default_styles = + {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} let cur_styles = ref default_styles + (* let get_styles () = !cur_styles *) (* let set_styles s = cur_styles := s *) (* map a tag to a style, if the tag is known. @raise Not_found otherwise *) - let style_of_tag s = match s with - | "error" -> (!cur_styles).error - | "warning" -> (!cur_styles).warning - | "loc" -> (!cur_styles).loc + let style_of_tag s = + match s with + | "error" -> !cur_styles.error + | "warning" -> !cur_styles.warning + | "loc" -> !cur_styles.loc | "info" -> [Bold; FG Yellow] | "dim" -> [Dim] | "filename" -> [FG Cyan] | _ -> raise Not_found - [@@raises Not_found] + [@@raises Not_found] let color_enabled = ref true @@ -116,14 +111,18 @@ module Color = struct let set_color_tag_handling ppf = let open Format in let functions = pp_get_formatter_tag_functions ppf () in - let functions' = {functions with - mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); - mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); - } in - pp_set_mark_tags ppf true; (* enable tags *) + let functions' = + { + functions with + mark_open_tag = mark_open_tag ~or_else:functions.mark_open_tag; + mark_close_tag = mark_close_tag ~or_else:functions.mark_close_tag; + } + in + pp_set_mark_tags ppf true; + (* enable tags *) pp_set_formatter_tag_functions ppf functions'; (* also setup margins *) - pp_set_margin ppf (pp_get_margin std_formatter()); + pp_set_margin ppf (pp_get_margin std_formatter ()); () external isatty : out_channel -> bool = "caml_sys_isatty" @@ -131,14 +130,13 @@ module Color = struct (* reasonable heuristic on whether colors should be enabled *) let should_enable_color () = let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr + term <> "dumb" && term <> "" && isatty stderr type setting = Auto [@live] | Always [@live] | Never [@live] let setup = - let first = ref true in (* initialize only once *) + let first = ref true in + (* initialize only once *) let formatter_l = [Format.std_formatter; Format.err_formatter; Format.str_formatter] in @@ -147,26 +145,26 @@ module Color = struct first := false; Format.set_mark_tags true; List.iter set_color_tag_handling formatter_l; - color_enabled := (match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); + color_enabled := + match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); () end (* command line flags *) -module ResClflags: sig - val recover: bool ref - val print: string ref - val width: int ref - val origin: string ref - val file: string ref - val interface: bool ref - val ppx: string ref - - val parse: unit -> unit +module ResClflags : sig + val recover : bool ref + val print : string ref + val width : int ref + val origin : string ref + val file : string ref + val interface : bool ref + val ppx : string ref + + val parse : unit -> unit end = struct let recover = ref false let width = ref 100 @@ -177,33 +175,48 @@ end = struct let ppx = ref "" let file = ref "" - let usage = "\n**This command line is for the repo developer's testing purpose only. DO NOT use it in production**!\n\n" ^ - "Usage:\n rescript \n\n" ^ - "Examples:\n" ^ - " rescript myFile.res\n" ^ - " rescript -parse ml -print res myFile.ml\n" ^ - " rescript -parse res -print binary -interface myFile.resi\n\n" ^ - "Options are:" - - let spec = [ - ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); - ("-parse", Arg.String (fun txt -> origin := txt), "Parse reasonBinary, ml or res. Default: res"); - ("-print", Arg.String (fun txt -> print := txt), "Print either binary, ml, ast, sexp or res. Default: res"); - ("-width", Arg.Int (fun w -> width := w), "Specify the line length for the printer (formatter)"); - ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); - ("-ppx", Arg.String (fun txt -> ppx := txt), "Apply a specific built-in ppx before parsing, none or jsx. Default: none"); - ] + let usage = + "\n\ + **This command line is for the repo developer's testing purpose only. DO \ + NOT use it in production**!\n\n" + ^ "Usage:\n rescript \n\n" ^ "Examples:\n" + ^ " rescript myFile.res\n" ^ " rescript -parse ml -print res myFile.ml\n" + ^ " rescript -parse res -print binary -interface myFile.resi\n\n" + ^ "Options are:" + + let spec = + [ + ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); + ( "-parse", + Arg.String (fun txt -> origin := txt), + "Parse reasonBinary, ml or res. Default: res" ); + ( "-print", + Arg.String (fun txt -> print := txt), + "Print either binary, ml, ast, sexp or res. Default: res" ); + ( "-width", + Arg.Int (fun w -> width := w), + "Specify the line length for the printer (formatter)" ); + ( "-interface", + Arg.Unit (fun () -> interface := true), + "Parse as interface" ); + ( "-ppx", + Arg.String (fun txt -> ppx := txt), + "Apply a specific built-in ppx before parsing, none or jsx. Default: \ + none" ); + ] let parse () = Arg.parse spec (fun f -> file := f) usage end module CliArgProcessor = struct - type backend = Parser: ('diagnostics) Res_driver.parsingEngine -> backend [@@unboxed] + type backend = Parser : 'diagnostics Res_driver.parsingEngine -> backend + [@@unboxed] let processFile ~isInterface ~width ~recover ~origin ~target ~ppx filename = let len = String.length filename in let processInterface = - isInterface || len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i' + isInterface + || (len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i') in let parsingEngine = match origin with @@ -214,10 +227,11 @@ module CliArgProcessor = struct match Filename.extension filename with | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine | ".re" | ".rei" -> Parser Res_driver_reason_binary.parsingEngine - | _ -> Parser Res_driver.parsingEngine - ) + | _ -> Parser Res_driver.parsingEngine) | origin -> - print_endline ("-parse needs to be either reasonBinary, ml or res. You provided " ^ origin); + print_endline + ("-parse needs to be either reasonBinary, ml or res. You provided " + ^ origin); exit 1 in let printEngine = @@ -226,71 +240,70 @@ module CliArgProcessor = struct | "ml" -> Res_driver_ml_parser.printEngine | "ast" -> Res_ast_debugger.printEngine | "sexp" -> Res_ast_debugger.sexpPrintEngine - | "res" -> Res_driver.printEngine + | "res" -> Res_driver.printEngine | target -> - print_endline ("-print needs to be either binary, ml, ast, sexp or res. You provided " ^ target); + print_endline + ("-print needs to be either binary, ml, ast, sexp or res. You \ + provided " ^ target); exit 1 in - let forPrinter = match target with - | "res" | "sexp" -> true - | _ -> false + let forPrinter = + match target with + | "res" | "sexp" -> true + | _ -> false in - let Parser backend = parsingEngine in + let (Parser backend) = parsingEngine in (* This is the whole purpose of the Color module above *) Color.setup None; if processInterface then let parseResult = backend.parseInterface ~forPrinter ~filename in - if parseResult.invalid then begin - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics; + if parseResult.invalid then ( + backend.stringOfDiagnostics ~source:parseResult.source + ~filename:parseResult.filename parseResult.diagnostics; if recover then - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else exit 1 - end + printEngine.printInterface ~width ~filename + ~comments:parseResult.comments parseResult.parsetree + else exit 1) else - let parsetree = match ppx with + let parsetree = + match ppx with | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree | _ -> parseResult.parsetree in - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parsetree + printEngine.printInterface ~width ~filename + ~comments:parseResult.comments parsetree else let parseResult = backend.parseImplementation ~forPrinter ~filename in - if parseResult.invalid then begin - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics; + if parseResult.invalid then ( + backend.stringOfDiagnostics ~source:parseResult.source + ~filename:parseResult.filename parseResult.diagnostics; if recover then - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else exit 1 - end + printEngine.printImplementation ~width ~filename + ~comments:parseResult.comments parseResult.parsetree + else exit 1) else - let parsetree = match ppx with - | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree + let parsetree = + match ppx with + | "jsx" -> + Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree | _ -> parseResult.parsetree in - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parsetree - [@@raises Invalid_argument, Failure, exit] + printEngine.printImplementation ~width ~filename + ~comments:parseResult.comments parsetree + [@@raises Invalid_argument, Failure, exit] end - (* let [@raises Invalid_argument, Failure, exit] () = - if not !Sys.interactive then begin - ResClflags.parse (); - CliArgProcessor.processFile - ~isInterface:!ResClflags.interface - ~width:!ResClflags.width - ~recover:!ResClflags.recover - ~target:!ResClflags.print - ~origin:!ResClflags.origin - ~ppx:!ResClflags.ppx - !ResClflags.file -end *) + if not !Sys.interactive then begin + ResClflags.parse (); + CliArgProcessor.processFile + ~isInterface:!ResClflags.interface + ~width:!ResClflags.width + ~recover:!ResClflags.recover + ~target:!ResClflags.print + ~origin:!ResClflags.origin + ~ppx:!ResClflags.ppx + !ResClflags.file + end *) diff --git a/analysis/vendor/res_outcome_printer/res_comment.ml b/analysis/vendor/res_outcome_printer/res_comment.ml index 203450e58..23898f8bc 100644 --- a/analysis/vendor/res_outcome_printer/res_comment.ml +++ b/analysis/vendor/res_outcome_printer/res_comment.ml @@ -1,10 +1,11 @@ -type style = SingleLine | MultiLine | DocComment +type style = SingleLine | MultiLine | DocComment | ModuleComment let styleToString s = match s with | SingleLine -> "SingleLine" | MultiLine -> "MultiLine" | DocComment -> "DocComment" + | ModuleComment -> "ModuleComment" type t = { txt: string; @@ -23,6 +24,8 @@ let isSingleLineComment t = t.style = SingleLine let isDocComment t = t.style = DocComment +let isModuleComment t = t.style = ModuleComment + let toString t = let {Location.loc_start; loc_end} = t.loc in Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt @@ -34,11 +37,13 @@ let toString t = let makeSingleLineComment ~loc txt = {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} -let makeMultiLineComment ~loc ~docComment txt = +let makeMultiLineComment ~loc ~docComment ~standalone txt = { txt; loc; - style = (if docComment then DocComment else MultiLine); + style = + (if docComment then if standalone then ModuleComment else DocComment + else MultiLine); prevTokEndPos = Lexing.dummy_pos; } diff --git a/analysis/vendor/res_outcome_printer/res_comment.mli b/analysis/vendor/res_outcome_printer/res_comment.mli index de3067428..f1d5424d9 100644 --- a/analysis/vendor/res_outcome_printer/res_comment.mli +++ b/analysis/vendor/res_outcome_printer/res_comment.mli @@ -10,10 +10,13 @@ val setPrevTokEndPos : t -> Lexing.position -> unit val isDocComment : t -> bool +val isModuleComment : t -> bool + val isSingleLineComment : t -> bool val makeSingleLineComment : loc:Location.t -> string -> t -val makeMultiLineComment : loc:Location.t -> docComment:bool -> string -> t +val makeMultiLineComment : + loc:Location.t -> docComment:bool -> standalone:bool -> string -> t val fromOcamlComment : loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t val trimSpaces : string -> string diff --git a/analysis/vendor/res_outcome_printer/res_core.ml b/analysis/vendor/res_outcome_printer/res_core.ml index 2d8542725..506ceea3d 100644 --- a/analysis/vendor/res_outcome_printer/res_core.ml +++ b/analysis/vendor/res_outcome_printer/res_core.ml @@ -5,7 +5,6 @@ module Diagnostics = Res_diagnostics module CommentTable = Res_comments_table module ResPrinter = Res_printer module Scanner = Res_scanner -module JsFfi = Res_js_ffi module Parser = Res_parser let mkLoc startLoc endLoc = @@ -556,6 +555,9 @@ let rec parseLident p = Parser.next p; let loc = mkLoc startPos p.prevEndPos in (ident, loc) + | Eof -> + Parser.err ~startPos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("_", mkLoc startPos p.prevEndPos) | _ -> ( match recoverLident p with | Some () -> parseLident p @@ -600,6 +602,9 @@ let parseHashIdent ~startPos p = in Parser.next p; (i, mkLoc startPos p.prevEndPos) + | Eof -> + Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) @@ -635,11 +640,11 @@ let parseValuePath p = Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); Longident.Lident ident) in - if p.token <> Eof then Parser.next p; + Parser.nextUnsafe p; res | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.next p; + Parser.nextUnsafe p; Longident.Lident "_" in Location.mkloc ident (mkLoc startPos p.prevEndPos) @@ -721,30 +726,6 @@ let parseModuleLongIdent ~lowercase p = (* Parser.eatBreadcrumb p; *) moduleIdent -(* `window.location` or `Math` or `Foo.Bar` *) -let parseIdentPath p = - let rec loop p acc = - match p.Parser.token with - | Uident ident | Lident ident -> ( - Parser.next p; - let lident = Longident.Ldot (acc, ident) in - match p.Parser.token with - | Dot -> - Parser.next p; - loop p lident - | _ -> lident) - | _t -> acc - in - match p.Parser.token with - | Lident ident | Uident ident -> ( - Parser.next p; - match p.Parser.token with - | Dot -> - Parser.next p; - loop p (Longident.Lident ident) - | _ -> Longident.Lident ident) - | _ -> Longident.Lident "_" - let verifyJsxOpeningClosingName p nameExpr = let closing = match p.Parser.token with @@ -826,7 +807,7 @@ let parseConstant p = Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Pconst_string ("", None) in - Parser.next p; + Parser.nextUnsafe p; constant let parseTemplateConstant ~prefix (p : Parser.t) = @@ -834,7 +815,7 @@ let parseTemplateConstant ~prefix (p : Parser.t) = let startPos = p.startPos in Parser.nextTemplateLiteralToken p; match p.token with - | TemplateTail txt -> + | TemplateTail (txt, _) -> Parser.next p; Parsetree.Pconst_string (txt, prefix) | _ -> @@ -1090,6 +1071,10 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = in Parser.next p; (i, mkLoc startPos p.prevEndPos) + | Eof -> + Parser.err ~startPos p + (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mkLoc startPos p.prevEndPos) | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p in match p.Parser.token with @@ -1113,6 +1098,9 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = let extension = parseExtension p in let loc = mkLoc startPos p.prevEndPos in Ast_helper.Pat.extension ~loc ~attrs extension + | Eof -> + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultPattern () | token -> ( Parser.err p (Diagnostics.unexpected token p.breadcrumbs); match @@ -1859,6 +1847,10 @@ and parseAtomicExpr p = Parser.err p (Diagnostics.lident token); Parser.next p; Recover.defaultExpr () + | Eof -> + Parser.err ~startPos:p.prevEndPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultExpr () | token -> ( let errPos = p.prevEndPos in Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); @@ -1897,7 +1889,7 @@ and parseFirstClassModuleExpr ~startPos p = and parseBracketAccess p expr startPos = Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; let lbracket = p.startPos in - Parser.next p; + Parser.expect Lbracket p; let stringStart = p.startPos in match p.Parser.token with | String s -> ( @@ -2155,36 +2147,34 @@ and parseTemplateExpr ?(prefix = "js") p = let op = Location.mknoloc (Longident.Lident "^") in Ast_helper.Exp.ident op in - let rec parseParts acc = + let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = + let loc = mkLoc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in + Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator + [(Nolabel, e1); (Nolabel, e2)] + in + let rec parseParts (acc : Parsetree.expression) = let startPos = p.Parser.startPos in Parser.nextTemplateLiteralToken p; match p.token with - | TemplateTail txt -> + | TemplateTail (txt, lastPos) -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mkLoc startPos lastPos in let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string (txt, Some prefix)) in - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator - [(Nolabel, acc); (Nolabel, str)] - | TemplatePart txt -> + concat acc str + | TemplatePart (txt, lastPos) -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mkLoc startPos lastPos in let expr = parseExprBlock p in - let fullLoc = mkLoc startPos p.prevEndPos in let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string (txt, Some prefix)) in let next = - let a = - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc - hiddenOperator - [(Nolabel, acc); (Nolabel, str)] - in - Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator - [(Nolabel, a); (Nolabel, expr)] + let a = concat acc str in + concat a expr in parseParts next | token -> @@ -2194,25 +2184,20 @@ and parseTemplateExpr ?(prefix = "js") p = let startPos = p.startPos in Parser.nextTemplateLiteralToken p; match p.token with - | TemplateTail txt -> + | TemplateTail (txt, lastPos) -> Parser.next p; Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos p.prevEndPos) + ~loc:(mkLoc startPos lastPos) (Pconst_string (txt, Some prefix)) - | TemplatePart txt -> + | TemplatePart (txt, lastPos) -> Parser.next p; - let constantLoc = mkLoc startPos p.prevEndPos in + let constantLoc = mkLoc startPos lastPos in let expr = parseExprBlock p in - let fullLoc = mkLoc startPos p.prevEndPos in let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:constantLoc (Pconst_string (txt, Some prefix)) in - let next = - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc - hiddenOperator - [(Nolabel, str); (Nolabel, expr)] - in + let next = concat str expr in parseParts next | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); @@ -2428,17 +2413,6 @@ and parseLetBindings ~attrs p = match p.Parser.token with | And -> Parser.next p; - let attrs = - match p.token with - | Export -> - let exportLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let genTypeAttr = - (Location.mkloc "genType" exportLoc, Parsetree.PStr []) - in - genTypeAttr :: attrs - | _ -> attrs - in ignore (Parser.optional p Let); (* overparse for fault tolerance *) let letBinding = parseLetBindingBody ~startPos ~attrs p in @@ -3249,7 +3223,10 @@ and parseForRest hasOpeningParen pattern startPos p = Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Asttypes.Upto in - Parser.next p; + if p.Parser.token = Eof then + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs) + else Parser.next p; let e2 = parseExpr ~context:WhenExpr p in if hasOpeningParen then Parser.expect Rparen p; Parser.expect Lbrace p; @@ -3607,7 +3584,7 @@ and parseValueOrConstructor p = Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) | token -> if acc = [] then ( - Parser.next p; + Parser.nextUnsafe p; Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Recover.defaultExpr ()) else @@ -3808,7 +3785,11 @@ and parseAtomicTypExpr ~attrs p = | SingleQuote -> Parser.next p; let ident, loc = - parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p in Ast_helper.Typ.var ~loc ~attrs ident | Underscore -> @@ -3854,6 +3835,9 @@ and parseAtomicTypExpr ~attrs p = let loc = mkLoc startPos p.prevEndPos in Ast_helper.Typ.extension ~attrs ~loc extension | Lbrace -> parseRecordOrObjectType ~attrs p + | Eof -> + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.defaultType () | token -> ( Parser.err p (Diagnostics.unexpected token p.breadcrumbs); match @@ -4596,7 +4580,11 @@ and parseTypeParam p = | SingleQuote -> Parser.next p; let ident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + if p.Parser.token = Eof then ( + Parser.err ~startPos:p.startPos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mkLoc p.startPos p.prevEndPos)) + else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> @@ -5163,17 +5151,6 @@ and parseTypeDefinitions ~attrs ~name ~params ~startPos p = match p.Parser.token with | And -> Parser.next p; - let attrs = - match p.token with - | Export -> - let exportLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let genTypeAttr = - (Location.mkloc "genType" exportLoc, Parsetree.PStr []) - in - genTypeAttr :: attrs - | _ -> attrs - in let typeDef = parseTypeDef ~attrs ~startPos p in loop p (typeDef :: defs) | _ -> List.rev defs @@ -5336,12 +5313,6 @@ and parseStructureItemRegion p = parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Str.primitive ~loc externalDef) - | Import -> - let importDescr = parseJsImport ~startPos ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - let structureItem = JsFfi.toParsetree importDescr in - Some {structureItem with pstr_loc = loc} | Exception -> let exceptionDef = parseExceptionDef ~attrs p in parseNewlineOrSemicolonStructure p; @@ -5352,11 +5323,6 @@ and parseStructureItemRegion p = parseNewlineOrSemicolonStructure p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Str.include_ ~loc includeStatement) - | Export -> - let structureItem = parseJsExport ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some {structureItem with pstr_loc = loc} | Module -> Parser.beginRegion p; let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in @@ -5364,6 +5330,16 @@ and parseStructureItemRegion p = let loc = mkLoc startPos p.prevEndPos in Parser.endRegion p; Some {structureItem with pstr_loc = loc} + | ModuleComment (loc, s) -> + Parser.next p; + Some + (Ast_helper.Str.attribute ~loc + ( {txt = "ns.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | AtAt -> let attr = parseStandaloneAttribute p in parseNewlineOrSemicolonStructure p; @@ -5393,103 +5369,6 @@ and parseStructureItemRegion p = | _ -> None) [@@progress Parser.next, Parser.expect] -and parseJsImport ~startPos ~attrs p = - Parser.expect Token.Import p; - let importSpec = - match p.Parser.token with - | Token.Lident _ | Token.At -> - let decl = - match parseJsFfiDeclaration p with - | Some decl -> decl - | None -> assert false - in - JsFfi.Default decl - | _ -> JsFfi.Spec (parseJsFfiDeclarations p) - in - let scope = parseJsFfiScope p in - let loc = mkLoc startPos p.prevEndPos in - JsFfi.importDescr ~attrs ~importSpec ~scope ~loc - -and parseJsExport ~attrs p = - let exportStart = p.Parser.startPos in - Parser.expect Token.Export p; - let exportLoc = mkLoc exportStart p.prevEndPos in - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - let attrs = genTypeAttr :: attrs in - match p.Parser.token with - | Typ -> ( - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> Ast_helper.Str.type_ recFlag types - | TypeExt ext -> Ast_helper.Str.type_extension ext) - (* Let *) - | _ -> - let recFlag, letBindings = parseLetBindings ~attrs p in - Ast_helper.Str.value recFlag letBindings - -and parseSignJsExport ~attrs p = - let exportStart = p.Parser.startPos in - Parser.expect Token.Export p; - let exportLoc = mkLoc exportStart p.prevEndPos in - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - let attrs = genTypeAttr :: attrs in - match p.Parser.token with - | Typ -> ( - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - let loc = mkLoc exportStart p.prevEndPos in - Ast_helper.Sig.type_ recFlag types ~loc - | TypeExt ext -> - let loc = mkLoc exportStart p.prevEndPos in - Ast_helper.Sig.type_extension ext ~loc) - (* Let *) - | _ -> - let valueDesc = parseSignLetDesc ~attrs p in - let loc = mkLoc exportStart p.prevEndPos in - Ast_helper.Sig.value valueDesc ~loc - -and parseJsFfiScope p = - match p.Parser.token with - | Token.Lident "from" -> ( - Parser.next p; - match p.token with - | String s -> - Parser.next p; - JsFfi.Module s - | Uident _ | Lident _ -> - let value = parseIdentPath p in - JsFfi.Scope value - | _ -> JsFfi.Global) - | _ -> JsFfi.Global - -and parseJsFfiDeclarations p = - Parser.expect Token.Lbrace p; - let decls = - parseCommaDelimitedRegion ~grammar:Grammar.JsFfiImport ~closing:Rbrace - ~f:parseJsFfiDeclaration p - in - Parser.expect Rbrace p; - decls - -and parseJsFfiDeclaration p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Lident _ -> - let ident, _ = parseLident p in - let alias = - match p.token with - | As -> - Parser.next p; - let ident, _ = parseLident p in - ident - | _ -> ident - in - Parser.expect Token.Colon p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (JsFfi.decl ~loc ~alias ~attrs ~name:ident ~typ) - | _ -> None - (* include-statement ::= include module-expr *) and parseIncludeStatement ~attrs p = let startPos = p.Parser.startPos in @@ -6033,11 +5912,6 @@ and parseSignatureItemRegion p = parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Sig.value ~loc externalDef) - | Export -> - let signatureItem = parseSignJsExport ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some {signatureItem with psig_loc = loc} | Exception -> let exceptionDef = parseExceptionDef ~attrs p in parseNewlineOrSemicolonSignature p; @@ -6088,14 +5962,21 @@ and parseSignatureItemRegion p = parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Sig.attribute ~loc attr) + | ModuleComment (loc, s) -> + Parser.next p; + Some + (Ast_helper.Sig.attribute ~loc + ( {txt = "ns.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) | PercentPercent -> let extension = parseExtension ~moduleLanguage:true p in parseNewlineOrSemicolonSignature p; let loc = mkLoc startPos p.prevEndPos in Some (Ast_helper.Sig.extension ~attrs ~loc extension) - | Import -> - Parser.next p; - parseSignatureItemRegion p | _ -> ( match attrs with | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> @@ -6318,6 +6199,7 @@ and parseAttributes p = *) and parseStandaloneAttribute p = let startPos = p.startPos in + (* XX *) Parser.expect AtAt p; let attrId = parseAttributeId ~startPos p in let payload = parsePayload p in diff --git a/analysis/vendor/res_outcome_printer/res_grammar.ml b/analysis/vendor/res_outcome_printer/res_grammar.ml index 4c9cb942a..44f0e4976 100644 --- a/analysis/vendor/res_outcome_printer/res_grammar.ml +++ b/analysis/vendor/res_outcome_printer/res_grammar.ml @@ -56,7 +56,6 @@ type t = | TypeConstraint | AtomicTypExpr | ListExpr - | JsFfiImport | Pattern | AttributePayload | TagNames @@ -116,7 +115,6 @@ let toString = function | AtomicTypExpr -> "a type" | ListExpr -> "an ocaml list expr" | PackageConstraint -> "a package constraint" - | JsFfiImport -> "js ffi import" | JsxChild -> "jsx child" | Pattern -> "pattern" | ExprFor -> "a for expression" @@ -125,7 +123,7 @@ let toString = function let isSignatureItemStart = function | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt - | Export | PercentPercent -> + | PercentPercent -> true | _ -> false @@ -162,8 +160,8 @@ let isJsxAttributeStart = function | _ -> false let isStructureItemStart = function - | Token.Open | Let | Typ | External | Import | Export | Exception | Include - | Module | AtAt | PercentPercent | At -> + | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt + | PercentPercent | At -> true | t when isExprStart t -> true | _ -> false @@ -254,10 +252,6 @@ let isAttributeStart = function | Token.At -> true | _ -> false -let isJsFfiImportStart = function - | Token.Lident _ | At -> true - | _ -> false - let isJsxChildStart = isAtomicExprStart let isBlockExprStart = function @@ -296,7 +290,6 @@ let isListElement grammar token = | PackageConstraint -> token = And | ConstructorDeclaration -> token = Bar | JsxAttribute -> isJsxAttributeStart token - | JsFfiImport -> isJsFfiImportStart token | AttributePayload -> token = Lparen | TagNames -> token = Hash | _ -> false @@ -318,7 +311,6 @@ let isListTerminator grammar token = | TypeParams, Rparen | ParameterList, (EqualGreater | Lbrace) | JsxAttribute, (Forwardslash | GreaterThan) - | JsFfiImport, Rbrace | StringFieldDeclarations, Rbrace -> true | Attribute, token when token <> At -> true diff --git a/analysis/vendor/res_outcome_printer/res_parser.ml b/analysis/vendor/res_outcome_printer/res_parser.ml index f920c57f2..9fcdc3c5c 100644 --- a/analysis/vendor/res_outcome_printer/res_parser.ml +++ b/analysis/vendor/res_outcome_printer/res_parser.ml @@ -54,6 +54,11 @@ let docCommentToAttributeToken comment = let loc = Comment.loc comment in Token.DocComment (loc, txt) +let moduleCommentToAttributeToken comment = + let txt = Comment.txt comment in + let loc = Comment.loc comment in + Token.ModuleComment (loc, txt) + (* Advance to the next non-comment token and store any encountered comment * in the parser's state. Every comment contains the end position of its * previous token to facilite comment interleaving *) @@ -72,6 +77,11 @@ let rec next ?prevEndPos p = p.prevEndPos <- prevEndPos; p.startPos <- startPos; p.endPos <- endPos) + else if Comment.isModuleComment c then ( + p.token <- moduleCommentToAttributeToken c; + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos) else ( Comment.setPrevTokEndPos c p.endPos; p.comments <- c :: p.comments; diff --git a/analysis/vendor/res_outcome_printer/res_printer.ml b/analysis/vendor/res_outcome_printer/res_printer.ml index 023599777..19f3ee952 100644 --- a/analysis/vendor/res_outcome_printer/res_printer.ml +++ b/analysis/vendor/res_outcome_printer/res_printer.ml @@ -527,15 +527,19 @@ let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" else Doc.nil -let rec printStructure (s : Parsetree.structure) t = +let customLayoutThreshold = 2 + +let rec printStructure ~customLayout (s : Parsetree.structure) t = match s with | [] -> printCommentsInside t Location.none | structure -> printList ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure ~print:printStructureItem t + ~nodes:structure + ~print:(printStructureItem ~customLayout) + t -and printStructureItem (si : Parsetree.structure_item) cmtTbl = +and printStructureItem ~customLayout (si : Parsetree.structure_item) cmtTbl = match si.pstr_desc with | Pstr_value (rec_flag, valueBindings) -> let recFlag = @@ -543,53 +547,58 @@ and printStructureItem (si : Parsetree.structure_item) cmtTbl = | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printValueBindings ~recFlag valueBindings cmtTbl + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl | Pstr_type (recFlag, typeDeclarations) -> let recFlag = match recFlag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~recFlag typeDeclarations cmtTbl + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl | Pstr_primitive valueDescription -> - printValueDescription valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Pstr_eval (expr, attrs) -> let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.structureExpr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in - Doc.concat [printAttributes attrs cmtTbl; exprDoc] - | Pstr_attribute attr -> printAttribute ~standalone:true attr cmtTbl + Doc.concat [printAttributes ~customLayout attrs cmtTbl; exprDoc] + | Pstr_attribute attr -> + printAttribute ~customLayout ~standalone:true attr cmtTbl | Pstr_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs cmtTbl; - Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; ] | Pstr_include includeDeclaration -> - printIncludeDeclaration includeDeclaration cmtTbl - | Pstr_open openDescription -> printOpenDescription openDescription cmtTbl - | Pstr_modtype modTypeDecl -> printModuleTypeDeclaration modTypeDecl cmtTbl + printIncludeDeclaration ~customLayout includeDeclaration cmtTbl + | Pstr_open openDescription -> + printOpenDescription ~customLayout openDescription cmtTbl + | Pstr_modtype modTypeDecl -> + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl | Pstr_module moduleBinding -> - printModuleBinding ~isRec:false moduleBinding cmtTbl 0 + printModuleBinding ~customLayout ~isRec:false moduleBinding cmtTbl 0 | Pstr_recmodule moduleBindings -> printListi ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) ~nodes:moduleBindings - ~print:(printModuleBinding ~isRec:true) + ~print:(printModuleBinding ~customLayout ~isRec:true) cmtTbl | Pstr_exception extensionConstructor -> - printExceptionDef extensionConstructor cmtTbl - | Pstr_typext typeExtension -> printTypeExtension typeExtension cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl + | Pstr_typext typeExtension -> + printTypeExtension ~customLayout typeExtension cmtTbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil -and printTypeExtension (te : Parsetree.type_extension) cmtTbl = +and printTypeExtension ~customLayout (te : Parsetree.type_extension) cmtTbl = let prefix = Doc.text "type " in let name = printLidentPath te.ptyext_path cmtTbl in - let typeParams = printTypeParams te.ptyext_params cmtTbl in + let typeParams = printTypeParams ~customLayout te.ptyext_params cmtTbl in let extensionConstructors = let ecs = te.ptyext_constructors in let forceBreak = @@ -607,7 +616,8 @@ and printTypeExtension (te : Parsetree.type_extension) cmtTbl = let rows = printListi ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~print:printExtensionConstructor ~nodes:ecs ~forceBreak cmtTbl + ~print:(printExtensionConstructor ~customLayout) + ~nodes:ecs ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak (Doc.indent @@ -624,7 +634,8 @@ and printTypeExtension (te : Parsetree.type_extension) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~loc:te.ptyext_path.loc te.ptyext_attributes cmtTbl; + printAttributes ~customLayout ~loc:te.ptyext_path.loc + te.ptyext_attributes cmtTbl; prefix; name; typeParams; @@ -632,7 +643,7 @@ and printTypeExtension (te : Parsetree.type_extension) cmtTbl = extensionConstructors; ]) -and printModuleBinding ~isRec moduleBinding cmtTbl i = +and printModuleBinding ~customLayout ~isRec moduleBinding cmtTbl i = let prefix = if i = 0 then Doc.concat @@ -642,9 +653,9 @@ and printModuleBinding ~isRec moduleBinding cmtTbl i = let modExprDoc, modConstraintDoc = match moduleBinding.pmb_expr with | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( printModExpr modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType modType cmtTbl] ) - | modExpr -> (printModExpr modExpr cmtTbl, Doc.nil) + ( printModExpr ~customLayout modExpr cmtTbl, + Doc.concat [Doc.text ": "; printModType ~customLayout modType cmtTbl] ) + | modExpr -> (printModExpr ~customLayout modExpr cmtTbl, Doc.nil) in let modName = let doc = Doc.text moduleBinding.pmb_name.Location.txt in @@ -653,7 +664,7 @@ and printModuleBinding ~isRec moduleBinding cmtTbl i = let doc = Doc.concat [ - printAttributes ~loc:moduleBinding.pmb_name.loc + printAttributes ~customLayout ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes cmtTbl; prefix; modName; @@ -664,29 +675,31 @@ and printModuleBinding ~isRec moduleBinding cmtTbl i = in printComments doc cmtTbl moduleBinding.pmb_loc -and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) - cmtTbl = +and printModuleTypeDeclaration ~customLayout + (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = let modName = let doc = Doc.text modTypeDecl.pmtd_name.txt in printComments doc cmtTbl modTypeDecl.pmtd_name.loc in Doc.concat [ - printAttributes modTypeDecl.pmtd_attributes cmtTbl; + printAttributes ~customLayout modTypeDecl.pmtd_attributes cmtTbl; Doc.text "module type "; modName; (match modTypeDecl.pmtd_type with | None -> Doc.nil - | Some modType -> Doc.concat [Doc.text " = "; printModType modType cmtTbl]); + | Some modType -> + Doc.concat [Doc.text " = "; printModType ~customLayout modType cmtTbl]); ] -and printModType modType cmtTbl = +and printModType ~customLayout modType cmtTbl = let modTypeDoc = match modType.pmty_desc with | Parsetree.Pmty_ident longident -> Doc.concat [ - printAttributes ~loc:longident.loc modType.pmty_attributes cmtTbl; + printAttributes ~customLayout ~loc:longident.loc + modType.pmty_attributes cmtTbl; printLongidentLocation longident cmtTbl; ] | Pmty_signature [] -> @@ -710,12 +723,17 @@ and printModType modType cmtTbl = [ Doc.lbrace; Doc.indent - (Doc.concat [Doc.line; printSignature signature cmtTbl]); + (Doc.concat + [Doc.line; printSignature ~customLayout signature cmtTbl]); Doc.line; Doc.rbrace; ]) in - Doc.concat [printAttributes modType.pmty_attributes cmtTbl; signatureDoc] + Doc.concat + [ + printAttributes ~customLayout modType.pmty_attributes cmtTbl; + signatureDoc; + ] | Pmty_functor _ -> let parameters, returnType = ParsetreeViewer.functorType modType in let parametersDoc = @@ -725,8 +743,10 @@ and printModType modType cmtTbl = let cmtLoc = {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in - let attrs = printAttributes attrs cmtTbl in - let doc = Doc.concat [attrs; printModType modType cmtTbl] in + let attrs = printAttributes ~customLayout attrs cmtTbl in + let doc = + Doc.concat [attrs; printModType ~customLayout modType cmtTbl] + in printComments doc cmtTbl cmtLoc | params -> Doc.group @@ -751,7 +771,9 @@ and printModType modType cmtTbl = modType.Parsetree.pmty_loc.loc_end; } in - let attrs = printAttributes attrs cmtTbl in + let attrs = + printAttributes ~customLayout attrs cmtTbl + in let lblDoc = if lbl.Location.txt = "_" || lbl.txt = "*" then Doc.nil @@ -771,7 +793,8 @@ and printModType modType cmtTbl = [ (if lbl.txt = "_" then Doc.nil else Doc.text ": "); - printModType modType cmtTbl; + printModType ~customLayout modType + cmtTbl; ]); ] in @@ -784,7 +807,7 @@ and printModType modType cmtTbl = ]) in let returnDoc = - let doc = printModType returnType cmtTbl in + let doc = printModType ~customLayout returnType cmtTbl in if Parens.modTypeFunctorReturn returnType then addParens doc else doc in Doc.group @@ -794,14 +817,15 @@ and printModType modType cmtTbl = Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); ]) | Pmty_typeof modExpr -> - Doc.concat [Doc.text "module type of "; printModExpr modExpr cmtTbl] + Doc.concat + [Doc.text "module type of "; printModExpr ~customLayout modExpr cmtTbl] | Pmty_extension extension -> - printExtension ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmty_alias longident -> Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] | Pmty_with (modType, withConstraints) -> let operand = - let doc = printModType modType cmtTbl in + let doc = printModType ~customLayout modType cmtTbl in if Parens.modTypeWithOperand modType then addParens doc else doc in Doc.group @@ -810,7 +834,10 @@ and printModType modType cmtTbl = operand; Doc.indent (Doc.concat - [Doc.line; printWithConstraints withConstraints cmtTbl]); + [ + Doc.line; + printWithConstraints ~customLayout withConstraints cmtTbl; + ]); ]) in let attrsAlreadyPrinted = @@ -822,13 +849,13 @@ and printModType modType cmtTbl = Doc.concat [ (if attrsAlreadyPrinted then Doc.nil - else printAttributes modType.pmty_attributes cmtTbl); + else printAttributes ~customLayout modType.pmty_attributes cmtTbl); modTypeDoc; ] in printComments doc cmtTbl modType.pmty_loc -and printWithConstraints withConstraints cmtTbl = +and printWithConstraints ~customLayout withConstraints cmtTbl = let rows = List.mapi (fun i withConstraint -> @@ -836,18 +863,19 @@ and printWithConstraints withConstraints cmtTbl = (Doc.concat [ (if i == 0 then Doc.text "with " else Doc.text "and "); - printWithConstraint withConstraint cmtTbl; + printWithConstraint ~customLayout withConstraint cmtTbl; ])) withConstraints in Doc.join ~sep:Doc.line rows -and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = +and printWithConstraint ~customLayout + (withConstraint : Parsetree.with_constraint) cmtTbl = match withConstraint with (* with type X.t = ... *) | Pwith_type (longident, typeDeclaration) -> Doc.group - (printTypeDeclaration + (printTypeDeclaration ~customLayout ~name:(printLidentPath longident cmtTbl) ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) (* with module X.Y = Z *) @@ -862,7 +890,7 @@ and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_typesubst (longident, typeDeclaration) -> Doc.group - (printTypeDeclaration + (printTypeDeclaration ~customLayout ~name:(printLidentPath longident cmtTbl) ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> @@ -874,51 +902,60 @@ and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = Doc.indent (Doc.concat [Doc.line; printLongident longident2]); ] -and printSignature signature cmtTbl = +and printSignature ~customLayout signature cmtTbl = match signature with | [] -> printCommentsInside cmtTbl Location.none | signature -> printList ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature ~print:printSignatureItem cmtTbl + ~nodes:signature + ~print:(printSignatureItem ~customLayout) + cmtTbl -and printSignatureItem (si : Parsetree.signature_item) cmtTbl = +and printSignatureItem ~customLayout (si : Parsetree.signature_item) cmtTbl = match si.psig_desc with | Parsetree.Psig_value valueDescription -> - printValueDescription valueDescription cmtTbl + printValueDescription ~customLayout valueDescription cmtTbl | Psig_type (recFlag, typeDeclarations) -> let recFlag = match recFlag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~recFlag typeDeclarations cmtTbl - | Psig_typext typeExtension -> printTypeExtension typeExtension cmtTbl + printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl + | Psig_typext typeExtension -> + printTypeExtension ~customLayout typeExtension cmtTbl | Psig_exception extensionConstructor -> - printExceptionDef extensionConstructor cmtTbl + printExceptionDef ~customLayout extensionConstructor cmtTbl | Psig_module moduleDeclaration -> - printModuleDeclaration moduleDeclaration cmtTbl + printModuleDeclaration ~customLayout moduleDeclaration cmtTbl | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations moduleDeclarations cmtTbl - | Psig_modtype modTypeDecl -> printModuleTypeDeclaration modTypeDecl cmtTbl - | Psig_open openDescription -> printOpenDescription openDescription cmtTbl + printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl + | Psig_modtype modTypeDecl -> + printModuleTypeDeclaration ~customLayout modTypeDecl cmtTbl + | Psig_open openDescription -> + printOpenDescription ~customLayout openDescription cmtTbl | Psig_include includeDescription -> - printIncludeDescription includeDescription cmtTbl - | Psig_attribute attr -> printAttribute ~standalone:true attr cmtTbl + printIncludeDescription ~customLayout includeDescription cmtTbl + | Psig_attribute attr -> + printAttribute ~customLayout ~standalone:true attr cmtTbl | Psig_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs cmtTbl; - Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + printAttributes ~customLayout attrs cmtTbl; + Doc.concat + [printExtension ~customLayout ~atModuleLvl:true extension cmtTbl]; ] | Psig_class _ | Psig_class_type _ -> Doc.nil -and printRecModuleDeclarations moduleDeclarations cmtTbl = +and printRecModuleDeclarations ~customLayout moduleDeclarations cmtTbl = printListi ~getLoc:(fun n -> n.Parsetree.pmd_loc) - ~nodes:moduleDeclarations ~print:printRecModuleDeclaration cmtTbl + ~nodes:moduleDeclarations + ~print:(printRecModuleDeclaration ~customLayout) + cmtTbl -and printRecModuleDeclaration md cmtTbl i = +and printRecModuleDeclaration ~customLayout md cmtTbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> @@ -930,7 +967,7 @@ and printRecModuleDeclaration md cmtTbl i = | _ -> false in let modTypeDoc = - let doc = printModType md.pmd_type cmtTbl in + let doc = printModType ~customLayout md.pmd_type cmtTbl in if needsParens then addParens doc else doc in Doc.concat [Doc.text ": "; modTypeDoc] @@ -938,31 +975,34 @@ and printRecModuleDeclaration md cmtTbl i = let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text prefix; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; ] -and printModuleDeclaration (md : Parsetree.module_declaration) cmtTbl = +and printModuleDeclaration ~customLayout (md : Parsetree.module_declaration) + cmtTbl = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type cmtTbl] + | _ -> + Doc.concat [Doc.text ": "; printModType ~customLayout md.pmd_type cmtTbl] in Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + printAttributes ~customLayout ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; Doc.text "module "; printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; body; ] -and printOpenDescription (openDescription : Parsetree.open_description) cmtTbl = +and printOpenDescription ~customLayout + (openDescription : Parsetree.open_description) cmtTbl = Doc.concat [ - printAttributes openDescription.popen_attributes cmtTbl; + printAttributes ~customLayout openDescription.popen_attributes cmtTbl; Doc.text "open"; (match openDescription.popen_override with | Asttypes.Fresh -> Doc.space @@ -970,42 +1010,45 @@ and printOpenDescription (openDescription : Parsetree.open_description) cmtTbl = printLongidentLocation openDescription.popen_lid cmtTbl; ] -and printIncludeDescription (includeDescription : Parsetree.include_description) - cmtTbl = +and printIncludeDescription ~customLayout + (includeDescription : Parsetree.include_description) cmtTbl = Doc.concat [ - printAttributes includeDescription.pincl_attributes cmtTbl; + printAttributes ~customLayout includeDescription.pincl_attributes cmtTbl; Doc.text "include "; - printModType includeDescription.pincl_mod cmtTbl; + printModType ~customLayout includeDescription.pincl_mod cmtTbl; ] -and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) - cmtTbl = +and printIncludeDeclaration ~customLayout + (includeDeclaration : Parsetree.include_declaration) cmtTbl = Doc.concat [ - printAttributes includeDeclaration.pincl_attributes cmtTbl; + printAttributes ~customLayout includeDeclaration.pincl_attributes cmtTbl; Doc.text "include "; - (let includeDoc = printModExpr includeDeclaration.pincl_mod cmtTbl in + (let includeDoc = + printModExpr ~customLayout includeDeclaration.pincl_mod cmtTbl + in if Parens.includeModExpr includeDeclaration.pincl_mod then addParens includeDoc else includeDoc); ] -and printValueBindings ~recFlag (vbs : Parsetree.value_binding list) cmtTbl = +and printValueBindings ~customLayout ~recFlag + (vbs : Parsetree.value_binding list) cmtTbl = printListi ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) ~nodes:vbs - ~print:(printValueBinding ~recFlag) + ~print:(printValueBinding ~customLayout ~recFlag) cmtTbl -and printValueDescription valueDescription cmtTbl = +and printValueDescription ~customLayout valueDescription cmtTbl = let isExternal = match valueDescription.pval_prim with | [] -> false | _ -> true in let attrs = - printAttributes ~loc:valueDescription.pval_name.loc + printAttributes ~customLayout ~loc:valueDescription.pval_name.loc valueDescription.pval_attributes cmtTbl in let header = if isExternal then "external " else "let " in @@ -1018,7 +1061,7 @@ and printValueDescription valueDescription cmtTbl = (printIdentLike valueDescription.pval_name.txt) cmtTbl valueDescription.pval_name.loc; Doc.text ": "; - printTypExpr valueDescription.pval_type cmtTbl; + printTypExpr ~customLayout valueDescription.pval_type cmtTbl; (if isExternal then Doc.group (Doc.concat @@ -1039,11 +1082,11 @@ and printValueDescription valueDescription cmtTbl = else Doc.nil); ]) -and printTypeDeclarations ~recFlag typeDeclarations cmtTbl = +and printTypeDeclarations ~customLayout ~recFlag typeDeclarations cmtTbl = printListi ~getLoc:(fun n -> n.Parsetree.ptype_loc) ~nodes:typeDeclarations - ~print:(printTypeDeclaration2 ~recFlag) + ~print:(printTypeDeclaration2 ~customLayout ~recFlag) cmtTbl (* @@ -1078,14 +1121,16 @@ and printTypeDeclarations ~recFlag typeDeclarations cmtTbl = * (* Invariant: non-empty list *) * | Ptype_open *) -and printTypeDeclaration ~name ~equalSign ~recFlag i +and printTypeDeclaration ~customLayout ~name ~equalSign ~recFlag i (td : Parsetree.type_declaration) cmtTbl = - let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let attrs = + printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl + in let prefix = if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in - let typeParams = printTypeParams td.ptype_params cmtTbl in + let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( @@ -1096,7 +1141,7 @@ and printTypeDeclaration ~name ~equalSign ~recFlag i [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ]) | Ptype_open -> Doc.concat @@ -1113,7 +1158,7 @@ and printTypeDeclaration ~name ~equalSign ~recFlag i Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] in Doc.concat @@ -1121,7 +1166,7 @@ and printTypeDeclaration ~name ~equalSign ~recFlag i manifest; Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printRecordDeclaration lds cmtTbl; + printRecordDeclaration ~customLayout lds cmtTbl; ] | Ptype_variant cds -> let manifest = @@ -1131,33 +1176,39 @@ and printTypeDeclaration ~name ~equalSign ~recFlag i Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] in Doc.concat [ manifest; Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; ] in - let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + let constraints = + printTypeDefinitionConstraints ~customLayout td.ptype_cstrs + in Doc.group (Doc.concat [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) -and printTypeDeclaration2 ~recFlag (td : Parsetree.type_declaration) cmtTbl i = +and printTypeDeclaration2 ~customLayout ~recFlag + (td : Parsetree.type_declaration) cmtTbl i = let name = let doc = printIdentLike td.Parsetree.ptype_name.txt in printComments doc cmtTbl td.ptype_name.loc in let equalSign = "=" in - let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let attrs = + printAttributes ~customLayout ~loc:td.ptype_loc td.ptype_attributes cmtTbl + in let prefix = if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] in let typeName = name in - let typeParams = printTypeParams td.ptype_params cmtTbl in + let typeParams = printTypeParams ~customLayout td.ptype_params cmtTbl in let manifestAndKind = match td.ptype_kind with | Ptype_abstract -> ( @@ -1168,7 +1219,7 @@ and printTypeDeclaration2 ~recFlag (td : Parsetree.type_declaration) cmtTbl i = [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ]) | Ptype_open -> Doc.concat @@ -1185,7 +1236,7 @@ and printTypeDeclaration2 ~recFlag (td : Parsetree.type_declaration) cmtTbl i = Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] in Doc.concat @@ -1193,7 +1244,7 @@ and printTypeDeclaration2 ~recFlag (td : Parsetree.type_declaration) cmtTbl i = manifest; Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; printPrivateFlag td.ptype_private; - printRecordDeclaration lds cmtTbl; + printRecordDeclaration ~customLayout lds cmtTbl; ] | Ptype_variant cds -> let manifest = @@ -1203,22 +1254,25 @@ and printTypeDeclaration2 ~recFlag (td : Parsetree.type_declaration) cmtTbl i = Doc.concat [ Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] in Doc.concat [ manifest; Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + printConstructorDeclarations ~customLayout + ~privateFlag:td.ptype_private cds cmtTbl; ] in - let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + let constraints = + printTypeDefinitionConstraints ~customLayout td.ptype_cstrs + in Doc.group (Doc.concat [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) -and printTypeDefinitionConstraints cstrs = +and printTypeDefinitionConstraints ~customLayout cstrs = match cstrs with | [] -> Doc.nil | cstrs -> @@ -1229,18 +1283,20 @@ and printTypeDefinitionConstraints cstrs = Doc.line; Doc.group (Doc.join ~sep:Doc.line - (List.map printTypeDefinitionConstraint cstrs)); + (List.map + (printTypeDefinitionConstraint ~customLayout) + cstrs)); ])) -and printTypeDefinitionConstraint +and printTypeDefinitionConstraint ~customLayout ((typ1, typ2, _loc) : Parsetree.core_type * Parsetree.core_type * Location.t) = Doc.concat [ Doc.text "constraint "; - printTypExpr typ1 CommentTable.empty; + printTypExpr ~customLayout typ1 CommentTable.empty; Doc.text " = "; - printTypExpr typ2 CommentTable.empty; + printTypExpr ~customLayout typ2 CommentTable.empty; ] and printPrivateFlag (flag : Asttypes.private_flag) = @@ -1248,7 +1304,7 @@ and printPrivateFlag (flag : Asttypes.private_flag) = | Private -> Doc.text "private " | Public -> Doc.nil -and printTypeParams typeParams cmtTbl = +and printTypeParams ~customLayout typeParams cmtTbl = match typeParams with | [] -> Doc.nil | typeParams -> @@ -1264,7 +1320,9 @@ and printTypeParams typeParams cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typeParam -> - let doc = printTypeParam typeParam cmtTbl in + let doc = + printTypeParam ~customLayout typeParam cmtTbl + in printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc) typeParams); @@ -1274,7 +1332,8 @@ and printTypeParams typeParams cmtTbl = Doc.greaterThan; ]) -and printTypeParam (param : Parsetree.core_type * Asttypes.variance) cmtTbl = +and printTypeParam ~customLayout + (param : Parsetree.core_type * Asttypes.variance) cmtTbl = let typ, variance = param in let printedVariance = match variance with @@ -1282,9 +1341,10 @@ and printTypeParam (param : Parsetree.core_type * Asttypes.variance) cmtTbl = | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr typ cmtTbl] + Doc.concat [printedVariance; printTypExpr ~customLayout typ cmtTbl] -and printRecordDeclaration (lds : Parsetree.label_declaration list) cmtTbl = +and printRecordDeclaration ~customLayout + (lds : Parsetree.label_declaration list) cmtTbl = let forceBreak = match (lds, List.rev lds) with | first :: _, last :: _ -> @@ -1303,7 +1363,9 @@ and printRecordDeclaration (lds : Parsetree.label_declaration list) cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = printLabelDeclaration ld cmtTbl in + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in printComments doc cmtTbl ld.Parsetree.pld_loc) lds); ]); @@ -1312,7 +1374,7 @@ and printRecordDeclaration (lds : Parsetree.label_declaration list) cmtTbl = Doc.rbrace; ]) -and printConstructorDeclarations ~privateFlag +and printConstructorDeclarations ~customLayout ~privateFlag (cds : Parsetree.constructor_declaration list) cmtTbl = let forceBreak = match (cds, List.rev cds) with @@ -1330,16 +1392,16 @@ and printConstructorDeclarations ~privateFlag ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) ~nodes:cds ~print:(fun cd cmtTbl i -> - let doc = printConstructorDeclaration2 i cd cmtTbl in + let doc = printConstructorDeclaration2 ~customLayout i cd cmtTbl in printComments doc cmtTbl cd.Parsetree.pcd_loc) ~forceBreak cmtTbl in Doc.breakableGroup ~forceBreak (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) -and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) - cmtTbl = - let attrs = printAttributes cd.pcd_attributes cmtTbl in +and printConstructorDeclaration2 ~customLayout i + (cd : Parsetree.constructor_declaration) cmtTbl = + let attrs = printAttributes ~customLayout cd.pcd_attributes cmtTbl in let bar = if i > 0 || cd.pcd_attributes <> [] then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil @@ -1348,12 +1410,15 @@ and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) let doc = Doc.text cd.pcd_name.txt in printComments doc cmtTbl cd.pcd_name.loc in - let constrArgs = printConstructorArguments ~indent:true cd.pcd_args cmtTbl in + let constrArgs = + printConstructorArguments ~customLayout ~indent:true cd.pcd_args cmtTbl + in let gadt = match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent (Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl]) + Doc.indent + (Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl]) in Doc.concat [ @@ -1369,8 +1434,8 @@ and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) ]); ] -and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) - cmtTbl = +and printConstructorArguments ~customLayout ~indent + (cdArgs : Parsetree.constructor_arguments) cmtTbl = match cdArgs with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> @@ -1384,7 +1449,9 @@ and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types); + (List.map + (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + types); ]); Doc.trailingComma; Doc.softLine; @@ -1407,7 +1474,9 @@ and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = printLabelDeclaration ld cmtTbl in + let doc = + printLabelDeclaration ~customLayout ld cmtTbl + in printComments doc cmtTbl ld.Parsetree.pld_loc) lds); ]); @@ -1419,8 +1488,11 @@ and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) in if indent then Doc.indent args else args -and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = - let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl in +and printLabelDeclaration ~customLayout (ld : Parsetree.label_declaration) + cmtTbl = + let attrs = + printAttributes ~customLayout ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl + in let mutableFlag = match ld.pld_mutable with | Mutable -> Doc.text "mutable " @@ -1439,17 +1511,17 @@ and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = name; optional; Doc.text ": "; - printTypExpr ld.pld_type cmtTbl; + printTypExpr ~customLayout ld.pld_type cmtTbl; ]) -and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = +and printTypExpr ~customLayout (typExpr : Parsetree.core_type) cmtTbl = let renderedType = match typExpr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] | Ptyp_extension extension -> - printExtension ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Ptyp_alias (typ, alias) -> let typ = (* Technically type t = (string, float) => unit as 'x, doesn't require @@ -1461,14 +1533,14 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = | Ptyp_arrow _ -> true | _ -> false in - let doc = printTypExpr typ cmtTbl in + let doc = printTypExpr ~customLayout typ cmtTbl in if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in Doc.concat [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] (* object printings *) | Ptyp_object (fields, openFlag) -> - printObject ~inline:false fields openFlag cmtTbl + printObject ~customLayout ~inline:false fields openFlag cmtTbl | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1478,7 +1550,7 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = [ constrName; Doc.lessThan; - printObject ~inline:true fields openFlag cmtTbl; + printObject ~customLayout ~inline:true fields openFlag cmtTbl; Doc.greaterThan; ] | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> @@ -1488,7 +1560,7 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = [ constrName; Doc.lessThan; - printTupleType ~inline:true tuple cmtTbl; + printTupleType ~customLayout ~inline:true tuple cmtTbl; Doc.greaterThan; ]) | Ptyp_constr (longidentLoc, constrArgs) -> ( @@ -1508,7 +1580,8 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr typexpr cmtTbl) + (fun typexpr -> + printTypExpr ~customLayout typexpr cmtTbl) constrArgs); ]); Doc.trailingComma; @@ -1523,7 +1596,7 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = | _ -> false in let returnDoc = - let doc = printTypExpr returnType cmtTbl in + let doc = printTypExpr ~customLayout returnType cmtTbl in if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in @@ -1535,11 +1608,12 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = | [([], Nolabel, n)] when not isUncurried -> let hasAttrsBefore = not (attrs = []) in let attrs = - if hasAttrsBefore then printAttributes ~inline:true attrsBefore cmtTbl + if hasAttrsBefore then + printAttributes ~customLayout ~inline:true attrsBefore cmtTbl else Doc.nil in let typDoc = - let doc = printTypExpr n cmtTbl in + let doc = printTypExpr ~customLayout n cmtTbl in match n.ptyp_desc with | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc | _ -> doc @@ -1562,7 +1636,7 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = else Doc.concat [typDoc; Doc.text " => "; returnDoc]); ]) | args -> - let attrs = printAttributes ~inline:true attrs cmtTbl in + let attrs = printAttributes ~customLayout ~inline:true attrs cmtTbl in let renderedArgs = Doc.concat [ @@ -1576,7 +1650,9 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = else Doc.nil); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun tp -> printTypeParameter tp cmtTbl) args); + (List.map + (fun tp -> printTypeParameter ~customLayout tp cmtTbl) + args); ]); Doc.trailingComma; Doc.softLine; @@ -1584,8 +1660,9 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = ] in Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc])) - | Ptyp_tuple types -> printTupleType ~inline:false types cmtTbl - | Ptyp_poly ([], typ) -> printTypExpr typ cmtTbl + | Ptyp_tuple types -> + printTupleType ~customLayout ~inline:false types cmtTbl + | Ptyp_poly ([], typ) -> printTypExpr ~customLayout typ cmtTbl | Ptyp_poly (stringLocs, typ) -> Doc.concat [ @@ -1597,10 +1674,11 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = stringLocs); Doc.dot; Doc.space; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] | Ptyp_package packageType -> - printPackageType ~printModuleKeywordAndParens:true packageType cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:true + packageType cmtTbl | Ptyp_class _ -> Doc.text "classes are not supported in types" | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> let forceBreak = @@ -1613,7 +1691,7 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = Doc.group (Doc.concat [ - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; Doc.concat [Doc.text "#"; printPolyVarIdent txt]; ]) in @@ -1621,8 +1699,10 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = | Rtag ({txt}, attrs, truth, types) -> let doType t = match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr t cmtTbl - | _ -> Doc.concat [Doc.lparen; printTypExpr t cmtTbl; Doc.rparen] + | Ptyp_tuple _ -> printTypExpr ~customLayout t cmtTbl + | _ -> + Doc.concat + [Doc.lparen; printTypExpr ~customLayout t cmtTbl; Doc.rparen] in let printedTypes = List.map doType types in let cases = @@ -1634,11 +1714,11 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = Doc.group (Doc.concat [ - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; Doc.concat [Doc.text "#"; printPolyVarIdent txt]; cases; ]) - | Rinherit coreType -> printTypExpr coreType cmtTbl + | Rinherit coreType -> printTypExpr ~customLayout coreType cmtTbl in let docs = List.map printRowField rowFields in let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in @@ -1684,12 +1764,13 @@ and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = let doc = match typExpr.ptyp_attributes with | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes attrs cmtTbl; renderedType]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; renderedType]) | _ -> renderedType in printComments doc cmtTbl typExpr.ptyp_loc -and printObject ~inline fields openFlag cmtTbl = +and printObject ~customLayout ~inline fields openFlag cmtTbl = let doc = match fields with | [] -> @@ -1720,7 +1801,7 @@ and printObject ~inline fields openFlag cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun field -> printObjectField field cmtTbl) + (fun field -> printObjectField ~customLayout field cmtTbl) fields); ]); Doc.trailingComma; @@ -1730,7 +1811,8 @@ and printObject ~inline fields openFlag cmtTbl = in if inline then doc else Doc.group doc -and printTupleType ~inline (types : Parsetree.core_type list) cmtTbl = +and printTupleType ~customLayout ~inline (types : Parsetree.core_type list) + cmtTbl = let tuple = Doc.concat [ @@ -1741,7 +1823,9 @@ and printTupleType ~inline (types : Parsetree.core_type list) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types); + (List.map + (fun typexpr -> printTypExpr ~customLayout typexpr cmtTbl) + types); ]); Doc.trailingComma; Doc.softLine; @@ -1750,7 +1834,7 @@ and printTupleType ~inline (types : Parsetree.core_type list) cmtTbl = in if inline == false then Doc.group tuple else tuple -and printObjectField (field : Parsetree.object_field) cmtTbl = +and printObjectField ~customLayout (field : Parsetree.object_field) cmtTbl = match field with | Otag (labelLoc, attrs, typ) -> let lbl = @@ -1760,25 +1844,26 @@ and printObjectField (field : Parsetree.object_field) cmtTbl = let doc = Doc.concat [ - printAttributes ~loc:labelLoc.loc attrs cmtTbl; + printAttributes ~customLayout ~loc:labelLoc.loc attrs cmtTbl; lbl; Doc.text ": "; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] in let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in printComments doc cmtTbl cmtLoc - | Oinherit typexpr -> Doc.concat [Doc.dotdotdot; printTypExpr typexpr cmtTbl] + | Oinherit typexpr -> + Doc.concat [Doc.dotdotdot; printTypExpr ~customLayout typexpr cmtTbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) -and printTypeParameter (attrs, lbl, typ) cmtTbl = +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 attrs cmtTbl in + let attrs = printAttributes ~customLayout attrs cmtTbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil @@ -1802,13 +1887,21 @@ and printTypeParameter (attrs, lbl, typ) cmtTbl = let doc = Doc.group (Doc.concat - [uncurried; attrs; label; printTypExpr typ cmtTbl; optionalIndicator]) + [ + uncurried; + attrs; + label; + printTypExpr ~customLayout typ cmtTbl; + optionalIndicator; + ]) in printComments doc cmtTbl loc -and printValueBinding ~recFlag vb cmtTbl i = +and printValueBinding ~customLayout ~recFlag (vb : Parsetree.value_binding) + cmtTbl i = let attrs = - printAttributes ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl + printAttributes ~customLayout ~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 " @@ -1842,7 +1935,7 @@ and printValueBinding ~recFlag vb cmtTbl i = [ attrs; header; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; Doc.text ":"; Doc.indent (Doc.concat @@ -1850,10 +1943,13 @@ and printValueBinding ~recFlag vb cmtTbl i = Doc.line; abstractType; Doc.space; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; Doc.text " ="; Doc.concat - [Doc.line; printExpressionWithComments expr cmtTbl]; + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; ]); ]) | _ -> @@ -1866,7 +1962,7 @@ and printValueBinding ~recFlag vb cmtTbl i = [ attrs; header; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; Doc.text ":"; Doc.indent (Doc.concat @@ -1874,22 +1970,25 @@ and printValueBinding ~recFlag vb cmtTbl i = Doc.line; abstractType; Doc.space; - printTypExpr patTyp cmtTbl; + printTypExpr ~customLayout patTyp cmtTbl; Doc.text " ="; Doc.concat - [Doc.line; printExpressionWithComments expr cmtTbl]; + [ + Doc.line; + printExpressionWithComments ~customLayout expr cmtTbl; + ]; ]); ])) | _ -> let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in let printedExpr = - let doc = printExpressionWithComments vb.pvb_expr cmtTbl in + let doc = printExpressionWithComments ~customLayout vb.pvb_expr cmtTbl in match Parens.expr vb.pvb_expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in - let patternDoc = printPattern vb.pvb_pat cmtTbl in + let patternDoc = printPattern ~customLayout vb.pvb_pat cmtTbl in (* * we want to optimize the layout of one pipe: * let tbl = data->Js.Array2.reduce((map, curr) => { @@ -1951,7 +2050,7 @@ and printValueBinding ~recFlag vb cmtTbl i = else Doc.concat [Doc.space; printedExpr]); ]) -and printPackageType ~printModuleKeywordAndParens +and printPackageType ~customLayout ~printModuleKeywordAndParens (packageType : Parsetree.package_type) cmtTbl = let doc = match packageType with @@ -1962,7 +2061,7 @@ and printPackageType ~printModuleKeywordAndParens (Doc.concat [ printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints packageConstraints cmtTbl; + printPackageConstraints ~customLayout packageConstraints cmtTbl; Doc.softLine; ]) in @@ -1970,7 +2069,7 @@ and printPackageType ~printModuleKeywordAndParens Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc -and printPackageConstraints packageConstraints cmtTbl = +and printPackageConstraints ~customLayout packageConstraints cmtTbl = Doc.concat [ Doc.text " with"; @@ -1988,23 +2087,25 @@ and printPackageConstraints packageConstraints cmtTbl = loc_end = typexpr.Parsetree.ptyp_loc.loc_end; } in - let doc = printPackageConstraint i cmtTbl pc in + let doc = + printPackageConstraint ~customLayout i cmtTbl pc + in printComments doc cmtTbl cmtLoc) packageConstraints); ]); ] -and printPackageConstraint i cmtTbl (longidentLoc, typ) = +and printPackageConstraint ~customLayout i cmtTbl (longidentLoc, typ) = let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in Doc.concat [ prefix; printLongidentLocation longidentLoc cmtTbl; Doc.text " = "; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] -and printExtension ~atModuleLvl (stringLoc, payload) cmtTbl = +and printExtension ~customLayout ~atModuleLvl (stringLoc, payload) cmtTbl = let txt = convertBsExtension stringLoc.Location.txt in let extName = let doc = @@ -2017,9 +2118,9 @@ and printExtension ~atModuleLvl (stringLoc, payload) cmtTbl = in printComments doc cmtTbl stringLoc.Location.loc in - Doc.group (Doc.concat [extName; printPayload payload cmtTbl]) + Doc.group (Doc.concat [extName; printPayload ~customLayout payload cmtTbl]) -and printPattern (p : Parsetree.pattern) cmtTbl = +and printPattern ~customLayout (p : Parsetree.pattern) cmtTbl = let patternWithoutAttributes = match p.ppat_desc with | Ppat_any -> Doc.text "_" @@ -2040,7 +2141,9 @@ and printPattern (p : Parsetree.pattern) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> printPattern pat cmtTbl) patterns); + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); Doc.trailingComma; Doc.softLine; @@ -2060,7 +2163,9 @@ and printPattern (p : Parsetree.pattern) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> printPattern pat cmtTbl) patterns); + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); Doc.trailingComma; Doc.softLine; @@ -2088,11 +2193,16 @@ and printPattern (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 pat cmtTbl) patterns); + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); (match tail.Parsetree.ppat_desc with | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil | _ -> - let doc = Doc.concat [Doc.text "..."; printPattern tail cmtTbl] in + let doc = + Doc.concat + [Doc.text "..."; printPattern ~customLayout tail cmtTbl] + in let tail = printComments doc cmtTbl tail.ppat_loc in Doc.concat [Doc.text ","; Doc.line; tail]); ] @@ -2133,7 +2243,8 @@ and printPattern (p : Parsetree.pattern) cmtTbl = ] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern arg cmtTbl; Doc.rparen] + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2144,14 +2255,16 @@ and printPattern (p : Parsetree.pattern) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun pat -> printPattern pat cmtTbl) patterns); + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); Doc.trailingComma; Doc.softLine; Doc.rparen; ] | Some arg -> - let argDoc = printPattern arg cmtTbl in + let argDoc = printPattern ~customLayout arg cmtTbl in let shouldHug = ParsetreeViewer.isHuggablePattern arg in Doc.concat [ @@ -2188,7 +2301,8 @@ and printPattern (p : Parsetree.pattern) cmtTbl = ] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern arg cmtTbl; Doc.rparen] + Doc.concat + [Doc.lparen; printPattern ~customLayout arg cmtTbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2199,14 +2313,16 @@ and printPattern (p : Parsetree.pattern) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun pat -> printPattern pat cmtTbl) patterns); + (List.map + (fun pat -> printPattern ~customLayout pat cmtTbl) + patterns); ]); Doc.trailingComma; Doc.softLine; Doc.rparen; ] | Some arg -> - let argDoc = printPattern arg cmtTbl in + let argDoc = printPattern ~customLayout arg cmtTbl in let shouldHug = ParsetreeViewer.isHuggablePattern arg in Doc.concat [ @@ -2237,7 +2353,8 @@ and printPattern (p : Parsetree.pattern) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> printPatternRecordRow row cmtTbl) + (fun row -> + printPatternRecordRow ~customLayout row cmtTbl) rows); (match openFlag with | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] @@ -2254,7 +2371,7 @@ and printPattern (p : Parsetree.pattern) cmtTbl = | _ -> false in let pat = - let p = printPattern p cmtTbl in + let p = printPattern ~customLayout 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]) @@ -2264,7 +2381,7 @@ and printPattern (p : Parsetree.pattern) cmtTbl = let docs = List.mapi (fun i pat -> - let patternDoc = printPattern pat cmtTbl in + let patternDoc = printPattern ~customLayout pat cmtTbl in Doc.concat [ (if i == 0 then Doc.nil @@ -2283,7 +2400,8 @@ and printPattern (p : Parsetree.pattern) cmtTbl = | _ -> false in Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) - | Ppat_extension ext -> printExtension ~atModuleLvl:false ext cmtTbl + | Ppat_extension ext -> + printExtension ~customLayout ~atModuleLvl:false ext cmtTbl | Ppat_lazy p -> let needsParens = match p.ppat_desc with @@ -2291,7 +2409,7 @@ and printPattern (p : Parsetree.pattern) cmtTbl = | _ -> false in let pat = - let p = printPattern p cmtTbl in + let p = printPattern ~customLayout p cmtTbl in if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat [Doc.text "lazy "; pat] @@ -2302,7 +2420,7 @@ and printPattern (p : Parsetree.pattern) cmtTbl = | _ -> false in let renderedPattern = - let p = printPattern p cmtTbl in + let p = printPattern ~customLayout p cmtTbl in if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat @@ -2318,14 +2436,18 @@ and printPattern (p : Parsetree.pattern) cmtTbl = printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; Doc.text ": "; printComments - (printPackageType ~printModuleKeywordAndParens:false packageType - cmtTbl) + (printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl) cmtTbl ptyp_loc; Doc.rparen; ] | Ppat_constraint (pattern, typ) -> Doc.concat - [printPattern pattern cmtTbl; Doc.text ": "; printTypExpr typ cmtTbl] + [ + printPattern ~customLayout pattern cmtTbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_unpack stringLoc -> @@ -2344,11 +2466,14 @@ and printPattern (p : Parsetree.pattern) cmtTbl = | [] -> patternWithoutAttributes | attrs -> Doc.group - (Doc.concat [printAttributes attrs cmtTbl; patternWithoutAttributes]) + (Doc.concat + [ + printAttributes ~customLayout attrs cmtTbl; patternWithoutAttributes; + ]) in printComments doc cmtTbl p.ppat_loc -and printPatternRecordRow row cmtTbl = +and printPatternRecordRow ~customLayout row cmtTbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), @@ -2357,7 +2482,7 @@ and printPatternRecordRow row cmtTbl = Doc.concat [ printOptionalLabel ppat_attributes; - printAttributes ppat_attributes cmtTbl; + printAttributes ~customLayout ppat_attributes cmtTbl; printLidentPath longident cmtTbl; ] | longident, pattern -> @@ -2365,7 +2490,7 @@ and printPatternRecordRow row cmtTbl = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in let rhsDoc = - let doc = printPattern pattern cmtTbl in + let doc = printPattern ~customLayout pattern cmtTbl in let doc = if Parens.patternRecordRowRhs pattern then addParens doc else doc in @@ -2384,11 +2509,11 @@ and printPatternRecordRow row cmtTbl = in printComments doc cmtTbl locForComments -and printExpressionWithComments expr cmtTbl = - let doc = printExpression expr cmtTbl in +and printExpressionWithComments ~customLayout expr cmtTbl : Doc.t = + let doc = printExpression ~customLayout expr cmtTbl in printComments doc cmtTbl expr.Parsetree.pexp_loc -and printIfChain pexp_attributes ifs elseExpr cmtTbl = +and printIfChain ~customLayout pexp_attributes ifs elseExpr cmtTbl = let ifDocs = Doc.join ~sep:Doc.space (List.mapi @@ -2399,9 +2524,11 @@ and printIfChain pexp_attributes ifs elseExpr cmtTbl = | ParsetreeViewer.If ifExpr -> let condition = if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~braces:true ifExpr cmtTbl + printExpressionBlock ~customLayout ~braces:true ifExpr cmtTbl else - let doc = printExpressionWithComments ifExpr cmtTbl in + let doc = + printExpressionWithComments ~customLayout ifExpr cmtTbl + in match Parens.expr ifExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc ifExpr braces @@ -2418,11 +2545,15 @@ and printIfChain pexp_attributes ifs elseExpr cmtTbl = | Some _, expr -> expr | _ -> thenExpr in - printExpressionBlock ~braces:true thenExpr cmtTbl); + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl); ] | IfLet (pattern, conditionExpr) -> let conditionDoc = - let doc = printExpressionWithComments conditionExpr cmtTbl in + let doc = + printExpressionWithComments ~customLayout conditionExpr + cmtTbl + in match Parens.expr conditionExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc conditionExpr braces @@ -2432,11 +2563,12 @@ and printIfChain pexp_attributes ifs elseExpr cmtTbl = [ ifTxt; Doc.text "let "; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; Doc.text " = "; conditionDoc; Doc.space; - printExpressionBlock ~braces:true thenExpr cmtTbl; + printExpressionBlock ~customLayout ~braces:true thenExpr + cmtTbl; ] in printLeadingComments doc cmtTbl.leading outerLoc) @@ -2447,18 +2579,21 @@ and printIfChain pexp_attributes ifs elseExpr cmtTbl = | None -> Doc.nil | Some expr -> Doc.concat - [Doc.text " else "; printExpressionBlock ~braces:true expr cmtTbl] + [ + Doc.text " else "; + printExpressionBlock ~customLayout ~braces:true expr cmtTbl; + ] in let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes attrs cmtTbl; ifDocs; elseDoc] + Doc.concat [printAttributes ~customLayout attrs cmtTbl; ifDocs; elseDoc] -and printExpression (e : Parsetree.expression) cmtTbl = +and printExpression ~customLayout (e : Parsetree.expression) cmtTbl = let printedExpression = match e.pexp_desc with | Parsetree.Pexp_constant c -> printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment e cmtTbl + printJsxFragment ~customLayout e cmtTbl | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> Doc.concat @@ -2473,7 +2608,9 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.text ","; Doc.line; Doc.dotdotdot; - (let doc = printExpressionWithComments expr cmtTbl in + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2493,7 +2630,10 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2518,7 +2658,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments arg cmtTbl in + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2537,7 +2677,10 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2550,7 +2693,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = ] | Some arg -> let argDoc = - let doc = printExpressionWithComments arg cmtTbl in + let doc = printExpressionWithComments ~customLayout arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2586,7 +2729,10 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2613,7 +2759,10 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2637,7 +2786,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments arg cmtTbl in + (let doc = printExpressionWithComments ~customLayout arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2656,7 +2805,10 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = + printExpressionWithComments ~customLayout expr + cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2669,7 +2821,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = ] | Some arg -> let argDoc = - let doc = printExpressionWithComments arg cmtTbl in + let doc = printExpressionWithComments ~customLayout arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -2699,7 +2851,9 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.dotdotdot; - (let doc = printExpressionWithComments expr cmtTbl in + (let doc = + printExpressionWithComments ~customLayout expr cmtTbl + in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2735,7 +2889,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun row -> - printExpressionRecordRow row cmtTbl punningAllowed) + printExpressionRecordRow ~customLayout row cmtTbl + punningAllowed) rows); ]); Doc.trailingComma; @@ -2769,24 +2924,29 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.softLine; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun row -> printBsObjectRow row cmtTbl) rows); + (List.map + (fun row -> + printBsObjectRow ~customLayout row cmtTbl) + rows); ]); Doc.trailingComma; Doc.softLine; Doc.rbrace; ]) - | extension -> printExtension ~atModuleLvl:false extension cmtTbl) + | extension -> + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl) | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then printUnaryExpression e cmtTbl + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression ~customLayout e cmtTbl else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral e cmtTbl + printTemplateLiteral ~customLayout e cmtTbl else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression e cmtTbl - else printPexpApply e cmtTbl + printBinaryExpression ~customLayout e cmtTbl + else printPexpApply ~customLayout e cmtTbl | Pexp_unreachable -> Doc.dot | Pexp_field (expr, longidentLoc) -> let lhs = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.fieldExpr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2794,8 +2954,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = in Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc - cmtTbl + printSetFieldExpr ~customLayout e.pexp_attributes expr1 longidentLoc expr2 + e.pexp_loc cmtTbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> let parts, alternate = ParsetreeViewer.collectTernaryParts e in @@ -2805,7 +2965,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.group (Doc.concat [ - printTernaryOperand condition1 cmtTbl; + printTernaryOperand ~customLayout condition1 cmtTbl; Doc.indent (Doc.concat [ @@ -2814,7 +2974,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = (Doc.concat [ Doc.text "? "; - printTernaryOperand consequent1 cmtTbl; + printTernaryOperand ~customLayout consequent1 + cmtTbl; ]); Doc.concat (List.map @@ -2823,15 +2984,18 @@ and printExpression (e : Parsetree.expression) cmtTbl = [ Doc.line; Doc.text ": "; - printTernaryOperand condition cmtTbl; + printTernaryOperand ~customLayout condition + cmtTbl; Doc.line; Doc.text "? "; - printTernaryOperand consequent cmtTbl; + printTernaryOperand ~customLayout consequent + cmtTbl; ]) rest); Doc.line; Doc.text ": "; - Doc.indent (printTernaryOperand alternate cmtTbl); + Doc.indent + (printTernaryOperand ~customLayout alternate cmtTbl); ]); ]) | _ -> Doc.nil @@ -2844,15 +3008,15 @@ and printExpression (e : Parsetree.expression) cmtTbl = in Doc.concat [ - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; (if needsParens then addParens ternaryDoc else ternaryDoc); ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain e.pexp_attributes ifs elseExpr cmtTbl + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_while (expr1, expr2) -> let condition = - let doc = printExpressionWithComments expr1 cmtTbl in + let doc = printExpressionWithComments ~customLayout expr1 cmtTbl in match Parens.expr expr1 with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr1 braces @@ -2865,28 +3029,32 @@ and printExpression (e : Parsetree.expression) cmtTbl = (if ParsetreeViewer.isBlockExpr expr1 then condition else Doc.group (Doc.ifBreaks (addParens condition) condition)); Doc.space; - printExpressionBlock ~braces:true expr2 cmtTbl; + printExpressionBlock ~customLayout ~braces:true expr2 cmtTbl; ]) | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> Doc.breakableGroup ~forceBreak:true (Doc.concat [ Doc.text "for "; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; Doc.text " in "; - (let doc = printExpressionWithComments fromExpr cmtTbl in + (let doc = + printExpressionWithComments ~customLayout fromExpr cmtTbl + in match Parens.expr fromExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc fromExpr braces | Nothing -> doc); printDirectionFlag directionFlag; - (let doc = printExpressionWithComments toExpr cmtTbl in + (let doc = + printExpressionWithComments ~customLayout toExpr cmtTbl + in match Parens.expr toExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc toExpr braces | Nothing -> doc); Doc.space; - printExpressionBlock ~braces:true body cmtTbl; + printExpressionBlock ~customLayout ~braces:true body cmtTbl; ]) | Pexp_constraint ( {pexp_desc = Pexp_pack modExpr}, @@ -2899,11 +3067,11 @@ and printExpression (e : Parsetree.expression) cmtTbl = (Doc.concat [ Doc.softLine; - printModExpr modExpr cmtTbl; + printModExpr ~customLayout modExpr cmtTbl; Doc.text ": "; printComments - (printPackageType ~printModuleKeywordAndParens:false - packageType cmtTbl) + (printPackageType ~customLayout + ~printModuleKeywordAndParens:false packageType cmtTbl) cmtTbl ptyp_loc; ]); Doc.softLine; @@ -2911,20 +3079,20 @@ and printExpression (e : Parsetree.expression) cmtTbl = ]) | Pexp_constraint (expr, typ) -> let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr typ cmtTbl] + Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_assert expr -> let rhs = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.lazyOrAssertExprRhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2933,7 +3101,7 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.concat [Doc.text "assert "; rhs] | Pexp_lazy expr -> let rhs = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.lazyOrAssertExprRhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -2941,25 +3109,28 @@ and printExpression (e : Parsetree.expression) cmtTbl = in Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~braces:true e cmtTbl + printExpressionBlock ~customLayout ~braces:true e cmtTbl | Pexp_pack modExpr -> Doc.group (Doc.concat [ Doc.text "module("; - Doc.indent (Doc.concat [Doc.softLine; printModExpr modExpr cmtTbl]); + Doc.indent + (Doc.concat + [Doc.softLine; printModExpr ~customLayout modExpr cmtTbl]); Doc.softLine; Doc.rparen; ]) - | Pexp_sequence _ -> printExpressionBlock ~braces:true e cmtTbl - | Pexp_let _ -> printExpressionBlock ~braces:true e cmtTbl + | 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 + printExpressionWithComments ~customLayout (ParsetreeViewer.rewriteUnderscoreApply e) cmtTbl | Pexp_fun _ | Pexp_newtype _ -> @@ -2984,8 +3155,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = | None -> false in let parametersDoc = - printExprFunParameters ~inCallback:NoCallback ~uncurried ~hasConstraint - parameters cmtTbl + printExprFunParameters ~customLayout ~inCallback:NoCallback ~uncurried + ~hasConstraint parameters cmtTbl in let returnExprDoc = let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in @@ -3007,7 +3178,9 @@ and printExpression (e : Parsetree.expression) cmtTbl = | _ -> true in let returnDoc = - let doc = printExpressionWithComments returnExpr cmtTbl in + let doc = + printExpressionWithComments ~customLayout returnExpr cmtTbl + in match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc returnExpr braces @@ -3023,13 +3196,13 @@ and printExpression (e : Parsetree.expression) cmtTbl = match typConstraint with | Some typ -> let typDoc = - let doc = printTypExpr typ cmtTbl in + 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 attrs cmtTbl in + let attrs = printAttributes ~customLayout attrs cmtTbl in Doc.group (Doc.concat [ @@ -3041,42 +3214,54 @@ and printExpression (e : Parsetree.expression) cmtTbl = ]) | Pexp_try (expr, cases) -> let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in Doc.concat - [Doc.text "try "; exprDoc; Doc.text " catch "; printCases cases cmtTbl] + [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases ~customLayout cases cmtTbl; + ] | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain e.pexp_attributes ifs elseExpr cmtTbl + printIfChain ~customLayout e.pexp_attributes ifs elseExpr cmtTbl | Pexp_match (expr, cases) -> let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc in Doc.concat - [Doc.text "switch "; exprDoc; Doc.space; printCases cases cmtTbl] + [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases ~customLayout cases cmtTbl; + ] | Pexp_function cases -> - Doc.concat [Doc.text "x => switch x "; printCases cases cmtTbl] + Doc.concat + [Doc.text "x => switch x "; printCases ~customLayout cases cmtTbl] | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments expr cmtTbl in - let docTyp = printTypExpr typ cmtTbl in + let docExpr = printExpressionWithComments ~customLayout expr cmtTbl in + let docTyp = printTypExpr ~customLayout typ cmtTbl in let ofType = match typOpt with | None -> Doc.nil - | Some typ1 -> Doc.concat [Doc.text ": "; printTypExpr typ1 cmtTbl] + | Some typ1 -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ1 cmtTbl] in Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] | Pexp_send (parentExpr, label) -> let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3106,10 +3291,12 @@ and printExpression (e : Parsetree.expression) cmtTbl = match e.pexp_attributes with | [] -> printedExpression | attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes attrs cmtTbl; printedExpression]) + Doc.group + (Doc.concat + [printAttributes ~customLayout attrs cmtTbl; printedExpression]) | _ -> printedExpression -and printPexpFun ~inCallback e cmtTbl = +and printPexpFun ~customLayout ~inCallback e cmtTbl = let attrsOnArrow, parameters, returnExpr = ParsetreeViewer.funExpr e in let uncurried, attrs = ParsetreeViewer.processUncurriedAttribute attrsOnArrow @@ -3126,7 +3313,7 @@ and printPexpFun ~inCallback e cmtTbl = | _ -> (returnExpr, None) in let parametersDoc = - printExprFunParameters ~inCallback ~uncurried + printExprFunParameters ~customLayout ~inCallback ~uncurried ~hasConstraint: (match typConstraint with | Some _ -> true @@ -3153,7 +3340,7 @@ and printPexpFun ~inCallback e cmtTbl = | _ -> false in let returnDoc = - let doc = printExpressionWithComments returnExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout returnExpr cmtTbl in match Parens.expr returnExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc returnExpr braces @@ -3174,35 +3361,36 @@ and printPexpFun ~inCallback e cmtTbl = in let typConstraintDoc = match typConstraint with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl] + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | _ -> Doc.nil in Doc.concat [ - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; parametersDoc; typConstraintDoc; Doc.text " =>"; returnExprDoc; ] -and printTernaryOperand expr cmtTbl = - let doc = printExpressionWithComments expr cmtTbl in +and printTernaryOperand ~customLayout expr cmtTbl = + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.ternaryOperand expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc -and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl = +and printSetFieldExpr ~customLayout attrs lhs longidentLoc rhs loc cmtTbl = let rhsDoc = - let doc = printExpressionWithComments rhs cmtTbl in + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in match Parens.setFieldExprRhs rhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc rhs braces | Nothing -> doc in let lhsDoc = - let doc = printExpressionWithComments lhs cmtTbl in + let doc = printExpressionWithComments ~customLayout lhs cmtTbl in match Parens.fieldExpr lhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc lhs braces @@ -3225,11 +3413,12 @@ and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl = let doc = match attrs with | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes attrs cmtTbl; doc]) + | attrs -> + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) in printComments doc cmtTbl loc -and printTemplateLiteral expr cmtTbl = +and printTemplateLiteral ~customLayout expr cmtTbl = let tag = ref "js" in let rec walkExpr expr = let open Parsetree in @@ -3244,7 +3433,7 @@ and printTemplateLiteral expr cmtTbl = tag := prefix; printStringContents txt | _ -> - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in let content = walkExpr expr in @@ -3256,7 +3445,7 @@ and printTemplateLiteral expr cmtTbl = Doc.text "`"; ] -and printUnaryExpression expr cmtTbl = +and printUnaryExpression ~customLayout expr cmtTbl = let printUnaryOperator op = Doc.text (match op with @@ -3272,7 +3461,7 @@ and printUnaryExpression expr cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, operand)] ) -> let printedOperand = - let doc = printExpressionWithComments operand cmtTbl in + let doc = printExpressionWithComments ~customLayout operand cmtTbl in match Parens.unaryExprOperand operand with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc operand braces @@ -3282,7 +3471,7 @@ and printUnaryExpression expr cmtTbl = printComments doc cmtTbl expr.pexp_loc | _ -> assert false -and printBinaryExpression (expr : Parsetree.expression) cmtTbl = +and printBinaryExpression ~customLayout (expr : Parsetree.expression) cmtTbl = let printBinaryOperator ~inlineRhs operator = let operatorTxt = match operator with @@ -3329,7 +3518,7 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = right.pexp_attributes in let doc = - printExpressionWithComments + printExpressionWithComments ~customLayout {right with pexp_attributes = rightAttrs} cmtTbl in @@ -3342,7 +3531,8 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = ParsetreeViewer.filterPrintableAttributes right.pexp_attributes in let doc = - Doc.concat [printAttributes printableAttrs cmtTbl; doc] + Doc.concat + [printAttributes ~customLayout printableAttrs cmtTbl; doc] in match printableAttrs with | [] -> doc @@ -3364,7 +3554,7 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = printComments doc cmtTbl expr.pexp_loc else let doc = - printExpressionWithComments + printExpressionWithComments ~customLayout {expr with pexp_attributes = []} cmtTbl in @@ -3377,7 +3567,8 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat [printAttributes expr.pexp_attributes cmtTbl; doc] + Doc.concat + [printAttributes ~customLayout expr.pexp_attributes cmtTbl; doc] | _ -> assert false else match expr.pexp_desc with @@ -3385,19 +3576,19 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral expr cmtTbl in + let doc = printTemplateLiteral ~customLayout expr cmtTbl in printComments doc cmtTbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> let doc = - printSetFieldExpr expr.pexp_attributes lhs field rhs expr.pexp_loc - cmtTbl + printSetFieldExpr ~customLayout expr.pexp_attributes lhs field rhs + expr.pexp_loc cmtTbl in if isLhs then addParens doc else doc | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments rhs cmtTbl in - let lhsDoc = printExpressionWithComments lhs cmtTbl in + let rhsDoc = printExpressionWithComments ~customLayout rhs cmtTbl in + let lhsDoc = printExpressionWithComments ~customLayout lhs cmtTbl in (* TODO: unify indentation of "=" *) let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in let doc = @@ -3415,11 +3606,12 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = match expr.pexp_attributes with | [] -> doc | attrs -> - Doc.group (Doc.concat [printAttributes attrs cmtTbl; doc]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc]) in if isLhs then addParens doc else doc | _ -> ( - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.binaryExprOperand ~isLhs expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -3473,7 +3665,7 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes cmtTbl; + printAttributes ~customLayout expr.pexp_attributes cmtTbl; (match Parens.binaryExpr { @@ -3494,13 +3686,13 @@ and printBinaryExpression (expr : Parsetree.expression) cmtTbl = | _ -> Doc.nil (* callExpr(arg1, arg2) *) -and printPexpApply expr cmtTbl = +and printPexpApply ~customLayout expr cmtTbl = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3511,14 +3703,14 @@ and printPexpApply expr cmtTbl = match memberExpr.pexp_desc with | Pexp_ident lident -> printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments memberExpr cmtTbl + | _ -> printExpressionWithComments ~customLayout memberExpr cmtTbl in Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] in Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes cmtTbl; + printAttributes ~customLayout expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3528,7 +3720,7 @@ and printPexpApply expr cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( let rhsDoc = - let doc = printExpressionWithComments rhs cmtTbl in + let doc = printExpressionWithComments ~customLayout rhs cmtTbl in match Parens.expr rhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc rhs braces @@ -3543,7 +3735,7 @@ and printPexpApply expr cmtTbl = Doc.group (Doc.concat [ - printExpressionWithComments lhs cmtTbl; + printExpressionWithComments ~customLayout lhs cmtTbl; Doc.text " ="; (if shouldIndent then Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) @@ -3552,7 +3744,8 @@ and printPexpApply expr cmtTbl = in match expr.pexp_attributes with | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes attrs cmtTbl; doc])) + | attrs -> + Doc.group (Doc.concat [printAttributes ~customLayout attrs cmtTbl; doc])) | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) @@ -3560,7 +3753,7 @@ and printPexpApply 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 memberExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc memberExpr braces @@ -3577,7 +3770,7 @@ and printPexpApply expr cmtTbl = [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] in let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3586,7 +3779,7 @@ and printPexpApply expr cmtTbl = Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes cmtTbl; + printAttributes ~customLayout expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3598,7 +3791,7 @@ and printPexpApply expr cmtTbl = -> let member = let memberDoc = - let doc = printExpressionWithComments memberExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout memberExpr cmtTbl in match Parens.expr memberExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc memberExpr braces @@ -3632,14 +3825,14 @@ and printPexpApply expr cmtTbl = || ParsetreeViewer.isArrayAccess e in let targetExpr = - let doc = printExpressionWithComments targetExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout targetExpr cmtTbl in match Parens.expr targetExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc targetExpr braces | Nothing -> doc in let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout parentExpr cmtTbl in match Parens.unaryExprOperand parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces @@ -3648,7 +3841,7 @@ and printPexpApply expr cmtTbl = Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes cmtTbl; + printAttributes ~customLayout expr.pexp_attributes cmtTbl; parentDoc; Doc.lbracket; member; @@ -3661,7 +3854,7 @@ and printPexpApply expr cmtTbl = (* TODO: cleanup, are those branches even remotely performant? *) | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression lident args cmtTbl + printJsxExpression ~customLayout lident args cmtTbl | Pexp_apply (callExpr, args) -> let args = List.map @@ -3672,7 +3865,7 @@ and printPexpApply expr cmtTbl = ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes in let callExprDoc = - let doc = printExpressionWithComments callExpr cmtTbl in + let doc = printExpressionWithComments ~customLayout callExpr cmtTbl in match Parens.callExpr callExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc callExpr braces @@ -3680,12 +3873,15 @@ and printPexpApply expr cmtTbl = in if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl + printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args + cmtTbl in - Doc.concat [printAttributes attrs cmtTbl; callExprDoc; argsDoc] + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then let argsDoc = - printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl + printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl in (* * Fixes the following layout (the `[` and `]` should break): @@ -3705,15 +3901,21 @@ and printPexpApply expr cmtTbl = if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil in Doc.concat - [maybeBreakParent; printAttributes attrs cmtTbl; callExprDoc; argsDoc] + [ + maybeBreakParent; + printAttributes ~customLayout attrs cmtTbl; + callExprDoc; + argsDoc; + ] else - let argsDoc = printArguments ~uncurried args cmtTbl in - Doc.concat [printAttributes attrs cmtTbl; callExprDoc; argsDoc] + let argsDoc = printArguments ~customLayout ~uncurried args cmtTbl in + Doc.concat + [printAttributes ~customLayout attrs cmtTbl; callExprDoc; argsDoc] | _ -> assert false -and printJsxExpression lident args cmtTbl = +and printJsxExpression ~customLayout lident args cmtTbl = let name = printJsxName lident in - let formattedProps, children = printJsxProps args cmtTbl in + let formattedProps, children = printJsxProps ~customLayout args cmtTbl in (*
*) let isSelfClosing = match children with @@ -3765,7 +3967,8 @@ and printJsxExpression lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren childrenExpression ~sep:lineSep cmtTbl + printJsxChildren ~customLayout childrenExpression + ~sep:lineSep cmtTbl | None -> Doc.nil); ]); lineSep; @@ -3775,7 +3978,7 @@ and printJsxExpression lident args cmtTbl = ]); ]) -and printJsxFragment expr cmtTbl = +and printJsxFragment ~customLayout expr cmtTbl = let opening = Doc.text "<>" in let closing = Doc.text "" in let lineSep = @@ -3789,12 +3992,17 @@ and printJsxFragment expr cmtTbl = | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil | _ -> Doc.indent - (Doc.concat [Doc.line; printJsxChildren expr ~sep:lineSep cmtTbl])); + (Doc.concat + [ + Doc.line; + printJsxChildren ~customLayout expr ~sep:lineSep cmtTbl; + ])); lineSep; closing; ]) -and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = +and printJsxChildren ~customLayout (childrenExpr : Parsetree.expression) ~sep + cmtTbl = match childrenExpr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, _) -> let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in @@ -3805,7 +4013,9 @@ and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in - let exprDoc = printExpressionWithComments expr cmtTbl in + let exprDoc = + printExpressionWithComments ~customLayout expr cmtTbl + in let addParensOrBraces exprDoc = (* {(20: int)} make sure that we also protect the expression inside *) let innerDoc = @@ -3824,7 +4034,9 @@ and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = let leadingLineCommentPresent = hasLeadingLineComment cmtTbl childrenExpr.pexp_loc in - let exprDoc = printExpressionWithComments childrenExpr cmtTbl in + let exprDoc = + printExpressionWithComments ~customLayout childrenExpr cmtTbl + in Doc.concat [ Doc.dotdotdot; @@ -3839,7 +4051,8 @@ and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = | Nothing -> exprDoc); ] -and printJsxProps args cmtTbl : Doc.t * Parsetree.expression option = +and printJsxProps ~customLayout args cmtTbl : + Doc.t * Parsetree.expression option = let rec loop props args = match args with | [] -> (Doc.nil, None) @@ -3861,12 +4074,12 @@ and printJsxProps args cmtTbl : Doc.t * Parsetree.expression option = in (formattedProps, Some children) | arg :: args -> - let propDoc = printJsxProp arg cmtTbl in + let propDoc = printJsxProp ~customLayout arg cmtTbl in loop (propDoc :: props) args in loop [] args -and printJsxProp arg cmtTbl = +and printJsxProp ~customLayout arg cmtTbl = match arg with | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), { @@ -3912,7 +4125,7 @@ and printJsxProp arg cmtTbl = let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.jsxPropExpr expr with | Parenthesized | Braced _ -> (* {(20: int)} make sure that we also protect the expression inside *) @@ -3942,10 +4155,12 @@ and printJsxName {txt = lident} = let segments = flatten [] lident in Doc.join ~sep:Doc.dot (List.map Doc.text segments) -and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = +and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout 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 cmtTblCopy = CommentTable.copy cmtTbl in let callback, printedArgs = match args with @@ -3959,13 +4174,18 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] in let callback = - Doc.concat [lblDoc; printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl] + Doc.concat + [ + lblDoc; + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl; + ] in - let callback = printComments callback cmtTbl expr.pexp_loc in + let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in let printedArgs = - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument arg cmtTbl) args) + lazy + (Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun arg -> printArgument ~customLayout arg cmtTbl) args)) in (callback, printedArgs) | _ -> assert false @@ -3977,15 +4197,16 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = * }, longArgumet, veryLooooongArgument) *) let fitsOnOneLine = - Doc.concat - [ - (if uncurried then Doc.text "(. " else Doc.lparen); - callback; - Doc.comma; - Doc.line; - printedArgs; - Doc.rparen; - ] + lazy + (Doc.concat + [ + (if uncurried then Doc.text "(. " else Doc.lparen); + Lazy.force callback; + Doc.comma; + Doc.line; + Lazy.force printedArgs; + Doc.rparen; + ]) in (* Thing.map( @@ -3995,7 +4216,9 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = * arg3, * ) *) - let breakAllArgs = printArguments ~uncurried args cmtTblCopy in + let breakAllArgs = + lazy (printArguments ~customLayout ~uncurried args cmtTblCopy) + in (* Sometimes one of the non-callback arguments will break. * There might be a single line comment in there, or a multiline string etc. @@ -4012,18 +4235,21 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if Doc.willBreak printedArgs then breakAllArgs - else Doc.customLayout [fitsOnOneLine; breakAllArgs] + if customLayout > customLayoutThreshold 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 ~uncurried args cmtTbl = +and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args + cmtTbl = (* Because the same subtree gets printed twice, we need to copy the cmtTbl. * consumed comments need to be marked not-consumed and reprinted… * Cheng's different comment algorithm will solve this. *) + let customLayout = customLayout + 1 in let cmtTblCopy = CommentTable.copy cmtTbl in let cmtTblCopy2 = CommentTable.copy cmtTbl in let rec loop acc args = match args with - | [] -> (Doc.nil, Doc.nil, Doc.nil) + | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) | [(lbl, expr)] -> let lblDoc = match lbl with @@ -4034,35 +4260,41 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] in let callbackFitsOnOneLine = - let pexpFunDoc = printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:FitsOnOneLine expr cmtTbl + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc) in let callbackArgumentsFitsOnOneLine = - let pexpFunDoc = - printPexpFun ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc + lazy + (let pexpFunDoc = + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy + in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc) in - ( Doc.concat (List.rev acc), + ( lazy (Doc.concat (List.rev acc)), callbackFitsOnOneLine, callbackArgumentsFitsOnOneLine ) | arg :: args -> - let argDoc = printArgument arg cmtTbl in + let argDoc = printArgument ~customLayout arg cmtTbl in loop (Doc.line :: Doc.comma :: argDoc :: acc) args in let printedArgs, callback, callback2 = loop [] args in (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) let fitsOnOneLine = - Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - printedArgs; - callback; - Doc.rparen; - ] + lazy + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Lazy.force printedArgs; + Lazy.force callback; + Doc.rparen; + ]) in (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => @@ -4070,13 +4302,14 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = * ) *) let arugmentsFitOnOneLine = - Doc.concat - [ - (if uncurried then Doc.text "(." else Doc.lparen); - printedArgs; - Doc.breakableGroup ~forceBreak:true callback2; - Doc.rparen; - ] + lazy + (Doc.concat + [ + (if uncurried then Doc.text "(." else Doc.lparen); + Lazy.force printedArgs; + Doc.breakableGroup ~forceBreak:true (Lazy.force callback2); + Doc.rparen; + ]) in (* Thing.map( @@ -4086,7 +4319,9 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = * (param1, parm2) => doStuff(param1, parm2) * ) *) - let breakAllArgs = printArguments ~uncurried args cmtTblCopy2 in + let breakAllArgs = + lazy (printArguments ~customLayout ~uncurried args cmtTblCopy2) + in (* Sometimes one of the non-callback arguments will break. * There might be a single line comment in there, or a multiline string etc. @@ -4103,10 +4338,17 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if Doc.willBreak printedArgs then breakAllArgs - else Doc.customLayout [fitsOnOneLine; arugmentsFitOnOneLine; breakAllArgs] + if customLayout > customLayoutThreshold then Lazy.force breakAllArgs + else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs + else + Doc.customLayout + [ + Lazy.force fitsOnOneLine; + Lazy.force arugmentsFitOnOneLine; + Lazy.force breakAllArgs; + ] -and printArguments ~uncurried +and printArguments ~customLayout ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = match args with | [ @@ -4125,7 +4367,7 @@ and printArguments ~uncurried | _ -> Doc.text "()") | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> let argDoc = - let doc = printExpressionWithComments arg cmtTbl in + let doc = printExpressionWithComments ~customLayout arg cmtTbl in match Parens.expr arg with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc arg braces @@ -4144,7 +4386,9 @@ and printArguments ~uncurried (if uncurried then Doc.line else Doc.softLine); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument arg cmtTbl) args); + (List.map + (fun arg -> printArgument ~customLayout arg cmtTbl) + args); ]); Doc.trailingComma; Doc.softLine; @@ -4165,7 +4409,7 @@ and printArguments ~uncurried * | ~ label-name = ? expr * | ~ label-name = ? _ (* syntax sugar *) * | ~ label-name = ? expr : type *) -and printArgument (argLbl, arg) cmtTbl = +and printArgument ~customLayout (argLbl, arg) cmtTbl = match (argLbl, arg) with (* ~a (punned)*) | ( Asttypes.Labelled lbl, @@ -4201,7 +4445,12 @@ and printArgument (argLbl, arg) cmtTbl = in let doc = Doc.concat - [Doc.tilde; printIdentLike lbl; Doc.text ": "; printTypExpr typ cmtTbl] + [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr ~customLayout typ cmtTbl; + ] in printComments doc cmtTbl loc (* ~a? (optional lbl punned)*) @@ -4238,7 +4487,7 @@ and printArgument (argLbl, arg) cmtTbl = printComments doc cmtTbl argLoc in let printedExpr = - let doc = printExpressionWithComments expr cmtTbl in + let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4248,7 +4497,7 @@ and printArgument (argLbl, arg) cmtTbl = let doc = Doc.concat [printedLbl; printedExpr] in printComments doc cmtTbl loc -and printCases (cases : Parsetree.case list) cmtTbl = +and printCases ~customLayout (cases : Parsetree.case list) cmtTbl = Doc.breakableGroup ~forceBreak:true (Doc.concat [ @@ -4262,22 +4511,22 @@ and printCases (cases : Parsetree.case list) cmtTbl = n.Parsetree.pc_lhs.ppat_loc with loc_end = n.pc_rhs.pexp_loc.loc_end; }) - ~print:printCase ~nodes:cases cmtTbl; + ~print:(printCase ~customLayout) ~nodes:cases cmtTbl; ]; Doc.line; Doc.rbrace; ]) -and printCase (case : Parsetree.case) cmtTbl = +and printCase ~customLayout (case : Parsetree.case) cmtTbl = let rhs = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock + printExpressionBlock ~customLayout ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl | _ -> ( - let doc = printExpressionWithComments case.pc_rhs cmtTbl in + let doc = printExpressionWithComments ~customLayout case.pc_rhs cmtTbl in match Parens.expr case.pc_rhs with | Parenthesized -> addParens doc | _ -> doc) @@ -4289,7 +4538,11 @@ and printCase (case : Parsetree.case) cmtTbl = | Some expr -> Doc.group (Doc.concat - [Doc.line; Doc.text "if "; printExpressionWithComments expr cmtTbl]) + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ]) in let shouldInlineRhs = match case.pc_rhs.pexp_desc with @@ -4305,7 +4558,7 @@ and printCase (case : Parsetree.case) cmtTbl = | _ -> true in let patternDoc = - let doc = printPattern case.pc_lhs cmtTbl in + let doc = printPattern ~customLayout case.pc_lhs cmtTbl in match case.pc_lhs.ppat_desc with | Ppat_constraint _ -> addParens doc | _ -> doc @@ -4322,8 +4575,8 @@ and printCase (case : Parsetree.case) cmtTbl = in Doc.group (Doc.concat [Doc.text "| "; content]) -and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters - cmtTbl = +and printExprFunParameters ~customLayout ~inCallback ~uncurried ~hasConstraint + parameters cmtTbl = match parameters with (* let f = _ => () *) | [ @@ -4380,7 +4633,9 @@ and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters (if shouldHug || inCallback then Doc.nil else Doc.softLine); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun p -> printExpFunParameter p cmtTbl) parameters); + (List.map + (fun p -> printExpFunParameter ~customLayout p cmtTbl) + parameters); ] in Doc.group @@ -4394,13 +4649,13 @@ and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters Doc.rparen; ]) -and printExpFunParameter parameter cmtTbl = +and printExpFunParameter ~customLayout parameter cmtTbl = match parameter with | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> Doc.group (Doc.concat [ - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; Doc.text "type "; Doc.join ~sep:Doc.space (List.map @@ -4415,19 +4670,20 @@ and printExpFunParameter parameter cmtTbl = let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes attrs cmtTbl in + let attrs = printAttributes ~customLayout attrs cmtTbl in (* =defaultValue *) let defaultExprDoc = match defaultExpr with | Some expr -> - Doc.concat [Doc.text "="; printExpressionWithComments expr cmtTbl] + Doc.concat + [Doc.text "="; printExpressionWithComments ~customLayout expr cmtTbl] | None -> Doc.nil in (* ~from as hometown * ~from -> punning *) let labelWithPattern = match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern pattern cmtTbl + | Asttypes.Nolabel, pattern -> printPattern ~customLayout pattern cmtTbl | ( (Asttypes.Labelled lbl | Optional lbl), { ppat_desc = Ppat_var stringLoc; @@ -4448,7 +4704,7 @@ and printExpFunParameter parameter cmtTbl = Doc.text "~"; printIdentLike lbl; Doc.text ": "; - printTypExpr typ cmtTbl; + printTypExpr ~customLayout typ cmtTbl; ] | (Asttypes.Labelled lbl | Optional lbl), pattern -> (* ~b as c *) @@ -4457,7 +4713,7 @@ and printExpFunParameter parameter cmtTbl = Doc.text "~"; printIdentLike lbl; Doc.text " as "; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; ] in let optionalLabelSuffix = @@ -4497,7 +4753,7 @@ and printExpFunParameter parameter cmtTbl = in printComments doc cmtTbl cmtLoc -and printExpressionBlock ~braces expr cmtTbl = +and printExpressionBlock ~customLayout ~braces expr cmtTbl = let rec collectRows acc expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> @@ -4508,7 +4764,10 @@ and printExpressionBlock ~braces expr cmtTbl = let letModuleDoc = Doc.concat [ - Doc.text "module "; name; Doc.text " = "; printModExpr modExpr cmtTbl; + Doc.text "module "; + name; + Doc.text " = "; + printModExpr ~customLayout modExpr cmtTbl; ] in let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in @@ -4524,7 +4783,9 @@ and printExpressionBlock ~braces expr cmtTbl = let cmtLoc = Comment.loc comment in {cmtLoc with loc_end = loc.loc_end} in - let letExceptionDoc = printExceptionDef extensionConstructor cmtTbl in + let letExceptionDoc = + printExceptionDef ~customLayout extensionConstructor cmtTbl + in collectRows ((loc, letExceptionDoc) :: acc) expr2 | Pexp_open (overrideFlag, longidentLoc, expr2) -> let openDoc = @@ -4540,7 +4801,7 @@ and printExpressionBlock ~braces expr cmtTbl = collectRows ((loc, openDoc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> let exprDoc = - let doc = printExpression expr1 cmtTbl in + let doc = printExpression ~customLayout expr1 cmtTbl in match Parens.expr expr1 with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr1 braces @@ -4567,7 +4828,9 @@ and printExpressionBlock ~braces expr cmtTbl = | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - let letDoc = printValueBindings ~recFlag valueBindings cmtTbl in + let letDoc = + printValueBindings ~customLayout ~recFlag valueBindings cmtTbl + in (* let () = { * let () = foo() * () @@ -4580,7 +4843,7 @@ and printExpressionBlock ~braces expr cmtTbl = | _ -> collectRows ((loc, letDoc) :: acc) expr2) | _ -> let exprDoc = - let doc = printExpression expr cmtTbl in + let doc = printExpression ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4657,7 +4920,7 @@ and printDirectionFlag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = +and printExpressionRecordRow ~customLayout (lbl, expr) cmtTbl punningAllowed = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group @@ -4667,7 +4930,7 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = (* print punned field *) Doc.concat [ - printAttributes expr.pexp_attributes cmtTbl; + printAttributes ~customLayout expr.pexp_attributes cmtTbl; printOptionalLabel expr.pexp_attributes; printLidentPath lbl cmtTbl; ] @@ -4677,7 +4940,7 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = printLidentPath lbl cmtTbl; Doc.text ": "; printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments expr cmtTbl in + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4686,7 +4949,7 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = in printComments doc cmtTbl cmtLoc -and printBsObjectRow (lbl, expr) cmtTbl = +and printBsObjectRow ~customLayout (lbl, expr) cmtTbl = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let lblDoc = let doc = @@ -4699,7 +4962,7 @@ and printBsObjectRow (lbl, expr) cmtTbl = [ lblDoc; Doc.text ": "; - (let doc = printExpressionWithComments expr cmtTbl in + (let doc = printExpressionWithComments ~customLayout expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces @@ -4714,8 +4977,8 @@ and printBsObjectRow (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) (attrs : Parsetree.attributes) cmtTbl - = +and printAttributes ?loc ?(inline = false) ~customLayout + (attrs : Parsetree.attributes) cmtTbl = match ParsetreeViewer.filterParsingAttrs attrs with | [] -> Doc.nil | attrs -> @@ -4733,15 +4996,17 @@ and printAttributes ?loc ?(inline = false) (attrs : Parsetree.attributes) cmtTbl [ Doc.group (Doc.join ~sep:Doc.line - (List.map (fun attr -> printAttribute attr cmtTbl) attrs)); + (List.map + (fun attr -> printAttribute ~customLayout attr cmtTbl) + attrs)); (if inline then Doc.space else lineBreak); ] -and printPayload (payload : Parsetree.payload) cmtTbl = +and printPayload ~customLayout (payload : Parsetree.payload) cmtTbl = match payload with | PStr [] -> Doc.nil | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments expr cmtTbl in + let exprDoc = printExpressionWithComments ~customLayout expr cmtTbl in let needsParens = match attrs with | [] -> false @@ -4752,7 +5017,7 @@ and printPayload (payload : Parsetree.payload) cmtTbl = Doc.concat [ Doc.lparen; - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; (if needsParens then addParens exprDoc else exprDoc); Doc.rparen; ] @@ -4764,21 +5029,22 @@ and printPayload (payload : Parsetree.payload) cmtTbl = (Doc.concat [ Doc.softLine; - printAttributes attrs cmtTbl; + printAttributes ~customLayout attrs cmtTbl; (if needsParens then addParens exprDoc else exprDoc); ]); Doc.softLine; Doc.rparen; ] | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem si cmtTbl) - | PStr structure -> addParens (printStructure structure cmtTbl) + addParens (printStructureItem ~customLayout si cmtTbl) + | PStr structure -> addParens (printStructure ~customLayout structure cmtTbl) | PTyp typ -> Doc.concat [ Doc.lparen; Doc.text ":"; - Doc.indent (Doc.concat [Doc.line; printTypExpr typ cmtTbl]); + Doc.indent + (Doc.concat [Doc.line; printTypExpr ~customLayout typ cmtTbl]); Doc.softLine; Doc.rparen; ] @@ -4787,7 +5053,11 @@ and printPayload (payload : Parsetree.payload) cmtTbl = match optExpr with | Some expr -> Doc.concat - [Doc.line; Doc.text "if "; printExpressionWithComments expr cmtTbl] + [ + Doc.line; + Doc.text "if "; + printExpressionWithComments ~customLayout expr cmtTbl; + ] | None -> Doc.nil in Doc.concat @@ -4795,7 +5065,12 @@ and printPayload (payload : Parsetree.payload) cmtTbl = Doc.lparen; Doc.indent (Doc.concat - [Doc.softLine; Doc.text "? "; printPattern pat cmtTbl; whenDoc]); + [ + Doc.softLine; + Doc.text "? "; + printPattern ~customLayout pat cmtTbl; + whenDoc; + ]); Doc.softLine; Doc.rparen; ] @@ -4804,13 +5079,14 @@ and printPayload (payload : Parsetree.payload) cmtTbl = [ Doc.lparen; Doc.text ":"; - Doc.indent (Doc.concat [Doc.line; printSignature signature cmtTbl]); + Doc.indent + (Doc.concat [Doc.line; printSignature ~customLayout signature cmtTbl]); Doc.softLine; Doc.rparen; ] -and printAttribute ?(standalone = false) ((id, payload) : Parsetree.attribute) - cmtTbl = +and printAttribute ?(standalone = false) ~customLayout + ((id, payload) : Parsetree.attribute) cmtTbl = match (id, payload) with | ( {txt = "ns.doc"}, PStr @@ -4820,17 +5096,22 @@ and printAttribute ?(standalone = false) ((id, payload) : Parsetree.attribute) Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); }; ] ) -> - Doc.concat [Doc.text "/**"; Doc.text txt; Doc.text "*/"] + Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ] | _ -> Doc.group (Doc.concat [ Doc.text (if standalone then "@@" else "@"); Doc.text (convertBsExternalAttribute id.txt); - printPayload payload cmtTbl; + printPayload ~customLayout payload cmtTbl; ]) -and printModExpr modExpr cmtTbl = +and printModExpr ~customLayout modExpr cmtTbl = let doc = match modExpr.pmod_desc with | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl @@ -4854,7 +5135,8 @@ and printModExpr modExpr cmtTbl = [ Doc.lbrace; Doc.indent - (Doc.concat [Doc.softLine; printStructure structure cmtTbl]); + (Doc.concat + [Doc.softLine; printStructure ~customLayout structure cmtTbl]); Doc.softLine; Doc.rbrace; ]) @@ -4874,8 +5156,8 @@ and printModExpr modExpr cmtTbl = (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> let packageDoc = let doc = - printPackageType ~printModuleKeywordAndParens:false packageType - cmtTbl + printPackageType ~customLayout ~printModuleKeywordAndParens:false + packageType cmtTbl in printComments doc cmtTbl ptyp_loc in @@ -4890,7 +5172,10 @@ and printModExpr modExpr cmtTbl = let unpackDoc = Doc.group (Doc.concat - [printExpressionWithComments expr cmtTbl; moduleConstraint]) + [ + printExpressionWithComments ~customLayout expr cmtTbl; + moduleConstraint; + ]) in Doc.group (Doc.concat @@ -4906,7 +5191,7 @@ and printModExpr modExpr cmtTbl = Doc.rparen; ]) | Pmod_extension extension -> - printExtension ~atModuleLvl:false extension cmtTbl + printExtension ~customLayout ~atModuleLvl:false extension cmtTbl | Pmod_apply _ -> let args, callExpr = ParsetreeViewer.modExprApply modExpr in let isUnitSugar = @@ -4922,15 +5207,19 @@ and printModExpr modExpr cmtTbl = Doc.group (Doc.concat [ - printModExpr callExpr cmtTbl; + printModExpr ~customLayout callExpr cmtTbl; (if isUnitSugar then - printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl else Doc.concat [ Doc.lparen; (if shouldHug then - printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl + printModApplyArg ~customLayout + (List.hd args [@doesNotRaise]) + cmtTbl else Doc.indent (Doc.concat @@ -4939,7 +5228,8 @@ and printModExpr modExpr cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun modArg -> printModApplyArg modArg cmtTbl) + (fun modArg -> + printModApplyArg ~customLayout modArg cmtTbl) args); ])); (if not shouldHug then @@ -4951,13 +5241,15 @@ and printModExpr modExpr cmtTbl = | Pmod_constraint (modExpr, modType) -> Doc.concat [ - printModExpr modExpr cmtTbl; Doc.text ": "; printModType modType cmtTbl; + printModExpr ~customLayout modExpr cmtTbl; + Doc.text ": "; + printModType ~customLayout modType cmtTbl; ] - | Pmod_functor _ -> printModFunctor modExpr cmtTbl + | Pmod_functor _ -> printModFunctor ~customLayout modExpr cmtTbl in printComments doc cmtTbl modExpr.pmod_loc -and printModFunctor modExpr cmtTbl = +and printModFunctor ~customLayout modExpr cmtTbl = let parameters, returnModExpr = ParsetreeViewer.modExprFunctor modExpr in (* let shouldInline = match returnModExpr.pmod_desc with *) (* | Pmod_structure _ | Pmod_ident _ -> true *) @@ -4968,17 +5260,18 @@ and printModFunctor modExpr cmtTbl = match returnModExpr.pmod_desc with | Pmod_constraint (modExpr, modType) -> let constraintDoc = - let doc = printModType modType cmtTbl in + let doc = printModType ~customLayout modType cmtTbl in if Parens.modExprFunctorConstraint modType then addParens doc else doc in let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr modExpr cmtTbl) - | _ -> (Doc.nil, printModExpr returnModExpr cmtTbl) + (modConstraint, printModExpr ~customLayout modExpr cmtTbl) + | _ -> (Doc.nil, printModExpr ~customLayout returnModExpr cmtTbl) in let parametersDoc = match parameters with | [(attrs, {txt = "*"}, None)] -> - Doc.group (Doc.concat [printAttributes attrs cmtTbl; Doc.text "()"]) + Doc.group + (Doc.concat [printAttributes ~customLayout attrs cmtTbl; Doc.text "()"]) | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> Doc.group @@ -4992,7 +5285,8 @@ and printModFunctor modExpr cmtTbl = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun param -> printModFunctorParam param cmtTbl) + (fun param -> + printModFunctorParam ~customLayout param cmtTbl) parameters); ]); Doc.trailingComma; @@ -5004,14 +5298,14 @@ and printModFunctor modExpr cmtTbl = (Doc.concat [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) -and printModFunctorParam (attrs, lbl, optModType) cmtTbl = +and printModFunctorParam ~customLayout (attrs, lbl, optModType) cmtTbl = let cmtLoc = match optModType with | None -> lbl.Asttypes.loc | Some modType -> {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} in - let attrs = printAttributes attrs cmtTbl in + let attrs = printAttributes ~customLayout attrs cmtTbl in let lblDoc = let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in printComments doc cmtTbl lbl.loc @@ -5025,17 +5319,19 @@ and printModFunctorParam (attrs, lbl, optModType) cmtTbl = (match optModType with | None -> Doc.nil | Some modType -> - Doc.concat [Doc.text ": "; printModType modType cmtTbl]); + Doc.concat + [Doc.text ": "; printModType ~customLayout modType cmtTbl]); ]) in printComments doc cmtTbl cmtLoc -and printModApplyArg modExpr cmtTbl = +and printModApplyArg ~customLayout modExpr cmtTbl = match modExpr.pmod_desc with | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr modExpr cmtTbl + | _ -> printModExpr ~customLayout modExpr cmtTbl -and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = +and printExceptionDef ~customLayout (constr : Parsetree.extension_constructor) + cmtTbl = let kind = match constr.pext_kind with | Pext_rebind longident -> @@ -5046,10 +5342,15 @@ and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = | Pext_decl (args, gadt) -> let gadtDoc = match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl] + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | None -> Doc.nil in - Doc.concat [printConstructorArguments ~indent:false args cmtTbl; gadtDoc] + Doc.concat + [ + printConstructorArguments ~customLayout ~indent:false args cmtTbl; + gadtDoc; + ] in let name = printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc @@ -5058,7 +5359,7 @@ and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = Doc.group (Doc.concat [ - printAttributes constr.pext_attributes cmtTbl; + printAttributes ~customLayout constr.pext_attributes cmtTbl; Doc.text "exception "; name; kind; @@ -5066,9 +5367,9 @@ and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = in printComments doc cmtTbl constr.pext_loc -and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl - i = - let attrs = printAttributes constr.pext_attributes cmtTbl in +and printExtensionConstructor ~customLayout + (constr : Parsetree.extension_constructor) cmtTbl i = + let attrs = printAttributes ~customLayout constr.pext_attributes cmtTbl in let bar = if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil in @@ -5082,25 +5383,36 @@ and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl | Pext_decl (args, gadt) -> let gadtDoc = match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl] + | Some typ -> + Doc.concat [Doc.text ": "; printTypExpr ~customLayout typ cmtTbl] | None -> Doc.nil in - Doc.concat [printConstructorArguments ~indent:false args cmtTbl; gadtDoc] + Doc.concat + [ + printConstructorArguments ~customLayout ~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 printImplementation ~width (s : Parsetree.structure) ~comments = let cmtTbl = CommentTable.make () in CommentTable.walkStructure s cmtTbl comments; (* CommentTable.log cmtTbl; *) - let doc = printStructure s cmtTbl in + let doc = printStructure ~customLayout:0 s cmtTbl in (* Doc.debug doc; *) Doc.toString ~width doc ^ "\n" let printInterface ~width (s : Parsetree.signature) ~comments = let cmtTbl = CommentTable.make () in CommentTable.walkSignature s cmtTbl comments; - Doc.toString ~width (printSignature s cmtTbl) ^ "\n" + Doc.toString ~width (printSignature ~customLayout:0 s cmtTbl) ^ "\n" + +let printStructure = printStructure ~customLayout:0 diff --git a/analysis/vendor/res_outcome_printer/res_scanner.ml b/analysis/vendor/res_outcome_printer/res_scanner.ml index 026bf16a4..6fbfac959 100644 --- a/analysis/vendor/res_outcome_printer/res_scanner.ml +++ b/analysis/vendor/res_outcome_printer/res_scanner.ml @@ -546,12 +546,11 @@ let scanSingleLineComment scanner = let scanMultiLineComment scanner = (* assumption: we're only ever using this helper in `scan` after detecting a comment *) - let docComment = - peek2 scanner = '*' - && peek3 scanner <> '/' - (* no /**/ *) && peek3 scanner <> '*' (* no /*** *) + let docComment = peek2 scanner = '*' && peek3 scanner <> '/' (* no /**/ *) in + let standalone = docComment && peek3 scanner = '*' (* /*** *) in + let contentStartOff = + scanner.offset + if docComment then if standalone then 4 else 3 else 2 in - let contentStartOff = scanner.offset + if docComment then 3 else 2 in let startPos = position scanner in let rec scan ~depth = (* invariant: depth > 0 right after this match. See assumption *) @@ -573,7 +572,7 @@ let scanMultiLineComment scanner = let length = scanner.offset - 2 - contentStartOff in let length = if length < 0 (* in case of EOF *) then 0 else length in Token.Comment - (Comment.makeMultiLineComment ~docComment + (Comment.makeMultiLineComment ~docComment ~standalone ~loc: Location. {loc_start = startPos; loc_end = position scanner; loc_ghost = false} @@ -588,12 +587,15 @@ let scanTemplateLiteralToken scanner = let startPos = position scanner in let rec scan () = + let lastPos = position scanner in match scanner.ch with | '`' -> next scanner; - Token.TemplateTail - ((String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff)) + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (scanner.offset - 1 - startOff) + in + Token.TemplateTail (contents, lastPos) | '$' -> ( match peek scanner with | '{' -> @@ -602,7 +604,7 @@ let scanTemplateLiteralToken scanner = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 2 - startOff) in - Token.TemplatePart contents + Token.TemplatePart (contents, lastPos) | _ -> next scanner; scan ()) @@ -618,9 +620,11 @@ let scanTemplateLiteralToken scanner = | ch when ch = hackyEOFChar -> let endPos = position scanner in scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - Token.TemplateTail - ((String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0)) + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff + (max (scanner.offset - 1 - startOff) 0) + in + Token.TemplateTail (contents, lastPos) | _ -> next scanner; scan () diff --git a/analysis/vendor/res_outcome_printer/res_token.ml b/analysis/vendor/res_outcome_printer/res_token.ml index e8901fcd3..2c4f8f26b 100644 --- a/analysis/vendor/res_outcome_printer/res_token.ml +++ b/analysis/vendor/res_outcome_printer/res_token.ml @@ -88,14 +88,13 @@ type t = | PercentPercent | Comment of Comment.t | List - | TemplateTail of string - | TemplatePart of string + | TemplateTail of string * Lexing.position + | TemplatePart of string * Lexing.position | Backtick | BarGreater | Try - | Import - | Export | DocComment of Location.t * string + | ModuleComment of Location.t * string let precedence = function | HashEqual | ColonEqual -> 1 @@ -199,14 +198,13 @@ let toString = function | PercentPercent -> "%%" | Comment c -> "Comment" ^ Comment.toString c | List -> "list{" - | TemplatePart text -> text ^ "${" - | TemplateTail text -> "TemplateTail(" ^ text ^ ")" + | TemplatePart (text, _) -> text ^ "${" + | TemplateTail (text, _) -> "TemplateTail(" ^ text ^ ")" | Backtick -> "`" | BarGreater -> "|>" | Try -> "try" - | Import -> "import" - | Export -> "export" | DocComment (_loc, s) -> "DocComment " ^ s + | ModuleComment (_loc, s) -> "ModuleComment " ^ s let keywordTable = function | "and" -> And @@ -215,12 +213,10 @@ let keywordTable = function | "constraint" -> Constraint | "else" -> Else | "exception" -> Exception - | "export" -> Export | "external" -> External | "false" -> False | "for" -> For | "if" -> If - | "import" -> Import | "in" -> In | "include" -> Include | "lazy" -> Lazy @@ -242,10 +238,9 @@ let keywordTable = function [@@raises Not_found] let isKeyword = function - | And | As | Assert | Constraint | Else | Exception | Export | External - | False | For | If | Import | In | Include | Land | Lazy | Let | List | Lor - | Module | Mutable | Of | Open | Private | Rec | Switch | True | Try | Typ - | When | While -> + | And | As | Assert | Constraint | Else | Exception | External | False | For + | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable | Of + | Open | Private | Rec | Switch | True | Try | Typ | When | While -> true | _ -> false