From 3e7a99094b1a37e57220fedf0dc5aba4420fa0da Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Thu, 30 Nov 2023 18:32:02 -0500 Subject: [PATCH] Print non-value layouts on type variables Signed-off-by: Nick Roberts --- src/analysis/type_utils.ml | 5 ++- src/ocaml/typing/printtyp.ml | 40 ++++++++++++++++--- src/ocaml/typing/printtyp.mli | 18 ++++++++- .../type-enclosing/jane-street.t/run.t | 19 +++++---- 4 files changed, 62 insertions(+), 20 deletions(-) diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index d397ba370..0fb42095c 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -111,7 +111,8 @@ module Printtyp = struct Mtype.scrape_alias env mty let verbose_type_scheme env ppf t = - Printtyp.type_scheme ppf (expand_type env t) + Printtyp.type_scheme_for_merlin ppf (expand_type env t) + ~print_non_value_jkind_on_type_variables:true let verbose_type_declaration ~print_non_value_inferred_jkind env id ppf t = Printtyp.type_declaration_for_merlin id ppf (expand_type_decl env t) @@ -128,7 +129,7 @@ module Printtyp = struct let type_scheme env ppf ty = (select_by_verbosity - ~default:type_scheme + ~default:(type_scheme_for_merlin ~print_non_value_jkind_on_type_variables:false) ~verbose:(verbose_type_scheme env)) ppf ty let type_declaration env id ppf = diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 18d7a609d..d24ba3f28 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -1188,6 +1188,13 @@ let alias_nongen_row mode px ty = add_alias_proxy px | _ -> () +(* Merlin-only: This configuration exists only in merlin, so + we'd like to avoid threading it through the recursive knot + and opening ourselves to merge conflicts. See the mli + for documentation on [print_non_value_jkind_on_type_variables]. +*) +let print_non_value_jkind_on_type_variables_ref = ref false + let rec tree_of_typexp mode ty = let px = proxy ty in if List.memq px !printed_aliases && not (List.memq px !delayed) then @@ -1198,10 +1205,17 @@ let rec tree_of_typexp mode ty = let pr_typ () = let tty = Transient_expr.repr ty in match tty.desc with - | Tvar _ -> + | Tvar { jkind } -> let non_gen = is_non_gen mode ty in let name_gen = Names.new_var_name ~non_gen ty in - Otyp_var (non_gen, Names.name_of_type name_gen tty) + let tvar = Otyp_var (non_gen, Names.name_of_type name_gen tty) in + if !print_non_value_jkind_on_type_variables_ref + then + begin match Jkind.get_default_value jkind with + | Value -> tvar + | jkind -> Otyp_jkind_annot (tvar, Olay_const jkind) + end + else tvar | Tarrow ((l, marg, mret), ty1, ty2, _) -> let lab = if !print_labels || is_optional l then string_of_label l else "" @@ -1389,11 +1403,18 @@ and tree_of_typfields mode rest = function let (fields, rest) = tree_of_typfields mode rest l in (field :: fields, rest) -let typexp mode ppf ty = +let typexp ?(print_non_value_jkind_on_type_variables = false) mode ppf ty = + Misc.protect_refs + [ R ( print_non_value_jkind_on_type_variables_ref + , print_non_value_jkind_on_type_variables + ) + ] begin fun () -> !Oprint.out_type ppf (tree_of_typexp mode ty) + end let prepared_type_expr ppf ty = typexp Type ppf ty -let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty +let prepared_type_scheme ?print_non_value_jkind_on_type_variables ppf ty = + typexp ?print_non_value_jkind_on_type_variables Type_scheme ppf ty let type_expr ppf ty = (* [type_expr] is used directly by error message printers, @@ -1414,9 +1435,9 @@ let shared_type_scheme ppf ty = prepare_type ty; typexp Type_scheme ppf ty -let type_scheme ppf ty = +let type_scheme ?print_non_value_jkind_on_type_variables ppf ty = prepare_for_printing [ty]; - prepared_type_scheme ppf ty + prepared_type_scheme ?print_non_value_jkind_on_type_variables ppf ty let type_path ppf p = let p = best_class_type_path_simple p in @@ -3011,9 +3032,16 @@ let shorten_class_type_path env p = (fun () -> best_class_type_path_simple p) (* Export merlin-only versions of functions *) + +let type_scheme_for_merlin ~print_non_value_jkind_on_type_variables ppf ty = + type_scheme ~print_non_value_jkind_on_type_variables ppf ty + let type_declaration_for_merlin = type_declaration (* Drop merlin-only arguments from exported interface *) + +let prepared_type_scheme x y : unit = prepared_type_scheme x y +let type_scheme x y : unit = type_scheme x y let type_declaration x y z : unit = type_declaration x y z ~print_non_value_inferred_jkind:false diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index 18730f9c6..de9847508 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -149,6 +149,21 @@ val type_declaration_for_merlin: print_non_value_inferred_jkind:bool -> Ident.t -> formatter -> type_declaration -> unit +val type_scheme_for_merlin: + (* Like [type_scheme]. + + [print_non_value_jkind_on_type_variables] is a setting controlled + by merlin verbosity levels. When it's true, merlin will print + layout annotations on type variables when the layout isn't merely + value. + + E.g. When this flag is [true], + ['a -> 'b] is printed as [('a : float64) -> 'b] + if ['a] has layout [float64] and ['b] has layout [value]. + *) + print_non_value_jkind_on_type_variables:bool -> + formatter -> type_expr -> unit + val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit val label : formatter -> label_declaration -> unit @@ -160,8 +175,7 @@ val tree_of_type_declaration: val add_type_declaration_to_preparation : Ident.t -> type_declaration -> unit val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit -val type_declaration: - Ident.t -> formatter -> type_declaration -> unit +val type_declaration: Ident.t -> formatter -> type_declaration -> unit val tree_of_extension_constructor: Ident.t -> extension_constructor -> ext_status -> out_sig_item val add_extension_constructor_to_preparation : diff --git a/tests/test-dirs/type-enclosing/jane-street.t/run.t b/tests/test-dirs/type-enclosing/jane-street.t/run.t index 538a4d27e..edd9c8c37 100644 --- a/tests/test-dirs/type-enclosing/jane-street.t/run.t +++ b/tests/test-dirs/type-enclosing/jane-street.t/run.t @@ -193,12 +193,12 @@ to print everything on one line. let poly3 (type a : float64) (x : a) = x ^ With verbosity 0: "'a -> 'a" - With verbosity 1: "'a -> 'a" + With verbosity 1: "('a : float64) -> ('a : float64)" let poly4 (type (a : immediate) (b : value)) (f : a -> b -> _) = f ^ With verbosity 0: "('a -> ('b -> 'c)) -> 'a -> ('b -> 'c)" - With verbosity 1: "('a -> ('b -> 'c)) -> 'a -> ('b -> 'c)" + With verbosity 1: "(('a : immediate) -> ('b -> 'c)) -> ('a : immediate) -> ('b -> 'c)" -parameter @@ -265,12 +265,12 @@ to print everything on one line. let poly_client3 x = poly3 x ^ With verbosity 0: "'a -> 'a" - With verbosity 1: "'a -> 'a" + With verbosity 1: "('a : float64) -> ('a : float64)" let poly_client4 x = poly4 x ^ With verbosity 0: "('a -> ('b -> 'c)) -> 'a -> ('b -> 'c)" - With verbosity 1: "('a -> ('b -> 'c)) -> 'a -> ('b -> 'c)" + With verbosity 1: "(('a : immediate) -> ('b -> 'c)) -> ('a : immediate) -> ('b -> 'c)" -parameter @@ -291,12 +291,12 @@ to print everything on one line. let poly_client3 x = poly3 x ^ With verbosity 0: "'a" - With verbosity 1: "'a" + With verbosity 1: "('a : float64)" let poly_client4 x = poly4 x ^ With verbosity 0: "'a -> ('b -> 'c)" - With verbosity 1: "'a -> ('b -> 'c)" + With verbosity 1: "('a : immediate) -> ('b -> 'c)" (V) Parameterized type - definition @@ -336,7 +336,7 @@ to print everything on one line. type ('a : immediate) p2 = A of 'a [@@unboxed] ^ With verbosity 0: "'a" - With verbosity 1: "'a" + With verbosity 1: "('a : immediate)" (V) Parameterized type client @@ -357,7 +357,7 @@ to print everything on one line. let param_client2 (x : 'a p2) (a : 'a) = x, a ^ With verbosity 0: "'a p2 -> 'a -> 'a p2 * 'a" - With verbosity 1: "'a p2 -> 'a -> 'a p2 * 'a" + With verbosity 1: "('a : immediate) p2 -> ('a : immediate) -> ('a : immediate) p2 * ('a : immediate)" - parameter @@ -377,5 +377,4 @@ to print everything on one line. let param_client2 (x : 'a p2) (a : 'a) = x, a ^ With verbosity 0: "'a p2" - With verbosity 1: "'a p2 type ('a : immediate) p2 = A of 'a [@@unboxed]" - + With verbosity 1: "('a : immediate) p2 type ('a : immediate) p2 = A of 'a [@@unboxed]"