Print non-value layouts on type variables

Signed-off-by: Nick Roberts <[email protected]>

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 =

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
 

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 :

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,9 @@ 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]"
 
+<<<<<<< HEAD
+||||||| parent of adf20680d (Print non-value layouts on type variables)
+=======
+>>>>>>> adf20680d (Print non-value layouts on type variables)