Undo let-bindings normalizations, carry out the args to remove the su…

…garing

lib/Fmt_ast.ml

@@ -2311,7 +2311,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
           $ fmt_atrs )
   | Pexp_let (lbs, body) ->
       let bindings =
-        Sugar.Let_binding.of_let_bindings c.cmts ~ctx lbs.pvbs_bindings
+        Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
       in
       let fmt_expr = fmt_expression c (sub_exp ~ctx body) in
       let ext = lbs.pvbs_extension in
@@ -2971,7 +2971,7 @@ and fmt_class_expr c ({ast= exp; ctx= ctx0} as xexp) =
         | _ -> c.conf.fmt_opts.indent_after_in.v
       in
       let bindings =
-        Sugar.Let_binding.of_let_bindings c.cmts ~ctx lbs.pvbs_bindings
+        Sugar.Let_binding.of_let_bindings ~ctx lbs.pvbs_bindings
       in
       let fmt_expr = fmt_class_expr c (sub_cl ~ctx body) in
       let has_attr = not (List.is_empty pcl_attributes) in
@@ -4340,7 +4340,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
       let fmt_item c ctx ~prev ~next b =
         let first = Option.is_none prev in
         let last = Option.is_none next in
-        let b = Sugar.Let_binding.of_let_binding c.cmts ~ctx ~first b in
+        let b = Sugar.Let_binding.of_let_binding ~ctx ~first b in
         let epi =
           match c.conf.fmt_opts.let_binding_spacing.v with
           | `Compact -> None

lib/Sugar.ml

@@ -149,82 +149,18 @@ module Let_binding = struct
     ; lb_attrs: attribute list
     ; lb_loc: Location.t }
 
-  let split_annot cmts xargs ({ast= body; _} as xbody) =
-    let ctx = Exp body in
-    match body.pexp_desc with
-    | Pexp_constraint (exp, typ)
-      when Source.type_constraint_is_first typ exp.pexp_loc ->
-        Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc
-          ~after:exp.pexp_loc ;
-        let exp_ctx =
-          (* The type constraint is moved to the pattern, so we need to
-             replace the context from [Pexp_constraint] to [Pexp_fun]. This
-             won't be necessary once the normalization is moved to
-             [Extended_ast]. *)
-          let pat = Ast_helper.Pat.any () in
-          let param =
-            { pparam_desc= Param_val (Nolabel, None, pat)
-            ; pparam_loc= pat.ppat_loc }
-          in
-          Exp (Ast_helper.Exp.fun_ param exp)
-        in
-        ( Some (Pvc_constraint {locally_abstract_univars= []; typ})
-        , sub_exp ~ctx:exp_ctx exp )
-    (* The type constraint is always printed before the declaration for
-       functions, for other value bindings we preserve its position. *)
-    | Pexp_constraint (exp, typ) when not (List.is_empty xargs) ->
-        Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc
-          ~after:exp.pexp_loc ;
-        ( Some (Pvc_constraint {locally_abstract_univars= []; typ})
-        , sub_exp ~ctx exp )
-    | Pexp_coerce (exp, typ1, typ2)
-      when Source.type_constraint_is_first typ2 exp.pexp_loc ->
-        Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc
-          ~after:exp.pexp_loc ;
-        (Some (Pvc_coercion {ground= typ1; coercion= typ2}), sub_exp ~ctx exp)
-    | _ -> (None, xbody)
-
-  let split_fun_args cmts xpat xbody =
-    let xargs, xbody =
-      match xpat.ast with
-      | {ppat_desc= Ppat_var _; ppat_attributes= []; _} ->
-          fun_ cmts ~will_keep_first_ast_node:false xbody
-      | _ -> ([], xbody)
-    in
-    let annot =
-      match (xbody.ast.pexp_desc, xpat.ast.ppat_desc) with
-      | Pexp_constraint _, Ppat_constraint _ -> (None, xbody)
-      | _ -> split_annot cmts xargs xbody
-    in
-    (xargs, annot)
-
-  let should_desugar_args pat typ =
-    match (pat.ast, typ) with
-    | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, None -> true
-    | _ -> false
-
-  let of_let_binding cmts ~ctx ~first
-      {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc}
-      =
-    let lb_exp = sub_exp ~ctx pvb_expr
-    and lb_pat = sub_pat ~ctx pvb_pat
-    and lb_typ = pvb_constraint in
-    let lb_args, (lb_typ, lb_exp) =
-      if should_desugar_args lb_pat lb_typ then
-        split_fun_args cmts lb_pat lb_exp
-      else ([], (lb_typ, lb_exp))
-    in
+  let of_let_binding ~ctx ~first vb =
     { lb_op= Location.{txt= (if first then "let" else "and"); loc= none}
-    ; lb_pat
-    ; lb_args
-    ; lb_typ
-    ; lb_exp
-    ; lb_pun= pvb_is_pun
-    ; lb_attrs= pvb_attributes
-    ; lb_loc= pvb_loc }
+    ; lb_pat= sub_pat ~ctx vb.pvb_pat
+    ; lb_args= vb.pvb_args
+    ; lb_typ= vb.pvb_constraint
+    ; lb_exp= sub_exp ~ctx vb.pvb_expr
+    ; lb_pun= vb.pvb_is_pun
+    ; lb_attrs= vb.pvb_attributes
+    ; lb_loc= vb.pvb_loc }
 
-  let of_let_bindings cmts ~ctx =
-    List.mapi ~f:(fun i -> of_let_binding cmts ~ctx ~first:(i = 0))
+  let of_let_bindings ~ctx =
+    List.mapi ~f:(fun i -> of_let_binding ~ctx ~first:(i = 0))
 
   let of_binding_ops bos =
     List.map bos ~f:(fun bo ->

lib/Sugar.mli

@@ -56,10 +56,9 @@ module Let_binding : sig
     ; lb_attrs: attribute list
     ; lb_loc: Location.t }
 
-  val of_let_binding :
-    Cmts.t -> ctx:Ast.t -> first:bool -> value_binding -> t
+  val of_let_binding : ctx:Ast.t -> first:bool -> value_binding -> t
 
-  val of_let_bindings : Cmts.t -> ctx:Ast.t -> value_binding list -> t list
+  val of_let_bindings : ctx:Ast.t -> value_binding list -> t list
 
   val of_binding_ops : binding_op list -> t list
 end

test/passing/tests/comments-no-wrap.ml.ref

@@ -114,7 +114,7 @@ end
 
 let f = (* comment *) function x -> x
 
-let foo x : z = (* comment *) y
+let foo x = (* comment *) (y : z)
 
 let _ =
   (*a*)
@@ -455,8 +455,4 @@ let _ =
 *)
   ()
 
-let vexpr (*aa*)
-    (type (*bb*) a
-    (*cc*)
-    (*dd*) b ) : _ -> _ =
-  (*ee*) k
+let vexpr (*aa*) (type (*bb*) a) (*cc*) (type (*dd*) b) (*ee*) : _ -> _ = k

test/passing/tests/comments.ml.ref

@@ -114,7 +114,7 @@ end
 
 let f = (* comment *) function x -> x
 
-let foo x : z = (* comment *) y
+let foo x = (* comment *) (y : z)
 
 let _ =
   (*a*)
@@ -454,8 +454,4 @@ let _ =
   (* indentation not preserved *)
   ()
 
-let vexpr (*aa*)
-    (type (*bb*) a
-    (*cc*)
-    (*dd*) b ) : _ -> _ =
-  (*ee*) k
+let vexpr (*aa*) (type (*bb*) a) (*cc*) (type (*dd*) b) (*ee*) : _ -> _ = k

test/passing/tests/js_args.ml.ref

@@ -9,7 +9,7 @@ let should_check_can_sell_and_marking regulatory_regime =
 let should_check_can_sell_and_marking regulatory_regime =
   match z with `foo -> some_function argument
 
-let f x = ghi x
+let f = fun x -> ghi x
 
 (* common *)
 let x = try x with a -> b | c -> d

test/passing/tests/js_source.ml.err

@@ -1,6 +1,6 @@
 Warning: tests/js_source.ml:162 exceeds the margin
-Warning: tests/js_source.ml:9546 exceeds the margin
-Warning: tests/js_source.ml:9650 exceeds the margin
-Warning: tests/js_source.ml:9709 exceeds the margin
-Warning: tests/js_source.ml:9791 exceeds the margin
-Warning: tests/js_source.ml:10290 exceeds the margin
+Warning: tests/js_source.ml:9552 exceeds the margin
+Warning: tests/js_source.ml:9656 exceeds the margin
+Warning: tests/js_source.ml:9715 exceeds the margin
+Warning: tests/js_source.ml:9797 exceeds the margin
+Warning: tests/js_source.ml:10296 exceeds the margin

test/passing/tests/js_source.ml.ocp

@@ -812,7 +812,7 @@ open Typ
 let int = Int TypEq.refl
 let str = String TypEq.refl
 
-let pair (type s1 s2) t1 t2 =
+let pair (type s1) (type s2) t1 t2 =
   let module P = struct
     type t = s1 * s2
     type t1 = s1
@@ -2418,7 +2418,13 @@ type (_, _, _) binop =
   | Leq : ('a, 'a, bool) binop
   | Add : (int, int, int) binop
 
-let eval (type a b c) (bop : (a, b, c) binop) (x : a constant) (y : b constant)
+let eval
+      (type a)
+      (type b)
+      (type c)
+      (bop : (a, b, c) binop)
+      (x : a constant)
+      (y : b constant)
   : c constant
   =
   match bop, x, y with
@@ -2663,7 +2669,7 @@ let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> vis
     | Global -> fun _ -> raise Exit
 ;;
 
-let vexpr (type result visit_action)
+let vexpr (type result) (type visit_action)
   : (unit, result, visit_action) context -> unit -> visit_action
   = function
     | Local -> fun _ -> raise Exit
@@ -3500,7 +3506,7 @@ end =
 let int = Typ.Int TypEq.refl
 let str = Typ.String TypEq.refl
 
-let pair (type s1 s2) t1 t2 =
+let pair (type s1) (type s2) t1 t2 =
   let module P = struct
     type t = s1 * s2
     type t1 = s1
@@ -3540,7 +3546,7 @@ end
 type ('k, 'd, 'm) map =
   (module MapT with type key = 'k and type data = 'd and type map = 'm)
 
-let add (type k d m) (m : (k, d, m) map) x y s =
+let add (type k) (type d) (type m) (m : (k, d, m) map) x y s =
   let module M = (val m : MapT with type key = k and type data = d and type map = m) in
   M.of_t (M.add x y (M.to_t s))
 ;;
@@ -4572,7 +4578,7 @@ type foo =
 
 type bar = { x : int }
 
-let f (r : bar) : foo = { r with z = 3 }
+let f (r : bar) = ({ r with z = 3 } : foo)
 
 type foo = { x : int }
 
@@ -4626,8 +4632,8 @@ module Hash2 : sig
 end =
   Hash
 
-let f1 (x : (_, _) Hash1.t) : (_, _) Hashtbl.t = x
-let f2 (x : (_, _) Hash2.t) : (_, _) Hashtbl.t = x
+let f1 (x : (_, _) Hash1.t) = (x : (_, _) Hashtbl.t)
+let f2 (x : (_, _) Hash2.t) = (x : (_, _) Hashtbl.t)
 
 (* Another case, not using include *)
 
@@ -4640,7 +4646,7 @@ end
 module Std' = Std2
 module M' : module type of Std'.M = Std2.M
 
-let f3 (x : M'.t) : Std2.M.t = x
+let f3 (x : M'.t) = (x : Std2.M.t)
 
 (* original report required Core_kernel:
    module type S = sig
@@ -5040,7 +5046,7 @@ module Fix (F : sig
 struct
   type 'a fix = ('a, 'a F.f) eq
 
-  let uniq (type a b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
+  let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
 end
 
 (* This would allow:
@@ -5569,7 +5575,7 @@ module S = String
 module StringSet = Set.Make (String)
 module SSet = Set.Make (S)
 
-let f (x : StringSet.t) : SSet.t = x
+let f (x : StringSet.t) = (x : SSet.t)
 
 (* Also using include (cf. Leo's mail 2013-11-16) *)
 module F (M : sig end) : sig
@@ -5925,7 +5931,7 @@ end
 
 (* ok to convert between structurally equal signatures, and parameters
    are inferred *)
-let f (x : (module S with type t = 'a and type u = 'b)) : (module S') = x
+let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'))
 let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'))
 
 (* with subtyping it is also ok to forget some types *)
@@ -5937,10 +5943,10 @@ end
 
 let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S'))
 let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a))
-let f2 (x : (module S2 with type t = 'a and type u = 'b)) : (module S') = x
+let f2 (x : (module S2 with type t = 'a and type u = 'b)) = (x : (module S'))
 
 (* fail *)
-let k (x : (module S2 with type t = 'a)) : (module S with type t = 'a) = x
+let k (x : (module S2 with type t = 'a)) = (x : (module S with type t = 'a))
 
 (* fail *)
 
@@ -6485,7 +6491,7 @@ type refer1 = < poly : 'a 'b 'c. (('b, 'c) #Classdef.cl2 as 'a) >
 type refer2 = < poly : 'a 'b 'c. (('b, 'c) #Classdef.cl2 as 'a) >
 
 (* Actually this should succeed ... *)
-let f (x : refer1) : refer2 = x
+let f (x : refer1) = (x : refer2)
 
 module Classdef = struct
   class virtual ['a, 'b, 'c] cl0 =
@@ -6519,7 +6525,7 @@ end
 open Pr3918b
 
 let f x = (x : 'a vlist :> 'b vlist)
-let f (x : 'a vlist) : 'b vlist = x
+let f (x : 'a vlist) = (x : 'b vlist)
 
 module type Poly = sig
   type 'a t = 'a constraint 'a = [> ]
@@ -6730,13 +6736,13 @@ module F0 : sig
 end =
   Foobar
 
-let f (x : F0.t) : Foobar.t = x
+let f (x : F0.t) = (x : Foobar.t)
 
 (* fails *)
 
 module F = Foobar
 
-let f (x : F.t) : Foobar.t = x
+let f (x : F.t) = (x : Foobar.t)
 
 module M = struct
   type t = < m : int >
@@ -6803,7 +6809,7 @@ module Bar : sig
 end = struct
   type t = int
 
-  let f (x : int) : t = x
+  let f (x : int) = (x : t)
 end
 
 (* must fail *)
@@ -6904,7 +6910,7 @@ end
 
 module Test2 : module type of Test with type t = Test.t = Test
 
-let f (x : Test.t) : Test2.t = x
+let f (x : Test.t) = (x : Test2.t)
 let f Test2.A = ()
 let a = Test2.A
 
@@ -7240,7 +7246,7 @@ module PR_4758 = struct
     type t
   end
 
-  let f (x : F(C).t) : F(C').t = x
+  let f (x : F(C).t) = (x : F(C').t)
 end
 
 (* PR 4557 *)
@@ -7268,7 +7274,7 @@ module PR_4557 = struct
       type elt = X.t
       type t = XSet.t XMap.t
 
-      let compare x y = 0
+      let compare = fun x y -> 0
     end
 
     and ModSet : (Set.S with type elt = Mod.t) = Set.Make (Mod)
@@ -7298,7 +7304,7 @@ module F (X : Set.OrderedType) = struct
     type elt = X.t
     type t = XSet.t XMap.t
 
-    let compare x y = 0
+    let compare = fun x y -> 0
   end
 
   and ModSet : (Set.S with type elt = Mod.t) = Set.Make (Mod)
@@ -9360,7 +9366,7 @@ let g = function
   | { l1 = x; l2 = y; _ } -> ()
 ;;
 
-let h ?l:(p = 1) ?y:u ?(x = 3) = 2
+let h = fun ?l:(p = 1) ?y:u ?(x = 3) -> 2
 
 let _ = function
   | a, s, ba1, ba2, ba3, bg ->