diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index e2673bd18..9dab8b409 100644 --- a/src/analysis/type_enclosing.ml +++ b/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 diff --git a/src/analysis/type_enclosing.mli b/src/analysis/type_enclosing.mli index 87538b63e..1e5f40c31 100644 --- a/src/analysis/type_enclosing.mli +++ b/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 = diff --git a/src/ocaml/typing/jkind.mli b/src/ocaml/typing/jkind.mli index db9129495..e25b162bc 100644 --- a/src/ocaml/typing/jkind.mli +++ b/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 diff --git a/tests/test-dirs/type-enclosing/jkind-hover.t b/tests/test-dirs/type-enclosing/jkind-hover.t new file mode 100644 index 000000000..b46614405 --- /dev/null +++ b/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"