Callbacks without exponential explosion.

src/res_doc.ml

@@ -21,7 +21,7 @@ type t =
   | LineSuffix of t
   | LineBreak of lineStyle
   | Group of {mutable shouldBreak: bool; doc: t}
-  | CustomLayout of t list
+  | CustomLayout of {groups: t lazy_t list; mutable forceBreak: bool}
   | BreakParent
 
 let nil = Nil
@@ -50,7 +50,7 @@ let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false}
 let lineSuffix d = LineSuffix d
 let group d = Group {shouldBreak = false; doc = d}
 let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d}
-let customLayout gs = CustomLayout gs
+let customLayout lazyDocs = CustomLayout {groups = lazyDocs; forceBreak = false}
 let breakParent = BreakParent
 
 let space = Text " "
@@ -102,13 +102,8 @@ let propagateForcedBreaks doc =
           let childForcesBreak = walk child in
           forceBreak || childForcesBreak)
         false children
-    | CustomLayout children ->
-      (* When using CustomLayout, we don't want to propagate forced breaks
-       * from the children up. By definition it picks the first layout that fits
-       * otherwise it takes the last of the list.
-       * However we do want to propagate forced breaks in the sublayouts. They
-       * might need to be broken. We just don't propagate them any higher here *)
-      let _ = walk (Concat children) in
+    | CustomLayout cl ->
+      cl.forceBreak <- true;
       false
   in
   let _ = walk doc in
@@ -119,7 +114,8 @@ let rec willBreak doc =
   match doc with
   | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} ->
     true
-  | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc
+  | Group {doc} | Indent doc -> willBreak doc
+  | CustomLayout {groups = _lazyDoc :: _} -> false
   | Concat docs -> List.exists willBreak docs
   | IfBreaks {yes; no} -> willBreak yes || willBreak no
   | _ -> false
@@ -155,10 +151,7 @@ let fits w stack =
     | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc
     | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc
     | _, Concat docs -> calculateConcat indent mode docs
-    | _, CustomLayout (hd :: _) ->
-      (* TODO: if we have nested custom layouts, what we should do here? *)
-      calculate indent mode hd
-    | _, CustomLayout [] -> ()
+    | _, CustomLayout _ -> ()
   and calculateConcat indent mode docs =
     if result.contents == None then
       match docs with
@@ -234,16 +227,19 @@ let toString ~width doc =
         if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest))
         then process ~pos lineSuffices ((ind, Break, doc) :: rest)
         else process ~pos lineSuffices ((ind, Flat, doc) :: rest)
-      | CustomLayout docs ->
-        let rec findGroupThatFits groups =
-          match groups with
-          | [] -> Nil
-          | [lastGroup] -> lastGroup
-          | doc :: docs ->
-            if fits (width - pos) ((ind, Flat, doc) :: rest) then doc
-            else findGroupThatFits docs
+      | CustomLayout {groups = lazyDocs; forceBreak} ->
+        let rec findGroupThatFits lazyDocs =
+          match lazyDocs with
+          | [] -> lazy Nil
+          | [lazyDoc] -> lazyDoc
+          | lazyDoc :: lazyDocs ->
+            if fits (width - pos) ((ind, Flat, Lazy.force lazyDoc) :: rest) then
+              lazyDoc
+            else findGroupThatFits lazyDocs
         in
-        let doc = findGroupThatFits docs in
+        let lazyDoc = findGroupThatFits lazyDocs in
+        let doc = Lazy.force lazyDoc in
+        if forceBreak then propagateForcedBreaks doc;
         process ~pos lineSuffices ((ind, Flat, doc) :: rest))
     | [] -> (
       match lineSuffices with
@@ -282,7 +278,7 @@ let debug t =
              line;
              text ")";
            ])
-    | CustomLayout docs ->
+    | CustomLayout {groups = lazyDocs} ->
       group
         (concat
            [
@@ -291,7 +287,9 @@ let debug t =
                (concat
                   [
                     line;
-                    join ~sep:(concat [text ","; line]) (List.map toDoc docs);
+                    join
+                      ~sep:(concat [text ","; line])
+                      (List.map (fun ld -> toDoc (Lazy.force ld)) lazyDocs);
                   ]);
              line;
              text ")";

src/res_doc.mli

@@ -16,7 +16,7 @@ val breakableGroup : forceBreak:bool -> t -> t
 (* `customLayout docs` will pick the layout that fits from `docs`.
  * This is a very expensive computation as every layout from the list
  * will be checked until one fits. *)
-val customLayout : t list -> t
+val customLayout : t lazy_t list -> t
 val breakParent : t
 val join : sep:t -> t list -> t
 

src/res_printer.ml

@@ -1905,20 +1905,27 @@ and printValueBinding ~recFlag vb cmtTbl i =
     if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then
       Doc.customLayout
         [
-          Doc.group
-            (Doc.concat
-               [
-                 attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr;
-               ]);
-          Doc.group
-            (Doc.concat
-               [
-                 attrs;
-                 header;
-                 patternDoc;
-                 Doc.text " =";
-                 Doc.indent (Doc.concat [Doc.line; printedExpr]);
-               ]);
+          lazy
+            (Doc.group
+               (Doc.concat
+                  [
+                    attrs;
+                    header;
+                    patternDoc;
+                    Doc.text " =";
+                    Doc.space;
+                    printedExpr;
+                  ]));
+          lazy
+            (Doc.group
+               (Doc.concat
+                  [
+                    attrs;
+                    header;
+                    patternDoc;
+                    Doc.text " =";
+                    Doc.indent (Doc.concat [Doc.line; printedExpr]);
+                  ]));
         ]
     else
       let shouldIndent =
@@ -3977,15 +3984,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 +4003,7 @@ and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl =
    *   arg3,
    * )
    *)
-  let breakAllArgs = printArguments ~uncurried args cmtTblCopy in
+  let breakAllArgs = lazy (printArguments ~uncurried args cmtTblCopy) in
 
   (* Sometimes one of the non-callback arguments will break.
    * There might be a single line comment in there, or a multiline string etc.
@@ -4012,7 +4020,7 @@ 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
+  if Doc.willBreak printedArgs then Lazy.force breakAllArgs
   else Doc.customLayout [fitsOnOneLine; breakAllArgs]
 
 and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
@@ -4023,7 +4031,7 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
   let cmtTblCopy2 = CommentTable.copy cmtTbl in
   let rec loop acc args =
     match args with
-    | [] -> (Doc.nil, Doc.nil, Doc.nil)
+    | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil)
     | [(lbl, expr)] ->
       let lblDoc =
         match lbl with
@@ -4034,18 +4042,22 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
           Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question]
       in
       let callbackFitsOnOneLine =
-        let pexpFunDoc = printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl in
-        let doc = Doc.concat [lblDoc; pexpFunDoc] in
-        printComments doc cmtTbl expr.pexp_loc
+        lazy
+          (let pexpFunDoc =
+             printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl
+           in
+           let doc = Doc.concat [lblDoc; pexpFunDoc] in
+           printComments doc cmtTbl expr.pexp_loc)
       in
       let callbackArgumentsFitsOnOneLine =
-        let pexpFunDoc =
-          printPexpFun ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy
-        in
-        let doc = Doc.concat [lblDoc; pexpFunDoc] in
-        printComments doc cmtTblCopy expr.pexp_loc
+        lazy
+          (let pexpFunDoc =
+             printPexpFun ~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 ->
@@ -4056,27 +4068,29 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
 
   (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *)
   let fitsOnOneLine =
-    Doc.concat
-      [
-        (if uncurried then Doc.text "(." else Doc.lparen);
-        printedArgs;
-        callback;
-        Doc.rparen;
-      ]
+    lazy
+      (Doc.concat
+         [
+           (if uncurried then Doc.text "(." else Doc.lparen);
+           Lazy.force printedArgs;
+           Lazy.force callback;
+           Doc.rparen;
+         ])
   in
 
   (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) =>
    *   MyModuleBlah.toList(argument)
    * )
    *)
   let arugmentsFitOnOneLine =
-    Doc.concat
-      [
-        (if uncurried then Doc.text "(." else Doc.lparen);
-        printedArgs;
-        Doc.breakableGroup ~forceBreak:true callback2;
-        Doc.rparen;
-      ]
+    lazy
+      (Doc.concat
+         [
+           (if uncurried then Doc.text "(." else Doc.lparen);
+           Lazy.force printedArgs;
+           Doc.breakableGroup ~forceBreak:true (Lazy.force callback2);
+           Doc.rparen;
+         ])
   in
 
   (* Thing.map(
@@ -4086,7 +4100,7 @@ and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
    *   (param1, parm2) => doStuff(param1, parm2)
    * )
    *)
-  let breakAllArgs = printArguments ~uncurried args cmtTblCopy2 in
+  let breakAllArgs = lazy (printArguments ~uncurried args cmtTblCopy2) in
 
   (* Sometimes one of the non-callback arguments will break.
    * There might be a single line comment in there, or a multiline string etc.
@@ -4103,7 +4117,7 @@ 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
+  if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs
   else Doc.customLayout [fitsOnOneLine; arugmentsFitOnOneLine; breakAllArgs]
 
 and printArguments ~uncurried

tests/conversion/reason/expected/bracedJsx.res.txt

@@ -112,8 +112,7 @@ let make = () => {
       className=Styles.terminal
       onClick={event => (event->ReactEvent.Mouse.target)["querySelector"]("input")["focus"]()}
       ref={containerRef->ReactDOMRe.Ref.domRef}>
-      {state.history
-      ->Array.mapWithIndex((index, item) =>
+      {state.history->Array.mapWithIndex((index, item) =>
         <div key={j`$index`} className=Styles.line>
           {ReasonReact.string(
             switch item {
@@ -122,8 +121,7 @@ let make = () => {
             },
           )}
         </div>
-      )
-      ->ReasonReact.array}
+      )->ReasonReact.array}
       <div>
         {userPrefix->ReasonReact.string}
         {<input

tests/conversion/reason/expected/fastPipe.res.txt

@@ -15,9 +15,9 @@ let x = @attr ((@attr2 a)->f(b)->c(d))
 Route.urlToRoute(url)->ChangeView->self.send
 
 let aggregateTotal = (forecast, ~audienceType) =>
-  Js.Nullable.toOption(forecast["audiences"])
-  ->Option.flatMap(item => Js.Dict.get(item, audienceType))
-  ->Option.map(item => {
+  Js.Nullable.toOption(forecast["audiences"])->Option.flatMap(item =>
+    Js.Dict.get(item, audienceType)
+  )->Option.map(item => {
     pages: item["reach"]["pages"],
     views: item["reach"]["views"],
     sample: item["reach"]["sample"],

tests/conversion/reason/expected/uncurrried.res.txt

@@ -51,14 +51,8 @@ let () = {
 
 let _ = library.getBalance(. account)->Promise.Js.catch(_ => Promise.resolved(None))
 
-let _ =
-  library.getBalance(. account)
-  ->Promise.Js.catch(_ => Promise.resolved(None))
-  ->Promise.get(newBalance =>
-    dispatch(
-      LoadAddress(
-        account,
-        newBalance->Belt.Option.flatMap(balance => Eth.make(balance.toString(.))),
-      ),
-    )
+let _ = library.getBalance(. account)->Promise.Js.catch(_ => Promise.resolved(None))->Promise.get(
+    newBalance => dispatch(LoadAddress(account, newBalance->Belt.Option.flatMap(balance =>
+            Eth.make(balance.toString(.))
+          ))),
   )