From 8bf099ada9a38fcf8616afb400a25bedd32184ae Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 28 Jun 2022 13:47:28 +0200 Subject: [PATCH 1/2] Quick fix to exponential blowup. Stop it after a nested threshold. --- src/res_printer.ml | 1238 +++++++++++++++++++++++++++----------------- 1 file changed, 771 insertions(+), 467 deletions(-) diff --git a/src/res_printer.ml b/src/res_printer.ml index 02359977..f6c61fe9 100644 --- a/src/res_printer.ml +++ b/src/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,17 @@ 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 printedArgs = 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) in (callback, printedArgs) | _ -> assert false @@ -3977,15 +4196,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); + callback; + Doc.comma; + Doc.line; + printedArgs; + Doc.rparen; + ]) in (* Thing.map( @@ -3995,7 +4215,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,13 +4234,16 @@ 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 Doc.willBreak printedArgs then Lazy.force breakAllArgs + else if customLayout > customLayoutThreshold then Lazy.force fitsOnOneLine + 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 = @@ -4034,13 +4259,16 @@ 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 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 + printPexpFun ~customLayout ~inCallback:ArgumentsFitOnOneLine expr + cmtTblCopy in let doc = Doc.concat [lblDoc; pexpFunDoc] in printComments doc cmtTblCopy expr.pexp_loc @@ -4049,20 +4277,21 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = 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); + printedArgs; + callback; + Doc.rparen; + ]) in (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => @@ -4070,13 +4299,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); + printedArgs; + Doc.breakableGroup ~forceBreak:true callback2; + Doc.rparen; + ]) in (* Thing.map( @@ -4086,7 +4316,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 +4335,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 Doc.willBreak printedArgs then Lazy.force breakAllArgs + else if customLayout > customLayoutThreshold then Lazy.force fitsOnOneLine + 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 +4364,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 +4383,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 +4406,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 +4442,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 +4484,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 +4494,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 +4508,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 +4535,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 +4555,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 +4572,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 +4630,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 +4646,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 +4667,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 +4701,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 +4710,7 @@ and printExpFunParameter parameter cmtTbl = Doc.text "~"; printIdentLike lbl; Doc.text " as "; - printPattern pattern cmtTbl; + printPattern ~customLayout pattern cmtTbl; ] in let optionalLabelSuffix = @@ -4497,7 +4750,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 +4761,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 +4780,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 +4798,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 +4825,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 +4840,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 +4917,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 +4927,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 +4937,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 +4946,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 +4959,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 +4974,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 +4993,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 +5014,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 +5026,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 +5050,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 +5062,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 +5076,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 @@ -4827,10 +5100,10 @@ and printAttribute ?(standalone = false) ((id, payload) : Parsetree.attribute) [ 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 +5127,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 +5148,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 +5164,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 +5183,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 +5199,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 +5220,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 +5233,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 +5252,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 +5277,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 +5290,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 +5311,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 +5334,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 +5351,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 +5359,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 +5375,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 From dc697b34654520a2d0a432285d7563a55361c680 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 28 Jun 2022 14:02:34 +0200 Subject: [PATCH 2/2] More lazy. --- src/res_printer.ml | 57 +++++++++--------- .../expr/expected/nestedCallbacks.res.txt | 60 +++++++++++++++++++ tests/printer/expr/nestedCallbacks.res | 24 ++++++++ 3 files changed, 114 insertions(+), 27 deletions(-) create mode 100644 tests/printer/expr/expected/nestedCallbacks.res.txt create mode 100644 tests/printer/expr/nestedCallbacks.res diff --git a/src/res_printer.ml b/src/res_printer.ml index f6c61fe9..f23ef76a 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -4180,11 +4180,12 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args 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 ~customLayout 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 @@ -4200,10 +4201,10 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args (Doc.concat [ (if uncurried then Doc.text "(. " else Doc.lparen); - callback; + Lazy.force callback; Doc.comma; Doc.line; - printedArgs; + Lazy.force printedArgs; Doc.rparen; ]) in @@ -4234,8 +4235,8 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried ~customLayout args * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if Doc.willBreak printedArgs then Lazy.force breakAllArgs - else if customLayout > customLayoutThreshold then Lazy.force fitsOnOneLine + 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 ~customLayout ~uncurried args @@ -4248,7 +4249,7 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args 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 @@ -4259,21 +4260,23 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] in let callbackFitsOnOneLine = - let pexpFunDoc = - printPexpFun ~customLayout ~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 ~customLayout ~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 -> @@ -4288,8 +4291,8 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args (Doc.concat [ (if uncurried then Doc.text "(." else Doc.lparen); - printedArgs; - callback; + Lazy.force printedArgs; + Lazy.force callback; Doc.rparen; ]) in @@ -4303,8 +4306,8 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args (Doc.concat [ (if uncurried then Doc.text "(." else Doc.lparen); - printedArgs; - Doc.breakableGroup ~forceBreak:true callback2; + Lazy.force printedArgs; + Doc.breakableGroup ~forceBreak:true (Lazy.force callback2); Doc.rparen; ]) in @@ -4335,8 +4338,8 @@ and printArgumentsWithCallbackInLastPosition ~customLayout ~uncurried args * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if Doc.willBreak printedArgs then Lazy.force breakAllArgs - else if customLayout > customLayoutThreshold then Lazy.force fitsOnOneLine + if customLayout > customLayoutThreshold then Lazy.force breakAllArgs + else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs else Doc.customLayout [ diff --git a/tests/printer/expr/expected/nestedCallbacks.res.txt b/tests/printer/expr/expected/nestedCallbacks.res.txt new file mode 100644 index 00000000..fb10bdb7 --- /dev/null +++ b/tests/printer/expr/expected/nestedCallbacks.res.txt @@ -0,0 +1,60 @@ +let foo = () => + bar(x => + bar(x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar( + x => + bar(x => bar(x => x)), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ), + ) + ) + ) diff --git a/tests/printer/expr/nestedCallbacks.res b/tests/printer/expr/nestedCallbacks.res new file mode 100644 index 00000000..cc2f9c89 --- /dev/null +++ b/tests/printer/expr/nestedCallbacks.res @@ -0,0 +1,24 @@ +let foo = () => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => + bar(x => x) + ))))))))))))))))))))) \ No newline at end of file