diff --git a/emacs/merlin.el b/emacs/merlin.el index 9100dfa360..06212e1b41 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1784,24 +1784,20 @@ Empty string defaults to jumping to all these." (let ((inhibit-read-only t) (buffer-undo-list t) (pending-line) - (pending-lines-text)) + (pending-lines-text) + (previous-buf)) (erase-buffer) (occur-mode) - (insert (propertize (format "%d occurrences in buffer: %s" - (length lst) - src-buff) - 'font-lock-face list-matching-lines-buffer-name-face - 'read-only t - 'occur-title (get-buffer src-buff))) - (insert "\n") (dolist (pos positions) - (let* ((marker (cdr (assoc 'marker pos))) - (start (assoc 'start pos)) + (let* ((start (assoc 'start pos)) (end (assoc 'end pos)) + (occ-buff (find-file-noselect (cdr (assoc 'file pos)))) + (marker (with-current-buffer occ-buff + (copy-marker (merlin--point-of-pos start)))) (line (cdr (assoc 'line start))) - (start-buf-pos (with-current-buffer src-buff + (start-buf-pos (with-current-buffer occ-buff (merlin--point-of-pos start))) - (end-buf-pos (with-current-buffer src-buff + (end-buf-pos (with-current-buffer occ-buff (merlin--point-of-pos end))) (prefix-length 8) (start-offset (+ prefix-length @@ -1813,8 +1809,7 @@ Empty string defaults to jumping to all these." marker start-buf-pos end-buf-pos - src-buff)))) - + occ-buff)))) ;; Insert the critical text properties that occur-mode ;; makes use of (add-text-properties start-offset @@ -1828,9 +1823,22 @@ Empty string defaults to jumping to all these." ;; found in order to accumulate multiple matches within ;; one line. (when (and pending-lines-text - (not (equal line pending-line))) + (or (not (equal line pending-line)) + (not (equal previous-buf occ-buff)))) (insert pending-lines-text)) + + (when (not (equal previous-buf occ-buff)) + (insert (propertize (format "Occurrences in buffer: %s" + ;(length lst) + occ-buff) + 'font-lock-face + list-matching-lines-buffer-name-face + 'read-only t + 'occur-title occ-buff)) + (insert "\n")) + (setq pending-line line) + (setq previous-buf occ-buff) (setq pending-lines-text lines-text))) ;; Catch final pending text @@ -1860,6 +1868,19 @@ Empty string defaults to jumping to all these." (merlin-occurrences-list r) (error "%s" r))))) +(defun merlin--project-occurrences () + (merlin-call "occurrences" "-scope" "project" "-identifier-at" + (merlin-unmake-point (point)))) + +(defun merlin-project-occurrences () + "List all occurrences of identifier under cursor in buffer." + (interactive) + (let ((r (merlin--project-occurrences))) + (when r + (if (listp r) + (merlin-occurrences-list r) + (error "%s" r))))) + ;;;;;;;;;;;;;;;;;;; ;; OPEN REFACTOR ;; ;;;;;;;;;;;;;;;;;;; diff --git a/src/analysis/dune b/src/analysis/dune index 6b4d2f6d09..905df41c6d 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -10,16 +10,19 @@ -open Merlin_utils -open Merlin_specific -open Merlin_extend - -open Merlin_kernel) + -open Merlin_kernel + -open Merlin_index_format) (libraries merlin_config merlin_specific merlin_extend merlin_kernel merlin_utils + merlin_index_format ocaml_parsing ocaml_preprocess query_protocol ocaml_typing ocaml_utils - str)) + str + unix)) diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml deleted file mode 100644 index 12957f1d9d..0000000000 --- a/src/analysis/index_format.ml +++ /dev/null @@ -1,23 +0,0 @@ -module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct - type t = Longident.t Location.loc - - let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = - match String.compare p1.pos_fname p2.pos_fname with - | 0 -> Int.compare p1.pos_cnum p2.pos_cnum - | n -> n - - let compare (t1 : t) (t2 : t) = - match compare_pos t1.loc.loc_start t2.loc.loc_start with - | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end - | n -> n -end - -module LidSet = Set.Make (Lid) - -(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is - already present the locations are merged. *) - let add tbl uid locs = - try - let locations = Hashtbl.find tbl uid in - Hashtbl.replace tbl uid (LidSet.union locs locations) - with Not_found -> Hashtbl.add tbl uid locs diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index edb205c97b..91a54d2247 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -1,8 +1,10 @@ open Std -module LidSet = Index_format.LidSet +module Lid_set = Index_format.Lid_set let {Logger. log} = Logger.for_section "occurrences" +type res = { locs: Warnings.loc list; synced: bool } + let set_fname ~file (loc : Location.t) = let pos_fname = file in { loc with @@ -25,9 +27,15 @@ let decl_of_path_or_lid env namespace path lid = end | _ -> Env_lookup.loc path namespace env -let index_buffer_ ~current_buffer_path ~local_defs () = +let index_buffer_ ~scope ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in + let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (Lid_set.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs + in let module Shape_reduce = Shape_reduce.Make (struct let fuel = 10 @@ -54,7 +62,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () = | Some decl -> log ~title:"index_buffer" "Found declaration: %a" Logger.fmt (Fun.flip Location.print_loc decl.loc); - Index_format.(add defs decl.uid (LidSet.singleton lid)) + add defs decl.uid (Lid_set.singleton lid) end in if not_ghost lid then @@ -70,7 +78,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () = (Longident.head lid.txt) Logger.fmt (Fun.flip Location.print_loc lid.loc) Logger.fmt (Fun.flip Shape.Uid.print uid); - Index_format.(add defs uid (LidSet.singleton lid)) + add defs uid (Lid_set.singleton lid) | Some uid, true -> log ~title:"index_buffer" "Shape is approximative, found uid: %a" Logger.fmt (Fun.flip Shape.Uid.print uid); @@ -86,6 +94,7 @@ let index_buffer_ ~current_buffer_path ~local_defs () = occurrences in the current buffer only. *) let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) = let () = f ~namespace env path lid in + if scope = `Buffer then match path, txt with | Pdot (path, _), Ldot (lid, s) -> let length_with_dot = String.length s + 1 in @@ -106,19 +115,20 @@ let index_buffer = (* Right now, we only cache the last used index. We could do better by caching the index for every known buffer. *) let cache = ref None in - fun ~current_buffer_path ~stamp ~local_defs () -> + fun ~scope ~current_buffer_path ~stamp ~local_defs () -> let {Logger. log} = Logger.for_section "index" in match !cache with - | Some (path, stamp', value) when + | Some (path, stamp', scope', value) when String.equal path current_buffer_path - && Int.equal stamp' stamp -> + && Int.equal stamp' stamp + && scope' = scope -> log ~title:"index_cache" "Reusing cached value for path %s and stamp %i." path stamp'; value | _ -> log ~title:"index_cache" "No valid cache found, reindexing."; - let result = index_buffer_ ~current_buffer_path ~local_defs () in - cache := Some (current_buffer_path, stamp, result); + let result = index_buffer_ ~current_buffer_path ~scope ~local_defs () in + cache := Some (current_buffer_path, stamp, scope, result); result (* A longident can have the form: A.B.x Right now we are only interested in @@ -163,7 +173,24 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~typer_result ~pos path = +let check Index_format.{ stats; _ } file = + let open Index_format in + match Stats.find_opt file stats with + | None -> log ~title:"stat_check" "No mtime found for file %S." file; true + | Some { size; _ } -> + try + let stats = Unix.stat file in + let equal = + (* This is fast but approximative. A better option would be to check + [mtime] and then [source_digest] if the times differ. *) + Int.equal stats.st_size size + in + log ~title:"stat_check" + "File %s has been modified since the index was built." file; + equal + with Unix.Unix_error _ -> false + +let locs_of ~config ~env ~typer_result ~pos ~scope path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); @@ -173,28 +200,29 @@ let locs_of ~config ~env ~typer_result ~pos path = ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} ~env ~local_defs ~pos path in - let def = + (* When we fail to find an exact definition we restrict scope to `Buffer *) + let def, scope = match locate_result with | `At_origin -> log ~title:"locs_of" "Cursor is on definition / declaration"; (* We are on a definition / declaration so we look for the node's uid *) let browse = Mbrowse.of_typedtree local_defs in let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [browse]) in - uid_and_loc_of_node env node + uid_and_loc_of_node env node, scope | `Found { uid; location; approximated = false; _ } -> log ~title:"locs_of" "Found definition uid using locate: %a " Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - Some (uid, location) + Some (uid, location), scope | `Found { decl_uid; location; approximated = true; _ } -> - log ~title:"locs_of" "Approx: %a " + log ~title:"locs_of" "Approx. definition: %a " Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some (decl_uid, location) + Some (decl_uid, location), `Buffer | `Builtin (uid, s) -> log ~title:"locs_of" "Locate found a builtin: %s" s; - Some (uid, Location.none) + Some (uid, Location.none), scope | _ -> log ~title:"locs_of" "Locate failed to find a definition."; - None + None, `Buffer in let current_buffer_path = Filename.concat config.query.directory config.query.filename @@ -207,23 +235,73 @@ let locs_of ~config ~env ~typer_result ~pos path = log ~title:"locs_of" "Indexing current buffer"; let buffer_index = let stamp = Mtyper.get_stamp typer_result in - index_buffer ~current_buffer_path ~stamp ~local_defs () + index_buffer ~scope ~current_buffer_path ~stamp ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in - let locs = Option.value ~default:LidSet.empty buffer_locs in + let external_locs, desync = + if scope = `Buffer then [], false else begin + let file_changed = ref false in + let locs = List.filter_map config.merlin.index_files ~f:(fun file -> + let external_locs = try + let external_index = Index_cache.read file in + Index_format.Uid_map.find_opt def_uid external_index.defs + |> Option.map ~f:(fun uid_locs -> external_index, uid_locs) + with + | Index_format.Not_an_index _ | Sys_error _ -> + log ~title:"external_index" "Could not load index %s" file; + None + in + Option.map external_locs ~f:(fun (file, locs) -> Lid_set.filter (fun {loc; _} -> + (* We ignore external results that concern the current buffer *) + let fname = loc.Location.loc_start.Lexing.pos_fname in + if String.equal fname current_buffer_path then false + else begin + (* We ignore external results if the index is not up-to-date *) + (* We could return partial results from up-to-date file *) + if not (check file fname) then begin + log ~title:"locs_of" "File %s might be out-of-sync." fname; + file_changed := true; + false + end else + true + end) locs)) + in + locs, !file_changed + end + in + if desync then log ~title:"locs_of" "External index might be out-of-sync."; + let locs = + let all_locs = + match buffer_locs with + | Some buffer_locs -> buffer_locs :: external_locs + | None -> external_locs + in + List.fold_left ~init:Lid_set.empty ~f:Lid_set.union all_locs + in let locs = - log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); - LidSet.elements locs - |> List.map ~f:(fun {Location.txt; loc} -> - log ~title:"occurrences" "Found occ: %s %a" - (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); - last_loc loc txt) + log ~title:"occurrences" "Found %i locs" (Lid_set.cardinal locs); + Lid_set.elements locs + |> List.filter_map ~f:(fun {Location.txt; loc} -> + log ~title:"occurrences" "Found occ: %s %a" + (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); + let loc = last_loc loc txt in + let fname = loc.Location.loc_start.Lexing.pos_fname in + if Filename.is_relative fname then begin + match Locate.find_source ~config loc fname with + | `Found (file, _) -> Some (set_fname ~file loc) + | `File_not_found msg -> + log ~title:"occurrences" "%s" msg; + None + end else Some loc) in let def_uid_is_in_current_unit = let uid_comp_unit = comp_unit_of_uid def_uid in Option.value_map ~default:false uid_comp_unit ~f:(String.equal @@ Env.get_unit_name ()) in - if not def_uid_is_in_current_unit then Ok locs - else Ok (set_fname ~file:current_buffer_path def_loc :: locs) - | None -> Error "Could not find the uid of the definition." + let synced = not desync in + if not def_uid_is_in_current_unit then Ok { locs; synced } + else + let locs = set_fname ~file:current_buffer_path def_loc :: locs in + Ok { locs; synced } + | None -> Error "Could not find the definition [uid]" diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index eea7b6b3e7..4a60ac3908 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,7 +1,10 @@ +type res = { locs: Warnings.loc list; synced: bool } + val locs_of : config:Mconfig.t -> env:Env.t -> typer_result:Mtyper.result -> pos:Lexing.position + -> scope:[`Project | `Buffer] -> string - -> (Warnings.loc list, string) result + -> (res, string) result diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e768d6cacb..a4dc799bf5 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -82,6 +82,8 @@ module Cache = File_cache.Make (struct tell (`CMI (String.drop 4 line)) else if String.is_prefixed ~by:"CMT " line then tell (`CMT (String.drop 4 line)) + else if String.is_prefixed ~by:"INDEX " line then + tell (`INDEX (String.drop 6 line)) else if String.is_prefixed ~by:"PKG " line then tell (`PKG (rev_split_words (String.drop 4 line))) else if String.is_prefixed ~by:"EXT " line then @@ -326,7 +328,7 @@ let empty_config = { let prepend_config ~cwd ~cfg = List.fold_left ~init:cfg ~f:(fun cfg (d : Merlin_dot_protocol.Directive.Raw.t) -> match d with - | `B _ | `H _ | `S _ | `CMI _ | `CMT _ as directive -> + | `B _ | `H _ | `S _ | `CMI _ | `CMT _ | `INDEX _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> @@ -458,6 +460,8 @@ let postprocess cfg = | `S path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `S p) | `CMI path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMI p) | `CMT path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `CMT p) + | `INDEX path -> + List.map (expand ~stdlib dir path) ~f:(fun p -> `INDEX p) in (dirs :> Merlin_dot_protocol.directive list) ) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index ba7ea25d0c..f10ccc4abe 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -31,7 +31,12 @@ open Merlin_utils.Std.Result module Directive = struct type include_path = - [ `B of string | `H of string | `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `H of string + | `S of string + | `CMI of string + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list @@ -85,6 +90,7 @@ module Sexp = struct | "H" -> `H value | "CMI" -> `CMI value | "CMT" -> `CMT value + | "INDEX" -> `INDEX value | "STDLIB" -> `STDLIB value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value @@ -116,6 +122,7 @@ module Sexp = struct | `S s -> ("S", single s) | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) + | `INDEX s -> ("INDEX", single s) | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ]) | `STDLIB s -> ("STDLIB", single s) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index 2acff7bbf3..c11e8bd137 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -43,7 +43,12 @@ really do not want to load them. *) module Directive : sig type include_path = - [ `B of string | `H of string| `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `H of string + | `S of string + | `CMI of string + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 150a53e622..379ba19ed8 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -795,7 +795,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let config = Mpipeline.final_config pipeline in Mconfig.(config.merlin.source_path) - | Occurrences (`Ident_at pos, _) -> + | Occurrences (`Ident_at pos, scope) -> let config = Mpipeline.final_config pipeline in let typer_result = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in @@ -809,12 +809,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~env ~typer_result ~pos path - |> Result.value ~default:[] + match Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path with + | Ok { locs; _ } -> locs + | Error _ -> [] in - let loc_start l = l.Location.loc_start in - let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in - (List.sort ~cmp locs) + locs | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" diff --git a/src/index-format/dune b/src/index-format/dune new file mode 100644 index 0000000000..7cdf97ffd4 --- /dev/null +++ b/src/index-format/dune @@ -0,0 +1,10 @@ +(library + (name merlin_index_format) + (public_name merlin-lib.index_format) + (flags + :standard + -open Ocaml_parsing + -open Ocaml_typing + -open Ocaml_utils + -open Merlin_utils) + (libraries ocaml_parsing ocaml_typing ocaml_utils merlin_utils)) diff --git a/src/index-format/index_cache.ml b/src/index-format/index_cache.ml new file mode 100644 index 0000000000..6ff979bfd4 --- /dev/null +++ b/src/index-format/index_cache.ml @@ -0,0 +1,5 @@ +include File_cache.Make (struct + type t = Index_format.index + let read file = Index_format.read_exn ~file + let cache_name = "Index_cache" +end) diff --git a/src/index-format/index_format.ml b/src/index-format/index_format.ml new file mode 100644 index 0000000000..12606cbb25 --- /dev/null +++ b/src/index-format/index_format.ml @@ -0,0 +1,105 @@ +exception Not_an_index of string + +module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct + type t = Longident.t Location.loc + + let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = + let p1f, p2f = Filename.(basename p1.pos_fname, basename p2.pos_fname) in + match String.compare p1f p2f with + | 0 -> Int.compare p1.pos_cnum p2.pos_cnum + | n -> n + + let compare (t1 : t) (t2 : t) = + match compare_pos t1.loc.loc_start t2.loc.loc_start with + | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end + | n -> n +end + +module Lid_set = Set.Make (Lid) +module Uid_map = Shape.Uid.Map +module Stats = Map.Make (String) + +(** [add map uid locs] adds a binding of [uid] to the locations [locs]. If this key is + already present the locations are merged. *) +let add map uid locs = Uid_map.update uid (function + | None -> Some locs + | Some locs' -> Some (Lid_set.union locs' locs)) + map + +type stat = { mtime : float; size : int; source_digest : string option } + +type index = { + defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) = + Format.fprintf fmt "{@["; + Uid_map.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (Lid_set.elements locs)) + partials; + Format.fprintf fmt "@]}" + +let pp (fmt : Format.formatter) pl = + Format.fprintf fmt "%i uids:@ {@[" (Uid_map.cardinal pl.defs); + Uid_map.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (Lid_set.elements locs)) + pl.defs; + Format.fprintf fmt "@]},@ "; + Format.fprintf fmt "%i approx shapes:@ @[%a@],@ " + (Uid_map.cardinal pl.approximated) + pp_partials pl.approximated; + Format.fprintf fmt "and shapes for CUS %s.@ " + (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) + +let ext = "ocaml-index" + +let magic_number = Config.index_magic_number + +let write ~file index = + Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file + (fun _temp_file_name oc -> + output_string oc magic_number; + output_value oc (index : index)) + +type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown + +let read ~file = + let ic = open_in_bin file in + Merlin_utils.Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let file_magic_number = ref (Cmt_format.read_magic_number ic) in + let cmi_magic_number = Ocaml_utils.Config.cmi_magic_number in + let cmt_magic_number = Ocaml_utils.Config.cmt_magic_number in + (if String.equal !file_magic_number cmi_magic_number then + let _ = Cmi_format.input_cmi ic in + file_magic_number := Cmt_format.read_magic_number ic); + if String.equal !file_magic_number cmt_magic_number then + Cmt (input_value ic : Cmt_format.cmt_infos) + else if String.equal !file_magic_number magic_number then + Index (input_value ic : index) + else Unknown) + +let read_exn ~file = + match read ~file with Index index -> index | _ -> raise (Not_an_index file) diff --git a/src/index-format/index_format.mli b/src/index-format/index_format.mli new file mode 100644 index 0000000000..3b3866eb6e --- /dev/null +++ b/src/index-format/index_format.mli @@ -0,0 +1,37 @@ +exception Not_an_index of string + +val ext : string +val magic_number : string + +module Lid : Set.OrderedType with type t = Longident.t Location.loc +module Lid_set : Set.S with type elt = Lid.t +module Stats : Map.S with type key = String.t +module Uid_map = Shape.Uid.Map + +type stat = { + mtime : float; + size : int; + source_digest : string option +} + +type index = { + defs : Lid_set.t Uid_map.t; + approximated : Lid_set.t Uid_map.t; + cu_shape : (string, Shape.t) Hashtbl.t; + stats : stat Stats.t; +} + +val pp : Format.formatter -> index -> unit + +(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this + key is already present the locations are merged. *) +val add : Lid_set.t Uid_map.t -> Shape.Uid.t -> Lid_set.t -> Lid_set.t Uid_map.t + +type file_content = + | Cmt of Cmt_format.cmt_infos + | Index of index + | Unknown + +val write : file:string -> index -> unit +val read : file:string -> file_content +val read_exn : file:string -> index diff --git a/src/kernel/dune b/src/kernel/dune index 7d12d85e73..bd98153bd1 100644 --- a/src/kernel/dune +++ b/src/kernel/dune @@ -15,7 +15,7 @@ -open Merlin_extend) (libraries merlin_config os_ipc ocaml_parsing ocaml_preprocess ocaml_typing ocaml_utils merlin_extend merlin_specific merlin_utils - merlin_dot_protocol unix str)) + merlin_dot_protocol merlin_index_format unix str)) (rule (targets standard_library.ml) diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 7ac75834ec..6dbcc90576 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -75,6 +75,7 @@ type merlin = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; extensions : string list; suffixes : (string * string) list; stdlib : string option; @@ -107,6 +108,7 @@ let dump_merlin x = "source_path" , `List (List.map ~f:Json.string x.source_path); "cmi_path" , `List (List.map ~f:Json.string x.cmi_path); "cmt_path" , `List (List.map ~f:Json.string x.cmt_path); + "index_files" , `List (List.map ~f:Json.string x.index_files); "flags_applied", `List (List.map ~f:dump_flag_list x.flags_applied); "extensions" , `List (List.map ~f:Json.string x.extensions); "suffixes" , `List ( @@ -247,6 +249,7 @@ let get_external_config path t = source_path = dot.source_path @ merlin.source_path; cmi_path = dot.cmi_path @ merlin.cmi_path; cmt_path = dot.cmt_path @ merlin.cmt_path; + index_files = dot.index_files @ merlin.index_files; exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir; use_ppx_cache = dot.use_ppx_cache || merlin.use_ppx_cache; extensions = dot.extensions @ merlin.extensions; @@ -287,6 +290,12 @@ let merlin_flags = [ {merlin with cmt_path = dir :: merlin.cmt_path}), " Add to merlin cmt path" ); + ( + "-index-file", + marg_path (fun file merlin -> + {merlin with index_files = file :: merlin.index_files}), + " Add to the index files used by merlin" + ); ( "-reader", Marg.param "command" (fun reader merlin -> @@ -620,6 +629,7 @@ let initial = { source_path = []; cmi_path = []; cmt_path = []; + index_files = []; extensions = []; suffixes = [(".ml", ".mli"); (".re", ".rei")]; stdlib = None; diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 8337776ccb..bd8e5b21b6 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -33,6 +33,7 @@ type merlin = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; extensions : string list; suffixes : (string * string) list; stdlib : string option; diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index a4d7ff1a9c..a902551b9f 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -38,6 +38,7 @@ type config = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; flags : string list with_workdir list; extensions : string list; suffixes : (string * string) list; @@ -53,6 +54,7 @@ let empty_config = { source_path = []; cmi_path = []; cmt_path = []; + index_files = []; extensions = []; suffixes = []; flags = []; @@ -240,6 +242,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = | `S path -> {config with source_path = path :: config.source_path}, errors | `CMI path -> {config with cmi_path = path :: config.cmi_path}, errors | `CMT path -> {config with cmt_path = path :: config.cmt_path}, errors + | `INDEX file -> + {config with index_files = file :: config.index_files}, errors | `EXT exts -> {config with extensions = exts @ config.extensions}, errors | `SUFFIX suffix -> @@ -274,6 +278,7 @@ let postprocess_config config = source_path = clean config.source_path; cmi_path = clean config.cmi_path; cmt_path = clean config.cmt_path; + index_files = clean config.index_files; extensions = clean config.extensions; suffixes = clean config.suffixes; flags = clean config.flags; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 60636e37e3..7a7fb1b175 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -34,6 +34,7 @@ type config = { source_path : string list; cmi_path : string list; cmt_path : string list; + index_files : string list; flags : string list with_workdir list; extensions : string list; suffixes : (string * string) list; diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 833db64fe8..650d8d7925 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -112,5 +112,6 @@ let clear_caches () = ( (* Flush cache *) let flush_caches ?older_than () = ( Cmi_cache.flush ?older_than (); - Cmt_cache.flush ?older_than () + Cmt_cache.flush ?older_than (); + Merlin_index_format.Index_cache.flush ?older_than () ) diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 4c2a9566f6..0a2c82eec5 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -49,6 +49,7 @@ and ast_impl_magic_number = "Caml1999M034" and ast_intf_magic_number = "Caml1999N034" and cmxs_magic_number = "Caml1999D034" and cmt_magic_number = "Caml1999T034" +and index_magic_number = "Merl2023I001" let interface_suffix = ref ".mli" diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli index 26323f87fa..df34aee281 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -43,6 +43,8 @@ val cmxs_magic_number: string (* Magic number for dynamically-loadable plugins *) val cmt_magic_number: string (* Magic number for compiled interface files *) +val index_magic_number: string + (* Magic number for index files *) val max_tag: int (* Biggest tag that can be stored in the header of a regular block. *) diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..40ef946790 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -16,6 +16,7 @@ "source_path": [], "cmi_path": [], "cmt_path": [], + "index_files": [], "flags_applied": [ { "workdir": "$TESTCASE_ROOT", diff --git a/tests/test-dirs/occurrences/project-wide/pwo-basic.t b/tests/test-dirs/occurrences/project-wide/pwo-basic.t new file mode 100644 index 0000000000..5fcd73f6e1 --- /dev/null +++ b/tests/test-dirs/occurrences/project-wide/pwo-basic.t @@ -0,0 +1,65 @@ + $ cat >lib.ml <<'EOF' + > let foo = "bar" + > let () = print_string foo + > EOF + + $ cat >main.ml <<'EOF' + > let () = print_string Lib.foo + > EOF + + $ ocamlc -bin-annot -bin-annot-occurrences -c lib.ml main.ml + + $ ocaml-index aggregate main.cmt lib.cmt + $ ocaml-index dump project.ocaml-index + 2 uids: + {uid: Lib.0; locs: + "foo": File "lib.ml", line 1, characters 4-7; + "foo": File "lib.ml", line 2, characters 22-25; + "Lib.foo": File "main.ml", line 1, characters 22-29 + uid: Stdlib.312; locs: + "print_string": File "lib.ml", line 2, characters 9-21; + "print_string": File "main.ml", line 1, characters 9-21 + }, 0 approx shapes: {}, and shapes for CUS . + + $ $MERLIN single occurrences -scope project -identifier-at 1:28 \ + > -index-file project.ocaml-index \ + > -filename main.ml