Fix pprintast with ppat_constraint in let bindings

CHANGES.md

@@ -1,6 +1,9 @@
 unreleased
 ----------
 
+- Fix pprintast to output correct syntax from `Ppat_constraint (pat, Ptyp_poly ...)`
+  nodes until they are completely dropped. (#588, @NathanReb)
+
 0.36.1 (2025-07-10)
 -------------------
 

astlib/pprintast.ml

@@ -27,6 +27,10 @@
    - Replaced [Lexer.is_keyword] with [Keyword.is_keyword] for compat with
      Ocaml < 5.2.
    - Added [class_signature] and [type_declaration] entry points at the end.
+   - Added a custom case to `binding` to print specific instances of
+     [Ppat_constraint (p, typ)] in [value_binding] patterns as if they were encoded
+     using the new [pvb_constraint] field instead of producing incorrect syntax as
+     the compiler version does.
 *)
 
 open Ast_502
@@ -1337,26 +1341,31 @@ and binding ctxt f { pvb_pat = p; pvb_expr = x; pvb_constraint = ct; _ } =
           pp f "(type@ %a)@ %a" ident_of_name str.txt pp_print_pexp_function e
       | _ -> pp f "=@;%a" (expression ctxt) x
   in
-  match ct with
-  | Some (Pvc_constraint { locally_abstract_univars = []; typ }) ->
+  match (ct, p) with
+  | ( None,
+      {
+        ppat_attributes = [];
+        ppat_desc =
+          Ppat_constraint
+            (({ ppat_desc = Ppat_var _; ppat_attributes = [] } as p), typ);
+      } )
+  | Some (Pvc_constraint { locally_abstract_univars = []; typ }), p ->
       pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) typ
         (expression ctxt) x
-  | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) ->
+  | Some (Pvc_constraint { locally_abstract_univars = vars; typ }), _ ->
       pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p
         (list pp_print_string ~sep:"@;")
         (List.map (fun x -> x.txt) vars)
         (core_type ctxt) typ (expression ctxt) x
-  | Some (Pvc_coercion { ground = None; coercion }) ->
+  | Some (Pvc_coercion { ground = None; coercion }), _ ->
       pp f "%a@;:>@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) coercion
         (expression ctxt) x
-  | Some (Pvc_coercion { ground = Some ground; coercion }) ->
+  | Some (Pvc_coercion { ground = Some ground; coercion }), _ ->
       pp f "%a@;:%a@;:>@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt)
         ground (core_type ctxt) coercion (expression ctxt) x
-  | None -> (
-      match p with
-      | { ppat_desc = Ppat_var _; ppat_attributes = [] } ->
-          pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
-      | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x)
+  | None, { ppat_desc = Ppat_var _; ppat_attributes = [] } ->
+      pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
+  | _, _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
 
 (* [in] is not printed *)
 and bindings ctxt f (rf, l) =

test/pprintast/oldschool-constraints/dune

@@ -0,0 +1,9 @@
+(executables
+ (names pprint_pvb_constraint pprint_ppat_constraint)
+ (libraries ppxlib astlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps pprint_pvb_constraint.exe pprint_ppat_constraint.exe))

test/pprintast/oldschool-constraints/pprint_ppat_constraint.ml

@@ -0,0 +1,19 @@
+open Ppxlib
+
+let loc = Location.none
+
+let ast =
+  let vbs =
+    let pat =
+      Ast_builder.Default.ppat_constraint ~loc
+        [%pat? f]
+        (Ast_builder.Default.ptyp_poly ~loc
+           [ Loc.make ~loc "a" ]
+           [%type: 'a -> unit])
+    in
+    let expr = [%expr fun _ -> ()] in
+    [ Ast_builder.Default.Latest.value_binding ~loc ~pat ~expr () ]
+  in
+  Ast_builder.Default.pstr_value ~loc Nonrecursive vbs
+
+let () = Format.printf "%a\n" Pprintast.structure_item ast

test/pprintast/oldschool-constraints/pprint_pvb_constraint.ml

@@ -0,0 +1,23 @@
+open Ppxlib
+
+let loc = Location.none
+
+let ast =
+  let vbs =
+    let pat = [%pat? f] in
+    let expr = [%expr fun _ -> ()] in
+    let constraint_ =
+      Pvc_constraint
+        {
+          locally_abstract_univars = [];
+          typ =
+            Ast_builder.Default.ptyp_poly ~loc
+              [ Loc.make ~loc "a" ]
+              [%type: 'a -> unit];
+        }
+    in
+    [ Ast_builder.Default.Latest.value_binding ~loc ~pat ~expr ~constraint_ () ]
+  in
+  Ast_builder.Default.pstr_value ~loc Nonrecursive vbs
+
+let () = Format.printf "%a\n" Pprintast.structure_item ast

test/pprintast/oldschool-constraints/run.t

@@ -0,0 +1,22 @@
+We have two executables that prints the same bit of code:
+let f : 'a . 'a -> unit = ()
+but represented with different ASTs: pprint_pvb_constraint encodes the type
+constraint in the pvb_constraint field of the value_binding while
+pprint_ppat_constraint encodes it in the pvb_pat field, i.e. the legacy way.
+
+
+  $ ./pprint_pvb_constraint.exe
+  let f : 'a . 'a -> unit = fun _ -> ()
+
+  $ ./pprint_ppat_constraint.exe
+  let f : 'a . 'a -> unit = fun _ -> ()
+
+The legacy gets printed the same way as the pvb_constraint version to allow both
+representation to coexist. The compiler's pprintast doesn't support it and prints
+an incorrect syntax that does not parse. The compiler itself still seems to accept
+such ASTs though, hence why we modified our pprintast to allow those.
+
+The output should be accepted by the parser:
+
+  $ ./pprint_ppat_constraint.exe > test.ml
+  $ ocamlc test.ml