Normalize type_expr nodes on access (#10337)

Co-authored-by: Takafumi Saikawa <tscompor@gmail.com>

.depend

@@ -538,6 +538,7 @@ typing/ctype.cmi : \
     typing/ident.cmi \
     typing/errortrace.cmi \
     typing/env.cmi \
+    typing/btype.cmi \
     parsing/asttypes.cmi
 typing/datarepr.cmo : \
     typing/types.cmi \
@@ -1722,6 +1723,7 @@ typing/types.cmo : \
     utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    utils/local_store.cmi \
     utils/identifiable.cmi \
     typing/ident.cmi \
     utils/config.cmi \
@@ -1735,6 +1737,7 @@ typing/types.cmx : \
     utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \
+    utils/local_store.cmx \
     utils/identifiable.cmx \
     typing/ident.cmx \
     utils/config.cmx \
@@ -6399,6 +6402,7 @@ toplevel/byte/topeval.cmi : \
     toplevel/topcommon.cmi \
     parsing/parsetree.cmi
 toplevel/byte/topmain.cmo : \
+    typing/types.cmi \
     toplevel/byte/trace.cmi \
     toplevel/toploop.cmi \
     toplevel/byte/topeval.cmi \
@@ -6416,6 +6420,7 @@ toplevel/byte/topmain.cmo : \
     utils/clflags.cmi \
     toplevel/byte/topmain.cmi
 toplevel/byte/topmain.cmx : \
+    typing/types.cmx \
     toplevel/byte/trace.cmx \
     toplevel/toploop.cmx \
     toplevel/byte/topeval.cmx \

Changes

@@ -447,6 +447,13 @@ OCaml 4.13.0
 - #10327: Add a subdirectories variable and a copy action to ocamltest
   (Sébastien Hinderer, review by David Allsopp)
 
+* #10337: Normalize type_expr nodes on access
+  One should now use accessors such as get_desc and get_level to access fields
+  of type_expr, rather than calling manually Btype.repr (which is now hidden
+  in Types.Transient_expr).
+  (Jacques Garrigue and Takafumi Saikawa,
+   review by Florian Angeletti and Gabriel Radanne)
+
 - #10358: Use a hash table for the load path.
   (Leo White, review by Gabriel Scherer)
 

debugger/.depend

@@ -72,7 +72,6 @@ command_line.cmo : \
     debugger_lexer.cmi \
     debugger_config.cmi \
     debugcom.cmi \
-    ../typing/ctype.cmi \
     checkpoints.cmi \
     breakpoints.cmi \
     command_line.cmi
@@ -110,7 +109,6 @@ command_line.cmx : \
     debugger_lexer.cmx \
     debugger_config.cmx \
     debugcom.cmx \
-    ../typing/ctype.cmx \
     checkpoints.cmx \
     breakpoints.cmx \
     command_line.cmi

debugger/command_line.ml

@@ -623,7 +623,7 @@ let instr_break ppf lexbuf =
         in
         begin try
           let (v, ty) = Eval.expression !selected_event env expr in
-          match (Ctype.repr ty).desc with
+          match get_desc ty with
           | Tarrow _ ->
               add_breakpoint_after_pc (Remote_value.closure_code v)
           | _ ->

debugger/eval.ml

@@ -112,7 +112,7 @@ let rec expression event env = function
       end
   | E_item(arg, n) ->
       let (v, ty) = expression event env arg in
-      begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with
+      begin match get_desc (Ctype.expand_head_opt env ty) with
         Ttuple ty_list ->
           if n < 1 || n > List.length ty_list
           then raise(Error(Tuple_index(ty, List.length ty_list, n)))
@@ -142,7 +142,7 @@ let rec expression event env = function
       end
   | E_field(arg, lbl) ->
       let (v, ty) = expression event env arg in
-      begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with
+      begin match get_desc (Ctype.expand_head_opt env ty) with
         Tconstr(path, _, _) ->
           let tydesc = Env.find_type path env in
           begin match tydesc.type_kind with

lambda/translmod.ml

@@ -242,10 +242,10 @@ let init_shape id modl =
       [] -> []
     | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem ->
         let init_v =
-          match Ctype.expand_head env ty with
-            {desc = Tarrow(_,_,_,_)} ->
+          match get_desc (Ctype.expand_head env ty) with
+            Tarrow(_,_,_,_) ->
               const_int 0 (* camlinternalMod.Function *)
-          | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
+          | Tconstr(p, _, _) when Path.same p Predef.path_lazy_t ->
               const_int 1 (* camlinternalMod.Lazy *)
           | _ ->
               let not_a_function =

ocamldoc/odoc_ast.ml

@@ -258,7 +258,7 @@ module Analyser =
 
         | Typedtree.Tpat_construct (_, cons_desc, _, _) when
             (* we give a name to the parameter only if it is unit *)
-            (match cons_desc.cstr_res.desc with
+            (match get_desc cons_desc.cstr_res with
               Tconstr (p, _, _) ->
                 Path.same p Predef.path_unit
             | _ ->
@@ -585,7 +585,7 @@ module Analyser =
               with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
             in
             let real_type =
-              match met_type.Types.desc with
+              match get_desc met_type with
               Tarrow (_, _, t, _) ->
                 t
             |  _ ->
@@ -627,7 +627,7 @@ module Analyser =
             with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
           in
           let real_type =
-            match exp.exp_type.desc with
+            match get_desc exp.exp_type with
               Tarrow (_, _, t,_) ->
                 t
             |  _ ->

ocamldoc/odoc_env.ml

@@ -169,26 +169,27 @@ let subst_type env t =
     if List.memq t !deja_vu then () else begin
       deja_vu := t :: !deja_vu;
       Btype.iter_type_expr iter t;
-      match t.Types.desc with
-      | Types.Tconstr (p, [_], _) when Path.same p Predef.path_option ->
+      let open Types in
+      match get_desc t with
+      | Tconstr (p, [_], _) when Path.same p Predef.path_option ->
           ()
-      | Types.Tconstr (p, l, a) ->
+      | Tconstr (p, l, a) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
-          Btype.set_type_desc t (Types.Tconstr (new_p, l, a))
-      | Types.Tpackage (p, fl) ->
+          set_type_desc t (Tconstr (new_p, l, a))
+      | Tpackage (p, fl) ->
           let new_p =
-            Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
-          Btype.set_type_desc t (Types.Tpackage (new_p, fl))
-      | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) ->
+            Odoc_name.to_path
+              (full_module_type_name env (Odoc_name.from_path p)) in
+          set_type_desc t (Tpackage (new_p, fl))
+      | Tobject (_, ({contents=Some(p,tyl)} as r)) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
           r := Some (new_p, tyl)
-      | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) ->
+      | Tvariant ({row_name=Some(p, tyl)} as row) ->
           let new_p =
             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
-          Btype.set_type_desc t
-            (Types.Tvariant {row with Types.row_name=Some(new_p, tyl)})
+          set_type_desc t (Tvariant {row with row_name=Some(new_p, tyl)})
       | _ ->
           ()
     end
@@ -202,7 +203,9 @@ let subst_module_type env t =
     let open Types in
     match t with
       Mty_ident p ->
-        let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
+        let new_p =
+          Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p))
+        in
         Mty_ident new_p
     | Mty_alias _
     | Mty_signature _ ->
@@ -215,18 +218,20 @@ let subst_module_type env t =
 
 let subst_class_type env t =
   let rec iter t =
+    let open Types in
     match t with
-      Types.Cty_constr (p,texp_list,ct) ->
-        let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
+      Cty_constr (p,texp_list,ct) ->
+        let new_p =
+          Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
         let new_texp_list = List.map (subst_type env) texp_list in
         let new_ct = iter ct in
-        Types.Cty_constr (new_p, new_texp_list, new_ct)
-    | Types.Cty_signature _ ->
+        Cty_constr (new_p, new_texp_list, new_ct)
+    | Cty_signature _ ->
         (* we don't handle vals and methods *)
         t
-    | Types.Cty_arrow (l, texp, ct) ->
+    | Cty_arrow (l, texp, ct) ->
         let new_texp = subst_type env texp in
         let new_ct = iter ct in
-        Types.Cty_arrow (l, new_texp, new_ct)
+        Cty_arrow (l, new_texp, new_ct)
   in
   iter t

ocamldoc/odoc_misc.ml

@@ -492,22 +492,27 @@ let is_optional = Btype.is_optional
 let label_name = Btype.label_name
 
 let remove_option typ =
-  let rec iter t =
+  let open Types in
+  let rec trim t =
     match t with
-    | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
-    | Types.Tconstr _
-    | Types.Tvar _
-    | Types.Tunivar _
-    | Types.Tpoly _
-    | Types.Tarrow _
-    | Types.Ttuple _
-    | Types.Tobject _
-    | Types.Tfield _
-    | Types.Tnil
-    | Types.Tvariant _
-    | Types.Tpackage _ -> t
-    | Types.Tlink t2 -> iter t2.Types.desc
-    | Types.Tsubst _ -> assert false
+    | Tconstr(path, [ty], _)
+      when Path.same path Predef.path_option -> get_desc ty
+    | Tconstr _
+    | Tvar _
+    | Tunivar _
+    | Tpoly _
+    | Tarrow _
+    | Ttuple _
+    | Tobject _
+    | Tfield _
+    | Tnil
+    | Tvariant _
+    | Tpackage _ -> t
+    | Tlink t2 -> trim (get_desc t2)
+    | Tsubst _ -> assert false
   in
-  Types.Private_type_expr.create (iter typ.Types.desc)
-    ~level:typ.Types.level ~scope:typ.Types.scope ~id:typ.Types.id
+  Transient_expr.type_expr
+    (Transient_expr.create (trim (get_desc typ))
+       ~level:(get_level typ)
+       ~scope:(get_scope typ)
+       ~id:(get_id typ))

ocamldoc/odoc_print.ml

@@ -81,27 +81,31 @@ let string_of_module_type ?code ?(complete=false) t =
    from the signatures. Used when we don't want to print a too long class type.*)
 let simpl_class_type t =
   let rec iter t =
+    let open Types in
     match t with
-      Types.Cty_constr _ -> t
-    | Types.Cty_signature cs ->
+      Cty_constr _ -> t
+    | Cty_signature cs ->
         (* we delete vals and methods in order to not print them when
            displaying the type *)
       let tself =
-        let t = cs.Types.csig_self in
-        let t' = Types.Private_type_expr.create Types.Tnil
+        let t = cs.csig_self in
+        let t' = Transient_expr.create Tnil
             ~level:0 ~scope:Btype.lowest_level ~id:0 in
-        let desc = Types.Tobject (t', ref None) in
-        Types.Private_type_expr.create desc
-          ~level:t.Types.level ~scope:t.Types.scope ~id:t.Types.id
+        let desc =
+          Tobject (Transient_expr.type_expr t', ref None) in
+        Transient_expr.create desc
+          ~level:(get_level t)
+          ~scope:(get_scope t)
+          ~id:(get_id t)
       in
-        Types.Cty_signature { Types.csig_self = tself;
-                              csig_vars = Types.Vars.empty ;
-                              csig_concr = Types.Concr.empty ;
+        Cty_signature { csig_self = Transient_expr.type_expr tself;
+                              csig_vars = Vars.empty ;
+                              csig_concr = Concr.empty ;
                               csig_inher = []
                              }
-    | Types.Cty_arrow (l, texp, ct) ->
+    | Cty_arrow (l, texp, ct) ->
         let new_ct = iter ct in
-        Types.Cty_arrow (l, texp, new_ct)
+        Cty_arrow (l, texp, new_ct)
   in
   iter t
 

ocamldoc/odoc_sig.ml

@@ -341,7 +341,7 @@ module Analyser =
 
 
     let manifest_structure env name_comment_list type_expr =
-      match type_expr.desc with
+      match get_desc type_expr with
       | Tobject (fields, _) ->
         let f (field_name, _, type_expr) =
           let comment_opt =

ocamldoc/odoc_str.ml

@@ -30,7 +30,7 @@ let string_of_variance t (co,cn) =
   else
     ""
 let rec is_arrow_type t =
-  match t.Types.desc with
+  match Types.get_desc t with
     Types.Tarrow _ -> true
   | Types.Tlink t2 -> is_arrow_type t2
   | Types.Ttuple _
@@ -43,7 +43,7 @@ let raw_string_of_type_list sep type_list =
   let buf = Buffer.create 256 in
   let fmt = Format.formatter_of_buffer buf in
   let rec need_parent t =
-    match t.Types.desc with
+    match Types.get_desc t with
       Types.Tarrow _ | Types.Ttuple _ -> true
     | Types.Tlink t2 -> need_parent t2
     | Types.Tconstr _

ocamldoc/odoc_value.ml

@@ -72,7 +72,7 @@ let update_value_parameters_text v =
    [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*)
 let parameter_list_from_arrows typ =
   let rec iter t =
-    match t.Types.desc with
+    match Types.get_desc t with
       Types.Tarrow (l, t1, t2, _) ->
         (l, t1) :: (iter t2)
     | Types.Tlink texp
@@ -102,7 +102,7 @@ let dummy_parameter_list typ =
   Printtyp.mark_loops typ;
   let liste_param = parameter_list_from_arrows typ in
   let rec iter (label, t) =
-    match t.Types.desc with
+    match Types.get_desc t with
     | Types.Ttuple l ->
         let open Asttypes in
         if label = Nolabel then
@@ -129,7 +129,7 @@ let dummy_parameter_list typ =
 (** Return true if the value is a function, i.e. has a functional type.*)
 let is_function v =
   let rec f t =
-    match t.Types.desc with
+    match Types.get_desc t with
       Types.Tarrow _ ->
         true
     | Types.Tlink t ->

testsuite/tests/typing-gadts/omega07.ml

@@ -904,9 +904,9 @@ val suc :
   (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
 val _1 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam =
   App (Shift (Var Suc), Var Zero)
-val _2 : ((zero, int, (suc, int -> int, '_weak2) rcons) rcons, int) lam =
+val _2 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam =
   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 : ((zero, int, (suc, int -> int, '_weak3) rcons) rcons, int) lam =
+val _3 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam =
   App (Shift (Var Suc),
    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
 val add :
@@ -921,7 +921,7 @@ val double :
    App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
 val ex3 :
   ((zero, int,
-    (suc, int -> int, (add, int -> int -> int, '_weak4) rcons) rcons)
+    (suc, int -> int, (add, int -> int -> int, '_weak2) rcons) rcons)
    rcons, int)
   lam =
   App

testsuite/tests/typing-gadts/test.ml

@@ -635,6 +635,15 @@ let f (type a) (x : a t) y =
     in M.z
 ;; (* fails because of aliasing... *)
 [%%expect{|
+Lines 2-4, characters 2-10:
+2 | ..match x with Int ->
+3 |     let module M = struct type b = a let z = (y : b) end
+4 |     in M.z
+Warning 18 [not-principal]:
+  The return type of this pattern-matching is ambiguous.
+  Please add a type annotation, as the choice of `a' is not principal.
+val f : 'a t -> 'a -> 'a = <fun>
+|}, Principal{|
 Line 3, characters 46-47:
 3 |     let module M = struct type b = a let z = (y : b) end
                                                   ^