Merge pull request #2053 from voodoos/te-classes-test

Improve type enclosing behavior on various class and object related items

Author: voodoos

CHANGES.md

@@ -10,6 +10,8 @@ unreleased
     - Fix bugs on signature help about labelled and optional parameters (#2032)
     - Add `-end-position` parameter for `enclosing` (#2029)
     - Signature help should appear even if the 'in' is not written (#2036)
+    - Improve type enclosing behavior on various class and object related items
+      (#2053)
   + merlin binary
     - Define PATH_MAX to 4096 if undefined (eg. hurd) (#2039)
   + tests

src/analysis/completion.ml

@@ -133,6 +133,11 @@ let classify_node = function
   | Module_binding_name _ -> `Module
   | Module_declaration_name _ -> `Module
   | Module_type_declaration_name _ -> `Module_type
+  | Class_declaration_name _ -> `Expression
+  | Class_type_declaration_name _ -> `Type
+  | Class_description_name _ -> `Type
+  | Class_field_name _ -> `Expression
+  | Exp_new_class_name _ -> `Expression
   | Open_description _ -> `Module
   | Open_declaration _ -> `Module
   | Include_declaration _ -> `Module

src/analysis/type_enclosing.ml

@@ -6,6 +6,7 @@ let { Logger.log } = Logger.for_section log_section
 
 type type_info =
   | Modtype of Env.t * Types.module_type
+  | Classtype of Env.t * Types.class_type
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
   | Type_constr of Env.t * Data_types.constructor_description
@@ -22,6 +23,10 @@ let print_type ~verbosity type_info =
     wrap_printing_env env (fun () ->
         print_type_with_decl ~verbosity env ppf t;
         Format.flush_str_formatter ())
+  | Classtype (env, t) ->
+    wrap_printing_env env (fun () ->
+        Printtyp.class_type ppf t;
+        Format.flush_str_formatter ())
   | Type_decl (env, id, t) ->
     wrap_printing_env env (fun () ->
         Printtyp.type_declaration env id ppf t;
@@ -40,6 +45,14 @@ let from_nodes ~path =
   let aux (env, node, tail) =
     let open Browse_raw in
     let ret x = Some (Mbrowse.node_loc node, x, tail) in
+    let filter_method_arrow exp_type =
+      (* Method types show the class as first parameter:
+            [#c -> unit]
+         We remove it from the type shown to he user *)
+      match Types.get_desc exp_type with
+      | Tarrow (_, _, t, _) -> t
+      | _ -> exp_type
+    in
     match[@ocaml.warning "-9"] node with
     | Expression { exp_type = t }
     | Pattern { pat_type = t }
@@ -57,12 +70,20 @@ 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))
+    | Class_declaration_name { ci_expr = { cl_type = t; _ }; _ } ->
+      ret (Classtype (env, t))
+    | Class_description_name { ci_expr = { cltyp_type = t; _ }; _ } ->
+      ret (Classtype (env, t))
+    | Class_expr { cl_desc = Tcl_ident (_, _, _); cl_type = t; _ } ->
+      ret (Classtype (env, t))
+    | Class_field_name
+        { cf_desc = Tcf_val (_, _, _, Tcfk_concrete (_, { exp_type = t }), _) }
+      -> ret (Type (env, t))
     | Class_field
+        { cf_desc = Tcf_method (_, _, Tcfk_concrete (_, { exp_type })) }
+    | Class_field_name
         { cf_desc = Tcf_method (_, _, Tcfk_concrete (_, { exp_type })) } ->
-      begin match Types.get_desc exp_type with
-      | Tarrow (_, _, t, _) -> ret (Type (env, t))
-      | _ -> None
-      end
+      ret (Type (env, filter_method_arrow exp_type))
     | Class_field
         { cf_desc = Tcf_val (_, _, _, Tcfk_concrete (_, { exp_type = t }), _) }
       -> ret (Type (env, t))
@@ -72,6 +93,11 @@ let from_nodes ~path =
     | Class_field
         { cf_desc = Tcf_val (_, _, _, Tcfk_virtual { ctyp_type = t }, _) } ->
       ret (Type (env, t))
+    | Exp_new_class_name (_, decl) ->
+      begin match decl.cty_new with
+      | Some ty -> ret (Type (env, ty))
+      | None -> None
+      end
     | Binding_op { bop_op_type; _ } -> ret (Type (env, bop_op_type))
     | _ -> None
   in

src/analysis/type_enclosing.mli

@@ -36,6 +36,7 @@ val log_section : string
 
 type type_info =
   | Modtype of Env.t * Types.module_type
+  | Classtype of Env.t * Types.class_type
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
   | Type_constr of Env.t * Data_types.constructor_description

src/ocaml/merlin_specific/browse_raw.ml

@@ -84,6 +84,11 @@ type node =
   | Module_binding_name of module_binding
   | Module_declaration_name of module_declaration
   | Module_type_declaration_name of module_type_declaration
+  | Class_declaration_name of class_declaration
+  | Class_type_declaration_name of class_type_declaration
+  | Class_description_name of class_description
+  | Class_field_name of class_field
+  | Exp_new_class_name of Longident.t Location.loc * Types.class_declaration
 
 let node_update_env env0 = function
   | Pattern { pat_env = env }
@@ -104,6 +109,11 @@ let node_update_env env0 = function
   | Class_signature _
   | Class_field _
   | Class_field_kind _
+  | Class_declaration_name _
+  | Class_type_declaration_name _
+  | Class_description_name _
+  | Class_field_name _
+  | Exp_new_class_name _
   | Type_extension _
   | Extension_constructor _
   | Package_type _
@@ -159,6 +169,12 @@ let node_real_loc loc0 = function
   | Class_declaration { ci_loc = loc }
   | Class_description { ci_loc = loc }
   | Class_type_declaration { ci_loc = loc }
+  | Class_declaration_name { ci_id_name = { loc } }
+  | Class_type_declaration_name { ci_id_name = { loc } }
+  | Class_description_name { ci_id_name = { loc } }
+  | Class_field_name
+      { cf_desc = Tcf_val ({ loc }, _, _, _, _) | Tcf_method ({ loc }, _, _) }
+  | Exp_new_class_name ({ loc }, _)
   | Extension_constructor { ext_loc = loc }
   | Include_description { incl_loc = loc }
   | Include_declaration { incl_loc = loc }
@@ -180,6 +196,7 @@ let node_real_loc loc0 = function
   | Type_kind _
   | Class_signature _
   | Package_type _
+  | Class_field_name _
   | Dummy -> loc0
 
 let node_attributes = function
@@ -351,7 +368,8 @@ let of_method_call obj meth loc env (f : _ f0) acc =
 let rec of_expression_desc loc = function
   | Texp_ident _ | Texp_constant _ | Texp_instvar _
   | Texp_variant (_, None)
-  | Texp_new _ | Texp_typed_hole -> id_fold
+  | Texp_typed_hole -> id_fold
+  | Texp_new (_, lid, decl) -> app (Exp_new_class_name (lid, decl))
   | Texp_let (_, vbs, e) -> of_expression e ** list_fold of_value_binding vbs
   | Texp_function (params, body) ->
     list_fold of_function_param params ** of_function_body body
@@ -586,7 +604,8 @@ let of_node = function
   | Class_expr { cl_desc } -> of_class_expr_desc cl_desc
   | Class_structure { cstr_self; cstr_fields } ->
     of_pattern cstr_self ** list_fold (fun f -> app (Class_field f)) cstr_fields
-  | Class_field { cf_desc } -> of_class_field_desc cf_desc
+  | Class_field ({ cf_desc } as cf) ->
+    of_class_field_desc cf_desc ** app (Class_field_name cf)
   | Class_field_kind (Tcfk_virtual ct) -> of_core_type ct
   | Class_field_kind (Tcfk_concrete (_, e)) -> of_expression e
   | Module_expr { mod_desc } -> of_module_expr_desc mod_desc
@@ -656,17 +675,28 @@ let of_node = function
     of_core_type csig_self
     ** list_fold (fun x -> app (Class_type_field x)) csig_fields
   | Class_type_field { ctf_desc } -> of_class_type_field_desc ctf_desc
-  | Class_declaration { ci_params; ci_expr } ->
-    app (Class_expr ci_expr) ** list_fold of_typ_param ci_params
-  | Class_description { ci_params; ci_expr } ->
-    app (Class_type ci_expr) ** list_fold of_typ_param ci_params
-  | Class_type_declaration { ci_params; ci_expr } ->
-    app (Class_type ci_expr) ** list_fold of_typ_param ci_params
+  | Class_declaration ({ ci_params; ci_expr } as cd) ->
+    app (Class_expr ci_expr)
+    ** list_fold of_typ_param ci_params
+    ** app (Class_declaration_name cd)
+  | Class_description ({ ci_params; ci_expr } as cd) ->
+    app (Class_type ci_expr)
+    ** list_fold of_typ_param ci_params
+    ** app (Class_description_name cd)
+  | Class_type_declaration ({ ci_params; ci_expr } as ctd) ->
+    app (Class_type ci_expr)
+    ** list_fold of_typ_param ci_params
+    ** app (Class_type_declaration_name ctd)
   | Method_call _ -> id_fold
   | Record_field _ -> id_fold
   | Module_binding_name _ -> id_fold
   | Module_declaration_name _ -> id_fold
   | Module_type_declaration_name _ -> id_fold
+  | Class_declaration_name _ -> id_fold
+  | Class_type_declaration_name _ -> id_fold
+  | Class_description_name _ -> id_fold
+  | Class_field_name _ -> id_fold
+  | Exp_new_class_name _ -> id_fold
   | Open_description _ -> id_fold
   | Open_declaration od -> app (Module_expr od.open_expr)
   | Include_declaration i -> of_module_expr i.incl_mod
@@ -723,6 +753,11 @@ let string_of_node = function
   | Module_binding_name _ -> "module_binding_name"
   | Module_declaration_name _ -> "module_declaration_name"
   | Module_type_declaration_name _ -> "module_type_declaration_name"
+  | Class_declaration_name _ -> "class_declaration_name"
+  | Class_type_declaration_name _ -> "class_type_declaration_name"
+  | Class_description_name _ -> "class_description_name"
+  | Class_field_name _ -> "class_field_name"
+  | Exp_new_class_name _ -> "exp_new_class_name"
   | Open_description _ -> "open_description"
   | Open_declaration _ -> "open_declaration"
   | Include_description _ -> "include_description"

src/ocaml/merlin_specific/browse_raw.mli

@@ -97,6 +97,11 @@ type node =
   | Module_binding_name of module_binding
   | Module_declaration_name of module_declaration
   | Module_type_declaration_name of module_type_declaration
+  | Class_declaration_name of class_declaration
+  | Class_type_declaration_name of class_type_declaration
+  | Class_description_name of class_description
+  | Class_field_name of class_field
+  | Exp_new_class_name of Longident.t Location.loc * Types.class_declaration
 
 val fold_node : (Env.t -> node -> 'a -> 'a) -> Env.t -> node -> 'a -> 'a
 

tests/test-dirs/type-enclosing/objects.t/run.t

@@ -16,8 +16,20 @@
   ]
 
   $ $MERLIN single type-enclosing -position 2:14 -verbosity 1 \
-  > -filename ./test.ml < ./test.ml | tr '\r\n' ' ' | jq ".value[0:2]"
+  > -filename ./test.ml < ./test.ml | tr '\r\n' ' ' | jq ".value[0:3]"
   [
+    {
+      "start": {
+        "line": 2,
+        "col": 14
+      },
+      "end": {
+        "line": 2,
+        "col": 15
+      },
+      "type": "int list  type 'a list = [] | (::) of 'a * 'a list",
+      "tail": "no"
+    },
     {
       "start": {
         "line": 2,
@@ -45,8 +57,20 @@
   ]
 
   $ $MERLIN single type-enclosing -position 11:10 -verbosity 1 \
-  > -filename ./test.ml < ./test.ml | jq ".value[0:2]"
+  > -filename ./test.ml < ./test.ml | jq ".value[0:3]"
   [
+    {
+      "start": {
+        "line": 11,
+        "col": 9
+      },
+      "end": {
+        "line": 11,
+        "col": 13
+      },
+      "type": "int -> unit",
+      "tail": "no"
+    },
     {
       "start": {
         "line": 11,