Refactor some types into query_protocol_kernel

.github/workflows/main.yml

@@ -62,7 +62,7 @@ jobs:
       - name: Install dependencies
         run: |
           opam pin menhirLib 20201216 --no-action
-          opam install menhir csexp alcotest yojson conf-jq ocamlfind --yes
+          opam install menhir csexp alcotest yojson ppx_yojson_conv ppx_jane conf-jq ocamlfind --yes
 
       - name: Build and test in release mode
         run: |

CHANGES.md

@@ -22,6 +22,7 @@ Tue Jun 24 16:10:42 CEST 2025
       ocaml/ocaml-lsp#1489)
     - Reproduce and fix a handful of jump-to-definition (locate) issues  (#1930,
       fixes #1580 and #1588, workaround for #1934)
+    - Add `locate-types` command (#1951)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

merlin-lib.opam

@@ -18,6 +18,9 @@ depends: [
   "menhir"    {dev & >= "20201216"}
   "menhirLib" {dev & >= "20201216"}
   "menhirSdk" {dev & >= "20201216"}
+  "yojson" {>= "2.0.0"}
+  "ppx_yojson_conv" {>= "0.17.0"}
+  "ppx_jane" {>= "0.17.0"}
 ]
 synopsis:
   "Merlin's libraries"

src/analysis/dune

@@ -23,6 +23,7 @@
   ocaml_parsing
   ocaml_preprocess
   query_protocol
+  query_protocol_kernel
   ocaml_typing
   ocaml_utils
   str

src/analysis/locate_types.ml

@@ -0,0 +1,57 @@
+open StdLabels
+
+module Type_tree = struct
+  type node_data =
+    | Arrow
+    | Tuple
+    | Poly_variant
+    | Object
+    | Type_ref of { path : Path.t; ty : Types.type_expr }
+
+  type t = { data : node_data; children : t list }
+end
+
+let rec flatten_arrow ret_ty =
+  match Types.get_desc ret_ty with
+  | Tarrow (_, ty1, ty2, _) -> ty1 :: flatten_arrow ty2
+  | _ -> [ ret_ty ]
+
+let rec create_type_tree ty : Type_tree.t option =
+  match Types.get_desc ty with
+  | Tarrow (_, ty1, ty2, _) ->
+    let tys = ty1 :: flatten_arrow ty2 in
+    let children = List.filter_map tys ~f:create_type_tree in
+    Some { data = Arrow; children }
+  | Ttuple tys ->
+    let children = List.filter_map tys ~f:create_type_tree in
+    Some { data = Tuple; children }
+  | Tconstr (path, arg_tys, abbrev_memo) ->
+    let ty_without_args =
+      Btype.newty2 ~level:Ident.highest_scope (Tconstr (path, [], abbrev_memo))
+    in
+    let children = List.filter_map arg_tys ~f:create_type_tree in
+    Some { data = Type_ref { path; ty = ty_without_args }; children }
+  | Tlink ty | Tpoly (ty, _) -> create_type_tree ty
+  | Tobject (fields_type, _) ->
+    let rec extract_field_types (ty : Types.type_expr) =
+      match Types.get_desc ty with
+      | Tfield (_, _, ty, rest) -> ty :: extract_field_types rest
+      | _ -> []
+    in
+    let field_types = List.rev (extract_field_types fields_type) in
+    let children = List.filter_map field_types ~f:create_type_tree in
+    Some { data = Object; children }
+  | Tvariant row_desc ->
+    let fields = Types.row_fields row_desc in
+    let children =
+      List.concat_map fields ~f:(fun (_, row_field) ->
+          match Types.row_field_repr row_field with
+          | Rpresent (Some ty) -> create_type_tree ty |> Option.to_list
+          | Reither (_, tys, _) ->
+            (* CR-someday: Types seem to get duplicated here. For example, if the type is
+               [< `A of a], tys is [a; a]. This leads to duplicated results *)
+            List.filter_map tys ~f:create_type_tree
+          | Rpresent None | Rabsent -> [])
+    in
+    Some { data = Poly_variant; children }
+  | Tnil | Tvar _ | Tsubst _ | Tunivar _ | Tpackage _ | Tfield _ -> None

src/analysis/locate_types.mli

@@ -0,0 +1,13 @@
+module Type_tree : sig
+  type node_data =
+    | Arrow
+    | Tuple
+    | Poly_variant
+    | Object
+    | Type_ref of { path : Path.t; ty : Types.type_expr }
+
+  type t = { data : node_data; children : t list }
+end
+
+(** Convert a type into a simplified tree representation. *)
+val create_type_tree : Types.type_expr -> Type_tree.t option

src/commands/dune

@@ -11,4 +11,7 @@
     merlin-lib.utils
     merlin-lib.kernel
     merlin-lib.query_protocol
-    merlin-lib.query_commands))
+    merlin-lib.query_protocol_kernel
+    merlin-lib.query_commands
+    yojson)
+  (preprocess (pps ppx_yojson_conv)))

src/commands/new_commands.ml

@@ -500,6 +500,23 @@ let all_commands =
           | #Msource.position as pos ->
             run buffer (Query_protocol.Locate_type pos)
       end;
+    command "locate-types"
+      ~spec:
+        [ arg "-position" "<position> Position to locate the type of"
+            (marg_position (fun pos _ -> pos))
+        ]
+      ~doc:
+        "Locate the declaration of the type of the expression. If the type is \
+         expressed via multiple identifiers, it returns the location of each \
+         identifier."
+      ~default:`None
+      begin
+        fun buffer pos ->
+          match pos with
+          | `None -> failwith "-position <pos> is mandatory"
+          | #Msource.position as pos ->
+            run buffer (Query_protocol.Locate_type_multi pos)
+      end;
     command "occurrences"
       ~spec:
         [ arg "-identifier-at" "<position> Position of the identifier"

src/commands/query_json.ml

@@ -40,17 +40,7 @@ let dump (type a) : a t -> json =
   in
   let kinds_to_json kind =
     `List
-      (List.map
-         ~f:(function
-           | `Constructor -> `String "constructor"
-           | `Keywords -> `String "keywords"
-           | `Labels -> `String "label"
-           | `Modules -> `String "module"
-           | `Modules_type -> `String "module-type"
-           | `Types -> `String "type"
-           | `Values -> `String "value"
-           | `Variants -> `String "variant")
-         kind)
+      (List.map ~f:(fun kind -> `String (Compl.In_kind.to_string kind)) kind)
   in
   function
   | Type_expr (expr, pos) ->
@@ -70,6 +60,7 @@ let dump (type a) : a t -> json =
         ("position", mk_position pos)
       ]
   | Locate_type pos -> mk "locate-type" [ ("position", mk_position pos) ]
+  | Locate_type_multi pos -> mk "locate-types" [ ("position", mk_position pos) ]
   | Enclosing pos -> mk "enclosing" [ ("position", mk_position pos) ]
   | Complete_prefix (prefix, pos, kind, doc, typ) ->
     mk "complete-prefix"
@@ -215,20 +206,12 @@ let dump (type a) : a t -> json =
     mk "signature-help" [ ("position", mk_position position) ]
   | Version -> mk "version" []
 
-let string_of_completion_kind = function
-  | `Value -> "Value"
-  | `Variant -> "Variant"
-  | `Constructor -> "Constructor"
-  | `Label -> "Label"
-  | `Module -> "Module"
-  | `Modtype -> "Signature"
-  | `Type -> "Type"
-  | `Method -> "Method"
-  | `MethodCall -> "#"
-  | `Exn -> "Exn"
-  | `Class -> "Class"
-  | `ClassType -> "ClassType"
-  | `Keyword -> "Keyword"
+let string_of_completion_kind =
+  (* Merlin-jst: In upstream Merlin, the to_string logic lives here. But in Merlin-jst,
+     we've moved it to query_protocol_kernel so that it can be used in jsoo contexts *)
+  function
+  | #Compl.Out_kind.t as kind -> Compl.Out_kind.to_string kind
+  | #Outline_kind.t as kind -> Outline_kind.to_string kind
 
 let with_location ?(with_file = false) ?(skip_none = false) loc assoc =
   let with_file l =
@@ -461,6 +444,8 @@ let json_of_response (type a) (query : a t) (response : a) : json =
     in
     str
   | Locate_type _, resp -> json_of_locate resp
+  | Locate_type_multi _, resp ->
+    Json.of_yojson_safe (Locate_types_result.yojson_of_t resp)
   | Locate _, resp -> json_of_locate resp
   | Jump _, resp -> begin
     match resp with

src/frontend/dune

@@ -2,8 +2,8 @@
  (name        query_protocol)
  (public_name merlin-lib.query_protocol)
  (modules     query_protocol)
- (flags :standard -open Merlin_utils -open Merlin_kernel -open Ocaml_parsing -open Merlin_kernel)
- (libraries merlin_kernel merlin_utils ocaml_parsing))
+ (flags :standard -open Merlin_utils -open Merlin_kernel -open Ocaml_parsing -open Merlin_kernel -open Query_protocol_kernel)
+ (libraries merlin_kernel merlin_utils ocaml_parsing query_protocol_kernel))
 
 (library
  (name        query_commands)
@@ -31,4 +31,5 @@
   merlin_analysis
   merlin_sherlodoc
   query_protocol
+  query_protocol_kernel
   str))

src/frontend/kernel/completion_kind.ml

@@ -0,0 +1,88 @@
+module In = struct
+  type t =
+    [ `Constructor
+    | `Labels
+    | `Modules
+    | `Modules_type
+    | `Types
+    | `Values
+    | `Variants
+    | `Keywords ]
+  [@@deriving enumerate, equal]
+
+  let to_string = function
+    | `Constructor -> "constructor"
+    | `Keywords -> "keywords"
+    | `Labels -> "label"
+    | `Modules -> "module"
+    | `Modules_type -> "module-type"
+    | `Types -> "type"
+    | `Values -> "value"
+    | `Variants -> "variant"
+
+  let of_string_opt = function
+    | "t" | "type" | "types" -> Some `Types
+    | "v" | "val" | "value" | "values" -> Some `Values
+    | "variant" | "variants" | "var" -> Some `Variants
+    | "c" | "constr" | "constructor" -> Some `Constructor
+    | "l" | "label" | "labels" -> Some `Labels
+    | "m" | "mod" | "module" -> Some `Modules
+    | "mt" | "modtype" | "module-type" -> Some `Modules_type
+    | "k" | "kw" | "keyword" | "keywords" -> Some `Keywords
+    | _ -> None
+end
+
+module Out = struct
+  (* CR-someday: This module is necessary because ppx_string_conv doesn't currently
+     (v0.17.0) support polymorphic variants. *)
+  module For_deriving = struct
+    type t =
+      | Value [@rename "Value"]
+      | Constructor [@rename "Constructor"]
+      | Variant [@rename "Variant"]
+      | Label [@rename "Label"]
+      | Module [@rename "Module"]
+      | Modtype [@rename "Signature"]
+      | Type [@rename "Type"]
+      | MethodCall [@rename "#"]
+      | Keyword [@rename "Keyword"]
+    [@@deriving string]
+
+    let to_poly = function
+      | Value -> `Value
+      | Constructor -> `Constructor
+      | Variant -> `Variant
+      | Label -> `Label
+      | Module -> `Module
+      | Modtype -> `Modtype
+      | Type -> `Type
+      | MethodCall -> `MethodCall
+      | Keyword -> `Keyword
+
+    let of_poly = function
+      | `Value -> Value
+      | `Constructor -> Constructor
+      | `Variant -> Variant
+      | `Label -> Label
+      | `Module -> Module
+      | `Modtype -> Modtype
+      | `Type -> Type
+      | `MethodCall -> MethodCall
+      | `Keyword -> Keyword
+  end
+
+  type t =
+    [ `Value
+    | `Constructor
+    | `Variant
+    | `Label
+    | `Module
+    | `Modtype
+    | `Type
+    | `MethodCall
+    | `Keyword ]
+  [@@deriving enumerate, equal]
+
+  let to_string x = For_deriving.of_poly x |> For_deriving.to_string
+  let of_string s = For_deriving.of_string s |> For_deriving.to_poly
+end

src/frontend/kernel/completion_kind.mli

@@ -0,0 +1,28 @@
+module In : sig
+  type t =
+    [ `Constructor
+    | `Labels
+    | `Modules
+    | `Modules_type
+    | `Types
+    | `Values
+    | `Variants
+    | `Keywords ]
+  [@@deriving to_string, enumerate, equal]
+
+  val of_string_opt : string -> t option
+end
+
+module Out : sig
+  type t =
+    [ `Value
+    | `Constructor
+    | `Variant
+    | `Label
+    | `Module
+    | `Modtype
+    | `Type
+    | `MethodCall
+    | `Keyword ]
+  [@@deriving string, enumerate, equal]
+end

src/frontend/kernel/dune

@@ -0,0 +1,5 @@
+(library
+ (name        query_protocol_kernel)
+ (public_name merlin-lib.query_protocol_kernel)
+ (libraries yojson)
+ (preprocess (pps ppx_jane ppx_yojson_conv)))

src/frontend/kernel/locate_types_result.ml

@@ -0,0 +1,34 @@
+(* This module contains definitions that can be used in a js-of-ocaml environment. This
+   is useful because it allows VSCode extensions (which run in javascript) to use the
+   serializers/deserializers defined in this module. *)
+
+open Ppx_yojson_conv_lib.Yojson_conv.Primitives
+
+module Lexing = struct
+  include Lexing
+
+  type nonrec position = position =
+    { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int }
+  [@@deriving yojson]
+end
+
+type node_data =
+  | Arrow
+  | Tuple
+  | Object
+  | Poly_variant
+  | Type_ref of
+      { type_ : string;
+        result :
+          [ `Found of string option * Lexing.position
+          | `Builtin of string
+          | `Not_in_env of string
+          | `File_not_found of string
+          | `Not_found of string * string option ]
+      }
+[@@deriving yojson]
+
+type type_tree = { data : node_data; children : type_tree list }
+[@@deriving yojson]
+
+type t = Success of type_tree | Invalid_context [@@deriving yojson]

src/frontend/kernel/locate_types_result.mli

@@ -0,0 +1,20 @@
+type node_data =
+  | Arrow
+  | Tuple
+  | Object
+  | Poly_variant
+  | Type_ref of
+      { type_ : string;
+        result :
+          [ `Found of string option * Lexing.position
+          | `Builtin of string
+          | `Not_in_env of string
+          | `File_not_found of string
+          | `Not_found of string * string option ]
+      }
+[@@deriving yojson]
+
+type type_tree = { data : node_data; children : type_tree list }
+[@@deriving yojson]
+
+type t = Success of type_tree | Invalid_context [@@deriving yojson]