Allow explicit binders for type variables (ocaml#10437) (#1757)

Update the parser with ocaml/ocaml#10437

Author: gpetiot

CHANGES.md

@@ -25,6 +25,8 @@
   + Handle punned labelled arguments with type constraint in function applications.
     For example, function application of the form `foo ~(x:int)` instead of the explicit `foo ~x:(x:int)`. (ocaml#10434) (#1756, @gpetiot)
 
+  + Allow explicit binders for type variables (ocaml#10437) (#1757, @gpetiot)
+
 ### 0.19.0 (2021-07-16)
 
 #### Bug fixes

lib/Ast.ml

@@ -932,7 +932,7 @@ end = struct
     in
     let check_ext {pext_kind; _} =
       match pext_kind with
-      | Pext_decl (cstr, t0) -> check_cstr cstr || Option.exists t0 ~f
+      | Pext_decl (_, cstr, t0) -> check_cstr cstr || Option.exists t0 ~f
       | _ -> false
     in
     let check_typext {ptyext_params; ptyext_constructors; _} =
@@ -1597,7 +1597,7 @@ end = struct
       | _ -> false
     in
     let is_tuple_lvl1_in_ext_constructor ty = function
-      | {pext_kind= Pext_decl (Pcstr_tuple t1N, _); _} ->
+      | {pext_kind= Pext_decl (_, Pcstr_tuple t1N, _); _} ->
           List.exists t1N ~f:(phys_equal ty)
       | _ -> false
     in
@@ -1869,14 +1869,14 @@ end = struct
               { pstr_desc=
                   Pstr_exception
                     { ptyexn_constructor=
-                        {pext_kind= Pext_decl (Pcstr_tuple t, _); _}
+                        {pext_kind= Pext_decl (_, Pcstr_tuple t, _); _}
                     ; _ }
               ; _ }
           | Sig
               { psig_desc=
                   Psig_exception
                     { ptyexn_constructor=
-                        {pext_kind= Pext_decl (Pcstr_tuple t, _); _}
+                        {pext_kind= Pext_decl (_, Pcstr_tuple t, _); _}
                     ; _ }
               ; _ } ) }
       when List.exists t ~f:(phys_equal typ) ->

lib/Exposed.ml

@@ -50,8 +50,8 @@ module Right = struct
     | {pext_kind; _} -> (
       match pext_kind with
       | Pext_rebind _ -> false
-      | Pext_decl (_, Some _result) -> false
-      | Pext_decl (args, None) -> constructor_arguments args )
+      | Pext_decl (_, _, Some _result) -> false
+      | Pext_decl (_, args, None) -> constructor_arguments args )
 
   let constructor_declaration = function
     | {pcd_attributes= _ :: _; _} -> false

lib/Fmt_ast.ml

@@ -3273,7 +3273,12 @@ and fmt_label_declaration c ctx ?(last = false) decl =
 
 and fmt_constructor_declaration c ctx ~max_len_name ~first ~last:_ cstr_decl
     =
-  let {pcd_name= {txt; loc}; pcd_args; pcd_res; pcd_attributes; pcd_loc} =
+  let { pcd_name= {txt; loc}
+      ; pcd_vars
+      ; pcd_args
+      ; pcd_res
+      ; pcd_attributes
+      ; pcd_loc } =
     cstr_decl
   in
   update_config_maybe_disabled c pcd_loc pcd_attributes
@@ -3311,16 +3316,17 @@ and fmt_constructor_declaration c ctx ~max_len_name ~first ~last:_ cstr_decl
               ( Cmts.fmt c loc
                   (wrap_if (String_id.is_symbol txt) "( " " )" (str txt))
               $ fmt_padding
-              $ fmt_constructor_arguments_result c ctx pcd_args pcd_res )
+              $ fmt_constructor_arguments_result c ctx pcd_vars pcd_args
+                  pcd_res )
           $ fmt_attributes c ~pre:(Break (1, 0)) ~key:"@" atrs
           $ fmt_docstring_padded c doc )
       $ Cmts.fmt_after c ~pro:(fmt_or c.conf.wrap_comments "@ " " ") pcd_loc
       )
 
-and fmt_constructor_arguments c ctx ~pre = function
+and fmt_constructor_arguments ?vars c ctx ~pre = function
   | Pcstr_tuple [] -> noop
   | Pcstr_tuple typs ->
-      pre $ fmt "@ "
+      pre $ fmt "@ " $ fmt_opt vars
       $ hvbox 0 (list typs "@ * " (sub_typ ~ctx >> fmt_core_type c))
   | Pcstr_record lds ->
       let p = Params.get_record_type c.conf in
@@ -3336,13 +3342,20 @@ and fmt_constructor_arguments c ctx ~pre = function
       $ p.box_record (list_fl lds fmt_ld)
       $ p.break_after $ p.docked_after
 
-and fmt_constructor_arguments_result c ctx args res =
+and fmt_constructor_arguments_result c ctx vars args res =
   let pre = fmt_or (Option.is_none res) " of" " :" in
   let before_type = match args with Pcstr_tuple [] -> ": " | _ -> "-> " in
   let fmt_type typ =
     fmt "@ " $ str before_type $ fmt_core_type c (sub_typ ~ctx typ)
   in
-  fmt_constructor_arguments c ctx ~pre args $ opt res fmt_type
+  let fmt_vars =
+    match vars with
+    | [] -> noop
+    | _ ->
+        hvbox 0 (list vars "@ " (fun {txt; _} -> fmt_type_var txt))
+        $ fmt ".@ "
+  in
+  fmt_constructor_arguments c ctx ~pre ~vars:fmt_vars args $ opt res fmt_type
 
 and fmt_type_extension ?ext c ctx
     { ptyext_attributes
@@ -3356,8 +3369,8 @@ and fmt_type_extension ?ext c ctx
   let fmt_ctor ctor =
     let sep =
       match ctor.pext_kind with
-      | Pext_decl (_, Some _) -> fmt " :@ "
-      | Pext_decl (_, None) | Pext_rebind _ -> fmt " of@ "
+      | Pext_decl (_, _, Some _) -> fmt " :@ "
+      | Pext_decl (_, _, None) | Pext_rebind _ -> fmt " of@ "
     in
     hvbox 0 (fmt_extension_constructor c sep ctx ctor)
   in
@@ -3406,20 +3419,20 @@ and fmt_extension_constructor c sep ctx ec =
   let doc, atrs = doc_atrs pext_attributes in
   let suf =
     match pext_kind with
-    | Pext_decl (_, None) | Pext_rebind _ -> None
-    | Pext_decl (_, Some _) -> Some " "
+    | Pext_decl (_, _, None) | Pext_rebind _ -> None
+    | Pext_decl (_, _, Some _) -> Some " "
   in
   Cmts.fmt c pext_loc
   @@ hvbox 4
        ( hvbox 2
            ( fmt_str_loc c pext_name
            $
            match pext_kind with
-           | Pext_decl ((Pcstr_tuple [] | Pcstr_record []), None) -> noop
-           | Pext_decl ((Pcstr_tuple [] | Pcstr_record []), Some res) ->
+           | Pext_decl (_, (Pcstr_tuple [] | Pcstr_record []), None) -> noop
+           | Pext_decl (_, (Pcstr_tuple [] | Pcstr_record []), Some res) ->
                sep $ fmt_core_type c (sub_typ ~ctx res)
-           | Pext_decl (args, res) ->
-               fmt_constructor_arguments_result c ctx args res
+           | Pext_decl (vars, args, res) ->
+               fmt_constructor_arguments_result c ctx vars args res
            | Pext_rebind lid -> str " = " $ fmt_longident_loc c lid )
        $ fmt_attributes c ~pre:(Break (1, 0)) ~key:"@" atrs ?suf
        $ fmt_docstring_padded c doc )

test/passing/dune.inc

@@ -155,6 +155,18 @@
  (package ocamlformat)
  (action (diff tests/attributes.mli.ref attributes.mli.output)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+   (with-outputs-to binders.ml.output
+     (run %{bin:ocamlformat} %{dep:tests/binders.ml}))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/binders.ml binders.ml.output)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)

test/passing/tests/binders.ml

@@ -0,0 +1,17 @@
+external f : 'a -> 'a = "asdf"
+
+external g :
+  'aaaaaaa 'aaaaaaaaaaaaaaa 'aaaaaaaaaaaaaaaaaaaaaa 'aaaaaaaaaaaaaa 'aaaaaaa
+  'fooooo_foooooo. 'a -> 'a -> 'a = "asdf"
+
+type f = Foo : 'a -> t
+
+type f = Foo : 'a -> 'a
+
+type g = Foo : 'a. 'a -> t
+
+type g =
+  | Foo :
+      'aaaaaaaaaaa 'bbbbbbbbbbbbbb 'ccccccccccccccc 'fooooo_fooooooo.
+      'foo
+      -> 'b

vendor/ocaml-4.13/ast_helper.ml

@@ -531,9 +531,10 @@ module Type = struct
     }
 
   let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info)
-        ?(args = Pcstr_tuple []) ?res name =
+        ?(vars = []) ?(args = Pcstr_tuple []) ?res name =
     {
      pcd_name = name;
+     pcd_vars = vars;
      pcd_args = args;
      pcd_res = res;
      pcd_loc = loc;
@@ -583,10 +584,10 @@ module Te = struct
     }
 
   let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
-             ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name =
+         ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name =
     {
      pext_name = name;
-     pext_kind = Pext_decl(args, res);
+     pext_kind = Pext_decl(vars, args, res);
      pext_loc = loc;
      pext_attributes = add_docs_attrs docs (add_info_attrs info attrs);
     }

vendor/ocaml-4.13/ast_helper.mli

@@ -212,7 +212,8 @@ module Type:
       type_declaration
 
     val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info ->
-      ?args:constructor_arguments -> ?res:core_type -> str ->
+      ?vars:str list -> ?args:constructor_arguments -> ?res:core_type ->
+      str ->
       constructor_declaration
     val field: ?loc:loc -> ?attrs:attrs -> ?info:info ->
       ?mut:mutable_flag -> str -> core_type -> label_declaration
@@ -232,7 +233,8 @@ module Te:
       str -> extension_constructor_kind -> extension_constructor
 
     val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
-      ?args:constructor_arguments -> ?res:core_type -> str ->
+      ?vars:str list -> ?args:constructor_arguments -> ?res:core_type ->
+      str ->
       extension_constructor
     val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info ->
       str -> lid -> extension_constructor

vendor/ocaml-4.13/ast_mapper.ml

@@ -206,8 +206,10 @@ module T = struct
       (sub.extension_constructor sub ptyexn_constructor)
 
   let map_extension_constructor_kind sub = function
-      Pext_decl(ctl, cto) ->
-        Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto)
+      Pext_decl(vars, ctl, cto) ->
+        Pext_decl(List.map (map_loc sub) vars,
+                  map_constructor_arguments sub ctl,
+                  map_opt (sub.typ sub) cto)
     | Pext_rebind li ->
         Pext_rebind (map_loc sub li)
 
@@ -701,9 +703,11 @@ let default_mapper =
 
 
     constructor_declaration =
-      (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
+      (fun this {pcd_name; pcd_vars; pcd_args;
+                 pcd_res; pcd_loc; pcd_attributes} ->
         Type.constructor
           (map_loc this pcd_name)
+          ~vars:(List.map (map_loc this) pcd_vars)
           ~args:(T.map_constructor_arguments this pcd_args)
           ?res:(map_opt (this.typ this) pcd_res)
           ~loc:(this.location this pcd_loc)

vendor/ocaml-4.13/parser.mly

@@ -2506,15 +2506,11 @@ let_binding_body_no_punning:
         let patloc = ($startpos($1), $endpos($2)) in
         (ghpat ~loc:patloc (Ppat_constraint(v, typ)),
          mkexp_constraint ~loc:$sloc $4 $2) }
-  | let_ident COLON typevar_list DOT core_type EQUAL seq_expr
-      (* TODO: could replace [typevar_list DOT core_type]
-               with [mktyp(poly(core_type))]
-               and simplify the semantic action? *)
-      { let typloc = ($startpos($3), $endpos($5)) in
-        let patloc = ($startpos($1), $endpos($5)) in
+  | let_ident COLON poly(core_type) EQUAL seq_expr
+      { let patloc = ($startpos($1), $endpos($3)) in
         (ghpat ~loc:patloc
-           (Ppat_constraint($1, ghtyp ~loc:typloc (Ptyp_poly($3,$5)))),
-         $7) }
+           (Ppat_constraint($1, ghtyp ~loc:($loc($3)) $3)),
+         $5) }
   | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
       { let exp, poly =
           wrap_type_annotation ~loc:$sloc $4 $6 $8 in
@@ -2877,7 +2873,7 @@ value_description:
   attrs1 = attributes
   id = mkrhs(val_ident)
   COLON
-  ty = core_type
+  ty = possibly_poly(core_type)
   attrs2 = post_item_attributes
     { let attrs = attrs1 @ attrs2 in
       let loc = make_loc $sloc in
@@ -2894,7 +2890,7 @@ primitive_declaration:
   attrs1 = attributes
   id = mkrhs(val_ident)
   COLON
-  ty = core_type
+  ty = possibly_poly(core_type)
   EQUAL
   prim = raw_string+
   attrs2 = post_item_attributes
@@ -3072,20 +3068,20 @@ constructor_declarations:
 generic_constructor_declaration(opening):
   opening
   cid = mkrhs(constr_ident)
-  args_res = generalized_constructor_arguments
+  vars_args_res = generalized_constructor_arguments
   attrs = attributes
     {
-      let args, res = args_res in
+      let vars, args, res = vars_args_res in
       let info = symbol_info $endpos in
       let loc = make_loc $sloc in
-      cid, args, res, attrs, loc, info
+      cid, vars, args, res, attrs, loc, info
     }
 ;
 %inline constructor_declaration(opening):
   d = generic_constructor_declaration(opening)
     {
-      let cid, args, res, attrs, loc, info = d in
-      Type.constructor cid ~args ?res ~attrs ~loc ~info
+      let cid, vars, args, res, attrs, loc, info = d in
+      Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info
     }
 ;
 str_exception_declaration:
@@ -3110,28 +3106,33 @@ sig_exception_declaration:
   ext = ext
   attrs1 = attributes
   id = mkrhs(constr_ident)
-  args_res = generalized_constructor_arguments
+  vars_args_res = generalized_constructor_arguments
   attrs2 = attributes
   attrs = post_item_attributes
-    { let args, res = args_res in
+    { let vars, args, res = vars_args_res in
       let loc = make_loc ($startpos, $endpos(attrs2)) in
       let docs = symbol_docs $sloc in
       Te.mk_exception ~attrs
-        (Te.decl id ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
+        (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs)
       , ext }
 ;
 %inline let_exception_declaration:
     mkrhs(constr_ident) generalized_constructor_arguments attributes
-      { let args, res = $2 in
-        Te.decl $1 ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
+      { let vars, args, res = $2 in
+        Te.decl $1 ~vars ~args ?res ~attrs:$3 ~loc:(make_loc $sloc) }
 ;
 generalized_constructor_arguments:
-    /*empty*/                     { (Pcstr_tuple [],None) }
-  | OF constructor_arguments      { ($2,None) }
+    /*empty*/                     { ([],Pcstr_tuple [],None) }
+  | OF constructor_arguments      { ([],$2,None) }
   | COLON constructor_arguments MINUSGREATER atomic_type %prec below_HASH
-                                  { ($2,Some $4) }
+                                  { ([],$2,Some $4) }
+  | COLON typevar_list DOT constructor_arguments MINUSGREATER atomic_type
+     %prec below_HASH
+                                  { ($2,$4,Some $6) }
   | COLON atomic_type %prec below_HASH
-                                  { (Pcstr_tuple [],Some $2) }
+                                  { ([],Pcstr_tuple [],Some $2) }
+  | COLON typevar_list DOT atomic_type %prec below_HASH
+                                  { ($2,Pcstr_tuple [],Some $4) }
 ;
 
 constructor_arguments:
@@ -3196,8 +3197,8 @@ label_declaration_semi:
 %inline extension_constructor_declaration(opening):
   d = generic_constructor_declaration(opening)
     {
-      let cid, args, res, attrs, loc, info = d in
-      Te.decl cid ~args ?res ~attrs ~loc ~info
+      let cid, vars, args, res, attrs, loc, info = d in
+      Te.decl cid ~vars ~args ?res ~attrs ~loc ~info
     }
 ;
 extension_constructor_rebind(opening):