Fast pipe sugar (#1999)

* Add initial prototype for native/builtin fast pipe in Reason

* implement fast pipe for fresh open expressions and underscore syntax

* Add prototype for tuple dispatch with fast pipe

* Address parsing feedback for fast pipe

-> parses into ocaml |.
|. parses into ocaml |.

* Print fast pipe beautiful

* Enhance printing of fast pipe in the neighbourhood of other infix operators

* Modify precedence of -> to be just below . and #.

examples:
x.c->f->g     === (x.c)->f->g
x##c->f->g    === (x##c)->f->g
!a->f->g      === !(a->f->g)

* remove obsolete fast pipe attribute partitioning

formatTest/typeCheckedTests/expected_output/fastPipe.re

@@ -0,0 +1,26 @@
+let (|.) = (x, y) => x + y;
+
+let a = 1;
+let b = 2;
+let c = 3;
+
+/* parses as 10 < (a->b->c) */
+let t1: bool = 10 < a->b->c;
+
+type coordinate = {
+  x: int,
+  y: int,
+};
+let coord = {x: 1, y: 1};
+
+/* parses as (coord.x)->a->b->c */
+let t2: int = coord.x->a->b->c;
+
+let (|.) = (x, y) => x || y;
+
+let a = true;
+let b = false;
+let c = true;
+
+/* parses as !(a->b->c) */
+let t3: bool = ! a->b->c;

formatTest/typeCheckedTests/input/fastPipe.re

@@ -0,0 +1,23 @@
+let (|.) = (x, y) => x + y;
+
+let a = 1;
+let b = 2;
+let c = 3;
+
+/* parses as 10 < (a->b->c) */
+let t1: bool = 10 < a->b->c;
+
+type coordinate = {x: int, y: int};
+let coord = {x: 1, y: 1};
+
+/* parses as (coord.x)->a->b->c */
+let t2: int = coord.x->a->b->c;
+
+let (|.) = (x, y) => x || y;
+
+let a = true;
+let b = false;
+let c = true;
+
+/* parses as !(a->b->c) */
+let t3: bool = !a->b->c;

formatTest/unit_tests/expected_output/fastPipe.re

@@ -0,0 +1,40 @@
+foo->f->g->h;
+
+bar->f->g->h;
+
+compilation
+->Plugin.buildAssets
+->Js.Json.stringify
+->Node.Fs.writeFileAsUtf8Sync(_, path);
+
+foo->bar->baz >>= monadicFunction |> bind;
+
+compilation
+->Plugin.buildAssets
+->Js.Json.stringify
+|> Cohttp_lwt_body.to_string
+>|= (
+  body =>
+    Printf.sprintf(
+      "okokok",
+      uri,
+      meth,
+      headers,
+      body,
+    )
+)
+>>= (
+  body =>
+    Server.respond_string(~status, ~body, ())
+);
+
+x + y + foo->bar->baz;
+x + y * foo->bar->baz;
+x && y || foo->bar->baz;
+
+x < foo->bar->baz;
+foo !== bar->baz;
+x |> y >>= foo->bar->baz;
+let m = f => foo->bar->f;
+
+obj##x->foo->bar;

formatTest/unit_tests/input/fastPipe.re

@@ -0,0 +1,44 @@
+foo |. f |. g |. h;
+
+bar->f->g->h;
+
+compilation
+->Plugin.buildAssets
+->Js.Json.stringify
+->Node.Fs.writeFileAsUtf8Sync(_, path);
+
+foo->bar->baz >>= monadicFunction |> bind;
+
+compilation
+->Plugin.buildAssets
+->Js.Json.stringify
+|> Cohttp_lwt_body.to_string
+>|= (
+  body =>
+    Printf.sprintf(
+      "okokok",
+      uri,
+      meth,
+      headers,
+      body,
+    )
+)
+>>= (
+  body =>
+    Server.respond_string(
+      ~status,
+      ~body,
+      (),
+    )
+);
+
+x + y + foo->bar->baz;
+x + y * foo->bar->baz;
+x && y || foo->bar->baz;
+
+x < foo->bar->baz;
+foo !== bar->baz;
+x |> y >>= foo->bar->baz;
+let m = f => foo->bar->f;
+
+obj##x->foo->bar;

src/reason-parser/jbuild

@@ -53,6 +53,7 @@
   (wrapped false)
   (modules
    (lexer_warning
+    reason_ast
     reason_syntax_util
     reason_comment
     reason_layout

src/reason-parser/reason_ast.ml

@@ -0,0 +1,14 @@
+open Ast_404
+open Parsetree
+
+let processFastPipe e =
+  match e.pexp_desc with
+  | Pexp_apply(
+      {pexp_desc = Pexp_ident({txt = Longident.Lident("|."); loc})} as identExp,
+      args
+    ) ->
+    let pipe = {identExp with pexp_desc =
+      Pexp_ident {txt = Longident.Lident("->"); loc}
+    } in
+    {e with pexp_desc = Pexp_apply(pipe, args) }
+  | _ -> e

src/reason-parser/reason_ast.mli

@@ -0,0 +1 @@
+val processFastPipe : Ast_404.Parsetree.expression -> Ast_404.Parsetree.expression

src/reason-parser/reason_parser.mly

@@ -1355,6 +1355,7 @@ conflicts.
 
 (* PREFIXOP and BANG precedence *)
 %nonassoc below_DOT_AND_SHARP           (* practically same as below_SHARP but we convey purpose *)
+%left    MINUSGREATER
 %nonassoc SHARP                         (* simple_expr/toplevel_directive *)
 %nonassoc below_DOT
 %nonassoc DOT POSTFIXOP
@@ -2851,7 +2852,11 @@ mark_position_exp
       mkexp_cons loc_colon (mkexp ~ghost:true ~loc (Pexp_tuple[$5;$7])) loc
     }
   | E as_loc(infix_operator) expr
-    { mkinfix $1 $2 $3 }
+    { let op = match $2.txt with
+      | "->" -> {$2 with txt = "|."}
+      | _ -> $2
+      in mkinfix $1 op $3
+    }
   | as_loc(subtractive) expr %prec prec_unary
     { mkuminus $1 $2 }
   | as_loc(additive) expr %prec prec_unary
@@ -4555,6 +4560,7 @@ val_ident:
      operator swapping requires that we express that as != *)
   | LESSDOTDOTGREATER { "<..>" }
   | GREATER GREATER   { ">>" }
+  | MINUSGREATER      { "->" }
 ;
 
 %inline sharpop:

src/reason-parser/reason_pprint_ast.ml

@@ -534,6 +534,9 @@ let isSimplePrefixToken s = match printedStringAndFixity s with
    `CustomPrecedence`) the string name of a custom rule precedence declared
    using %prec *)
 let rules = [
+  [
+    (TokenPrecedence, (fun s -> (Left, s = "->")));
+  ];
   [
     (TokenPrecedence, (fun s -> (Nonassoc, isSimplePrefixToken s)));
   ];
@@ -576,7 +579,7 @@ let rules = [
       else
         s.[0] == '+'
     )));
-    (TokenPrecedence ,(fun s -> (Left, s.[0] == '-' )));
+    (TokenPrecedence ,(fun s -> (Left, s.[0] == '-' && s <> "->" )));
     (TokenPrecedence ,(fun s -> (Left, s = "!" )));
   ];
   [
@@ -2124,6 +2127,40 @@ let rec computeInfixChain = function
 
 let equalityOperators = ["!="; "!=="; "==="; "=="; ">="; "<="; "<"; ">"]
 
+(* Takes a list of layouts and provides beautiful printing for fast pipe.
+ * Prints
+ *  [atom "foo"; atom "->"; atom "f"; atom "->"; atom "g"]
+ * as:
+ *  foo->f->g
+ * or if line-length indicates breaking:
+ *  foo
+ *  ->f
+ *  ->g
+ *)
+let formatFastPipeChain layouts =
+  (* transforms [->; f; ->; g] into [->f; ->g] *)
+  let rec processPipePairs acc = function
+  | pipe::exp::xs ->
+      let layout = label ~break:`Never pipe exp in
+      processPipePairs (layout::acc) xs
+  | [x] -> List.rev (x::acc)
+  | [] -> List.rev acc
+  in match layouts with
+  | hd::tl ->
+    (* process head of the layout list different so all "pipe pairs"
+     * are nicely aligned under the first element when the layout breaks.
+     *  foo->f->g
+     * becomes
+     *  foo
+     *  ->f
+     *  ->g
+     *)
+    let pipes = processPipePairs [] tl in
+    makeList ~break:IfNeed ~inline:(true, true) (hd::pipes)
+  | [] ->
+    atom ""
+
+
 (* Formats a flattened list of infixChain nodes into a list of layoutNodes
  * which allow smooth line-breaking
  * e.g. [LayoutNode foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z]
@@ -2148,7 +2185,7 @@ let formatComputedInfixChain infixChainList =
      * |> f
      * |> z *)
     if List.length group < 2 then
-      makeList ~inline:(true, true) ~sep:(Sep " ") ~break:Layout.Never group
+      makeList ~inline:(true, true) ~sep:(Sep " ") group
     (* Basic equality operators require special formatting, we can't give it
      * 'classic' infix operator formatting, otherwise we would get
      * let example =
@@ -2159,8 +2196,10 @@ let formatComputedInfixChain infixChainList =
      *  *)
     else if List.mem currentToken equalityOperators then
       let hd = List.hd group in
-      let tl = makeList ~inline:(true, true) ~sep:(Sep " ") ~break:Layout.Never (List.tl group) in
+      let tl = makeList ~inline:(true, true) ~sep:(Sep " ") (List.tl group) in
       makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed [hd; tl]
+    else if currentToken = "->" then
+      formatFastPipeChain group
     else
       (* Represents `|> f` in foo |> f
        * We need a label here to indent possible closing parens
@@ -2170,17 +2209,18 @@ let formatComputedInfixChain infixChainList =
        *   fun body =>
        *     Printf.sprintf
        *       "okokok" uri meth headers body
-       * )   <-- notice how this closing paren is on the same height as >|= *)
+       * )   <-- notice how this closing paren is on the same height as >|=
+       *)
       label ~break:`Never ~space:true (atom currentToken) (List.nth group 1)
   in
   let rec print acc group currentToken l =
     match l with
     | x::xs -> (match x with
       | InfixToken t ->
+          (* = or := *)
           if List.mem t requireIndentFor then
             let groupNode =
-              makeList ~inline:(true, true) ~sep:(Sep " ") ~break:Layout.Never
-                (group @ [atom t])
+              makeList ~inline:(true, true) ~sep:(Sep " ") (group @ [atom t])
             in
             let children =
               makeList ~inline:(true, true) ~preSpace:true ~break:IfNeed
@@ -2196,14 +2236,34 @@ let formatComputedInfixChain infixChainList =
            * *)
           else if t = "@@" then
             let groupNode =
-              makeList ~inline:(true, true) ~sep:(Sep " ") ~break:Layout.Never
-                (group @ [atom t])
+              makeList ~inline:(true, true) ~sep:(Sep " ") (group @ [atom t])
             in
             print (acc @ [groupNode]) [] t xs
+          (* != !== === == >= <= < > etc *)
           else if List.mem t equalityOperators then
             print acc (group @ [atom t]) t xs
           else
-            print (acc @ [layout_of_group group currentToken]) [(atom t)] t xs
+            begin if t = "->"  then
+              begin if (currentToken = "" || currentToken = "->") then
+                print acc (group@[atom t]) t xs
+              else
+                (* a + b + foo->bar->baz
+                 * `foo` needs to be picked from the current group
+                 * and inserted into a new one. This way `foo`
+                 * gets the special "fast pipe chain"-printing:
+                 * foo->bar->baz. *)
+                 begin match List.rev group with
+                 |  hd::tl ->
+                     let acc =
+                       acc @ [layout_of_group (List.rev tl) currentToken]
+                      in
+                     print acc [hd; atom t] t xs
+                 | [] -> print acc (group@[atom t]) t xs
+                 end
+              end
+            else
+              print (acc @ [layout_of_group group currentToken]) [(atom t)] t xs
+            end
       | Layout layoutNode -> print acc (group @ [layoutNode]) currentToken xs
       )
     | [] ->
@@ -2212,7 +2272,8 @@ let formatComputedInfixChain infixChainList =
         else
           acc @ [layout_of_group group currentToken]
   in
-  print [] [] "" infixChainList
+  let l = print [] [] "" infixChainList in
+  makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed l
 
 (**
  * [groupAndPrint] will print every item in [items] according to the function [xf].
@@ -3647,9 +3708,7 @@ let printer = object(self:'self)
   method unparseResolvedRule  = function
     | LayoutNode layoutNode -> layoutNode
     | InfixTree _ as infixTree ->
-          let infixChainList = computeInfixChain infixTree in
-          let l = formatComputedInfixChain infixChainList in
-          makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed l
+      formatComputedInfixChain (computeInfixChain infixTree)
 
 
   method unparseExprApplicationItems x =
@@ -3693,6 +3752,7 @@ let printer = object(self:'self)
       x
 
   method unparseExprRecurse x =
+    let x =  Reason_ast.processFastPipe x in
     let x = self#process_underscore_application x in
     (* If there are any attributes, render unary like `(~-) x [@ppx]`, and infix like `(+) x y [@attr]` *)