Fix Ast_builder's value_binding to generate the correct pvb_constraint

CHANGES.md

@@ -1,6 +1,9 @@
 unreleased
 ----------
 
+- Make Ast_builder's default `value_binding` constructor generate the proper
+  `pvb_constraint` from the pattern and expression arguments.
+  (#<PR_NUMBER>, @NathanReb)
 - Fix pprintast to output correct syntax from `Ppat_constraint (pat, Ptyp_poly ...)`
   nodes until they are completely dropped. (#588, @NathanReb)
 

src/ast_builder.ml

@@ -1,5 +1,126 @@
 open! Import
 
+(* Converts a pair of [pattern] and [expression] for value_binding to
+   the proper triple [pattern], [expression] and [pvb_constraint]. *)
+let to_pvb_constraint ~pvb_pat ~pvb_expr =
+  (* Copied and adapted from OCaml 5.0 Ast_helper *)
+  let varify_constructors var_names t =
+    let var_names = List.map ~f:(fun v -> v.Location.txt) var_names in
+    let rec loop t =
+      let desc =
+        match t.ptyp_desc with
+        | Ptyp_any -> Ptyp_any
+        | Ptyp_var x -> Ptyp_var x
+        | Ptyp_arrow (label, core_type, core_type') ->
+            Ptyp_arrow (label, loop core_type, loop core_type')
+        | Ptyp_tuple lst -> Ptyp_tuple (List.map ~f:loop lst)
+        | Ptyp_constr ({ txt = Longident.Lident s; _ }, [])
+          when List.mem s ~set:var_names ->
+            Ptyp_var s
+        | Ptyp_constr (longident, lst) ->
+            Ptyp_constr (longident, List.map ~f:loop lst)
+        | Ptyp_object (lst, o) ->
+            Ptyp_object (List.map ~f:loop_object_field lst, o)
+        | Ptyp_class (longident, lst) ->
+            Ptyp_class (longident, List.map ~f:loop lst)
+        | Ptyp_alias (core_type, string) -> Ptyp_alias (loop core_type, string)
+        | Ptyp_variant (row_field_list, flag, lbl_lst_option) ->
+            Ptyp_variant
+              (List.map ~f:loop_row_field row_field_list, flag, lbl_lst_option)
+        | Ptyp_poly (string_lst, core_type) ->
+            Ptyp_poly (string_lst, loop core_type)
+        | Ptyp_package (longident, lst) ->
+            Ptyp_package
+              (longident, List.map ~f:(fun (n, typ) -> (n, loop typ)) lst)
+        | Ptyp_open (longident, typ) -> Ptyp_open (longident, loop typ)
+        | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg)
+      in
+      { t with ptyp_desc = desc }
+    and loop_row_field field =
+      let prf_desc =
+        match field.prf_desc with
+        | Rtag (label, flag, lst) -> Rtag (label, flag, List.map ~f:loop lst)
+        | Rinherit t -> Rinherit (loop t)
+      in
+      { field with prf_desc }
+    and loop_object_field field =
+      let pof_desc =
+        match field.pof_desc with
+        | Otag (label, t) -> Otag (label, loop t)
+        | Oinherit t -> Oinherit (loop t)
+      in
+      { field with pof_desc }
+    in
+    loop t
+  in
+  (* Match the form of the expr and pattern to decide the value of
+     [pvb_constraint]. Adapted from OCaml 5.0 PPrinter. *)
+  let tyvars_str tyvars = List.map ~f:(fun v -> v.Location.txt) tyvars in
+  let resugarable_value_binding p e =
+    let value_pattern =
+      match p with
+      | {
+       ppat_desc =
+         Ppat_constraint
+           ( ({ ppat_desc = Ppat_var _; _ } as pat),
+             ({ ptyp_desc = Ptyp_poly (args_tyvars, rt); _ } as ty_ext) );
+       ppat_attributes = [];
+       _;
+      } ->
+          assert (match rt.ptyp_desc with Ptyp_poly _ -> false | _ -> true);
+          let ty = match args_tyvars with [] -> rt | _ -> ty_ext in
+          `Var (pat, args_tyvars, rt, ty)
+      | { ppat_desc = Ppat_constraint (pat, rt); ppat_attributes = []; _ } ->
+          `NonVar (pat, rt)
+      | _ -> `None
+    in
+    let rec value_exp tyvars e =
+      match e with
+      | { pexp_desc = Pexp_newtype (tyvar, e); pexp_attributes = []; _ } ->
+          value_exp (tyvar :: tyvars) e
+      | { pexp_desc = Pexp_constraint (e, ct); pexp_attributes = []; _ } ->
+          Some (List.rev tyvars, e, ct)
+      | _ -> None
+    in
+    let value_exp = value_exp [] e in
+    match (value_pattern, value_exp) with
+    | `Var (p, pt_tyvars, pt_ct, extern_ct), Some (e_tyvars, inner_e, e_ct)
+      when List.equal ~eq:String.equal (tyvars_str pt_tyvars)
+             (tyvars_str e_tyvars) ->
+        let ety = varify_constructors e_tyvars e_ct in
+        if Poly.(ety = pt_ct) then
+          `Desugared_locally_abstract (p, pt_tyvars, e_ct, inner_e)
+        else
+          (* the expression constraint and the pattern constraint,
+           don't match, but we still have a Ptyp_poly pattern constraint that
+           should be resugared to a value binding *)
+          `Univars (p, pt_tyvars, extern_ct, e)
+    | `Var (p, pt_tyvars, _pt_ct, extern_ct), _ ->
+        `Univars (p, pt_tyvars, extern_ct, e)
+    | `NonVar (pat, ct), _ -> `NonVar (pat, ct, e)
+    | _ -> `None
+  in
+  let with_constraint ty_vars typ =
+    Some (Pvc_constraint { locally_abstract_univars = ty_vars; typ })
+  in
+  match resugarable_value_binding pvb_pat pvb_expr with
+  | `Desugared_locally_abstract (p, ty_vars, typ, e) ->
+      (p, e, with_constraint ty_vars typ)
+  | `Univars (pat, [], ct, expr) -> (
+      (* check if we are in the [let x : ty? :> coer = expr ] case *)
+      match expr with
+      | {
+       pexp_desc = Pexp_coerce (expr, ground, coercion);
+       pexp_attributes = [];
+       _;
+      } ->
+          let pvb_constraint = Some (Pvc_coercion { ground; coercion }) in
+          (pat, expr, pvb_constraint)
+      | _ -> (pat, expr, with_constraint [] ct))
+  | `Univars (pat, _, ct, expr) -> (pat, expr, with_constraint [] ct)
+  | `NonVar (p, typ, e) -> (p, e, with_constraint [] typ)
+  | `None -> (pvb_pat, pvb_expr, None)
+
 module Default = struct
   module Located = struct
     type 'a t = 'a Loc.t
@@ -59,7 +180,10 @@ module Default = struct
     add_fun_params ~loc None [ param ] e
 
   let value_binding ~loc ~pat ~expr =
-    value_binding ~loc ~pat ~expr ~constraint_:None
+    let pat, expr, constraint_ =
+      to_pvb_constraint ~pvb_pat:pat ~pvb_expr:expr
+    in
+    value_binding ~loc ~pat ~expr ~constraint_
 
   let constructor_declaration ~loc ~name ~args ~res =
     {

test/ast_builder_value_binding/dune

@@ -0,0 +1,12 @@
+(rule
+ (package ppxlib)
+ (alias runtest)
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

test/ast_builder_value_binding/test.ml

@@ -0,0 +1,196 @@
+open Ppxlib
+
+(* This file contains tests to ensure that [Ast_builder.value_binding] properly
+   translates the given [pattern] and [expression] pair into the correct
+   [pattern], [expression] and [value_constraint] triple. *)
+
+
+(* ------- Test Setup -------- *)
+
+#install_printer Pp_ast.Default.structure_item;;
+#install_printer Pp_ast.Default.expression;;
+#install_printer Pp_ast.Default.pattern;;
+
+let loc = Location.none
+[%%ignore]
+
+(* --------- Simple case, no translation --------- *)
+
+let pat = [%pat? f]
+let expr = [%expr fun x -> x + 1]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body
+                  (Pexp_apply
+                     ( Pexp_ident (Lident "+")
+                     , [ ( Nolabel, Pexp_ident (Lident "x"))
+                       ; ( Nolabel
+                         , Pexp_constant (Pconst_integer ( "1", None))
+                         )
+                       ]
+                     ))
+              )
+        ; pvb_constraint = None
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the [pvb_constraint] field is none, the pattern and
+   expression are used as is. *)
+
+(* --------- No var Ppat_constraint to pvb_constraint --------- *)
+
+let pat = [%pat? (x : int)]
+let expr = [%expr 12]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "x"
+        ; pvb_expr = Pexp_constant (Pconst_integer ( "12", None))
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ = Ptyp_constr ( Lident "int", [])
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- poly Ppat_constraint to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun x -> unit]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ =
+                     Ptyp_poly
+                       ( [ "a"]
+                       , Ptyp_arrow
+                           ( Nolabel
+                           , Ptyp_var "a"
+                           , Ptyp_constr ( Lident "unit", [])
+                           )
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- desugared locally abstract univars to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun (type a) -> (fun _ -> unit : a -> unit)]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_any)
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = [ "a"]
+                 ; typ =
+                     Ptyp_arrow
+                       ( Nolabel
+                       , Ptyp_constr ( Lident "a", [])
+                       , Ptyp_constr ( Lident "unit", [])
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the matching constraint from the pattern and expression or
+   recombined into a single value constraint with locally abstract univars set
+   correctly. *)
+
+(* --------- coercion to pvb_constraint --------- *)
+
+(*TODO*)

test/pprintast/oldschool-constraints/pprint_ppat_constraint.ml

@@ -12,8 +12,23 @@ let ast =
            [%type: 'a -> unit])
     in
     let expr = [%expr fun _ -> ()] in
+    (* It is important that this is either built using [Latest.value_binding]
+       or assembled manually as [Ast_builder.Defaut.value_binding] will
+       generate a pvb_constraint, entirely defeatin the test's purpose. *)
     [ 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
+let print_source () = Format.printf "%a\n" Pprintast.structure_item ast
+let print_ast () = Format.printf "%a\n" Pp_ast.Default.structure_item ast
+
+let () =
+  match Sys.argv with
+  | [| _exec |] -> print_source ()
+  | [| _exec; _flag |] ->
+      print_ast ();
+      Format.printf "------- PRINTED AS -------\n";
+      print_source ()
+  | _ ->
+      Printf.eprintf "Invalid usage!";
+      exit 1