Expand one level of type definition on hover.

Fixes #557

Author: cristianoc

CHANGELOG.md

@@ -16,6 +16,7 @@
 
 - Add support for prop completion for JSX V4 https://github.com/rescript-lang/rescript-vscode/pull/579
 - Add support for create interface file for JSX V4 https://github.com/rescript-lang/rescript-vscode/pull/580
+- Expand one level of type definition on hover. Dig into record/variant body.
 
 ## v1.6.0
 

analysis/src/Hover.ml

@@ -98,25 +98,53 @@ let newHover ~full:{file; package} locItem =
          | Const_int64 _ -> "int64"
          | Const_nativeint _ -> "int"))
   | Typed (_, t, locKind) ->
+    let fromConstructorPath ~env path =
+      match References.digConstructor ~env ~package path with
+      | None -> None
+      | Some (_env, {name = {txt}; item = {decl}}) ->
+        if Utils.isUncurriedInternal path then None
+        else Some (decl |> Shared.declToString txt |> codeBlock)
+    in
     let fromType ~docstring typ =
       let typeString = codeBlock (typ |> Shared.typeToString) in
-      let extraTypeInfo =
+      let typeDefinitions =
+        (* Expand definitions of types mentioned in typ.
+           If typ itself is a record or variant, search its body *)
         let env = QueryEnv.fromFile file in
-        match typ |> Shared.digConstructor with
-        | None -> None
-        | Some path -> (
-          match References.digConstructor ~env ~package path with
-          | None -> None
-          | Some (_env, {docstring; name = {txt}; item = {decl}}) ->
-            if Utils.isUncurriedInternal path then None
-            else Some (decl |> Shared.declToString txt, docstring))
-      in
-      let typeString, docstring =
-        match extraTypeInfo with
-        | None -> (typeString, docstring)
-        | Some (extra, extraDocstring) ->
-          (typeString ^ "\n\n" ^ codeBlock extra, extraDocstring)
+        let envToSearch, typesToSearch =
+          match typ |> Shared.digConstructor with
+          | Some path -> (
+            let labelDeclarationsTypes lds =
+              lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type)
+            in
+            match References.digConstructor ~env ~package path with
+            | None -> (env, [typ])
+            | Some (env1, {item = {decl}}) -> (
+              match decl.type_kind with
+              | Type_record (lds, _) ->
+                (env1, typ :: (lds |> labelDeclarationsTypes))
+              | Type_variant cds ->
+                ( env1,
+                  cds
+                  |> List.map (fun (cd : Types.constructor_declaration) ->
+                         let fromArgs =
+                           match cd.cd_args with
+                           | Cstr_tuple ts -> ts
+                           | Cstr_record lds -> lds |> labelDeclarationsTypes
+                         in
+                         typ
+                         ::
+                         (match cd.cd_res with
+                         | None -> fromArgs
+                         | Some t -> t :: fromArgs))
+                  |> List.flatten )
+              | _ -> (env, [typ])))
+          | None -> (env, [typ])
+        in
+        let constructors = Shared.findTypeConstructors typesToSearch in
+        constructors |> List.filter_map (fromConstructorPath ~env:envToSearch)
       in
+      let typeString = typeString :: typeDefinitions |> String.concat "\n\n" in
       (typeString, docstring)
     in
     let parts =

analysis/src/Shared.ml

@@ -29,20 +29,38 @@ let tryReadCmi cmi =
       None
     | x -> Some x
 
-(** TODO move to the Process_ stuff *)
-let rec dig typ =
-  match typ.Types.desc with
-  | Types.Tlink inner -> dig inner
-  | Types.Tsubst inner -> dig inner
-  | Types.Tpoly (inner, _) -> dig inner
-  | _ -> typ
+let rec dig (te : Types.type_expr) =
+  match te.desc with
+  | Tlink inner -> dig inner
+  | Tsubst inner -> dig inner
+  | Tpoly (inner, _) -> dig inner
+  | _ -> te
 
-let digConstructor expr =
-  let expr = dig expr in
-  match expr.desc with
+let digConstructor te =
+  match (dig te).desc with
   | Tconstr (path, _args, _memo) -> Some path
   | _ -> None
 
+let findTypeConstructors (tel : Types.type_expr list) =
+  let paths = ref [] in
+  let addPath path =
+    if not (List.exists (Path.same path) !paths) then paths := path :: !paths
+  in
+  let rec loop (te : Types.type_expr) =
+    match te.desc with
+    | Tlink te1 | Tsubst te1 | Tpoly (te1, _) -> loop te1
+    | Tconstr (path, _, _) -> addPath path
+    | Tarrow (_, te1, te2, _) ->
+      loop te1;
+      loop te2
+    | Ttuple tel -> tel |> List.iter loop
+    | Tnil | Tvar _ | Tobject _ | Tfield _ | Tvariant _ | Tunivar _ | Tpackage _
+      ->
+      ()
+  in
+  tel |> List.iter loop;
+  !paths |> List.rev
+
 let declToString ?(recStatus = Types.Trec_not) name t =
   PrintType.printDecl ~recStatus name t
 

analysis/tests/src/expected/Auto.res.txt

@@ -1,3 +1,3 @@
 Hover src/Auto.res 2:13
-{"contents": "```rescript\n(Belt.List.t<'a>, 'a => 'b) => Belt.List.t<'b>\n```\n\n\n  Returns a new list with `f` applied to each element of `someList`.\n\n  ```res example\n  list{1, 2}->Belt.List.map(x => x + 1) // list{3, 4}\n  ```\n"}
+{"contents": "```rescript\n(Belt.List.t<'a>, 'a => 'b) => Belt.List.t<'b>\n```\n\n```rescript\ntype t<'a> = list<'a>\n```\n\n\n  Returns a new list with `f` applied to each element of `someList`.\n\n  ```res example\n  list{1, 2}->Belt.List.map(x => x + 1) // list{3, 4}\n  ```\n"}
 

analysis/tests/src/expected/Definition.res.txt

@@ -8,7 +8,7 @@ Hover src/Definition.res 14:14
 {"contents": "```rescript\n('a => 'b, list<'a>) => list<'b>\n```\n\n [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],\n   and builds the list [[f a1; ...; f an]]\n   with the results returned by [f].  Not tail-recursive. "}
 
 Hover src/Definition.res 18:14
-{"contents": "```rescript\n(Belt.List.t<'a>, 'a => 'b) => Belt.List.t<'b>\n```\n\n\n  Returns a new list with `f` applied to each element of `someList`.\n\n  ```res example\n  list{1, 2}->Belt.List.map(x => x + 1) // list{3, 4}\n  ```\n"}
+{"contents": "```rescript\n(Belt.List.t<'a>, 'a => 'b) => Belt.List.t<'b>\n```\n\n```rescript\ntype t<'a> = list<'a>\n```\n\n\n  Returns a new list with `f` applied to each element of `someList`.\n\n  ```res example\n  list{1, 2}->Belt.List.map(x => x + 1) // list{3, 4}\n  ```\n"}
 
 Hover src/Definition.res 23:3
 {"contents": "```rescript\n(. int, int) => int\n```"}

analysis/tests/src/expected/Div.res.txt

@@ -1,6 +1,6 @@
 Hover src/Div.res 0:10
 getLocItem #3: heuristic for <div>
-{"contents": "```rescript\n(\n  string,\n  ~props: ReactDOMRe.domProps=?,\n  array<React.element>,\n) => React.element\n```"}
+{"contents": "```rescript\n(\n  string,\n  ~props: ReactDOMRe.domProps=?,\n  array<React.element>,\n) => React.element\n```\n\n```rescript\ntype element\n```"}
 
 Complete src/Div.res 3:17
 posCursor:[3:17] posNoWhite:[3:16] Found expr:[3:4->3:17]

analysis/tests/src/expected/Hover.res.txt

@@ -75,10 +75,10 @@ Hover src/Hover.res 106:21
 {"contents": "```rescript\nint\n```"}
 
 Hover src/Hover.res 116:16
-{"contents": "```rescript\nAA.cond<[< #str(string)]> => AA.cond<[< #str(string)]>\n```"}
+{"contents": "```rescript\nAA.cond<[< #str(string)]> => AA.cond<[< #str(string)]>\n```\n\n```rescript\ntype cond<'a> = 'a\n  constraint 'a = [< #str(string)]\n```"}
 
 Hover src/Hover.res 119:25
-{"contents": "```rescript\nAA.cond<[< #str(string)]> => AA.cond<[< #str(string)]>\n```"}
+{"contents": "```rescript\nAA.cond<[< #str(string)]> => AA.cond<[< #str(string)]>\n```\n\n```rescript\ntype cond<'a> = 'a\n  constraint 'a = [< #str(string)]\n```"}
 
 Hover src/Hover.res 122:3
 Nothing at that position. Now trying to use completion.