Add locate-type-multi command

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,52 @@
+open StdLabels
+
+module Type_tree = struct
+  type node_data =
+    | Arrow
+    | Tuple
+    | 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 | Tunboxed_tuple tys ->
+    let children =
+      List.filter_map tys ~f:(fun (_, ty) -> create_type_tree ty)
+    in
+    Some { data = 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_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 }
+  | Tnil
+  | Tvar _
+  | Tsubst _
+  | Tvariant _
+  | Tunivar _
+  | Tpackage _
+  | Tfield _
+  | Tof_kind _ -> None

src/analysis/locate_type_multi.mli

@@ -0,0 +1,11 @@
+module Type_tree : sig
+  type node_data =
+    | Arrow
+    | Tuple
+    | Object
+    | Type_ref 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,23 @@ 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"
@@ -475,6 +477,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,39 @@
+(* 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 =
+    | Arrow
+    | Tuple
+    | Object
+    | 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]
+end

src/frontend/query_commands.ml

@@ -428,6 +428,74 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
         | `Found { file; location; _ } -> `Found (Some file, location.loc_start)
         | `File_not_found { file = reason; _ } -> `File_not_found reason)
     end
+  | Locate_type_multi pos -> (
+    let typer = Mpipeline.typer_result pipeline in
+    let verbosity = verbosity pipeline in
+    let local_defs = Mtyper.get_typedtree typer in
+    let structures = Mbrowse.of_typedtree local_defs in
+    let pos = Mpipeline.get_lexing_pos pipeline pos in
+    let result =
+      let open Misc_stdlib.Monad.Option.Syntax in
+      let* env, node =
+        match Mbrowse.enclosing pos [ structures ] with
+        | path :: _ -> Some path
+        | [] -> None
+      in
+      let* overall_ty =
+        Locate.log ~title:"query_commands Locate_type_multi"
+          "inspecting node: %s"
+          (Browse_raw.string_of_node node);
+        match node with
+        | Expression { exp_type = ty; _ }
+        | Pattern { pat_type = ty; _ }
+        | Core_type { ctyp_type = ty; _ }
+        | Value_description { val_desc = { ctyp_type = ty; _ }; _ } -> Some ty
+        | _ -> None
+      in
+      let+ type_tree = Locate_type_multi.create_type_tree overall_ty in
+      let type_to_string ~env ty =
+        Printtyp.wrap_printing_env env ~verbosity (fun () ->
+            Type_utils.print_type_with_decl ~verbosity env Format.str_formatter
+              ty);
+        Format.flush_str_formatter ()
+      in
+      let rec make_result ({ data; children } : Locate_type_multi.Type_tree.t) :
+          Locate_type_multi_result.type_tree =
+        let data : Locate_type_multi_result.node_data =
+          match data with
+          | Arrow -> Arrow
+          | Tuple -> Tuple
+          | Object -> Object
+          | Type_ref { path; ty } ->
+            Locate.log ~title:"debug" "found type: %s" (Path.name path);
+            let config : Locate.config =
+              { mconfig = Mpipeline.final_config pipeline;
+                ml_or_mli = `MLI;
+                traverse_aliases = true
+              }
+            in
+            let result =
+              match
+                Locate.from_path ~config ~env ~local_defs ~namespace:Type path
+              with
+              | `Builtin (_, s) -> `Builtin s
+              | `Not_in_env _ as s -> s
+              | `Not_found _ as s -> s
+              | `Found { file; location; _ } ->
+                `Found (Some file, location.loc_start)
+              | `File_not_found result -> `File_not_found result.file
+            in
+            let type_ = type_to_string ~env ty in
+            Type_ref { type_; result }
+        in
+        let children = List.map children ~f:make_result in
+        { data; children }
+      in
+      make_result type_tree
+    in
+    match result with
+    | Some result -> Success result
+    | None -> Invalid_context)
   | Complete_prefix (prefix, pos, kinds, with_doc, with_types) ->
     let pipeline, typer = for_completion pipeline pos in
     let config = Mpipeline.final_config pipeline in

src/frontend/query_protocol.ml

@@ -26,6 +26,8 @@
 
    )* }}} *)
 
+include Query_protocol_kernel
+
 module Compl = struct
   type 'desc raw_entry =
     { name : string;
@@ -231,6 +233,7 @@ type _ t =
          | `Not_found of string * string option
          | `At_origin ]
          t
+  | Locate_type_multi : Msource.position -> Locate_type_multi_result.t t
   | Locate (* *) :
       string option
       * [ `ML | `MLI ]

src/utils/dune

@@ -3,5 +3,5 @@
 (library
  (name merlin_utils)
  (public_name merlin-lib.utils)
- (libraries str unix)
+ (libraries str unix yojson)
  (foreign_stubs (language c) (names platform_misc)))

src/utils/std.ml

@@ -54,6 +54,8 @@ module Json = struct
       "Logger error: `Std.Json.pretty_to_string` is not set. You should \
        initialize that reference with the pretifier of your choice to enable \
        json logging. A common one is `Yojson.Basic.pretty_to_string`."
+
+  let of_yojson_safe = Yojson.Safe.to_basic
 end
 
 module Hashtbl = struct