Proof of Concept: explore per-module custom infix operators.

res_syntax/src/res_core.ml

@@ -2473,6 +2473,7 @@ and parseAttributesAndBinding (p : Parser.t) =
   let lineOffset = p.scanner.lineOffset in
   let lnum = p.scanner.lnum in
   let mode = p.scanner.mode in
+  let customInfix = p.scanner.customInfix in
   let token = p.token in
   let startPos = p.startPos in
   let endPos = p.endPos in
@@ -2495,6 +2496,7 @@ and parseAttributesAndBinding (p : Parser.t) =
       p.scanner.lineOffset <- lineOffset;
       p.scanner.lnum <- lnum;
       p.scanner.mode <- mode;
+      p.scanner.customInfix <- customInfix;
       p.token <- token;
       p.startPos <- startPos;
       p.endPos <- endPos;
@@ -5591,11 +5593,13 @@ and parseAtomicModuleExpr p =
     Ast_helper.Mod.ident ~loc:longident.loc longident
   | Lbrace ->
     Parser.next p;
+    let customInfix = p.scanner.customInfix in
     let structure =
       Ast_helper.Mod.structure
         (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace
            ~f:parseStructureItemRegion p)
     in
+    p.scanner.customInfix <- customInfix;
     Parser.expect Rbrace p;
     let endPos = p.prevEndPos in
     {structure with pmod_loc = mkLoc startPos endPos}
@@ -6366,10 +6370,12 @@ and parsePayload p =
       Parser.eatBreadcrumb p;
       Parsetree.PPat (pattern, expr)
     | _ ->
+      let customInfix = p.scanner.customInfix in
       let items =
         parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen
           ~f:parseStructureItemRegion p
       in
+      p.scanner.customInfix <- customInfix;
       Parser.expect Rparen p;
       Parser.eatBreadcrumb p;
       Parsetree.PStr items)
@@ -6407,15 +6413,44 @@ and parseStandaloneAttribute p =
   let startPos = p.startPos in
   Parser.expect AtAt p;
   let attrId = parseAttributeId ~startPos p in
+  let payload = parsePayload p in
   let attrId =
     match attrId.txt with
     | "uncurried" ->
       p.uncurried_config <- Res_uncurried.Default;
       attrId
     | "toUncurried" -> {attrId with txt = "uncurried"}
+    | "infix" -> (
+      match payload with
+      | PStr
+          [
+            {
+              pstr_desc =
+                Pstr_eval
+                  ( {
+                      pexp_desc =
+                        Pexp_tuple
+                          [
+                            {pexp_desc = Pexp_constant (Pconst_string (name, _))};
+                            {
+                              pexp_desc =
+                                Pexp_constant (Pconst_string (alias, _));
+                            };
+                          ];
+                    },
+                    _ );
+            };
+          ] ->
+        p.scanner.customInfix <-
+          p.scanner.customInfix |> Res_custom_infix.addSymbol ~name ~alias;
+        attrId
+      | _ ->
+        Parser.err ~startPos ~endPos:p.startPos p
+          (Diagnostics.message
+             ("Use the form @@" ^ attrId.txt ^ "((\"operator\", \"alias\"))"));
+        attrId)
     | _ -> attrId
   in
-  let payload = parsePayload p in
   (attrId, payload)
 
 (* extension	::=	% attr-id  attr-payload

res_syntax/src/res_custom_infix.ml

@@ -0,0 +1,20 @@
+type t = (string * string) list
+
+let addSymbol ~name ~alias x =
+  (* Put "++" before "+" *)
+  let cmp (n1, _) (n2, _) = String.length n2 - String.length n1 in
+  List.stable_sort cmp ((name, alias) :: x)
+
+let findAlias ~alias x = x |> List.find_opt (fun (_, a) -> alias = a)
+
+let lookupName ~name ~src ~srcLen ~offset =
+  let nameLen = String.length name in
+  let restLen = srcLen - offset in
+  if nameLen <= restLen then (
+    let found = ref true in
+    for i = 0 to nameLen - 1 do
+      if (name.[i] [@doesNotRaise]) <> (src.[offset + i] [@doesNotRaise]) then
+        found := false
+    done;
+    !found)
+  else false

res_syntax/src/res_parens.ml

@@ -25,7 +25,7 @@ let exprRecordRowRhs e =
     | _ -> kind)
   | _ -> kind
 
-let callExpr expr =
+let callExpr ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
@@ -38,7 +38,7 @@ let callExpr expr =
       Parenthesized
     | _
       when ParsetreeViewer.isUnaryExpression expr
-           || ParsetreeViewer.isBinaryExpression expr ->
+           || ParsetreeViewer.isBinaryExpression ~state expr ->
       Parenthesized
     | {
      Parsetree.pexp_desc =
@@ -77,7 +77,7 @@ let structureExpr expr =
     | {pexp_desc = Pexp_constraint _} -> Parenthesized
     | _ -> Nothing)
 
-let unaryExprOperand expr =
+let unaryExprOperand ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
@@ -90,7 +90,7 @@ let unaryExprOperand expr =
       Parenthesized
     | expr
       when ParsetreeViewer.isUnaryExpression expr
-           || ParsetreeViewer.isBinaryExpression expr ->
+           || ParsetreeViewer.isBinaryExpression ~state expr ->
       Parenthesized
     | {
      pexp_desc =
@@ -112,7 +112,7 @@ let unaryExprOperand expr =
       Parenthesized
     | _ -> Nothing)
 
-let binaryExprOperand ~isLhs expr =
+let binaryExprOperand ~isLhs ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
@@ -131,7 +131,7 @@ let binaryExprOperand ~isLhs expr =
        Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _;
     } ->
       Parenthesized
-    | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized
+    | expr when ParsetreeViewer.isBinaryExpression ~state expr -> Parenthesized
     | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized
     | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized
     | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes ->
@@ -149,7 +149,7 @@ let subBinaryExprOperand parentOperator childOperator =
   || (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *)
   (parentOperator = "||" && childOperator = "&&")
 
-let rhsBinaryExprOperand parentOperator rhs =
+let rhsBinaryExprOperand ~state parentOperator rhs =
   match rhs.Parsetree.pexp_desc with
   | Parsetree.Pexp_apply
       ( {
@@ -158,22 +158,22 @@ let rhsBinaryExprOperand parentOperator rhs =
             Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc};
         },
         [(_, _left); (_, _right)] )
-    when ParsetreeViewer.isBinaryOperator operator
+    when ParsetreeViewer.isBinaryOperator ~state operator
          && not (operatorLoc.loc_ghost && operator = "^") ->
     let precParent = ParsetreeViewer.operatorPrecedence parentOperator in
     let precChild = ParsetreeViewer.operatorPrecedence operator in
     precParent == precChild
   | _ -> false
 
-let flattenOperandRhs parentOperator rhs =
+let flattenOperandRhs ~state parentOperator rhs =
   match rhs.Parsetree.pexp_desc with
   | Parsetree.Pexp_apply
       ( {
           pexp_desc =
             Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc};
         },
         [(_, _left); (_, _right)] )
-    when ParsetreeViewer.isBinaryOperator operator
+    when ParsetreeViewer.isBinaryOperator ~state operator
          && not (operatorLoc.loc_ghost && operator = "^") ->
     let precParent = ParsetreeViewer.operatorPrecedence parentOperator in
     let precChild = ParsetreeViewer.operatorPrecedence operator in
@@ -189,7 +189,7 @@ let binaryOperatorInsideAwaitNeedsParens operator =
   ParsetreeViewer.operatorPrecedence operator
   < ParsetreeViewer.operatorPrecedence "|."
 
-let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr =
+let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
@@ -204,7 +204,7 @@ let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr =
      pexp_desc =
        Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, _);
     }
-      when ParsetreeViewer.isBinaryExpression expr ->
+      when ParsetreeViewer.isBinaryExpression ~state expr ->
       if inAwait && not (binaryOperatorInsideAwaitNeedsParens operator) then
         Nothing
       else Parenthesized
@@ -238,7 +238,7 @@ let isNegativeConstant constant =
   | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when isNeg i -> true
   | _ -> false
 
-let fieldExpr expr =
+let fieldExpr ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
@@ -250,7 +250,7 @@ let fieldExpr expr =
            | [] -> false ->
       Parenthesized
     | expr
-      when ParsetreeViewer.isBinaryExpression expr
+      when ParsetreeViewer.isBinaryExpression ~state expr
            || ParsetreeViewer.isUnaryExpression expr ->
       Parenthesized
     | {
@@ -394,14 +394,14 @@ let jsxChildExpr expr =
       | expr when ParsetreeViewer.isJsxExpression expr -> Nothing
       | _ -> Parenthesized))
 
-let binaryExpr expr =
+let binaryExpr ~state expr =
   let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
   match optBraces with
   | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc
   | None -> (
     match expr with
     | {Parsetree.pexp_attributes = _ :: _} as expr
-      when ParsetreeViewer.isBinaryExpression expr ->
+      when ParsetreeViewer.isBinaryExpression ~state expr ->
       Parenthesized
     | _ -> Nothing)
 

res_syntax/src/res_parens.mli

@@ -3,17 +3,21 @@ type kind = Parenthesized | Braced of Location.t | Nothing
 val expr : Parsetree.expression -> kind
 val structureExpr : Parsetree.expression -> kind
 
-val unaryExprOperand : Parsetree.expression -> kind
+val unaryExprOperand : state:Res_printer_state.t -> Parsetree.expression -> kind
 
-val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind
+val binaryExprOperand :
+  isLhs:bool -> state:Res_printer_state.t -> Parsetree.expression -> kind
 val subBinaryExprOperand : string -> string -> bool
-val rhsBinaryExprOperand : string -> Parsetree.expression -> bool
-val flattenOperandRhs : string -> Parsetree.expression -> bool
+val rhsBinaryExprOperand :
+  state:Res_printer_state.t -> string -> Parsetree.expression -> bool
+val flattenOperandRhs :
+  state:Res_printer_state.t -> string -> Parsetree.expression -> bool
 
 val binaryOperatorInsideAwaitNeedsParens : string -> bool
-val lazyOrAssertOrAwaitExprRhs : ?inAwait:bool -> Parsetree.expression -> kind
+val lazyOrAssertOrAwaitExprRhs :
+  ?inAwait:bool -> state:Res_printer_state.t -> Parsetree.expression -> kind
 
-val fieldExpr : Parsetree.expression -> kind
+val fieldExpr : state:Res_printer_state.t -> Parsetree.expression -> kind
 
 val setFieldExprRhs : Parsetree.expression -> kind
 
@@ -22,13 +26,13 @@ val ternaryOperand : Parsetree.expression -> kind
 val jsxPropExpr : Parsetree.expression -> kind
 val jsxChildExpr : Parsetree.expression -> kind
 
-val binaryExpr : Parsetree.expression -> kind
+val binaryExpr : state:Res_printer_state.t -> Parsetree.expression -> kind
 val modTypeFunctorReturn : Parsetree.module_type -> bool
 val modTypeWithOperand : Parsetree.module_type -> bool
 val modExprFunctorConstraint : Parsetree.module_type -> bool
 
 val bracedExpr : Parsetree.expression -> bool
-val callExpr : Parsetree.expression -> kind
+val callExpr : state:Res_printer_state.t -> Parsetree.expression -> kind
 
 val includeModExpr : Parsetree.module_expr -> bool
 

res_syntax/src/res_parser.ml

@@ -161,6 +161,7 @@ let lookahead p callback =
   let offset = p.scanner.offset in
   let offset16 = p.scanner.offset16 in
   let lineOffset = p.scanner.lineOffset in
+  let customInfix = p.scanner.customInfix in
   let lnum = p.scanner.lnum in
   let mode = p.scanner.mode in
   let token = p.token in
@@ -182,6 +183,7 @@ let lookahead p callback =
   p.scanner.lineOffset <- lineOffset;
   p.scanner.lnum <- lnum;
   p.scanner.mode <- mode;
+  p.scanner.customInfix <- customInfix;
   p.token <- token;
   p.startPos <- startPos;
   p.endPos <- endPos;

res_syntax/src/res_parsetree_viewer.ml

@@ -293,23 +293,25 @@ let isUnaryExpression expr =
   | _ -> false
 
 (* TODO: tweak this to check for ghost ^ as template literal *)
-let isBinaryOperator operator =
+let isBinaryOperator ~(state : Res_printer_state.t) operator =
   match operator with
   | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">="
   | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|."
   | "|.u" | "<>" ->
     true
-  | _ -> false
+  | _ ->
+    state.customInfix <> []
+    && state.customInfix |> Res_custom_infix.findAlias ~alias:operator <> None
 
-let isBinaryExpression expr =
+let isBinaryExpression ~state expr =
   match expr.pexp_desc with
   | Pexp_apply
       ( {
           pexp_desc =
             Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc};
         },
         [(Nolabel, _operand1); (Nolabel, _operand2)] )
-    when isBinaryOperator operator
+    when isBinaryOperator ~state operator
          && not (operatorLoc.loc_ghost && operator = "^")
          (* template literal *) ->
     true
@@ -502,7 +504,7 @@ let hasJsxAttribute attributes =
   in
   loop attributes
 
-let shouldIndentBinaryExpr expr =
+let shouldIndentBinaryExpr ~state expr =
   let samePrecedenceSubExpression operator subExpression =
     match subExpression with
     | {
@@ -511,7 +513,7 @@ let shouldIndentBinaryExpr expr =
          ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}},
            [(Nolabel, _lhs); (Nolabel, _rhs)] );
     }
-      when isBinaryOperator subOperator ->
+      when isBinaryOperator ~state subOperator ->
       flattenableOperators operator subOperator
     | _ -> true
   in
@@ -522,7 +524,7 @@ let shouldIndentBinaryExpr expr =
        ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
          [(Nolabel, lhs); (Nolabel, _rhs)] );
   }
-    when isBinaryOperator operator ->
+    when isBinaryOperator ~state operator ->
     isEqualityOperator operator
     || (not (samePrecedenceSubExpression operator lhs))
     || operator = ":="

res_syntax/src/res_parsetree_viewer.mli

@@ -75,8 +75,9 @@ val isHuggableRhs : Parsetree.expression -> bool
 val operatorPrecedence : string -> int
 
 val isUnaryExpression : Parsetree.expression -> bool
-val isBinaryOperator : string -> bool
-val isBinaryExpression : Parsetree.expression -> bool
+val isBinaryOperator : state:Res_printer_state.t -> string -> bool
+val isBinaryExpression :
+  state:Res_printer_state.t -> Parsetree.expression -> bool
 val isRhsBinaryOperator : string -> bool
 
 val flattenableOperators : string -> string -> bool
@@ -100,7 +101,8 @@ val isJsxExpression : Parsetree.expression -> bool
 val hasJsxAttribute : Parsetree.attributes -> bool
 val hasOptionalAttribute : Parsetree.attributes -> bool
 
-val shouldIndentBinaryExpr : Parsetree.expression -> bool
+val shouldIndentBinaryExpr :
+  state:Res_printer_state.t -> Parsetree.expression -> bool
 val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool
 val hasPrintableAttributes : Parsetree.attributes -> bool
 val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes