Add option to not print types when getting the outline

Author: liam923

src/analysis/outline.ml

@@ -53,14 +53,17 @@ let get_class_field_desc_infos = function
   | Typedtree.Tcf_method (str_loc, _, _) -> Some (str_loc, `Method)
   | _ -> None
 
-let outline_type ~env typ =
-  let ppf, to_string = Format.to_string () in
-  Printtyp.wrap_printing_env env (fun () ->
-      Type_utils.print_type_with_decl ~verbosity:(Mconfig.Verbosity.Lvl 0) env
-        ppf typ);
-  Some (to_string ())
-
-let rec summarize node =
+let outline_type ~include_types ~env typ =
+  match include_types with
+  | true ->
+    let ppf, to_string = Format.to_string () in
+    Printtyp.wrap_printing_env env (fun () ->
+        Type_utils.print_type_with_decl ~verbosity:(Mconfig.Verbosity.Lvl 0) env
+          ppf typ);
+    Some (to_string ())
+  | false -> None
+
+let rec summarize ~include_types node =
   let location = node.t_loc in
   match node.t_node with
   | Value_binding vb ->
@@ -69,15 +72,15 @@ let rec summarize node =
       match id_of_patt vb.vb_pat with
       | None -> None
       | Some ident ->
-        let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in
+        let typ = outline_type ~include_types ~env:node.t_env vb.vb_pat.pat_type in
         Some (mk ~location ~deprecated `Value typ ident)
     end
   | Value_description vd ->
     let deprecated = Type_utils.is_deprecated vd.val_attributes in
-    let typ = outline_type ~env:node.t_env vd.val_val.val_type in
+    let typ = outline_type ~include_types ~env:node.t_env vd.val_val.val_type in
     Some (mk ~location ~deprecated `Value typ vd.val_id)
   | Module_declaration md ->
-    let children = get_mod_children node in
+    let children = get_mod_children ~include_types node in
     begin
       match md.md_id with
       | None -> None
@@ -86,7 +89,7 @@ let rec summarize node =
         Some (mk ~children ~location ~deprecated `Module None id)
     end
   | Module_binding mb ->
-    let children = get_mod_children node in
+    let children = get_mod_children ~include_types node in
     begin
       match mb.mb_id with
       | None -> None
@@ -95,7 +98,7 @@ let rec summarize node =
         Some (mk ~children ~location ~deprecated `Module None id)
     end
   | Module_type_declaration mtd ->
-    let children = get_mod_children node in
+    let children = get_mod_children ~include_types node in
     let deprecated = Type_utils.is_deprecated mtd.mtd_attributes in
     Some (mk ~deprecated ~children ~location `Modtype None mtd.mtd_id)
   | Type_declaration td ->
@@ -120,7 +123,7 @@ let rec summarize node =
     let name = Path.name te.tyext_path in
     let children =
       List.filter_map (Lazy.force node.t_children) ~f:(fun x ->
-          summarize x >>| fun x ->
+          summarize ~include_types x >>| fun x ->
           { x with Query_protocol.outline_kind = `Constructor })
     in
     let deprecated = Type_utils.is_deprecated te.tyext_attributes in
@@ -167,24 +170,25 @@ and get_class_elements node =
         | _ -> None)
   | _ -> []
 
-and get_mod_children node =
-  List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
+and get_mod_children ~include_types node =
+  List.concat_map (Lazy.force node.t_children) ~f:(remove_mod_indir ~include_types)
 
-and remove_mod_indir node =
+and remove_mod_indir ~include_types node =
   match node.t_node with
   | Module_expr _ | Module_type _ ->
-    List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
-  | _ -> remove_top_indir node
+    List.concat_map (Lazy.force node.t_children) ~f:(remove_mod_indir ~include_types)
+  | _ -> remove_top_indir ~include_types node
 
-and remove_top_indir t =
+and remove_top_indir ~include_types t =
   match t.t_node with
   | Structure _ | Signature _ ->
-    List.concat_map ~f:remove_top_indir (Lazy.force t.t_children)
+    List.concat_map ~f:(remove_top_indir ~include_types) (Lazy.force t.t_children)
   | Signature_item _ | Structure_item _ ->
-    List.filter_map (Lazy.force t.t_children) ~f:summarize
+    List.filter_map (Lazy.force t.t_children) ~f:(summarize ~include_types)
   | _ -> []
 
-let get browses = List.concat @@ List.rev_map ~f:remove_top_indir browses
+let get ~include_types browses =
+  List.concat @@ List.rev_map ~f:(remove_top_indir ~include_types) browses
 
 let shape cursor nodes =
   let rec aux node =

src/analysis/outline.mli

@@ -26,5 +26,5 @@
 
    )* }}} *)
 
-val get : Browse_tree.t list -> Query_protocol.outline
+val get : include_types:bool -> Browse_tree.t list -> Query_protocol.outline
 val shape : Lexing.position -> Browse_tree.t list -> Query_protocol.shape list

src/commands/new_commands.ml

@@ -536,14 +536,19 @@ let all_commands =
           | `Ident_at pos, scope ->
             run buffer (Query_protocol.Occurrences (`Ident_at pos, scope))
       end;
-    command "outline" ~spec:[]
+    command "outline"
+      ~spec:
+        [ optional "-include-types" "Don't print"
+            (Marg.bool (fun include_types _ -> include_types))
+        ]
       ~doc:
         "Returns a tree of objects `{'start': position, 'end': position, \
          'name': string, 'kind': string, 'children': subnodes}` describing the \
          content of the buffer."
-      ~default:()
+      ~default:true
       begin
-        fun buffer () -> run buffer Query_protocol.Outline
+        fun buffer include_types ->
+          run buffer (Query_protocol.Outline { include_types })
       end;
     command "path-of-source"
       ~doc:

src/commands/query_json.ml

@@ -156,7 +156,8 @@ let dump (type a) : a t -> json =
         ("hint-pattern-variable", `Bool hint_pattern_var);
         ("avoid-ghost-location", `Bool ghost)
       ]
-  | Outline -> mk "outline" []
+  | Outline { include_types } ->
+    mk "outline" [ ("include-types", `Bool include_types) ]
   | Errors { lexing; parsing; typing } ->
     let args =
       if lexing && parsing && typing then []
@@ -502,7 +503,7 @@ let json_of_response (type a) (query : a t) (response : a) : json =
         ]
     in
     `List [ assoc; `List (List.map ~f:Json.string strs) ]
-  | Outline, outlines -> `List (json_of_outline outlines)
+  | Outline _, outlines -> `List (json_of_outline outlines)
   | Shape _, shapes -> `List (List.map ~f:json_of_shape shapes)
   | Inlay_hints _, result -> json_of_inlay_hints result
   | Errors _, errors -> `List (List.map ~f:json_of_error errors)

src/frontend/ocamlmerlin/old/old_IO.ml

@@ -178,7 +178,7 @@ let request_of_json context =
          (Locate (Some path, ml_or_mli choice, mandatory_position pos, None)))
   | `String "jump" :: `String target :: pos ->
     request (Query (Jump (target, mandatory_position pos)))
-  | [ `String "outline" ] -> request (Query Outline)
+  | [ `String "outline" ] -> request (Query (Outline { include_types = true }))
   | [ `String "shape"; pos ] -> request (Query (Shape (pos_of_json pos)))
   | [ `String "occurrences"; `String "ident"; `String "at"; jpos ] ->
     request (Query (Occurrences (`Ident_at (pos_of_json jpos), `Buffer)))

src/frontend/query_commands.ml

@@ -748,10 +748,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       | _ :: _ -> raise Construct.Not_a_hole
       | [] -> raise No_nodes
     end
-  | Outline ->
+  | Outline { include_types } ->
     let typer = Mpipeline.typer_result pipeline in
     let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
-    Outline.get [ Browse_tree.of_browse browse ]
+    Outline.get ~include_types [ Browse_tree.of_browse browse ]
   | Shape pos ->
     let typer = Mpipeline.typer_result pipeline in
     let browse = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in

src/frontend/query_protocol.ml

@@ -258,7 +258,7 @@ type _ t =
   | Inlay_hints :
       Msource.position * Msource.position * bool * bool * bool
       -> (Lexing.position * string) list t
-  | Outline (* *) : outline t
+  | Outline (* *) : { include_types : bool } -> outline t
   | Shape (* *) : Msource.position -> shape list t
   | Errors (* *) : error_filter -> Location.error list t
   | Dump : Std.json list -> Std.json t

tests/test-dirs/outline.t/run.t

@@ -242,3 +242,22 @@
   $ $MERLIN single outline -short-paths < path.ml | jq '.value[].type'
   "a"
   null
+
+Check that when we pass "-include-types false", every "type" is null.
+  $ $MERLIN single outline -include-types false < foo.ml \
+  >   | jq '.value | .. | objects | select(has("type")) | .type'
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null
+  null