Define type 'type_constraint' (#2464)

lib/Ast.ml

@@ -981,8 +981,10 @@ end = struct
       | Pexp_object _ -> assert false
       | Pexp_record (en1, _) ->
           assert (
-            List.exists en1 ~f:(fun (_, (t1, t2), _) ->
-                Option.exists t1 ~f || Option.exists t2 ~f ) )
+            List.exists en1 ~f:(fun (_, c, _) ->
+                Option.exists c ~f:(function
+                  | Pconstraint t -> f t
+                  | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2 ) ) )
       | Pexp_let (lbs, _) -> assert (check_let_bindings lbs)
       | _ -> assert false )
     | Lb _ -> assert false
@@ -1501,9 +1503,8 @@ end = struct
         List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp)
     | Pexp_record (e1N, e0) ->
         Option.for_all e0 ~f:Exp.is_trivial
-        && List.for_all e1N ~f:(fun (_, (ct1, ct2), eo) ->
-               Option.is_none ct1 && Option.is_none ct2
-               && Option.for_all eo ~f:Exp.is_trivial )
+        && List.for_all e1N ~f:(fun (_, c, eo) ->
+               Option.is_none c && Option.for_all eo ~f:Exp.is_trivial )
         && fit_margin c (width xexp)
     | Pexp_indexop_access {pia_lhs; pia_kind; pia_rhs= None; _} ->
         Exp.is_trivial pia_lhs

lib/Extended_ast.ml

@@ -69,8 +69,21 @@ module Parse = struct
         when Std_longident.field_alias ~field:f.txt v_txt ->
           (f, t, None)
       (* [{ x = (x : t) }] -> [{ x : t }] *)
+      | ( None
+        , Some
+            { pexp_desc=
+                Pexp_constraint
+                  ( { pexp_desc= Pexp_ident {txt= v_txt; _}
+                    ; pexp_attributes= []
+                    ; _ }
+                  , t1 )
+            ; pexp_attributes= []
+            ; _ } )
+        when enable_short_field_annot
+             && Std_longident.field_alias ~field:f.txt v_txt ->
+          (f, Some (Pconstraint t1), None)
       (* [{ x :> t = (x : t) }] -> [{ x : t :> t }] *)
-      | ( (None, t2)
+      | ( Some (Pcoerce (None, t2))
         , Some
             { pexp_desc=
                 Pexp_constraint
@@ -82,10 +95,10 @@ module Parse = struct
             ; _ } )
         when enable_short_field_annot
              && Std_longident.field_alias ~field:f.txt v_txt ->
-          (f, (Some t1, t2), None)
+          (f, Some (Pcoerce (Some t1, t2)), None)
       (* [{ x = (x :> t) }] -> [{ x :> t }] *)
       (* [{ x = (x : t :> t) }] -> [{ x : t :> t }] *)
-      | ( (None, None)
+      | ( None
         , Some
             { pexp_desc=
                 Pexp_coerce
@@ -98,9 +111,9 @@ module Parse = struct
             ; _ } )
         when enable_short_field_annot
              && Std_longident.field_alias ~field:f.txt v_txt ->
-          (f, (t1, Some t2), None)
+          (f, Some (Pcoerce (t1, t2)), None)
       (* [{ x : t = (x :> t) }] -> [{ x : t :> t }] *)
-      | ( (Some t1, None)
+      | ( Some (Pconstraint t1)
         , Some
             { pexp_desc=
                 Pexp_coerce
@@ -113,7 +126,7 @@ module Parse = struct
             ; _ } )
         when enable_short_field_annot
              && Std_longident.field_alias ~field:f.txt v_txt ->
-          (f, (Some t1, Some t2), None)
+          (f, Some (Pcoerce (Some t1, t2)), None)
       | _ -> (f, t, Option.map ~f:(m.expr m) v)
     in
     let pat_record_field m (f, t, v) =

lib/Fmt_ast.ml

@@ -2469,7 +2469,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
           (Params.parens_if outer_parens c.conf
              (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) )
   | Pexp_record (flds, default) ->
-      let fmt_field (lid, (typ1, typ2), exp) =
+      let fmt_field (lid, tc, exp) =
+        let typ1, typ2 =
+          match tc with
+          | Some (Pconstraint t1) -> (Some t1, None)
+          | Some (Pcoerce (t1, t2)) -> (t1, Some t2)
+          | None -> (None, None)
+        in
         let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in
         let typ2 = Option.map typ2 ~f:(sub_typ ~ctx) in
         let rhs =
@@ -2478,12 +2484,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
         hvbox 0 @@ fmt_record_field c ?typ1 ?typ2 ?rhs lid
       in
       let p1, p2 = Params.get_record_expr c.conf in
-      let last_loc (lid, (t1, t2), e) =
-        match (t1, t2, e) with
-        | _, _, Some e -> e.pexp_loc
-        | _, Some t2, _ -> t2.ptyp_loc
-        | Some t1, _, _ -> t1.ptyp_loc
-        | _ -> lid.loc
+      let last_loc (lid, tc, e) =
+        match (tc, e) with
+        | _, Some e -> e.pexp_loc
+        | Some (Pcoerce (_, t2)), None -> t2.ptyp_loc
+        | Some (Pconstraint t1), None -> t1.ptyp_loc
+        | None, None -> lid.loc
       in
       let fmt_fields =
         fmt_elements_collection c p1 last_loc pexp_loc fmt_field flds

vendor/parser-extended/ast_mapper.ml

@@ -467,6 +467,11 @@ end
 module E = struct
   (* Value expressions for the core language *)
 
+  let map_constraint sub c =
+    match c with
+    | Pconstraint ty -> Pconstraint (sub.typ sub ty)
+    | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2)
+
   let map_if_branch sub {if_cond; if_body; if_attrs} =
     let if_cond = sub.expr sub if_cond in
     let if_body = sub.expr sub if_body in
@@ -507,7 +512,7 @@ module E = struct
           List.map
             (map_tuple3
                (map_loc sub)
-               (map_tuple (map_opt (sub.typ sub)) (map_opt (sub.typ sub)))
+               (map_opt (map_constraint sub))
                (map_opt (sub.expr sub)))
             l
         in

vendor/parser-extended/parser.mly

@@ -226,11 +226,13 @@ let rec mktailpat nilloc = let open Location in function
 let mkstrexp e attrs =
   { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc }
 
-let mkexp_constraint ~loc e (t1, t2) =
-  match t1, t2 with
-  | Some t, None -> mkexp ~loc (Pexp_constraint(e, t))
-  | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t))
-  | None, None -> assert false
+let mkexp_desc_constraint e t =
+  match t with
+  | Pconstraint t -> Pexp_constraint(e, t)
+  | Pcoerce(t1, t2)  -> Pexp_coerce(e, t1, t2)
+
+let mkexp_constraint ~loc e t =
+  mkexp ~loc (mkexp_desc_constraint e t)
 
 (*
 let mkexp_opt_constraint ~loc e = function
@@ -2484,10 +2486,9 @@ let_binding_body_no_punning:
       { let v = $1 in (* PR#7344 *)
         let t =
           match $2 with
-            Some t, None ->
-             Pvc_constraint { locally_abstract_univars = []; typ=t }
-          | ground, Some coercion -> Pvc_coercion { ground; coercion}
-          | _ -> assert false
+          | Pconstraint typ ->
+             Pvc_constraint { locally_abstract_univars = []; typ }
+          | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion }
         in
         (v, $4, Some t)
         }
@@ -2623,8 +2624,7 @@ record_expr_content:
   | label = mkrhs(label_longident)
     c = type_constraint?
     eo = preceded(EQUAL, expr)?
-      { let c = Option.value ~default:(None, None) c in
-        label, c, eo }
+      { label, c, eo }
 ;
 %inline object_expr_content:
   xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field)
@@ -2648,9 +2648,9 @@ record_expr_content:
     { es }
 ;
 type_constraint:
-    COLON core_type                             { (Some $2, None) }
-  | COLON core_type COLONGREATER core_type      { (Some $2, Some $4) }
-  | COLONGREATER core_type                      { (None, Some $2) }
+  | COLON core_type                             { Pconstraint $2 }
+  | COLON core_type COLONGREATER core_type      { Pcoerce (Some $2, $4) }
+  | COLONGREATER core_type                      { Pcoerce (None, $2) }
   | COLON error                                 { syntax_error() }
   | COLONGREATER error                          { syntax_error() }
 ;

vendor/parser-extended/parsetree.mli

@@ -377,7 +377,7 @@ and expression_desc =
          *)
   | Pexp_record of
       ( Longident.t loc
-        * (core_type option * core_type option)
+        * type_constraint option
         * expression option )
         list
       * expression option
@@ -501,6 +501,10 @@ and binding_op =
     pbop_loc : Location.t;
   }
 
+and type_constraint =
+  | Pconstraint of core_type
+  | Pcoerce of core_type option * core_type
+
 (** {2 Value descriptions} *)
 
 and value_description =

vendor/parser-extended/printast.ml

@@ -514,6 +514,16 @@ and if_branch i ppf { if_cond; if_body } =
   expression i ppf if_cond;
   expression i ppf if_body
 
+and type_constraint i ppf constraint_ =
+  match constraint_ with
+  | Pconstraint ty ->
+      line i ppf "Pconstraint\n";
+      core_type (i+1) ppf ty
+  | Pcoerce (ty1, ty2) ->
+      line i ppf "Pcoerce\n";
+      option (i+1) core_type ppf ty1;
+      core_type (i+1) ppf ty2
+
 and value_description i ppf x =
   line i ppf "value_description %a %a\n" fmt_string_loc
        x.pval_name fmt_location x.pval_loc;
@@ -1119,10 +1129,9 @@ and string_x_expression i ppf (s, e) =
   line i ppf "<override> %a\n" fmt_string_loc s;
   expression (i+1) ppf e;
 
-and longident_x_expression i ppf (li, (t1, t2), e) =
+and longident_x_expression i ppf (li, c, e) =
   line i ppf "%a\n" fmt_longident_loc li;
-  option (i+1) core_type ppf t1;
-  option (i+1) core_type ppf t2;
+  option (i+1) type_constraint ppf c;
   option (i+1) expression ppf e;
 
 and label_x_expression i ppf (l,e) =