typing: fix the scope of extension constructor declarations

fixes #9970

Changes

@@ -652,6 +652,13 @@ OCaml 4.12.0
 - #9999: fix -dsource printing of the pattern (`A as x | (`B as x)).
   (Gabriel Scherer, report by Anton Bachin, review by Florian Angeletti)
 
+- #9970, #10010: fix the declaration scope of extensible-datatype constructors.
+  A regression that dates back to 4.08 makes extensible-datatype constructors
+  with inline records very fragile, for example:
+    type 'a t += X of {x : 'a}
+  (Gabriel Scherer, review by Thomas Refis and Leo White,
+   report by Nicolás Ojeda Bär)
+
 OCaml 4.11.1
 ------------
 

testsuite/tests/typing-extensions/extensions.ml

@@ -187,6 +187,30 @@ let get_num : type a. a foo -> a -> a option = fun f i1 ->
 val get_num : 'a foo -> 'a -> 'a option = <fun>
 |}]
 
+(* Extensions can have inline records (regression test for #9970) *)
+type _ inline = ..
+type 'a inline += X of {x : 'a}
+;;
+[%%expect {|
+type _ inline = ..
+type 'a inline += X of { x : 'a; }
+|}]
+
+let _ = X {x = 1};;
+[%%expect {|
+- : int inline = X {x = 1}
+|}]
+
+let must_be_polymorphic = fun x -> X {x};;
+[%%expect {|
+val must_be_polymorphic : 'a -> 'a inline = <fun>
+|}]
+
+let must_be_polymorphic : 'a . 'a -> 'a inline = fun x -> X {x};;
+[%%expect {|
+val must_be_polymorphic : 'a -> 'a inline = <fun>
+|}]
+
 (* Extensions must obey constraints *)
 
 type 'a foo = .. constraint 'a = [> `Var ]

typing/typedecl.ml

@@ -945,9 +945,8 @@ let transl_type_decl env rec_flag sdecl_list =
 
 (* Translating type extensions *)
 
-let transl_extension_constructor env type_path type_params
+let transl_extension_constructor ~scope env type_path type_params
                                  typext_params priv sext =
-  let scope = Ctype.create_scope () in
   let id = Ident.create_scoped ~scope sext.pext_name.txt in
   let args, ret_type, kind =
     match sext.pext_kind with
@@ -1060,10 +1059,10 @@ let transl_extension_constructor env type_path type_params
       Typedtree.ext_loc = sext.pext_loc;
       Typedtree.ext_attributes = sext.pext_attributes; }
 
-let transl_extension_constructor env type_path type_params
+let transl_extension_constructor ~scope env type_path type_params
     typext_params priv sext =
   Builtin_attributes.warning_scope sext.pext_attributes
-    (fun () -> transl_extension_constructor env type_path type_params
+    (fun () -> transl_extension_constructor ~scope env type_path type_params
         typext_params priv sext)
 
 let is_rebind ext =
@@ -1072,6 +1071,9 @@ let is_rebind ext =
   | Text_decl _ -> false
 
 let transl_type_extension extend env loc styext =
+  (* Note: it would be incorrect to call [create_scope] *after*
+     [reset_type_variables] or after [begin_def] (see #10010). *)
+  let scope = Ctype.create_scope () in
   reset_type_variables();
   Ctype.begin_def();
   let type_path, type_decl =
@@ -1124,7 +1126,7 @@ let transl_type_extension extend env loc styext =
     (Ctype.instance_list type_decl.type_params)
     type_params;
   let constructors =
-    List.map (transl_extension_constructor env type_path
+    List.map (transl_extension_constructor ~scope env type_path
                type_decl.type_params type_params styext.ptyext_private)
       styext.ptyext_constructors
   in
@@ -1180,10 +1182,11 @@ let transl_type_extension extend env loc styext =
     (fun () -> transl_type_extension extend env loc styext)
 
 let transl_exception env sext =
+  let scope = Ctype.create_scope () in
   reset_type_variables();
   Ctype.begin_def();
   let ext =
-    transl_extension_constructor env
+    transl_extension_constructor ~scope env
       Predef.path_exn [] [] Asttypes.Public sext
   in
   Ctype.end_def();