Source file `index_occurrences.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
open Std
module Lid_set = Index_format.Lid_set
let { Logger.log } = Logger.for_section "index-occurrences"

let set_fname ~file (loc : Location.t) =
  let pos_fname = file in
  { loc with
    loc_start = { loc.loc_start with pos_fname };
    loc_end = { loc.loc_end with pos_fname }
  }

let decl_of_path_or_lid env namespace path lid =
  match (namespace : Shape.Sig_component_kind.t) with
  | Constructor ->
    begin match Env.find_constructor_by_name lid env with
    | exception Not_found -> None
    | { cstr_uid; cstr_loc; _ } ->
      Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace }
    end
  | Label ->
    begin match Env.find_label_by_name Legacy lid env with
    | exception Not_found -> None
    | { lbl_uid; lbl_loc; _ } ->
      Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace }
    end
  | Unboxed_label ->
    begin match Env.find_label_by_name Unboxed_product lid env with
    | exception Not_found -> None
    | { lbl_uid; lbl_loc; _ } ->
      Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace }
    end
  | _ -> Env_lookup.by_path path namespace env

let should_ignore_lid (lid : Longident.t Location.loc) =
  (* Ignore occurrence if the location of the identifier is "none" because there is not a
     useful location to report to the user. This can occur when the occurrence is in ppx
     generated code and the ppx does not give location information.

     An alternative implementation could instead ignore the occurrence if the location is
     marked as "ghost". However, this seems too aggressive for two reasons:
      - The expression being bound in a punned let expression is marked as ghost
      - Ppx-generated code is often "ghost", but occurrences within ppx-generated code may
        be useful
  *)
  Location.is_none lid.loc

let iterator ~current_buffer_path ~index ~reduce_for_uid =
  let add uid loc = index := Shape.Uid.Map.add_to_list uid loc !index in
  let f ~namespace env path (lid : Longident.t Location.loc) =
    log ~title:"index_buffer" "Path: %a" Logger.fmt
      (Fun.flip (Format_doc.compat Path.print) path);
    let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
    let index_decl () =
      begin match decl_of_path_or_lid env namespace path lid.txt with
      | (exception _) | None ->
        log ~title:"index_buffer" "Declaration not found"
      | Some decl ->
        log ~title:"index_buffer" "Found declaration: %a" Logger.fmt
          (Fun.flip Location.print_loc decl.loc);
        add decl.uid lid
      end
    in
    if not (should_ignore_lid lid) then
      match Env.shape_of_path ~namespace env path with
      | exception Not_found -> ()
      | path_shape ->
        log ~title:"index_buffer" "Shape of path: %a" Logger.fmt
          (Fun.flip Shape.print path_shape);
        let result = reduce_for_uid env path_shape in
        begin match Locate.uid_of_result ~traverse_aliases:false result with
        | Some uid, false ->
          log ~title:"index_buffer" "Found %a (%a) wiht uid %a" Logger.fmt
            (Fun.flip Pprintast.longident lid.txt)
            Logger.fmt
            (Fun.flip Location.print_loc lid.loc)
            Logger.fmt
            (Fun.flip Shape.Uid.print uid);
          add uid lid
        | Some uid, true ->
          log ~title:"index_buffer" "Shape is approximative, found uid: %a"
            Logger.fmt
            (Fun.flip Shape.Uid.print uid);
          index_decl ()
        | None, _ ->
          log ~title:"index_buffer" "Reduction failed: missing uid";
          index_decl ()
        end
  in
  Ast_iterators.iterator_on_usages ~include_hidden:true ~f

let items index (config : Mconfig.t) items =
  let module Shape_reduce = Shape_reduce.Make (struct
    let fuel () = Misc.Maybe_bounded.of_int 10

    let read_unit_shape ~diagnostics:_ ~unit_name =
      log ~title:"read_unit_shape" "inspecting %s" unit_name;
      let read unit_name =
        let cms = Format.sprintf "%s.cms" unit_name in
        match Locate.Artifact.read (Load_path.find_normalized cms) with
        | artifact -> Some artifact
        | exception _ -> (
          let cmt = Format.sprintf "%s.cmt" unit_name in
          match Locate.Artifact.read (Load_path.find_normalized cmt) with
          | artifact -> Some artifact
          | exception _ -> None)
      in
      match read unit_name with
      | Some artifact ->
        log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
        Locate.Artifact.impl_shape artifact
      | None ->
        log ~title:"read_unit_shape" "failed to find %s" unit_name;
        None

    let projection_rules_for_merlin_enabled = true
    let fuel_for_compilation_units () : Misc.Maybe_bounded.t = Unbounded
    let max_shape_reduce_steps_per_variable () : Misc.Maybe_bounded.t =
      Unbounded
    let max_compilation_unit_depth () : Misc.Maybe_bounded.t = Unbounded
  end) in
  let current_buffer_path =
    Filename.concat config.query.directory config.query.filename
  in
  let reduce_for_uid = Shape_reduce.reduce_for_uid in
  let index = ref index in
  let iterator = iterator ~current_buffer_path ~index ~reduce_for_uid in
  let () =
    match items with
    | `Impl items -> List.iter ~f:(iterator.structure_item iterator) items
    | `Intf items -> List.iter ~f:(iterator.signature_item iterator) items
  in
  !index
Source file index_occurrences.ml

Source file `index_occurrences.ml`
