Skip to content

Refine type printing heuristics in view of #1962 #2105

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 5 commits into from
Dec 4, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 7 additions & 0 deletions ocaml/testsuite/tests/printing-types/multiple_files.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,7 @@
(* See [test_multiple_files.ml]. *)

module B = struct
type t = B1 | B2
end

type _b = B.t = B1 | B2
Original file line number Diff line number Diff line change
@@ -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
27 changes: 27 additions & 0 deletions ocaml/testsuite/tests/printing-types/test_multiple_files.ml
Original file line number Diff line number Diff line change
@@ -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
10 changes: 5 additions & 5 deletions ocaml/testsuite/tests/typing-short-paths/errors.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
|}]
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down
19 changes: 14 additions & 5 deletions ocaml/typing/printtyp.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand All @@ -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 =
Expand All @@ -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
Expand Down