Merge pull request #1932 from Tim-ats-d/test-outline

Fix class type handling in outline

Author: voodoos

CHANGES.md

@@ -9,6 +9,7 @@ unreleased
     - `occurrences` now reports stale files (#1885)
     - `inlay-hints` fix inlay hints on function parameters (#1923)
     - Fix issues with ident validation and Lid comparison for occurrences (#1924)
+    - Handle class type in outline (#1932)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

src/analysis/outline.ml

@@ -53,6 +53,11 @@ let get_class_field_desc_infos = function
   | Typedtree.Tcf_method (str_loc, _, _) -> Some (str_loc, `Method)
   | _ -> None
 
+let get_class_signature_field_desc_infos = function
+  | Typedtree.Tctf_val (outline_name, _, _, _) -> Some (outline_name, `Value)
+  | Typedtree.Tctf_method (outline_name, _, _, _) -> Some (outline_name, `Method)
+  | _ -> None
+
 let outline_type ~env typ =
   let ppf, to_string = Format.to_string () in
   Printtyp.wrap_printing_env env (fun () ->
@@ -141,6 +146,13 @@ let rec summarize node =
     in
     let deprecated = Type_utils.is_deprecated cd.ci_attributes in
     Some (mk ~children ~location `Class None cd.ci_id_class_type ~deprecated)
+  | Class_type_declaration ctd ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+    in
+    let deprecated = Type_utils.is_deprecated ctd.ci_attributes in
+    Some
+      (mk ~children ~location `ClassType None ctd.ci_id_class_type ~deprecated)
   | _ -> None
 
 and get_class_elements node =
@@ -151,20 +163,31 @@ and get_class_elements node =
     List.filter_map (Lazy.force node.t_children) ~f:(fun child ->
         match child.t_node with
         | Class_field cf -> begin
-          match get_class_field_desc_infos cf.cf_desc with
-          | Some (str_loc, outline_kind) ->
-            let deprecated = Type_utils.is_deprecated cf.cf_attributes in
-            Some
-              { Query_protocol.outline_name = str_loc.Location.txt;
-                outline_kind;
-                outline_type = None;
-                location = str_loc.Location.loc;
-                children = [];
-                deprecated
-              }
-          | None -> None
+          cf.cf_desc |> get_class_field_desc_infos
+          |> Option.map ~f:(fun (str_loc, outline_kind) ->
+                 let deprecated = Type_utils.is_deprecated cf.cf_attributes in
+                 { Query_protocol.outline_name = str_loc.Location.txt;
+                   outline_kind;
+                   outline_type = None;
+                   location = str_loc.Location.loc;
+                   children = [];
+                   deprecated
+                 })
         end
         | _ -> None)
+  | Class_type { cltyp_desc = Tcty_signature { csig_fields; _ }; _ } ->
+    List.filter_map csig_fields ~f:(fun field ->
+        get_class_signature_field_desc_infos field.ctf_desc
+        |> Option.map ~f:(fun (name, outline_kind) ->
+               let deprecated = Type_utils.is_deprecated field.ctf_attributes in
+               { Query_protocol.outline_name = name;
+                 outline_kind;
+                 outline_type = None;
+                 location = field.ctf_loc;
+                 (* TODO: could we have more precised location information? *)
+                 children = [];
+                 deprecated
+               }))
   | _ -> []
 
 and get_mod_children node =

src/commands/query_json.ml

@@ -227,6 +227,7 @@ let string_of_completion_kind = function
   | `MethodCall -> "#"
   | `Exn -> "Exn"
   | `Class -> "Class"
+  | `ClassType -> "ClassType"
   | `Keyword -> "Keyword"
 
 let with_location ?(with_file = false) ?(skip_none = false) loc assoc =

src/frontend/query_protocol.ml

@@ -88,6 +88,7 @@ and item =
       | `Type
       | `Exn
       | `Class
+      | `ClassType
       | `Method ];
     outline_type : string option;
     deprecated : bool;

tests/test-dirs/outline.t/foo.ml

@@ -1,28 +1,73 @@
 module Bar = struct
- type t = int
- module type S1 = sig
-   type t
+  type t = int
+  module type S1 = sig
+    type t
 
-   val foo : t -> int
- end
+    val foo : t -> int
+  end
+
+  class type b = object end
 end
 
 class type class_type_a = object
   method a : int -> int
 end
 
-class class_b = object
-  method b s = s ^ s
-end
+class class_b =
+  object
+    method b s = s ^ s
+  end
 
 exception Ex of char
 
-type ('a, 'b) eithery =
-  | Lefty of 'a
-  | Righty of 'b
+type ('a, 'b) eithery = Lefty of 'a | Righty of 'b
+
+type 'a point = { x : 'a; y : 'a; z : 'a }
+
+class a = object end
+
+and b = object end
+
+and c = object end
+
+class type ta = object end
+
+and tb = object end
+
+class b =
+  object
+    val foo = 10
+    method bar () = print_endline "bar"
+  end
+
+and c = object end
+
+class a =
+  object
+    val b =
+      object
+        method inside_a_b () =
+          let x_inside_a_b = 10 in
+          print_int x_inside_a_b
+      end
+  end
+
+and b =
+  object
+    val foo = 10
+    method bar = print_endline "bar"
+  end
+
+class type ta = object
+  method baz : int -> int -> string
+end
+
+and tb = object end
 
-type 'a point =
-  { x : 'a
-  ; y : 'a
-  ; z : 'a
-  }
+let final_let =
+  let c =
+    object
+      method foo = 10
+    end
+  in
+  c