Merge pull request #10487 from nchataing/cstr_res_unfolding

Move logic to get the type path from a constructor return type in Types

Changes

@@ -59,6 +59,10 @@ Working version
 - #10472: refactor caml_sys_random_seed to ease future Multicore changes
   (Gabriel Scherer, review by Xavier Leroy)
 
+- #10487: Move logic to get the type path from a constructor return type in
+  Types
+  (Nicolas Chataing, review by Jacques Garrigue)
+
 ### Build system:
 
 ### Bug fixes:

ocamldoc/.depend

@@ -125,6 +125,7 @@ odoc_ast.cmo : \
     odoc_class.cmo \
     ../parsing/location.cmi \
     ../typing/ident.cmi \
+    ../typing/btype.cmi \
     ../parsing/asttypes.cmi \
     odoc_ast.cmi
 odoc_ast.cmx : \
@@ -147,6 +148,7 @@ odoc_ast.cmx : \
     odoc_class.cmx \
     ../parsing/location.cmx \
     ../typing/ident.cmx \
+    ../typing/btype.cmx \
     ../parsing/asttypes.cmi \
     odoc_ast.cmi
 odoc_ast.cmi : \

ocamldoc/odoc_ast.ml

@@ -258,11 +258,7 @@ module Analyser =
 
         | Typedtree.Tpat_construct (_, cons_desc, _, _) when
             (* we give a name to the parameter only if it is unit *)
-            (match get_desc cons_desc.cstr_res with
-              Tconstr (p, _, _) ->
-                Path.same p Predef.path_unit
-            | _ ->
-                false)
+            Path.same (Btype.cstr_type_path cons_desc) Predef.path_unit
           ->
             (* a () argument, it never has description *)
             Simple_name { sn_name = "()" ;

toplevel/topdirs.ml

@@ -454,11 +454,7 @@ let () =
        let desc = Env.lookup_constructor ~loc Env.Positive lid env in
        if is_exception_constructor env desc.cstr_res then
          raise Not_found;
-       let path =
-         match get_desc desc.cstr_res with
-         | Tconstr(path, _, _) -> path
-         | _ -> raise Not_found
-       in
+       let path = Btype.cstr_type_path desc in
        let type_decl = Env.find_type path env in
        if is_extension_constructor desc.cstr_tag then
          let ret_type =

typing/btype.ml

@@ -697,3 +697,10 @@ let unmark_class_signature sign =
 
 let unmark_class_type cty =
   unmark_iterators.it_class_type unmark_iterators cty
+
+(**** Type information getter ****)
+
+let cstr_type_path cstr =
+  match get_desc cstr.cstr_res with
+  | Tconstr (p, _, _) -> p
+  | _ -> assert false

typing/btype.mli

@@ -271,3 +271,7 @@ val extract_label :
 
 (**** Forward declarations ****)
 val print_raw: (Format.formatter -> type_expr -> unit) ref
+
+(**** Type information getter ****)
+
+val cstr_type_path : constructor_description -> Path.t

typing/env.ml

@@ -2417,11 +2417,7 @@ let mark_label_used usage ld =
   | exception Not_found -> ()
 
 let mark_constructor_description_used usage env cstr =
-  let ty_path =
-    match get_desc cstr.cstr_res with
-    | Tconstr(path, _, _) -> path
-    | _ -> assert false
-  in
+  let ty_path = Btype.cstr_type_path cstr in
   mark_type_path_used env ty_path;
   match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
   | mark -> mark usage

typing/typecore.ml

@@ -396,10 +396,7 @@ let unify_pat ?refine env pat expected_ty =
 
 (* unification of a type with a Tconstr with freshly created arguments *)
 let unify_head_only ~refine loc env ty constr =
-  let path =
-    match get_desc constr.cstr_res with
-    | Tconstr(p, _, _) -> p
-    | _ -> assert false in
+  let path = cstr_type_path constr in
   let decl = Env.find_type path !env in
   let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
   unify_pat_types ~refine loc env ty' ty

typing/typedecl.ml

@@ -1036,13 +1036,8 @@ let transl_extension_constructor ~scope env type_path type_params
             typext_params
         end;
         (* Ensure that constructor's type matches the type being extended *)
-        let cstr_type_path, cstr_type_params =
-          match get_desc cdescr.cstr_res with
-            Tconstr (p, _, _) ->
-              let decl = Env.find_type p env in
-                p, decl.type_params
-          | _ -> assert false
-        in
+        let cstr_type_path = Btype.cstr_type_path cdescr in
+        let cstr_type_params = (Env.find_type cstr_type_path env).type_params in
         let cstr_types =
           (Btype.newgenty
              (Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))