Add type hovers for jkinds

src/analysis/type_enclosing.ml

@@ -9,6 +9,7 @@ type type_info =
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
   | Type_constr of Env.t * Types.constructor_description
+  | Jkind of Env.t * Types.jkind_lr
   | String of string
 
 type typed_enclosings =
@@ -34,6 +35,10 @@ let print_type ~verbosity type_info =
     wrap_printing_env env (fun () ->
         Printtyp.modtype env ppf m;
         Format.flush_str_formatter ())
+  | Jkind (env, jkind) ->
+    wrap_printing_env env (fun () ->
+        Jkind.format_expanded ppf jkind;
+        Format.flush_str_formatter ())
   | String s -> s
 
 let from_nodes ~path =
@@ -57,6 +62,21 @@ let from_nodes ~path =
     | Module_declaration_name { md_type = { mty_type = m } }
     | Module_type_declaration_name { mtd_type = Some { mty_type = m } } ->
       ret (Modtype (env, m))
+    | Jkind_annotation annot -> (
+      (* CR-someday: We need to parse the annotation because the compiler doesn't include
+         the parsed jkind in the relevant spots. We should track it so that this is less
+         hacky. It would also make it easier to deal with with-bounds. *)
+      (* [Jkind.of_annotation] will fail to parse jkinds with with-bounds. For now, this
+         isn't important. Usually, users will be hovering a jkind to know what an
+         abbreviation means. *)
+      try
+        (* The context isn't important. It's just used for printing error messages, which
+           we immediately discard anyways. *)
+        let jkind =
+          Jkind.of_annotation ~context:(Type_variable "fake_for_merlin") annot
+        in
+        ret (Jkind (env, jkind))
+      with Jkind.Error.User_error _ -> None)
     | Class_field
         { cf_desc = Tcf_method (_, _, Tcfk_concrete (_, { exp_type })) } ->
     begin

src/analysis/type_enclosing.mli

@@ -39,6 +39,7 @@ type type_info =
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
   | Type_constr of Env.t * Types.constructor_description
+  | Jkind of Env.t * Types.jkind_lr
   | String of string
 
 type typed_enclosings =

src/ocaml/typing/jkind.mli

@@ -899,3 +899,11 @@ module Debug_printers : sig
     val t : Format.formatter -> 'd Const.t -> unit
   end
 end
+
+(* For Merlin *)
+
+module Error : sig
+  type t
+
+  exception User_error of Location.t * t
+end

tests/test-dirs/type-enclosing/jkind-hover.t

@@ -0,0 +1,117 @@
+Test that hovering over jkind annotations shows their full expansion.
+
+  $ file="test.ml"
+
+  $ print_merlin_result () {
+  >   result="$1"
+  >   line=$(echo "$result" | jq '.start.line')
+  >   start=$(echo "$result" | jq '.start.col')
+  >   end=$(echo "$result" | jq '.end.col')
+  >   
+  >   start_for_cut=$((start + 1))
+  >   end_for_cut=$((end + 1))
+  >   value=$(sed -n "${line}p" "$file" | cut -c "${start_for_cut}-${end_for_cut}")
+  >   type=$(echo "$result" | jq '.type' -r)
+  >   echo "\"$value\" : \"$type\""
+  > }
+
+  $ hover () {
+  >   line="$1"
+  >   col="$2"
+  >   enclosings="$3"
+  >   
+  >   # Print the location we are hovering
+  >   sed -n "${line}p" "$file"
+  >   printf '%*s^\n' "$col" ''
+  >   
+  >   # Then print the output from Merlin
+  >   $MERLIN single type-enclosing -position "$line:$col" -filename "$file" < "$file" \
+  >     | jq -c ".value[:$enclosings][]" \
+  >     | while read -r result; do
+  >         print_merlin_result "$result"
+  >       done
+  > }
+
+  $ cat > "$file" << EOF
+  > type t1 : immutable_data
+  > type t2 : value mod portable
+  > type ('a : immediate) t3 : value
+  > type 'a t4 : immutable_data mod global with 'a
+  > type t5 : value mod everything
+  > type t6 : bits32
+  > type t7 : bits32 mod portable contended
+  > type t8 : void
+  > module type S = sig
+  >   val f : ('a : immediate). 'a -> 'a
+  >   val g : ('b : bits32) -> ('b : value mod portable)
+  > end
+  > EOF
+
+  $ hover 1 14 1
+  type t1 : immutable_data
+                ^
+  "immutable_data" : "value mod forkable unyielding many stateless immutable non_float"
+
+  $ hover 2 11 2
+  type t2 : value mod portable
+             ^
+  "value " : "value"
+  "value mod portable" : "value mod portable"
+
+  $ hover 3 16 1
+  type ('a : immediate) t3 : value
+                  ^
+  "immediate)" : "value mod global many stateless immutable external_ non_float"
+
+  $ hover 3 28 2
+  type ('a : immediate) t3 : value
+                              ^
+  "value" : "value"
+  "type ('a : immediate) t3 : value" : "type ('a : immediate) t3"
+
+# CR-someday: It'd be nice to print the with-bounds when we enclose the whole jkind
+  $ hover 4 20 3
+  type 'a t4 : immutable_data mod global with 'a
+                      ^
+  "immutable_data " : "value mod forkable unyielding many stateless immutable non_float"
+  "immutable_data mod global " : "value mod global many stateless immutable non_float"
+  "type 'a t4 : immutable_data mod global with 'a" : "type 'a t4 : immutable_data mod global unforkable yielding with 'a"
+
+  $ hover 5 11 2
+  type t5 : value mod everything
+             ^
+  "value " : "value"
+  "value mod everything" : "value mod global many stateless immutable external_"
+
+  $ hover 6 11 1
+  type t6 : bits32
+             ^
+  "bits32" : "bits32 mod non_float"
+
+  $ hover 7 11 2
+  type t7 : bits32 mod portable contended
+             ^
+  "bits32 " : "bits32 mod non_float"
+  "bits32 mod portable contended" : "bits32 mod portable contended non_float"
+
+  $ hover 8 11 1
+  type t8 : void
+             ^
+  "void" : "void mod non_float"
+
+  $ hover 10 18 1
+    val f : ('a : immediate). 'a -> 'a
+                    ^
+  "immediate)" : "value mod global many stateless immutable external_ non_float"
+
+  $ hover 11 18 1
+    val g : ('b : bits32) -> ('b : value mod portable)
+                    ^
+  "bits32)" : "bits32 mod non_float"
+
+# CR-someday: This is failing because of poor error recovery.
+  $ hover 11 35 2
+    val g : ('b : bits32) -> ('b : value mod portable)
+                                     ^
+  "('b : value mod portable)" : "'a"
+  "('b : bits32) -> ('b : value mod portable)" : "'b -> 'a"