Reuse type 'value_constraint' instead of redefining constraint type f…

…or Let_binding.t

lib/Ast.ml

@@ -639,6 +639,7 @@ module T = struct
     | Pat of pattern
     | Exp of expression
     | Fp of function_param
+    | Vc of value_constraint
     | Lb of value_binding
     | Mb of module_binding
     | Md of module_declaration
@@ -660,6 +661,7 @@ module T = struct
     | Pat p -> Format.fprintf fs "Pat:@\n%a" Printast.pattern p
     | Exp e -> Format.fprintf fs "Exp:@\n%a" Printast.expression e
     | Fp p -> Format.fprintf fs "Fp:@\n%a" Printast.function_param p
+    | Vc c -> Format.fprintf fs "Vc:@\n%a" Printast.value_constraint c
     | Lb b -> Format.fprintf fs "Lb:@\n%a" Printast.value_binding b
     | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m
     | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m
@@ -693,6 +695,7 @@ let attributes = function
   | Pat x -> x.ppat_attributes
   | Exp x -> x.pexp_attributes
   | Fp _ -> []
+  | Vc _ -> []
   | Lb x -> x.pvb_attributes
   | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs
   | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs
@@ -715,6 +718,7 @@ let location = function
   | Pat x -> x.ppat_loc
   | Exp x -> x.pexp_loc
   | Fp x -> x.pparam_loc
+  | Vc _ -> Location.none
   | Lb x -> x.pvb_loc
   | Mb x -> x.pmb_loc
   | Md x -> x.pmd_loc
@@ -908,12 +912,13 @@ end = struct
               List.exists t ~f:(fun x -> x.pap_type == typ)
           | _ -> false )
     in
-    let check_pvb pvb =
-      match pvb.pvb_constraint with
-      | Some (Pvc_constraint {typ= typ'; _}) -> typ' == typ
-      | Some (Pvc_coercion {ground; coercion}) ->
+    let check_value_constraint = function
+      | Pvc_constraint {typ= typ'; _} -> typ' == typ
+      | Pvc_coercion {ground; coercion} ->
           coercion == typ || Option.exists ground ~f:(fun x -> x == typ)
-      | None -> false
+    in
+    let check_pvb pvb =
+      Option.exists pvb.pvb_constraint ~f:check_value_constraint
     in
     let check_let_bindings lbs =
       List.exists lbs.pvbs_bindings ~f:check_pvb
@@ -992,6 +997,7 @@ end = struct
       | Pexp_let (lbs, _) -> assert (check_let_bindings lbs)
       | _ -> assert false )
     | Fp _ -> assert false
+    | Vc c -> assert (check_value_constraint c)
     | Lb _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1041,14 +1047,6 @@ end = struct
       | Pstr_extension ((_, PTyp t), _) -> assert (t == typ)
       | Pstr_extension (_, _) -> assert false
       | Pstr_value {pvbs_bindings; _} ->
-          let check_pvb pvb =
-            match pvb.pvb_constraint with
-            | Some (Pvc_constraint {typ= typ'; _}) -> typ' == typ
-            | Some (Pvc_coercion {ground; coercion}) ->
-                coercion == typ
-                || Option.exists ground ~f:(fun x -> x == typ)
-            | None -> false
-          in
           assert (List.exists pvbs_bindings ~f:check_pvb)
       | _ -> assert false )
     | Clf {pcf_desc; _} ->
@@ -1108,6 +1106,7 @@ end = struct
     match (ctx : t) with
     | Exp _ -> assert false
     | Fp _ -> assert false
+    | Vc _ -> assert false
     | Lb _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1176,6 +1175,7 @@ end = struct
     match (ctx : t) with
     | Exp _ -> assert false
     | Fp _ -> assert false
+    | Vc _ -> assert false
     | Lb _ -> assert false
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1301,6 +1301,7 @@ end = struct
       | Pexp_for (p, _, _, _, _) -> assert (p == pat)
       | Pexp_fun (p, _) -> assert (check_function_param p) )
     | Fp ctx -> assert (check_function_param ctx)
+    | Vc _ -> assert false
     | Lb x -> assert (x.pvb_pat == pat)
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1431,6 +1432,7 @@ end = struct
             assert (e1 == exp || e2 == exp || e3 == exp)
         | Pexp_override e1N -> assert (List.exists e1N ~f:snd_f) )
     | Fp ctx -> assert (check_function_param ctx)
+    | Vc _ -> assert false
     | Lb x -> assert (x.pvb_expr == exp)
     | Mb _ -> assert false
     | Md _ -> assert false
@@ -1683,6 +1685,8 @@ end = struct
           | Str _ | Clf _ | Ctf _ | Rep | Mb _ | Md _ ) }
      |{ctx= Fp _; ast= _}
      |{ctx= _; ast= Fp _}
+     |{ctx= Vc _; ast= _}
+     |{ctx= _; ast= Vc _}
      |{ctx= Lb _; ast= _}
      |{ctx= _; ast= Lb _}
      |{ctx= Td _; ast= _}
@@ -1767,6 +1771,7 @@ end = struct
       | Pexp_send _ -> Some Dot
       | _ -> None )
     | Fp _ -> None
+    | Vc _ -> None
     | Lb _ -> None
     | Cl c -> (
       match c.pcl_desc with

lib/Ast.mli

@@ -111,6 +111,7 @@ type t =
   | Pat of pattern
   | Exp of expression
   | Fp of function_param
+  | Vc of value_constraint
   | Lb of value_binding
   | Mb of module_binding
   | Md of module_declaration

lib/Fmt_ast.ml

@@ -4360,6 +4360,41 @@ and fmt_let c ~ext ~rec_flag ~bindings ~parens ~fmt_atrs ~fmt_expr ~body_loc
        $ hvbox 0 fmt_expr ) )
   $ fmt_atrs
 
+and fmt_value_constraint c vc_opt =
+  let fmt_sep x =
+    match c.conf.fmt_opts.break_colon.v with
+    | `Before -> fmt "@ " $ str x $ char ' '
+    | `After -> char ' ' $ str x $ fmt "@ "
+  in
+  match vc_opt with
+  | Some vc -> (
+      let ctx = Vc vc in
+      match vc with
+      | Pvc_constraint {locally_abstract_univars= []; typ} ->
+          (noop, fmt_type_cstr c (sub_typ ~ctx typ))
+      | Pvc_constraint {locally_abstract_univars= pvars; typ} -> (
+        match c.conf.fmt_opts.break_colon.v with
+        | `Before ->
+            ( noop
+            , fmt_sep ":"
+              $ hvbox 0
+                  ( str "type "
+                  $ list pvars " " (fmt_str_loc c)
+                  $ fmt ".@ "
+                  $ fmt_core_type c (sub_typ ~ctx typ) ) )
+        | `After ->
+            ( fmt_sep ":"
+              $ hvbox 0
+                  (str "type " $ list pvars " " (fmt_str_loc c) $ str ".")
+            , fmt "@ " $ fmt_core_type c (sub_typ ~ctx typ) ) )
+      | Pvc_coercion {ground; coercion} ->
+          ( noop
+          , opt ground (fun ty ->
+                fmt_sep ":" $ fmt_core_type c (sub_typ ~ctx ty) )
+            $ fmt_sep ":>"
+            $ fmt_core_type c (sub_typ ~ctx coercion) ) )
+  | None -> (noop, noop)
+
 and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
     {lb_op; lb_pat; lb_args; lb_typ; lb_exp; lb_attrs; lb_loc; lb_pun} =
   update_config_maybe_disabled c lb_loc lb_attrs
@@ -4371,33 +4406,7 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
   in
   let doc1, atrs = doc_atrs lb_attrs in
   let doc2, atrs = doc_atrs atrs in
-  let fmt_newtypes, fmt_cstr =
-    let fmt_sep x =
-      match c.conf.fmt_opts.break_colon.v with
-      | `Before -> fmt "@ " $ str x $ char ' '
-      | `After -> char ' ' $ str x $ fmt "@ "
-    in
-    match lb_typ with
-    | `Polynewtype (pvars, xtyp) -> (
-      match c.conf.fmt_opts.break_colon.v with
-      | `Before ->
-          ( noop
-          , fmt_sep ":"
-            $ hvbox 0
-                ( str "type "
-                $ list pvars " " (fmt_str_loc c)
-                $ fmt ".@ " $ fmt_core_type c xtyp ) )
-      | `After ->
-          ( fmt_sep ":"
-            $ hvbox 0 (str "type " $ list pvars " " (fmt_str_loc c) $ str ".")
-          , fmt "@ " $ fmt_core_type c xtyp ) )
-    | `Coerce (xtyp1, xtyp2) ->
-        ( noop
-        , opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1)
-          $ fmt_sep ":>" $ fmt_core_type c xtyp2 )
-    | `Other xtyp -> (noop, fmt_type_cstr c xtyp)
-    | `None -> (noop, noop)
-  in
+  let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in
   let indent =
     match lb_exp.ast.pexp_desc with
     | Pexp_function _ -> c.conf.fmt_opts.function_indent.v

lib/Sugar.ml

@@ -180,11 +180,7 @@ module Let_binding = struct
     { lb_op: string loc
     ; lb_pat: pattern xt
     ; lb_args: function_param list
-    ; lb_typ:
-        [ `Polynewtype of label loc list * core_type xt
-        | `Coerce of core_type xt option * core_type xt
-        | `Other of core_type xt
-        | `None ]
+    ; lb_typ: value_constraint option
     ; lb_exp: expression xt
     ; lb_pun: bool
     ; lb_attrs: attribute list
@@ -197,7 +193,6 @@ module Let_binding = struct
       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 typ_ctx = ctx in
         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
@@ -210,20 +205,25 @@ module Let_binding = struct
           in
           Exp (Ast_helper.Exp.fun_ param exp)
         in
-        (xargs, `Other (sub_typ ~ctx:typ_ctx typ), sub_exp ~ctx:exp_ctx exp)
+        ( xargs
+        , 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 ;
-        (xargs, `Other (sub_typ ~ctx typ), sub_exp ~ctx exp)
+        ( xargs
+        , 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 ;
-        let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in
-        (xargs, `Coerce (typ1, sub_typ ~ctx typ2), sub_exp ~ctx exp)
-    | _ -> (xargs, `None, xbody)
+        ( xargs
+        , Some (Pvc_coercion {ground= typ1; coercion= typ2})
+        , sub_exp ~ctx exp )
+    | _ -> (xargs, None, xbody)
 
   let split_fun_args cmts xpat xbody =
     let xargs, xbody =
@@ -233,7 +233,7 @@ module Let_binding = struct
       | _ -> ([], xbody)
     in
     match (xbody.ast.pexp_desc, xpat.ast.ppat_desc) with
-    | Pexp_constraint _, Ppat_constraint _ -> (xargs, `None, xbody)
+    | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, xbody)
     | _ -> split_annot cmts xargs xbody
 
   let type_cstr cmts ~ctx lb_pat lb_exp =
@@ -262,7 +262,7 @@ module Let_binding = struct
     let xbody = sub_exp ~ctx lb_exp in
     if
       (not (List.is_empty xbody.ast.pexp_attributes)) || pat_is_extension pat
-    then (xpat, [], `None, xbody)
+    then (xpat, [], None, xbody)
     else
       let xpat =
         match xpat.ast.ppat_desc with
@@ -273,26 +273,17 @@ module Let_binding = struct
       let xargs, typ, xbody = split_fun_args cmts xpat xbody in
       (xpat, xargs, typ, xbody)
 
-  let typ_of_pvb_constraint ~ctx = function
-    | Some (Pvc_constraint {locally_abstract_univars= []; typ}) ->
-        `Other (sub_typ ~ctx typ)
-    | Some (Pvc_constraint {locally_abstract_univars; typ}) ->
-        `Polynewtype (locally_abstract_univars, sub_typ ~ctx typ)
-    | Some (Pvc_coercion {ground; coercion}) ->
-        `Coerce (Option.map ground ~f:(sub_typ ~ctx), sub_typ ~ctx coercion)
-    | None -> `None
-
   let should_desugar_args pat typ =
     match (pat.ast, typ) with
-    | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, `None -> true
+    | {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 = typ_of_pvb_constraint ~ctx pvb_constraint in
+    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

lib/Sugar.mli

@@ -59,11 +59,7 @@ module Let_binding : sig
     { lb_op: string loc
     ; lb_pat: pattern Ast.xt
     ; lb_args: function_param list
-    ; lb_typ:
-        [ `Polynewtype of label loc list * core_type Ast.xt
-        | `Coerce of core_type Ast.xt option * core_type Ast.xt
-        | `Other of core_type Ast.xt
-        | `None ]
+    ; lb_typ: value_constraint option
     ; lb_exp: expression Ast.xt
     ; lb_pun: bool
     ; lb_attrs: attribute list

vendor/parser-extended/printast.ml

@@ -1231,3 +1231,5 @@ let structure_item ppf x = structure_item 0 ppf x
 let signature_item ppf x = signature_item 0 ppf x
 
 let function_param ppf x = function_param 0 ppf x
+
+let value_constraint ppf x = value_constraint 0 ppf x