Fix letop binary printing (#2624)

- also fixes ocamlmerlin-reason for letop syntax
- add compatibility with ocaml-syntax-shims

src/reason-merlin/ocamlmerlin_reason.cppo.ml

@@ -9,9 +9,15 @@ module Reason_reader = struct
   let load buffer = buffer
 
   let structure str =
+    let str =
+      Reason_syntax_util.(apply_mapper_to_structure str (backport_letopt_mapper remove_stylistic_attrs_mapper))
+    in
     Structure (Reason_toolchain.To_current.copy_structure str)
 
   let signature sg =
+    let sg =
+      Reason_syntax_util.(apply_mapper_to_signature sg (backport_letopt_mapper remove_stylistic_attrs_mapper))
+    in
     Signature (Reason_toolchain.To_current.copy_signature sg)
 
   let parse {text; path} =

src/reason-parser/reason_declarative_lexer.mll

@@ -635,9 +635,9 @@ rule token state = parse
   | '%' operator_chars*
     { INFIXOP3 (lexeme_operator lexbuf) }
   | "let" kwdopchar dotsymbolchar *
-    { LETOP (lexeme_operator lexbuf) }
+    { LETOP (Reason_syntax_util.expand_letop_identifier (lexeme_operator lexbuf)) }
   | "and" kwdopchar dotsymbolchar *
-    { ANDOP (lexeme_operator lexbuf) }
+    { ANDOP (Reason_syntax_util.expand_letop_identifier (lexeme_operator lexbuf)) }
   | eof { EOF }
   | _
     { raise_error

src/reason-parser/reason_pprint_ast.ml

@@ -469,9 +469,6 @@ let unary_plus_prefix_symbols  = ["~+"; "~+." ] ;;
 let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                       '$'; '%'; '\\'; '#' ]
 (* this should match "kwdopchar" from reason_declarative_lexer.mll *)
-let let_monad_symbols = [ '$'; '&'; '*'; '+'; '-'; '/'; '<'; '='; '>'; '@';
-                          '^'; '|'; '.'; '!']
-
 let special_infix_strings =
   ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "!=="]
 
@@ -482,20 +479,6 @@ let requireIndentFor = [updateToken; ":="]
 
 let namedArgSym = "~"
 
-let letop s =
-  String.length s > 3
-  && s.[0] = 'l'
-  && s.[1] = 'e'
-  && s.[2] = 't'
-  && List.mem s.[3] let_monad_symbols
-
-let andop s =
-  String.length s > 3
-  && s.[0] = 'a'
-  && s.[1] = 'n'
-  && s.[2] = 'd'
-  && List.mem s.[3] let_monad_symbols
-
 let requireNoSpaceFor tok =
   tok = pipeFirstToken || (tok.[0] = '#' && tok <> "#=")
 
@@ -531,8 +514,8 @@ let printedStringAndFixity = function
       else
         AlmostSimplePrefix s
   )
-  | s when letop s -> Letop s
-  | s when andop s -> Andop s
+  | s when is_letop s -> Letop s
+  | s when is_andop s -> Andop s
   | _ -> Normal
 
 
@@ -1979,7 +1962,14 @@ let typeApplicationFinalWrapping typeApplicationItems =
 
 (* add parentheses to binders when they are in fact infix or prefix operators *)
 let protectIdentifier txt =
-  if not (needs_parens txt) then atom txt
+  let needs_parens = needs_parens txt in
+  let txt =
+    if is_andop txt || is_letop txt then
+      Reason_syntax_util.compress_letop_identifier txt
+    else
+      txt
+  in
+  if not needs_parens then atom txt
   else if needs_spaces txt then makeList ~wrap:("(", ")") ~pad:(true, true) [atom txt]
   else atom ("(" ^ txt ^ ")")
 
@@ -5482,14 +5472,14 @@ let printer = object(self:'self)
         itemsLayout
 
   method letop_bindings { let_; ands } =
-    let label = let_.pbop_op.txt in
+    let label = compress_letop_identifier (let_.pbop_op.txt) in
     let let_item = self#binding_op label let_ in
     match ands with
     | [] -> let_item
     | l ->
       let and_items = List.map (fun x ->
         let loc = extractLocBindingOp x in
-        let layout = self#binding_op x.pbop_op.txt x in
+        let layout = self#binding_op (compress_letop_identifier x.pbop_op.txt) x in
         (loc, layout)
       ) l
       in

src/reason-parser/reason_syntax_util.cppo.ml

@@ -579,21 +579,145 @@ let remove_stylistic_attrs_mapper_maker super =
   end;
 }
 
+let escape_stars_slashes str =
+  if String.contains str '/' then
+    replace_string "/*" "/\\*" @@
+    replace_string "*/" "*\\/" @@
+    replace_string "//" "/\\/" @@
+    str
+  else
+    str
+
 let remove_stylistic_attrs_mapper =
   remove_stylistic_attrs_mapper_maker Ast_mapper.default_mapper
 
+let let_monad_symbols = [ '$'; '&'; '*'; '+'; '-'; '/'; '<'; '='; '>'; '@';
+                          '^'; '|'; '.'; '!']
+
+let is_letop s =
 #if OCAML_VERSION >= (4, 8, 0)
-let noop_mapper =
+  String.length s > 3
+#else
+  String.length s > 5
+#endif
+  && s.[0] = 'l'
+  && s.[1] = 'e'
+  && s.[2] = 't'
+#if OCAML_VERSION >= (4, 8, 0)
+  && List.mem s.[3] let_monad_symbols
+#else
+  && s.[3] = '_'
+  && s.[4] = '_'
+  && List.mem s.[5] let_monad_symbols
+#endif
+
+let is_andop s =
+#if OCAML_VERSION >= (4, 8, 0)
+  String.length s > 3
+#else
+  String.length s > 5
+#endif
+  && s.[0] = 'a'
+  && s.[1] = 'n'
+  && s.[2] = 'd'
+#if OCAML_VERSION >= (4, 8, 0)
+  && List.mem s.[3] let_monad_symbols
+#else
+  && s.[3] = '_'
+  && s.[4] = '_'
+  && List.mem s.[5] let_monad_symbols
+#endif
+
+#if OCAML_VERSION >= (4, 8, 0)
+let noop_mapper super =
   let noop = fun _mapper x -> x in
-  { Ast_mapper.default_mapper with
+  { super with
     expr = noop;
     structure = noop;
     structure_item = noop;
     signature = noop;
     signature_item = noop; }
 (* Don't need to backport past 4.08 *)
 let backport_letopt_mapper = noop_mapper
+let expand_letop_identifier s = s
+let compress_letop_identifier s = s
 #else
+  (* Adapted from https://github.com/ocaml-ppx/ocaml-syntax-shims, for
+   * compatibility with OCaml's own backporting. *)
+  let letop_table, reverse_letop_table =
+    let create_hashtable n l =
+      let t = Hashtbl.create n in
+      let rev_t = Hashtbl.create n in
+      List.iter (fun (k, v) ->
+        Hashtbl.add t k v;
+      Hashtbl.add rev_t v k;
+      ) l;
+      t, rev_t
+    in
+    create_hashtable 16 [
+      '!', "bang"
+    ; '$', "dollar"
+    ; '%', "percent"
+    ; '&', "ampersand"
+    ; '*', "star"
+    ; '+', "plus"
+    ; '-', "minus"
+    ; '/', "slash"
+    ; ':', "colon"
+    ; '<', "lesser"
+    ; '=', "equal"
+    ; '>', "greater"
+    ; '?', "question"
+    ; '@', "at"
+    ; '^', "circumflex"
+    ; '|', "pipe"
+    ]
+
+  let name s =
+    try Hashtbl.find letop_table s
+    with Not_found -> String.make 1 s
+
+  let rev_name s =
+    try String.make 1 (Hashtbl.find reverse_letop_table s)
+    with Not_found -> s
+
+  let split_on_char sep s =
+    let open String in
+    let r = ref [] in
+    let j = ref (length s) in
+    for i = length s - 1 downto 0 do
+      if unsafe_get s i = sep then begin
+        r := sub s (i + 1) (!j - i - 1) :: !r;
+        j := i
+      end
+    done;
+    sub s 0 !j :: !r
+
+  let compress_letop_identifier s =
+    let buf = Buffer.create 128 in
+    (* "let" or "and" *)
+    Buffer.add_string buf (String.sub s 0 3);
+    let s = String.sub s 5 (String.length s - 5) in
+    let segments = split_on_char '_' s in
+    let identifier = String.concat "" (List.map (function
+      | "" -> "_"
+      | segment -> rev_name segment) segments)
+    in
+    Buffer.add_string buf identifier;
+    escape_stars_slashes (Buffer.contents buf)
+
+  let expand_letop_identifier s =
+    let buf = Buffer.create 128 in
+    (* "let" or "and" *)
+    Buffer.add_string buf (String.sub s 0 3);
+    Buffer.add_string buf "__";
+    for i = 3 to String.length s - 1 do
+      if i > 3 then
+        Buffer.add_char buf '_';
+      Buffer.add_string buf (name s.[i])
+    done;
+    Buffer.contents buf
+
 (** This will convert Pexp_letop into a series of `apply`s to simulate 4.08's behavior.
  *
  * For example,
@@ -608,7 +732,7 @@ let backport_letopt_mapper = noop_mapper
  *
  * (let+)((and+)(y, b), ((x, a)) => x + a)
  *)
-let backport_letopt_mapper_maker super =
+let backport_letopt_mapper super =
   let open Ast_408 in
   let open Ast_mapper in
 { super with
@@ -654,20 +778,8 @@ let backport_letopt_mapper_maker super =
         ])}
     | _ -> super.expr mapper expr
 }
-
-let backport_letopt_mapper =
-  backport_letopt_mapper_maker Ast_mapper.default_mapper
 #endif
 
-let escape_stars_slashes str =
-  if String.contains str '/' then
-    replace_string "/*" "/\\*" @@
-    replace_string "*/" "*\\/" @@
-    replace_string "//" "/\\/" @@
-    str
-  else
-    str
-
 (** escape_stars_slashes_mapper escapes all stars and slashes in an AST *)
 let escape_stars_slashes_mapper = identifier_mapper escape_stars_slashes
 

src/reason-parser/reason_syntax_util.cppo.mli

@@ -38,7 +38,12 @@ val isLineComment : string -> bool
 
 val remove_stylistic_attrs_mapper : Ast_mapper.mapper
 
-val backport_letopt_mapper : Ast_mapper.mapper
+val is_letop : string -> bool
+val is_andop : string -> bool
+val compress_letop_identifier : string -> string
+val expand_letop_identifier : string -> string
+
+val backport_letopt_mapper : Ast_mapper.mapper -> Ast_mapper.mapper
 
 val escape_stars_slashes : string -> string
 

src/reason-parser/reason_toolchain_ocaml.ml

@@ -136,10 +136,9 @@ let format_interface_with_comments (signature, _) formatter =
     (To_current.copy_signature signature)
 let format_implementation_with_comments (structure, _) formatter =
   let structure =
-    Reason_syntax_util.(apply_mapper_to_structure structure remove_stylistic_attrs_mapper)
-  in
-  let structure =
-    Reason_syntax_util.(apply_mapper_to_structure structure backport_letopt_mapper)
+    Reason_syntax_util.(apply_mapper_to_structure
+      structure
+      (backport_letopt_mapper remove_stylistic_attrs_mapper))
   in
   Pprintast.structure formatter
     (To_current.copy_structure structure)

src/refmt/reason_implementation_printer.ml

@@ -51,18 +51,12 @@ let print printtype filename parsedAsML output_chan output_formatter =
   )
   | `Binary -> fun (ast, _) ->
     let ast =
-      Reason_syntax_util.(apply_mapper_to_structure ast remove_stylistic_attrs_mapper)
-    in
-    let ast =
-      Reason_syntax_util.(apply_mapper_to_structure ast backport_letopt_mapper)
+      Reason_syntax_util.(apply_mapper_to_structure ast (backport_letopt_mapper remove_stylistic_attrs_mapper))
     in
     Ast_io.to_channel output_chan filename
       (Ast_io.Impl ((module OCaml_current),
                     Reason_toolchain.To_current.copy_structure ast))
   | `AST -> fun (ast, _) -> (
-    let ast =
-      Reason_syntax_util.(apply_mapper_to_structure ast backport_letopt_mapper)
-    in
     Printast.implementation output_formatter
       (Reason_toolchain.To_current.copy_structure ast)
   )

src/refmt/reason_interface_printer.ml

@@ -49,6 +49,9 @@ let print printtype filename parsedAsML output_chan output_formatter =
     );
   )
   | `Binary -> fun (ast, _) -> (
+      let ast =
+        Reason_syntax_util.(apply_mapper_to_signature ast (backport_letopt_mapper remove_stylistic_attrs_mapper))
+      in
       Ast_io.to_channel output_chan filename
         (Ast_io.Intf ((module OCaml_current),
                       Reason_toolchain.To_current.copy_signature ast))
@@ -57,8 +60,6 @@ let print printtype filename parsedAsML output_chan output_formatter =
       Printast.interface output_formatter
         (Reason_toolchain.To_current.copy_signature ast)
   )
-  (* If you don't wrap the function in parens, it's a totally different
-   * meaning #thanksOCaml *)
   | `None -> (fun _ -> ())
   | `ML -> Reason_toolchain.ML.print_interface_with_comments output_formatter
   | `Reason -> Reason_toolchain.RE.print_interface_with_comments output_formatter