Add locate_type_multi query

Author: liam923

merlin-lib.opam

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

merlin.opam

@@ -16,7 +16,6 @@ depends: [
   "merlin-lib" {= version}
   "dot-merlin-reader" {>= "5.0"}
   "ocaml-index" {>= "1.0" & post}
-  "yojson" {>= "2.0.0"}
   "conf-jq" {with-test}
   "ppxlib" {with-test}
 ]

src/analysis/locate_type_multi.ml

@@ -0,0 +1,37 @@
+open StdLabels
+
+module Type_tree = struct
+  type node_data =
+    | Artificial_node of [ `Arrow | `Tuple ]
+    | Type 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 = Artificial_node `Arrow; children }
+  | Ttuple tys | Tunboxed_tuple tys ->
+    let children =
+      List.filter_map tys ~f:(fun (_, ty) -> create_type_tree ty)
+    in
+    Some { data = Artificial_node `Tuple; children }
+  | Tconstr (path, arg_tys, abbrev_memo) ->
+    let ty_without_args =
+      Types.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 { path; ty = ty_without_args }; children }
+  | Tlink ty | Tpoly (ty, _) -> create_type_tree ty
+  | Tobject _ | Tfield _ ->
+    (* CR-someday: support objects *)
+    None
+  | Tnil | Tvar _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> None

src/analysis/locate_type_multi.mli

@@ -0,0 +1,9 @@
+module Type_tree : sig
+  type node_data =
+    | Artificial_node of [ `Arrow | `Tuple ]
+    | Type of { path : Path.t; ty : Types.type_expr }
+
+  type t = { data : node_data; children : t list }
+end
+
+val create_type_tree : Types.type_expr -> Type_tree.t option

src/commands/dune

@@ -12,5 +12,8 @@
     merlin-lib.utils
     merlin-lib.kernel
     merlin-lib.query_protocol
+    merlin-lib.query_protocol_kernel
     merlin-lib.query_commands
-    merlin-lib.ocaml_utils))
+    merlin-lib.ocaml_utils
+    yojson)
+  (preprocess (pps ppx_yojson_conv)))

src/commands/new_commands.ml

@@ -513,6 +513,22 @@ let all_commands =
           | #Msource.position as pos ->
             run buffer (Query_protocol.Locate_type pos)
       end;
+    command "locate-type-multi"
+      ~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

@@ -79,6 +79,8 @@ 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-type-multi" [ ("position", mk_position pos) ]
   | Enclosing pos -> mk "enclosing" [ ("position", mk_position pos) ]
   | Complete_prefix (prefix, pos, kind, doc, typ) ->
     mk "complete-prefix"
@@ -474,6 +476,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_type_multi_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 Ocaml_utils)
- (libraries merlin_kernel merlin_utils ocaml_parsing ocaml_utils))
+ (flags :standard -open Merlin_utils -open Merlin_kernel -open Ocaml_parsing -open Ocaml_utils -open Query_protocol_kernel)
+ (libraries merlin_kernel merlin_utils ocaml_parsing ocaml_utils query_protocol_kernel))
 
 (library
  (name        query_commands)
@@ -32,4 +32,5 @@
   merlin_analysis
   merlin_sherlodoc
   query_protocol
+  query_protocol_kernel
   str))

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_yojson_conv)))

src/frontend/kernel/query_protocol_kernel.ml

@@ -0,0 +1,37 @@
+(* 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 struct
+  include 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
+end
+
+module Locate_type_multi_result = struct
+  open Ppx_yojson_conv_lib.Yojson_conv.Primitives
+
+  type node_data =
+    | Artificial_node of [ `Arrow | `Tuple ]
+    | Type 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]
+end