Refine type printing heuristics in view of #1962

ocaml/testsuite/tests/printing-types/multiple_files.ml

@@ -0,0 +1,7 @@
+(* See [test_multiple_files.ml]. *)
+
+module B = struct
+  type t = B1 | B2
+end
+
+type _b = B.t = B1 | B2

ocaml/testsuite/tests/printing-types/test_multiple_files.compilers.reference

@@ -0,0 +1,4 @@
+val other_file_b : Multiple_files.B.t
+module A : sig type t = A1 | A2 end
+type _a = A.t = A1 | A2
+val this_file_a : A.t

ocaml/testsuite/tests/printing-types/test_multiple_files.ml

@@ -0,0 +1,27 @@
+(* TEST
+
+   readonly_files ="multiple_files.ml"
+   * setup-ocamlopt.opt-build-env
+   ** ocamlopt.opt
+       module = "multiple_files.ml"
+       flags = "-g"
+   *** ocamlopt.opt
+        module = "test_multiple_files.ml"
+        flags = "-short-paths -i"
+   **** check-ocamlopt.opt-output
+*)
+
+(* Ensure that underscore-prefixed type names
+   are avoided by the type printer when
+   a good, underscoreless name is available.
+*)
+
+let other_file_b = Multiple_files.B1
+
+module A = struct
+  type t = A1 | A2
+end
+
+type _a = A.t = A1 | A2
+
+let this_file_a = A1

ocaml/testsuite/tests/typing-short-paths/errors.ml

@@ -86,9 +86,9 @@ Line 1, characters 0-75:
 1 | module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: The definition of A.t contains a cycle:
-         B.t -> int contains B.t,
-         B.t = B.t,
-         B.t = B.t -> int,
-         B.t -> int contains B.t,
-         B.t = B.t
+         A.t -> int contains A.t,
+         A.t = A.t,
+         A.t = A.t -> int,
+         A.t -> int contains A.t,
+         A.t = A.t
 |}]

ocaml/testsuite/tests/typing-short-paths/short-paths.compilers.reference

@@ -87,7 +87,7 @@ type t1 = A
 module M1 : sig type u = v and v = t1 end
 module N1 : sig type u = v and v = t1 end
 type t1 = B
-module N2 : sig type u = v and v = N1.v end
+module N2 : sig type u = v and v = t1/2 end
 module type PR6566 = sig type t = string end
 module PR6566 : sig type t = int end
 Line 1, characters 26-32:

ocaml/typing/printtyp.ml

@@ -732,6 +732,9 @@ let apply_subst s1 tyl =
     | Map l1 -> List.map (List.nth tyl) l1
     | Id -> tyl
 
+(* In the [Paths] constructor, more preferred paths are stored later in the
+   list. *)
+
 type best_path = Paths of Path.t list | Best of Path.t
 
 (** Short-paths cache: the five mutable variables below implement a one-slot
@@ -813,7 +816,13 @@ let set_printing_env env =
               Paths l -> r := Paths (p :: l)
             | Best p' -> r := Paths [p; p'] (* assert false *)
           with Not_found ->
-            printing_map := Path.Map.add p1 (ref (Paths [p])) !printing_map)
+            (* Jane Street: Often the best choice for printing [p1] is
+               [p1] itself. And often [p1] is a path whose "penalty"
+               would be reduced if the double-underscore rewrite
+               applied.
+            *)
+            let rewritten_p1 = rewrite_double_underscore_paths env p1 in
+            printing_map := Path.Map.add p1 (ref (Paths [ p; rewritten_p1 ])) !printing_map)
         env in
     printing_cont := [cont];
   end
@@ -867,8 +876,8 @@ let path_size path env =
   let rec size = function
       Pident id ->
         name_penalty (Ident.name id), -Ident.scope id
-    | Pdot (p, _) | Pextra_ty (p, Pcstr_ty _) ->
-        let (l, b) = size p in (1+l, b)
+    | Pdot (p, id) | Pextra_ty (p, Pcstr_ty id) ->
+        let (l, b) = size p in (name_penalty id + l, b)
     | Papply (p1, p2) ->
         let (l, b) = size p1 in
         (l + fst (size p2), b)
@@ -889,7 +898,7 @@ let rec get_best_path r env =
           match !r with
             Best p' when path_size p env >= path_size p' env -> ()
           | _ -> r := Best p)
-        l;
+        (List.rev l);
       get_best_path r env
 
 let best_type_path p =
@@ -902,7 +911,7 @@ let best_type_path p =
     let get_path () =
       try
         get_best_path (Path.Map.find p' !printing_map) !printing_env
-      with Not_found -> p'
+      with Not_found -> rewrite_double_underscore_paths !printing_env p'
     in
     while !printing_cont <> [] &&
       fst (path_size (get_path ()) !printing_env) > !printing_depth