hphp/hack/src/server/serverCallHierarchyIncomingCalls.ml

   1 (*
   2  * Copyright (c) Meta Platforms, Inc. and affiliates.
   3  *
   4  * This source code is licensed under the MIT license found in the
   5  * LICENSE file in the "hack" directory of this source tree.
   6  *
   7  *)
   8
   9 let group_refs_by_file (ref_result : ServerCommandTypes.Find_refs.result) :
  10     (string * ServerCommandTypes.Find_refs.result) list =
  11   let table = ref (3 * List.length ref_result / 4 |> Hashtbl.create) in
  12   let key_list : string list ref = ref [] in
  13   let add_ref_to_tbl ((name, pos) : string * Pos.absolute) : unit =
  14     let file_ = Pos.filename pos in
  15     if not (Hashtbl.mem !table file_) then key_list := file_ :: !key_list;
  16     Hashtbl.add !table file_ (name, pos)
  17   in
  18   List.iter add_ref_to_tbl ref_result;
  19   List.map (fun key -> (key, Hashtbl.find_all !table key)) !key_list
  20
  21 let occ_defs_of_file (ctx : Provider_context.t) (file : string) :
  22     (Relative_path.t SymbolOccurrence.t
  23     * Relative_path.t SymbolDefinition.t option)
  24     list =
  25   let path = Relative_path.create_detect_prefix file in
  26   let (ctx_out, entry) = Provider_context.add_entry_if_missing ~ctx ~path in
  27   let all_symbols = IdentifySymbolService.all_symbols_ctx ~ctx:ctx_out ~entry in
  28   let all_defs =
  29     List.filter (fun s -> s.SymbolOccurrence.is_declaration) all_symbols
  30   in
  31   let (_, get_def) = ServerDepsUtil.get_ast_getdef ctx_out entry in
  32   List.map (fun s -> (s, get_def s)) all_defs
  33
  34 let call_sites
  35     (refs : ServerCommandTypes.Find_refs.result)
  36     ((_, d) :
  37       Relative_path.t SymbolOccurrence.t
  38       * Relative_path.t SymbolDefinition.t option) :
  39     ServerCommandTypes.Find_refs.result =
  40   match d with
  41   | None -> []
  42   | Some ds ->
  43     List.filter
  44       (fun (_, p) -> Pos.contains ds.SymbolDefinition.span (Pos.to_relative p))
  45       refs
  46
  47 let def_call_sites_to_incoming_call
  48     ((o, d) :
  49       Relative_path.t SymbolOccurrence.t
  50       * Relative_path.t SymbolDefinition.t option)
  51     (refs : ServerCommandTypes.Find_refs.result) :
  52     Lsp.CallHierarchyIncomingCalls.callHierarchyIncomingCall =
  53   let open Lsp.CallHierarchyIncomingCalls in
  54   let from_ = Lsp_helpers.symbol_to_lsp_call_item o d in
  55   let fromRanges_ =
  56     List.map (fun (_, p) -> Lsp_helpers.pos_to_lsp_range p) refs
  57   in
  58   { from = from_; fromRanges = fromRanges_ }
  59
  60 let file_refs_to_incoming_calls
  61     (ctx : Provider_context.t)
  62     ((file, refs) : string * ServerCommandTypes.Find_refs.result) :
  63     Lsp.CallHierarchyIncomingCalls.callHierarchyIncomingCall list =
  64   let occ_defs = occ_defs_of_file ctx file in
  65   let present_occ_defs =
  66     List.filter (fun (_, d) -> Option.is_some d) occ_defs
  67   in
  68   let def_call_sites = List.map (call_sites refs) present_occ_defs in
  69   let def_call_sites_zipped = List.combine present_occ_defs def_call_sites in
  70   let def_call_sites_zipped_filtered =
  71     List.filter (fun (_, r) -> List.length r != 0) def_call_sites_zipped
  72   in
  73   let (present_occ_defs_filtered, def_call_sites_filtered) =
  74     List.split def_call_sites_zipped_filtered
  75   in
  76   List.map2
  77     def_call_sites_to_incoming_call
  78     present_occ_defs_filtered
  79     def_call_sites_filtered
  80
  81 let string_pos_to_enclosing_rel_occs
  82     ~(ctx : Provider_context.t) (pos : string Pos.pos) :
  83     Relative_path.t SymbolOccurrence.t list =
  84   let file = Pos.filename pos in
  85   let path = Relative_path.create_detect_prefix file in
  86   let (ctx_out, entry) = Provider_context.add_entry_if_missing ~ctx ~path in
  87   let all_symbols = IdentifySymbolService.all_symbols_ctx ~ctx:ctx_out ~entry in
  88   let all_defs =
  89     List.filter (fun s -> s.SymbolOccurrence.is_declaration) all_symbols
  90   in
  91   let pos_rel = Pos.to_relative pos in
  92   List.filter (fun s -> Pos.contains s.SymbolOccurrence.pos pos_rel) all_defs
  93
  94 let ref_result_to_incoming_call_result
  95     (ctx : Provider_context.t)
  96     (ref_result : ServerCommandTypes.Find_refs.result) :
  97     Lsp.CallHierarchyIncomingCalls.callHierarchyIncomingCall list =
  98   let grouped_by_file = group_refs_by_file ref_result in
  99   let incoming_calls =
 100     List.concat_map (file_refs_to_incoming_calls ctx) grouped_by_file
 101   in
 102   incoming_calls
 103
 104 let go
 105     (item : Lsp.CallHierarchyItem.t)
 106     ~(ctx : Provider_context.t)
 107     ~(genv : ServerEnv.genv)
 108     ~(env : ServerEnv.env) :
 109     Lsp.CallHierarchyIncomingCalls.callHierarchyIncomingCall list
 110     ServerCommandTypes.Done_or_retry.t
 111     list =
 112   let file = Lsp_helpers.lsp_uri_to_path item.Lsp.CallHierarchyItem.uri in
 113   let (ctx, entry, _, get_def) = ServerDepsUtil.get_def_setup ctx file in
 114   let declarations =
 115     IdentifySymbolService.all_symbols_ctx ~ctx ~entry
 116     |> List.filter (fun s -> s.SymbolOccurrence.is_declaration)
 117   in
 118   let target_symbols =
 119     ServerCallHierarchyUtils.call_item_to_symbol_occ_list ~ctx ~entry ~item
 120   in
 121   let get_body_references =
 122     ServerDepsInBatch.body_references
 123       ~ctx
 124       ~entry
 125       ~genv
 126       ~env
 127       ~get_def
 128       ~declarations
 129   in
 130   let ref_result_or_retries =
 131     List.concat_map get_body_references target_symbols
 132   in
 133   List.map
 134     (fun s ->
 135       ServerCommandTypes.Done_or_retry.map_env
 136         ~f:(ref_result_to_incoming_call_result ctx)
 137         (env, s)
 138       |> snd)
 139     ref_result_or_retries