Callbacks without exponential explosion.

Follows #576

Author: cristianoc

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 t lazy_t list
   | 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 lazyDocs
 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 _ ->
+      (* TODO: this should be done lazily *)
       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 (_lazyDoc :: _) -> false (* willBreak (Lazy.force lazyDoc) *)
   | 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,17 +227,18 @@ 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 lazyDocs ->
+        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
-        process ~pos lineSuffices ((ind, Flat, doc) :: rest))
+        let lazyDoc = findGroupThatFits lazyDocs in
+        process ~pos lineSuffices ((ind, Flat, Lazy.force lazyDoc) :: rest))
     | [] -> (
       match lineSuffices with
       | [] -> ()
@@ -282,7 +276,7 @@ let debug t =
              line;
              text ")";
            ])
-    | CustomLayout docs ->
+    | CustomLayout lazyDocs ->
       group
         (concat
            [
@@ -291,7 +285,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

@@ -50,55 +50,45 @@ module Styles = {
 let make = () => {
   let containerRef = React.useRef(Js.Nullable.null)
 
-  let (state, send) = React.useReducer((state, action) =>
-    switch action {
+  let (state, send) = React.useReducer((state, action) => switch action {
     | RunCommand => {
         input: "",
         history: Array.concat(
           state.history,
-          [
-            User(state.input),
-            switch state.input->Js.String.trim {
+          [User(state.input), switch state.input->Js.String.trim {
             | "" => System("")
-            | "help" =>
-              System(`available commands:
+            | "help" => System(`available commands:
 - help
 - ls
 - cat `)
-            | "ls" =>
-              System(`- hack-website.sh
+            | "ls" => System(`- hack-website.sh
 - go-to-home.sh
 - nuclear-codes.txt`)
             | "cat" => System("cat: missing argument")
             | "cat hack-website.sh"
-            | "cat ./hack-website.sh" =>
-              System("# seriously?\necho \"lol\"")
+            | "cat ./hack-website.sh" => System("# seriously?\necho \"lol\"")
             | "hack-website.sh"
-            | "./hack-website.sh" =>
-              System("lol")
+            | "./hack-website.sh" => System("lol")
             | "cat nuclear-codes.txt"
-            | "cat ./nuclear-codes.txt" =>
-              System("000000")
+            | "cat ./nuclear-codes.txt" => System("000000")
             | "go-to-home.sh"
-            | "./go-to-home.sh" =>
-              Js.Global.setTimeout(() => ReasonReact.Router.push("/"), 1_000)->ignore
+            | "./go-to-home.sh" => Js.Global.setTimeout(
+                () => ReasonReact.Router.push("/"),
+                1_000,
+              )->ignore
               System("Redirecting ...")
             | "cat go-to-home.sh"
-            | "cat ./go-to-home.sh" =>
-              System("ReasonReact.Router.push(\"/\")")
+            | "cat ./go-to-home.sh" => System("ReasonReact.Router.push(\"/\")")
             | _ => System("command not found: " ++ (state.input ++ "\ntry command 'help'"))
-            },
-          ],
+            }],
         ),
       }
     | SetValue(input) => {...state, input}
-    }
-  , {history: [], input: ""})
+    }, {history: [], input: ""})
 
   React.useEffect1(() => {
     switch containerRef.current->Js.Nullable.toOption {
-    | Some(containerRef) =>
-      open Webapi.Dom
+    | Some(containerRef) => open Webapi.Dom
       containerRef->Element.setScrollTop(containerRef->Element.scrollHeight->float_of_int)
     | None => ()
     }
@@ -112,18 +102,12 @@ 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) =>
-        <div key={j`$index`} className=Styles.line>
-          {ReasonReact.string(
-            switch item {
+      {state.history->Array.mapWithIndex((index, item) =>
+        <div key={j`$index`} className=Styles.line> {ReasonReact.string(switch item {
             | User(value) => userPrefix ++ value
             | System(value) => value
-            },
-          )}
-        </div>
-      )
-      ->ReasonReact.array}
+            })} </div>
+      )->ReasonReact.array}
       <div>
         {userPrefix->ReasonReact.string}
         {<input