generate better asts for function bindings (#2651)

v-gb · web-flow · commit 5cc318b21438 · 2025-02-17T11:40:48.000+01:00
Currently:

```ocaml
let foo1 : _ = function () -&gt; ()
let foo2 x : _ = function () -&gt; ()
```

are parsed into these value_bindings:

```ocaml
  (* foo1 *)
  { pvb_args = []
  ; pvb_constraint = Some "_"
  ; pvb_body = Pfunction_cases ...
  }
  (* foo2 *)
  { pvb_args = ["x"]
  ; pvb_constraint = Some "_"
  ; pvb_body = Pfunction_cases ...
  }
```

I expect instead:

```ocaml
  (* foo1 *)
  { pvb_args = []
  ; pvb_constraint = Some "_"
  ; pvb_body = Pfunction_body (Pexp_function ([], None, Pfunction_cases ...))
  }
  (* foo2 (no changes here) *)
  { pvb_args = ["x"]
  ; pvb_constraint = Some "_"
  ; pvb_body = Pfunction_cases ...
  }
```

I think the ast for foo1:

- is confusing
- creates a needless distinction between
  `let f : _ = function () -&gt; ()` vs `let f : _ = (function () -&gt; ())`,
  unlike, say, `1 + function () -&gt; ()` vs `1 + (function () -&gt; ())`.
- is essentially an invariant violation. The type of value_bindings
  in ocamlformat should be understood to be the union of a non-function
  let-binding + an inline pexp_function node.
  But the node for foo1 corresponds to the syntax of neither a non-function
  let-binding (because of body = Pfunction_cases _), nor an inline
  pexp_function (because pexp_function can't have a type_constraint with
  an empty list of params).
diff --git a/CHANGES.md b/CHANGES.md
@@ -14,6 +14,9 @@ profile. This started with version 0.26.0.
 
 - Fixed `nested-match=align` not working with `match%ext` (#2648, @EmileTrotignon)
 
+- Fixed the AST generated for bindings of the form `let pattern : type = function ...`
+  (#2651, @v-gb)
+
 ## 0.27.0
 
 ### Highlight
diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
@@ -4586,9 +4586,15 @@ and fmt_value_binding c ~ctx0 ~rec_flag ?in_ ?epi
   in
   let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in
   let indent, intro_as_pro =
-    match lb_body.ast with
-    | Pfunction_cases _ -> (c.conf.fmt_opts.function_indent.v, true)
-    | Pfunction_body {pexp_desc= Pexp_function (_, _, _); _}
+    match (lb_args, lb_body.ast) with
+    | _, Pfunction_cases _
+     |( []
+      , Pfunction_body
+          { pexp_attributes= []
+          ; pexp_desc= Pexp_function ([], None, Pfunction_cases _)
+          ; _ } ) ->
+        (c.conf.fmt_opts.function_indent.v, true)
+    | _, Pfunction_body {pexp_desc= Pexp_function (_, _, _); _}
       when c.conf.fmt_opts.let_binding_deindent_fun.v ->
         (max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false)
     | _ -> (c.conf.fmt_opts.let_binding_indent.v, false)
diff --git a/test/passing/refs.janestreet/let_binding-deindent-fun.ml.ref b/test/passing/refs.janestreet/let_binding-deindent-fun.ml.ref
@@ -306,8 +306,7 @@ fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ ->
   match () with
   | _ -> ()
 
-let _
-  =
+let _ =
   (*
      An alternative would be to track 'mutability of the field'
      directly.
diff --git a/test/passing/refs.janestreet/let_binding-in_indent.ml.ref b/test/passing/refs.janestreet/let_binding-in_indent.ml.ref
@@ -306,8 +306,7 @@ fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ ->
   match () with
   | _ -> ()
 
-let _
-  =
+let _ =
   (*
      An alternative would be to track 'mutability of the field'
      directly.
diff --git a/test/passing/refs.janestreet/let_binding-indent.ml.ref b/test/passing/refs.janestreet/let_binding-indent.ml.ref
@@ -306,8 +306,7 @@ fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ ->
   match () with
   | _ -> ()
 
-let _
-  =
+let _ =
   (*
      An alternative would be to track 'mutability of the field'
      directly.
diff --git a/test/passing/refs.janestreet/let_binding.ml.ref b/test/passing/refs.janestreet/let_binding.ml.ref
@@ -306,8 +306,7 @@ fun xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx : _ ->
   match () with
   | _ -> ()
 
-let _
-  =
+let _ =
   (*
      An alternative would be to track 'mutability of the field'
      directly.
diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly
@@ -2619,30 +2619,30 @@ let_binding_body_no_punning:
     let_ident strict_binding(fun_body)
       { let args, tc, exp = $2 in
         ($1, args, tc, exp) }
-  | let_ident type_constraint EQUAL fun_body
+  | let_ident type_constraint EQUAL seq_expr
       { let v = $1 in (* PR#7344 *)
         let t =
           match $2 with
             Pconstraint t ->
              Pvc_constraint { locally_abstract_univars = []; typ=t }
           | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion}
         in
-        (v, [], Some t, $4)
+        (v, [], Some t, Pfunction_body $4)
       }
-  | let_ident COLON poly(core_type) EQUAL fun_body
+  | let_ident COLON poly(core_type) EQUAL seq_expr
     {
       let t = ghtyp ~loc:($loc($3)) $3 in
-      ($1, [], Some (Pvc_constraint { locally_abstract_univars = []; typ=t }), $5)
+      ($1, [], Some (Pvc_constraint { locally_abstract_univars = []; typ=t }), Pfunction_body $5)
     }
-  | let_ident COLON TYPE lident_list DOT core_type EQUAL fun_body
+  | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
     { let constraint' =
         Pvc_constraint { locally_abstract_univars=$4; typ = $6}
       in
-      ($1, [], Some constraint', $8) }
-  | pattern_no_exn EQUAL fun_body
-      { ($1, [], None, $3) }
-  | simple_pattern_not_ident COLON core_type EQUAL fun_body
-      { ($1, [], Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 }), $5) }
+      ($1, [], Some constraint', Pfunction_body $8) }
+  | pattern_no_exn EQUAL seq_expr
+      { ($1, [], None, Pfunction_body $3) }
+  | simple_pattern_not_ident COLON core_type EQUAL seq_expr
+      { ($1, [], Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 }), Pfunction_body $5) }
 ;
 let_binding_body:
   | let_binding_body_no_punning
