From 617a91d39001734517bbb38c566072a0c9b1dbab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 18:50:46 +0200 Subject: [PATCH 1/6] Upgrade dune to 3.0 and fix warnings dune 2.9.0 is not compatible with OCaml 5.2 anyway. --- dune-project | 2 +- merlin.opam | 2 +- src/dot-merlin/dot_merlin_reader.ml | 61 ------------------- .../ocamlmerlin/ocamlmerlin_server.ml | 5 -- 4 files changed, 2 insertions(+), 68 deletions(-) diff --git a/dune-project b/dune-project index 22f5248a79..429aa69d7e 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.9) +(lang dune 3.0) (name merlin) (using menhir 2.0) diff --git a/merlin.opam b/merlin.opam index ea6974250f..bd1093a7f7 100644 --- a/merlin.opam +++ b/merlin.opam @@ -12,7 +12,7 @@ build: [ ] depends: [ "ocaml" {>= "5.2" & < "5.3"} - "dune" {>= "2.9.0"} + "dune" {>= "3.0.0"} "merlin-lib" {= version} "dot-merlin-reader" {>= "5.0"} "yojson" {>= "2.0.0"} diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index 7fd2fff19d..f6e5175771 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -379,67 +379,6 @@ let expand = let path = canonicalize_filename ~cwd:dir path in expand_glob ~filter path [] -module Import_from_dune = struct - let escape_only c s = - let open String in - let n = ref 0 in - let len = length s in - for i = 0 to len - 1 do - if unsafe_get s i = c then incr n - done; - if !n = 0 then - s - else - let b = Bytes.create (len + !n) in - n := 0; - for i = 0 to len - 1 do - if unsafe_get s i = c then ( - Bytes.unsafe_set b !n '\\'; - incr n - ); - Bytes.unsafe_set b !n (unsafe_get s i); - incr n - done; - Bytes.unsafe_to_string b - - let need_quoting s = - let len = String.length s in - len = 0 - || - let rec loop i = - if i = len then - false - else - match s.[i] with - | ' ' - | '\"' - | '(' - | ')' - | '{' - | '}' - | ';' - | '#' -> - true - | _ -> loop (i + 1) - in - loop 0 - - let quote s = - let s = - if Sys.win32 then - (* We need this hack because merlin unescapes backslashes (except when - protected by single quotes). It is only a problem on windows because - Filename.quote is using double quotes. *) - escape_only '\\' s - else - s - in - if need_quoting s then - Filename.quote s - else - s -end - let postprocess cfg = let stdlib = Option.value ~default:standard_library cfg.stdlib in let pkg_paths, ppxsetup, failures = path_of_packages cfg.packages_to_load in diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index 56b967a9a4..e183ab6fd5 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -4,11 +4,6 @@ let merlin_timeout = module Server = struct - let rec protect_eintr f = - match f () with - | exception (Unix.Unix_error(Unix.EINTR, _, _)) -> protect_eintr f - | result -> result - let process_request {Os_ipc. wd; environ; argv; context = _} = match Array.to_list argv with | "stop-server" :: _ -> raise Exit From e34f5ff2faba66adf8d698c998e767c48e35905b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:03:18 +0100 Subject: [PATCH 2/6] index: add new configuration directive --- src/dot-merlin/dot_merlin_reader.ml | 6 +++++- src/dot-protocol/merlin_dot_protocol.ml | 5 ++++- src/dot-protocol/merlin_dot_protocol.mli | 3 ++- src/kernel/mconfig.ml | 10 ++++++++++ src/kernel/mconfig.mli | 1 + src/kernel/mconfig_dot.ml | 5 +++++ src/kernel/mconfig_dot.mli | 1 + tests/test-dirs/config/dot-merlin-reader/load-config.t | 1 + tests/test-dirs/config/dot-merlin-reader/quoting.t | 1 + 9 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index f6e5175771..5513d79d47 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -84,6 +84,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 @@ -328,7 +330,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 _ | `S _ | `BH _ | `SH _ | `CMI _ | `CMT _ as directive -> + | `B _ | `S _ | `BH _ | `SH _ | `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 -> @@ -400,6 +402,8 @@ let postprocess cfg = | `SH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `SH 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 6798632b68..667e3aca58 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -36,7 +36,8 @@ module Directive = struct | `BH of string | `SH of string | `CMI of string - | `CMT of string ] + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list @@ -91,6 +92,7 @@ module Sexp = struct | "BH" -> `BH value | "CMI" -> `CMI value | "CMT" -> `CMT value + | "INDEX" -> `INDEX value | "STDLIB" -> `STDLIB value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value @@ -123,6 +125,7 @@ module Sexp = struct | `SH s -> ("SH", 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 96e34972d2..9eddf62e9b 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -48,7 +48,8 @@ module Directive : sig | `BH of string | `SH of string | `CMI of string - | `CMT of string ] + | `CMT of string + | `INDEX of string ] type no_processing_required = [ `EXT of string list diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index b17258bd5c..2985a8e185 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -76,6 +76,7 @@ type merlin = { hidden_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; @@ -110,6 +111,7 @@ let dump_merlin x = "hidden_source_path", `List (List.map ~f:Json.string x.hidden_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 ( @@ -244,6 +246,7 @@ let merge_merlin_config dot merlin ~failures ~config_path = hidden_source_path = dot.hidden_source_path @ merlin.hidden_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; @@ -305,6 +308,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 -> @@ -639,6 +648,7 @@ let initial = { hidden_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 0111f6c125..41f9a9232b 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -34,6 +34,7 @@ type merlin = { hidden_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 a5303f7a53..bbac1ea7c3 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -39,6 +39,7 @@ type config = { hidden_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; @@ -55,6 +56,7 @@ let empty_config = { source_path = []; cmi_path = []; cmt_path = []; + index_files = []; extensions = []; suffixes = []; flags = []; @@ -243,6 +245,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = | `SH path -> {config with hidden_source_path = path :: config.hidden_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 -> @@ -278,6 +282,7 @@ let postprocess_config config = hidden_source_path = clean config.hidden_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 b31f31b36f..5501408862 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -41,6 +41,7 @@ type config = { hidden_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/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t index 3aeea7a183..45c2965e7a 100644 --- a/tests/test-dirs/config/dot-merlin-reader/load-config.t +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -28,6 +28,7 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 ], "cmi_path": [], "cmt_path": [], + "index_files": [], "flags_applied": [], "extensions": [], "suffixes": [ diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index f8d0604e58..c72b9f1ac2 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -18,6 +18,7 @@ "hidden_source_path": [], "cmi_path": [], "cmt_path": [], + "index_files": [], "flags_applied": [ { "workdir": "$TESTCASE_ROOT", From dd23fbd0084223574fd79aaed779ca766acccb31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 23 May 2024 16:31:35 +0200 Subject: [PATCH 3/6] config: handle SOURCE_ROOT directive --- src/dot-merlin/dot_merlin_reader.ml | 11 +++++++++++ src/dot-protocol/merlin_dot_protocol.ml | 5 ++++- src/dot-protocol/merlin_dot_protocol.mli | 1 + src/kernel/mconfig.ml | 5 +++++ src/kernel/mconfig.mli | 1 + src/kernel/mconfig_dot.ml | 5 +++++ src/kernel/mconfig_dot.mli | 1 + .../test-dirs/config/dot-merlin-reader/load-config.t | 1 + tests/test-dirs/config/dot-merlin-reader/quoting.t | 1 + 9 files changed, 30 insertions(+), 1 deletion(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index 5513d79d47..d13b7f2f12 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -98,6 +98,8 @@ module Cache = File_cache.Make (struct includes := String.trim (String.drop 2 line) :: !includes else if String.is_prefixed ~by:"STDLIB " line then tell (`STDLIB (String.drop 7 line)) + else if String.is_prefixed ~by:"SOURCE_ROOT " line then + tell (`SOURCE_ROOT (String.drop 12 line)) else if String.is_prefixed ~by:"FINDLIB " line then tell (`FINDLIB (String.drop 8 line)) else if String.is_prefixed ~by:"SUFFIX " line then @@ -311,6 +313,7 @@ type config = { pass_forward : Merlin_dot_protocol.Directive.no_processing_required list; to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list; stdlib : string option; + source_root : string option; packages_to_load : string list; findlib : string option; findlib_path : string list; @@ -321,6 +324,7 @@ let empty_config = { pass_forward = []; to_canonicalize = []; stdlib = None; + source_root = None; packages_to_load = []; findlib = None; findlib_path = []; @@ -345,6 +349,9 @@ let prepend_config ~cwd ~cfg = log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path end; { cfg with stdlib = Some canon_path } + | `SOURCE_ROOT path -> + let canon_path = canonicalize_filename ~cwd path in + { cfg with source_root = Some canon_path } | `FINDLIB path -> let canon_path = canonicalize_filename ~cwd path in begin match cfg.stdlib with @@ -369,6 +376,10 @@ let process_one ~cfg {path;directives; _ } = let cwd = Filename.dirname path in prepend_config ~cwd ~cfg (List.rev directives) +(** [expand ~stdlib dir path] does 3 things: + - Re-root paths starting with [+] into [stdlib] + - Canonicalize [path] relatively to [dir] + - Expand glob patterns *) let expand = let filter path = let name = Filename.basename path in diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 667e3aca58..02cd14ab64 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -37,12 +37,13 @@ module Directive = struct | `SH of string | `CMI of string | `CMT of string - | `INDEX of string ] + | `INDEX of string] type no_processing_required = [ `EXT of string list | `FLG of string list | `STDLIB of string + | `SOURCE_ROOT of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR @@ -94,6 +95,7 @@ module Sexp = struct | "CMT" -> `CMT value | "INDEX" -> `INDEX value | "STDLIB" -> `STDLIB value + | "SOURCE_ROOT" -> `SOURCE_ROOT value | "SUFFIX" -> `SUFFIX value | "ERROR" -> `ERROR_MSG value | "FLG" -> @@ -126,6 +128,7 @@ module Sexp = struct | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) | `INDEX s -> ("INDEX", single s) + | `SOURCE_ROOT s -> ("SOURCE_ROOT", 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 9eddf62e9b..fe283001ec 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -55,6 +55,7 @@ module Directive : sig [ `EXT of string list | `FLG of string list | `STDLIB of string + | `SOURCE_ROOT of string | `SUFFIX of string | `READER of string list | `EXCLUDE_QUERY_DIR diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 2985a8e185..51958de96f 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -80,6 +80,7 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; @@ -121,6 +122,7 @@ let dump_merlin x = ]) x.suffixes ); "stdlib" , Json.option Json.string x.stdlib; + "source_root" , Json.option Json.string x.source_root; "reader" , `List (List.map ~f:Json.string x.reader); "protocol" , (match x.protocol with | `Json -> `String "json" @@ -252,6 +254,8 @@ let merge_merlin_config dot merlin ~failures ~config_path = extensions = dot.extensions @ merlin.extensions; suffixes = dot.suffixes @ merlin.suffixes; stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib); + source_root = + (if dot.source_root = None then merlin.source_root else dot.source_root); reader = if dot.reader = [] then merlin.reader @@ -652,6 +656,7 @@ let initial = { extensions = []; suffixes = [(".ml", ".mli"); (".re", ".rei")]; stdlib = None; + source_root = None; reader = []; protocol = `Json; log_file = None; diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 41f9a9232b..55a60637a9 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -38,6 +38,7 @@ type merlin = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; reader : string list; protocol : [`Json | `Sexp]; log_file : string option; diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index bbac1ea7c3..e0dd141151 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -44,6 +44,7 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; @@ -61,6 +62,7 @@ let empty_config = { suffixes = []; flags = []; stdlib = None; + source_root = None; reader = []; exclude_query_dir = false; use_ppx_cache = false; @@ -256,6 +258,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config = {config with flags = flags :: config.flags}, errors | `STDLIB path -> {config with stdlib = Some path}, errors + | `SOURCE_ROOT path -> + {config with source_root = Some path}, errors | `READER reader -> {config with reader}, errors | `EXCLUDE_QUERY_DIR -> @@ -287,6 +291,7 @@ let postprocess_config config = suffixes = clean config.suffixes; flags = clean config.flags; stdlib = config.stdlib; + source_root = config.source_root; reader = config.reader; exclude_query_dir = config.exclude_query_dir; use_ppx_cache = config.use_ppx_cache; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 5501408862..a85572a530 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -46,6 +46,7 @@ type config = { extensions : string list; suffixes : (string * string) list; stdlib : string option; + source_root : string option; reader : string list; exclude_query_dir : bool; use_ppx_cache : bool; diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t index 45c2965e7a..8c00d847dd 100644 --- a/tests/test-dirs/config/dot-merlin-reader/load-config.t +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -42,6 +42,7 @@ This test comes from: https://github.com/janestreet/merlin-jst/pull/59 } ], "stdlib": null, + "source_root": null, "reader": [], "protocol": "json", "log_file": null, diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index c72b9f1ac2..bf4fd0524c 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -54,6 +54,7 @@ } ], "stdlib": null, + "source_root": null, "reader": [], "protocol": "json", "log_file": null, From 34e2688270306929111c25b87f60188da0335c5e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:05:58 +0100 Subject: [PATCH 4/6] occurrences: add support for project-wide occurrences --- src/analysis/dune | 7 +- src/analysis/index_format.ml | 23 --- src/analysis/occurrences.ml | 164 +++++++++++++++--- src/analysis/occurrences.mli | 5 +- src/commands/query_json.ml | 2 +- src/frontend/query_commands.ml | 11 +- src/frontend/query_protocol.ml | 19 +- src/index-format/dune | 10 ++ src/index-format/index_cache.ml | 5 + src/index-format/index_format.ml | 103 +++++++++++ src/index-format/index_format.mli | 37 ++++ src/kernel/dune | 2 +- src/kernel/mocaml.ml | 3 +- src/ocaml/utils/config.ml | 1 + src/ocaml/utils/config.mli | 2 + tests/test-dirs/occurrences/project-wide/dune | 3 + .../occurrences/project-wide/pwo-basic.t | 65 +++++++ .../occurrences/project-wide/pwo-ml-gen.t | 60 +++++++ 18 files changed, 454 insertions(+), 68 deletions(-) delete mode 100644 src/analysis/index_format.ml create mode 100644 src/index-format/dune create mode 100644 src/index-format/index_cache.ml create mode 100644 src/index-format/index_format.ml create mode 100644 src/index-format/index_format.mli create mode 100644 tests/test-dirs/occurrences/project-wide/dune create mode 100644 tests/test-dirs/occurrences/project-wide/pwo-basic.t create mode 100644 tests/test-dirs/occurrences/project-wide/pwo-ml-gen.t 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 c3ce3abbea..eb16623797 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 t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status } + let set_fname ~file (loc : Location.t) = let pos_fname = file in { loc with @@ -28,6 +30,12 @@ let decl_of_path_or_lid env namespace path lid = let index_buffer_ ~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 () = 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); - 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); @@ -87,12 +95,13 @@ 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 @@ -101,7 +110,7 @@ let index_buffer = let result = index_buffer_ ~current_buffer_path ~local_defs () in - cache := Some (current_buffer_path, stamp, result); + 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 @@ -157,7 +166,51 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~typer_result ~pos path = +module Stat_check : sig + type t + val create: cache_size:int -> Index_format.index -> t + val check: t -> file:string -> bool + val get_outdated_files: t -> String.Set.t +end = struct + type t = { index : Index_format.index; cache : (string, bool) Hashtbl.t } + + let create ~cache_size index = { index; cache = Hashtbl.create cache_size } + + let get_outdated_files t = + Hashtbl.fold + (fun file check acc -> if check then acc else String.Set.add file acc) + t.cache String.Set.empty + + let stat t file = + let open Index_format in + match Stats.find_opt file t.index.stats with + | None -> + log ~title:"stat_check" "No stats 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 + if not equal then + log ~title:"stat_check" + "File %s has been modified since the index was built." file; + equal + with Unix.Unix_error _ -> + log ~title:"stat_check" "Could not stat file %S" file; + false + + let check t ~file = + let cache_and_return b = Hashtbl.add t.cache file b; b in + match Hashtbl.find_opt t.cache file with + | Some result -> result + | None -> cache_and_return (stat t file) +end + +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); @@ -167,28 +220,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 @@ -201,23 +255,81 @@ 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 = + if scope = `Buffer then [] + else 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 (index, locs) -> + let stats = Stat_check.create ~cache_size:128 index in + Lid_set.filter (fun {loc; _} -> + (* We ignore external results that concern the current buffer *) + let file = loc.Location.loc_start.Lexing.pos_fname in + if String.equal file current_buffer_path then false + else begin + (* We ignore external results if their source was modified *) + let check = Stat_check.check stats ~file in + if not check then + log ~title:"locs_of" "File %s might be out-of-sync." file; + check + end) locs, + Stat_check.get_outdated_files stats)) + in + let external_locs, out_of_sync_files = + List.fold_left ~init:(Lid_set.empty, String.Set.empty) + ~f:(fun (acc_locs, acc_files) (locs, files) -> + (Lid_set.union acc_locs locs, String.Set.union acc_files files)) + (external_locs) + in + let locs = + match buffer_locs with + | Some buffer_locs -> Lid_set.union buffer_locs external_locs + | None -> external_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 not (Filename.is_relative fname) then Some loc else + match config.merlin.source_root with + | Some path -> + let file = Filename.concat path loc.loc_start.pos_fname in + Some (set_fname ~file loc) + | None -> + 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) 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 status = match scope, String.Set.to_list out_of_sync_files with + | `Project, [] -> `Included + | `Project, l -> `Out_of_sync l + | `Buffer, _ -> `Not_requested + in + if not def_uid_is_in_current_unit then { locs; status } + else + let locs = set_fname ~file:current_buffer_path def_loc :: locs in + { locs; status } + | None -> { locs = []; status = `No_def} diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index eea7b6b3e7..8a04da910e 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,7 +1,10 @@ +type t = { locs: Warnings.loc list; status: Query_protocol.occurrences_status } + 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 + -> t diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 69515bc1f5..9276231bce 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -434,7 +434,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | Findlib_list, strs -> `List (List.map ~f:Json.string strs) | Extension_list _, strs -> `List (List.map ~f:Json.string strs) | Path_list _, strs -> `List (List.map ~f:Json.string strs) - | Occurrences (_, scope), locations -> + | Occurrences (_, scope), (locations, _project) -> let with_file = scope = `Project in `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index b2686fbe50..97e12275a1 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 @ config.merlin.hidden_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 @@ -808,13 +808,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = Locate.log ~title:"reconstructed identifier" "%s" path; path in - let locs = - Occurrences.locs_of ~config ~env ~typer_result ~pos path - |> Result.value ~default:[] + let { Occurrences.locs; status } = + Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path 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, status | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index cd8871e476..341b8f758a 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -96,17 +96,24 @@ type error_filter = { typing : bool; } -type syntax_doc_result = -{ - name : string; - description : string; - documentation : string +type syntax_doc_result = +{ + name : string; + description : string; + documentation : string } type is_tail_position = [`No | `Tail_position | `Tail_call] type _ _bool = bool +type occurrences_status = [ + | `Not_requested + | `Out_of_sync of string list + | `No_def + | `Included +] + type _ t = | Type_expr(* *) : string * Msource.position @@ -207,6 +214,6 @@ type _ t = -> string list t | Occurrences(* *) : [`Ident_at of Msource.position] * [`Project | `Buffer] - -> Location.t list t + -> (Location.t list * occurrences_status) t | Version : string t 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..26978d0290 --- /dev/null +++ b/src/index-format/index_format.ml @@ -0,0 +1,103 @@ +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) + +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/mocaml.ml b/src/kernel/mocaml.ml index 95f87afc24..7eedd99b8b 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/occurrences/project-wide/dune b/tests/test-dirs/occurrences/project-wide/dune new file mode 100644 index 0000000000..625ed79d9f --- /dev/null +++ b/tests/test-dirs/occurrences/project-wide/dune @@ -0,0 +1,3 @@ +(cram + (applies_to :whole_subtree) + (enabled_if %{bin-available:ocaml-index})) 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 dune-project <<'EOF' + > (lang dune 2.9) + > EOF + + $ cat >main.ml <<'EOF' + > open Lib + > open Aux + > let () = print_string foo + > EOF + + $ cat >dune <<'EOF' + > (executable (name main) (libraries lib)) + > EOF + + $ mkdir lib + $ cd lib + + $ cat >aux.ml <<'EOF' + > let foo = "bar" + > let _ = foo + > EOF + + $ cat >dune <<'EOF' + > (library (name lib)) + > EOF + + $ cd .. + $ dune exec ./main.exe + bar + + $ dune build @ocaml-index + + $ cat _build/default/lib/lib.ml-gen + (* generated by dune *) + + (** @canonical Lib.Aux *) + module Aux = Lib__Aux + +We should not index generated modules (lib.ml-gen) + $ ocaml-index dump _build/default/lib/.lib.objs/cctx.ocaml-index + 1 uids: + {uid: Lib__Aux.0; locs: + "foo": File "lib/aux.ml", line 1, characters 4-7; + "foo": File "lib/aux.ml", line 2, characters 8-11 + }, 0 approx shapes: {}, and shapes for CUS . + + $ ocaml-index dump _build/default/.main.eobjs/cctx.ocaml-index + 4 uids: + {uid: Lib; locs: "Lib": File "main.ml", line 1, characters 5-8 + uid: Lib__Aux; locs: "Aux": File "main.ml", line 2, characters 5-8 + uid: Lib__Aux.0; locs: "foo": File "main.ml", line 3, characters 22-25 + uid: Stdlib.312; locs: + "print_string": File "main.ml", line 3, characters 9-21 + }, 0 approx shapes: {}, and shapes for CUS . + + $ $MERLIN single occurrences -scope project -identifier-at 3:23 \ + > -filename main.ml Date: Fri, 23 Feb 2024 09:53:53 +0100 Subject: [PATCH 5/6] [emacs] handle project-wide-occurrences in occur-mode --- emacs/merlin.el | 56 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 39 insertions(+), 17 deletions(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index 9100dfa360..deb6356172 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1784,37 +1784,33 @@ 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)) + (file (cdr (assoc 'file pos))) + (occ-buff (if file (find-file-noselect file) src-buff)) + (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 (cdr (assoc 'col start)))) (lines-text - (if (equal line pending-line) - pending-lines-text + (if (and (equal line pending-line) occ-buff) + pending-lines-text (merlin--occurrence-text line 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 +1824,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 +1869,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 ;; ;;;;;;;;;;;;;;;;;;; From 2dfa1fc72a5eebefd68efe237368e25770cc0225 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 14 May 2024 17:38:30 +0200 Subject: [PATCH 6/6] Add changelog entry for #1766 --- CHANGES.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 4feafd16ca..f607cd94b3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,17 @@ +UNRELEASED +========== + + + merlin binary + - Support project-wide occurrences queries using index files (#1766) + - The file format is described in library `Merlin_lib.index_format` + - Two new configuration directives are introduced: + - `SOURCE_ROOT` that is used to resolve relative paths found in the + indexes. + - `INDEX` that is used to declare the list of index files Merlin should + use when looking for occurrences. + + editor modes + - emacs: add basic support for project-wide occurrences (#1766) + merlin 5.0 ========== Fri May 17 19:59:42 CET 2024