From e9a12e28361d3bbcae889143142902fc0b298195 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Mon, 10 Mar 2025 18:09:00 +0100 Subject: [PATCH 01/31] Remove some laziness. --- src/kernel/mpipeline.ml | 166 +++++++++++++++++++--------------------- 1 file changed, 79 insertions(+), 87 deletions(-) diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 2180675a74..e39357f05b 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -4,23 +4,22 @@ let { Logger.log } = Logger.for_section "Pipeline" let time_shift = ref 0.0 -let timed_lazy r x = - lazy - (let start = Misc.time_spent () in - let time_shift0 = !time_shift in - let update () = - let delta = Misc.time_spent () -. start in - let shift = !time_shift -. time_shift0 in - time_shift := time_shift0 +. delta; - r := !r +. delta -. shift - in - match Lazy.force x with - | x -> - update (); - x - | exception exn -> - update (); - Std.reraise exn) +let timed r x = + let start = Misc.time_spent () in + let time_shift0 = !time_shift in + let update () = + let delta = Misc.time_spent () -. start in + let shift = !time_shift -. time_shift0 in + time_shift := time_shift0 +. delta; + r := !r +. delta -. shift + in + match x () with + | x -> + update (); + x + | exception exn -> + update (); + Std.reraise exn module Cache = struct let cache = ref [] @@ -65,7 +64,7 @@ module Cache = struct end module Typer = struct - type t = { errors : exn list lazy_t; result : Mtyper.result } + type t = { errors : exn list; result : Mtyper.result } end module Ppx = struct @@ -82,10 +81,10 @@ type t = { config : Mconfig.t; state : Mocaml.typer_state; raw_source : Msource.t; - source : (Msource.t * Mreader.parsetree option) lazy_t; - reader : Reader.t lazy_t; - ppx : Ppx.t lazy_t; - typer : Typer.t lazy_t; + source : Msource.t * Mreader.parsetree option; + reader : Reader.t; + ppx : Ppx.t; + typer : Typer.t; pp_time : float ref; reader_time : float ref; ppx_time : float ref; @@ -99,7 +98,7 @@ type t = let raw_source t = t.raw_source let input_config t = t.config -let input_source t = fst (Lazy.force t.source) +let input_source t = fst t.source let with_pipeline t f = Mocaml.with_state t.state @@ fun () -> @@ -110,10 +109,10 @@ let get_lexing_pos t pos = ~filename:(Mconfig.filename t.config) pos -let reader t = Lazy.force t.reader +let reader t = t.reader -let ppx t = Lazy.force t.ppx -let typer t = Lazy.force t.typer +let ppx t = t.ppx +let typer t = t.typer let reader_config t = (reader t).config let reader_parsetree t = (reader t).result.Mreader.parsetree @@ -131,7 +130,7 @@ let ppx_errors t = (ppx t).Ppx.errors let final_config t = (ppx t).Ppx.config let typer_result t = (typer t).Typer.result -let typer_errors t = Lazy.force (typer t).Typer.errors +let typer_errors t = (typer t).Typer.errors module Reader_phase = struct type t = @@ -230,9 +229,8 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) | Some state -> state in let source = - timed_lazy pp_time - (lazy - (match Mconfig.(config.ocaml.pp) with + timed pp_time (fun () -> + match Mconfig.(config.ocaml.pp) with | None -> (raw_source, None) | Some { workdir; workval } -> ( let source = Msource.text raw_source in @@ -242,73 +240,67 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) ~source ~pp:workval with | `Source source -> (Msource.make source, None) - | (`Interface _ | `Implementation _) as ast -> (raw_source, Some ast)))) + | (`Interface _ | `Implementation _) as ast -> (raw_source, Some ast))) in let reader = - timed_lazy reader_time - (lazy - (let (lazy ((_, pp_result) as source)) = source in - let config = Mconfig.normalize config in - Mocaml.setup_reader_config config; - let cache_disabling = - match (config.merlin.use_ppx_cache, pp_result) with - | false, _ -> Some "configuration" - | true, Some _ -> - (* The cache could be refined in the future to also act on the + timed reader_time (fun () -> + let ((_, pp_result) as source) = source in + let config = Mconfig.normalize config in + Mocaml.setup_reader_config config; + let cache_disabling = + match (config.merlin.use_ppx_cache, pp_result) with + | false, _ -> Some "configuration" + | true, Some _ -> + (* The cache could be refined in the future to also act on the PP phase. For now, let's disable the whole cache when there's a PP. *) - Some "source preprocessor usage" - | true, None -> None - in - let { Reader_with_cache.output = { result; cache_version }; - cache_was_hit - } = - Reader_with_cache.apply ~cache_disabling - { source; for_completion; config } - in - reader_cache_hit := cache_was_hit; - let cache_version = - if Option.is_some cache_disabling then None else Some cache_version - in - { Reader.result; config; cache_version })) + Some "source preprocessor usage" + | true, None -> None + in + let { Reader_with_cache.output = { result; cache_version }; + cache_was_hit + } = + Reader_with_cache.apply ~cache_disabling + { source; for_completion; config } + in + reader_cache_hit := cache_was_hit; + let cache_version = + if Option.is_some cache_disabling then None else Some cache_version + in + { Reader.result; config; cache_version }) in let ppx = - timed_lazy ppx_time - (lazy - (let (lazy - { Reader.result = { Mreader.parsetree; _ }; - config; - cache_version - }) = - reader - in - let caught = ref [] in - Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught - @@ fun () -> - (* Currently the cache is invalidated even for source changes that don't + timed ppx_time (fun () -> + let { Reader.result = { Mreader.parsetree; _ }; config; cache_version } + = + reader + in + let caught = ref [] in + Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught + @@ fun () -> + (* Currently the cache is invalidated even for source changes that don't change the parsetree. To avoid that, we'd have to digest the parsetree in the cache. *) - let cache_disabling, reader_cache = - match cache_version with - | Some v -> (None, Ppx_phase.Version v) - | None -> (Some "reader cache is disabled", Off) - in - let { Ppx_with_cache.output = parsetree; cache_was_hit } = - Ppx_with_cache.apply ~cache_disabling - { parsetree; config; reader_cache } - in - ppx_cache_hit := cache_was_hit; - { Ppx.config; parsetree; errors = !caught })) + let cache_disabling, reader_cache = + match cache_version with + | Some v -> (None, Ppx_phase.Version v) + | None -> (Some "reader cache is disabled", Off) + in + let { Ppx_with_cache.output = parsetree; cache_was_hit } = + Ppx_with_cache.apply ~cache_disabling + { parsetree; config; reader_cache } + in + ppx_cache_hit := cache_was_hit; + { Ppx.config; parsetree; errors = !caught }) in let typer = - timed_lazy typer_time - (lazy - (let (lazy { Ppx.config; parsetree; _ }) = ppx in - Mocaml.setup_typer_config config; - let result = Mtyper.run config parsetree in - let errors = timed_lazy error_time (lazy (Mtyper.get_errors result)) in - typer_cache_stats := Mtyper.get_cache_stat result; - { Typer.errors; result })) + timed typer_time (fun () -> + let { Ppx.config; parsetree; _ } = ppx in + Mocaml.setup_typer_config config; + let result = Mtyper.run config parsetree in + let errors = timed error_time (fun () -> Mtyper.get_errors result) in + typer_cache_stats := Mtyper.get_cache_stat result; + { Typer.errors; result }) in { config; state; From 08b1aea72e3c1651ddadc3b56051ff2ea2041842 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Tue, 11 Mar 2025 13:33:46 +0100 Subject: [PATCH 02/31] Typing in the typer domain. --- src/frontend/ocamlmerlin/new/new_merlin.ml | 19 ++-- .../ocamlmerlin/ocamlmerlin_server.ml | 29 ++++-- src/kernel/mocaml.mli | 2 +- src/kernel/mpipeline.ml | 98 ++++++++++++++++++- src/kernel/mpipeline.mli | 11 +++ src/ocaml/utils/local_store.ml | 9 ++ src/ocaml/utils/local_store.mli | 4 + src/utils/shared.ml | 25 +++++ src/utils/shared.mli | 11 +++ 9 files changed, 188 insertions(+), 20 deletions(-) create mode 100644 src/utils/shared.ml create mode 100644 src/utils/shared.mli diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 78e13d9c34..97c999bfd0 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -47,7 +47,7 @@ let commands_help () = print_endline doc) New_commands.all_commands -let run = +let run shared = let query_num = ref (-1) in function | [] -> @@ -109,15 +109,15 @@ let run = (float_of_int (60 * Mconfig.(config.merlin.cache_lifespan))) (); File_id.with_cache @@ fun () -> + (* TODO : Would it be possible to not expose this function in mpipeline.mli and its type in mocaml.mli ? *) + let store = Mpipeline.Cache.get config in + Local_store.open_store store; let source = Msource.make (Misc.string_of_file stdin) in - let pipeline = Mpipeline.make config source in + let pipeline = Mpipeline.get shared config source in let json = let class_, message = Printexc.record_backtrace true; - match - Mpipeline.with_pipeline pipeline @@ fun () -> - command_action pipeline command_args - with + match command_action pipeline command_args with | result -> ("return", result) | exception Failure str -> let trace = Printexc.get_backtrace () in @@ -133,6 +133,7 @@ let run = Location.print_main Format.str_formatter err; ("error", `String (Format.flush_str_formatter ()))) in + Local_store.close_store store; let cpu_time = Misc.time_spent () -. start_cpu in let gc_stats = Gc.quick_stat () in let heap_mbytes = @@ -186,7 +187,7 @@ let with_wd ~wd ~old_wd f args = old_wd; f args -let run ~new_env wd args = +let run ~new_env wd args shared = begin match new_env with | Some env -> @@ -197,10 +198,10 @@ let run ~new_env wd args = let old_wd = Sys.getcwd () in let run args () = match wd with - | Some wd -> with_wd ~wd ~old_wd run args + | Some wd -> with_wd ~wd ~old_wd (run shared) args | None -> log ~title:"run" "No working directory specified (old wd: %S)" old_wd; - run args + run shared args in let `Log_file_path log_file, `Log_sections sections = Log_info.get () in Logger.with_log_file log_file ~sections @@ run args diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index 35ca8a3a64..e35d6b9ce3 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -2,19 +2,19 @@ let merlin_timeout = try float_of_string (Sys.getenv "MERLIN_TIMEOUT") with _ -> 600.0 module Server = struct - let process_request { Os_ipc.wd; environ; argv; context = _ } = + let process_request { Os_ipc.wd; environ; argv; context = _ } shared = match Array.to_list argv with | "stop-server" :: _ -> raise Exit - | args -> New_merlin.run ~new_env:(Some environ) (Some wd) args + | args -> New_merlin.run ~new_env:(Some environ) (Some wd) args shared - let process_client client = + let process_client client shared = let context = client.Os_ipc.context in Os_ipc.context_setup context; let close_with return_code = flush_all (); Os_ipc.context_close context ~return_code in - match process_request client with + match process_request client shared with | code -> close_with code | exception Exit -> close_with (-1); @@ -38,18 +38,18 @@ module Server = struct | Some _ as result -> result | None -> loop 1.0 - let rec loop merlinid server = + let rec loop merlinid server shared = match server_accept merlinid server with | None -> (* Timeout *) () | Some client -> let continue = - match process_client client with + match process_client client shared with | exception Exit -> false | () -> true in - if continue then loop merlinid server + if continue then loop merlinid server shared let start socket_path socket_fd = match Os_ipc.server_setup socket_path socket_fd with @@ -57,7 +57,12 @@ module Server = struct | Some server -> (* If the client closes its connection, don't let it kill us with a SIGPIPE. *) if Sys.unix then Sys.set_signal Sys.sigpipe Sys.Signal_ignore; - loop (File_id.get Sys.executable_name) server; + + let shared = Mpipeline.create_shared () in + let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in + loop (File_id.get Sys.executable_name) server shared; + Mpipeline.closing shared; + Domain.join domain_typer; Os_ipc.server_close server end @@ -65,7 +70,13 @@ let main () = (* Setup env for extensions *) Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())); match List.tl (Array.to_list Sys.argv) with - | "single" :: args -> exit (New_merlin.run ~new_env:None None args) + | "single" :: args -> + let shared = Mpipeline.create_shared () in + let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in + let vexit = New_merlin.run ~new_env:None None args shared in + Mpipeline.closing shared; + Domain.join domain_typer; + exit vexit | "old-protocol" :: args -> Old_merlin.run args | [ "server"; socket_path; socket_fd ] -> Server.start socket_path socket_fd | ("-help" | "--help" | "-h" | "server") :: _ -> diff --git a/src/kernel/mocaml.mli b/src/kernel/mocaml.mli index 62b45e5525..2e9c9fee87 100644 --- a/src/kernel/mocaml.mli +++ b/src/kernel/mocaml.mli @@ -1,5 +1,5 @@ (* An instance of load path, environment cache & btype unification log *) -type typer_state +type typer_state = Local_store.store val new_state : unit -> typer_state val with_state : typer_state -> (unit -> 'a) -> 'a diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index e39357f05b..67669b502f 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -318,7 +318,6 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) reader_cache_hit; typer_cache_stats } - let make config source = process (Mconfig.normalize config) source let for_completion position @@ -365,3 +364,100 @@ let cache_information t = ("cmt", cmt); ("cmi", cmi) ] + +(* Represents the different possible communications between the two domains: + + From Main to Typer : + - request is canceled + - merlin is closing + - main domain is waiting for the lock + + + From Typer to Main : + - caught an exception +*) +(* TODO : For message passing, it seems okay to have active waiting but it could be interesting to test both. +*) +type mess_main = [ `Empty | `Closing (*| `Waiting | `Cancel *) ] +type mess_typer = [ `Empty | `Exn of exn ] + +type shared = + { (* message from main domain to typer domain *) + mess_main : mess_main Atomic.t; + (* message from typer domain to main domain *) + mess_typer : mess_typer Atomic.t; + (* typer domain uses [config] to passively wait for a new request *) + config : (Mconfig.t * Msource.t) option Shared.t; + (* main domain uses [partial_result] to passively wait for a partial result *) + partial_result : t option Shared.t + (* result is used to pass a full result but also, and mainly to manage the main lock. *) + (* result : t option Shared.t *) + } + +let create_shared () = + { mess_main = Atomic.make `Empty; + mess_typer = Atomic.make `Empty; + config = Shared.create None; + partial_result = Shared.create None + } + +(** [closing]: called by the main domain *) +let closing shared = + (* CAS could be replaced by `set` here *) + if Atomic.compare_and_set shared.mess_main `Empty `Closing then + while Atomic.get shared.mess_main == `Closing do + Shared.signal shared.config + done + else failwith "closing: should not happen." + +(** [share_exn]: called by the typer domain *) +let share_exn (shared : shared) exn = + let exn_v = `Exn exn in + (* CAS could be replaced by `set` here *) + if Atomic.compare_and_set shared.mess_typer `Empty exn_v then + while Atomic.get shared.mess_typer == exn_v do + Shared.signal shared.partial_result + done + else failwith "shared_exn: should not happen." + +let domain_typer shared () = + let rec loop () = + match Atomic.get shared.mess_main with + | `Closing -> Atomic.set shared.mess_main `Empty + | `Empty -> ( + match Shared.get shared.config with + | None -> + Shared.wait shared.config; + loop () + | Some (config, source) -> + Shared.set shared.config None; + (try + let mpipeline = make config source in + Shared.locking_set shared.partial_result (Some mpipeline) + with exn -> share_exn shared exn); + loop ()) + in + Shared.protect shared.config (fun () -> loop ()) + +let get shared config source = + Shared.locking_set shared.config (Some (config, source)); + + let rec loop () = + let critical_section () = + match Shared.get shared.partial_result with + | None -> begin + match Atomic.get shared.mess_typer with + | `Empty -> + Shared.wait shared.partial_result; + `Retry + | `Exn exn -> + Atomic.set shared.mess_typer `Empty; + raise exn + end + | Some pipeline -> + Shared.set shared.partial_result None; + `Result pipeline + in + match Shared.protect shared.partial_result critical_section with + | `Retry -> loop () + | `Result pipeline -> pipeline + in + loop () diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index f6f1d21df6..87bbe2233a 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -1,6 +1,7 @@ type t val make : Mconfig.t -> Msource.t -> t val with_pipeline : t -> (unit -> 'a) -> 'a + val for_completion : Msource.position -> t -> t val raw_source : t -> Msource.t @@ -27,3 +28,13 @@ val typer_errors : t -> exn list val timing_information : t -> (string * float) list val cache_information : t -> Std.json + +type shared +val create_shared : unit -> shared +val domain_typer : shared -> unit -> unit +val get : shared -> Mconfig.t -> Msource.t -> t +val closing : shared -> unit + +module Cache : sig + val get : Mconfig.t -> Mocaml.typer_state +end diff --git a/src/ocaml/utils/local_store.ml b/src/ocaml/utils/local_store.ml index b6d117ea3b..37061da88e 100644 --- a/src/ocaml/utils/local_store.ml +++ b/src/ocaml/utils/local_store.ml @@ -57,3 +57,12 @@ let with_store slots f = List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; global_bindings.is_bound <- false; ) + +let open_store slots = + assert (not global_bindings.is_bound); + global_bindings.is_bound <- true; + List.iter (fun (Slot { ref; value }) -> ref := value) slots + +let close_store slots = + List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; + global_bindings.is_bound <- false \ No newline at end of file diff --git a/src/ocaml/utils/local_store.mli b/src/ocaml/utils/local_store.mli index 545cf71e02..22c51dbe06 100644 --- a/src/ocaml/utils/local_store.mli +++ b/src/ocaml/utils/local_store.mli @@ -65,3 +65,7 @@ val reset : unit -> unit val is_bound : unit -> bool (** Returns [true] when a store is active (i.e. when called from the callback passed to {!with_store}), [false] otherwise. *) + + +val open_store : store -> unit +val close_store : store -> unit \ No newline at end of file diff --git a/src/utils/shared.ml b/src/utils/shared.ml new file mode 100644 index 0000000000..a666ed5467 --- /dev/null +++ b/src/utils/shared.ml @@ -0,0 +1,25 @@ +type 'a t = { mutex : Mutex.t; cond : Condition.t; mutable value : 'a } + +let locking_set t a = + Mutex.protect t.mutex @@ fun () -> + t.value <- a; + Condition.signal t.cond + +let set t a = + t.value <- a; + Condition.signal t.cond +let locking_get t = Mutex.protect t.mutex @@ fun () -> t.value + +let get t = t.value + +let protect a f = Mutex.protect a.mutex f + +let signal a = Condition.signal a.cond + +let create a = + { mutex = Mutex.create (); cond = Condition.create (); value = a } + +let lock a = Mutex.lock a.mutex +let unlock a = Mutex.unlock a.mutex + +let wait a = Condition.wait a.cond a.mutex diff --git a/src/utils/shared.mli b/src/utils/shared.mli new file mode 100644 index 0000000000..5945a208f9 --- /dev/null +++ b/src/utils/shared.mli @@ -0,0 +1,11 @@ +type 'a t = { mutex : Mutex.t; cond : Condition.t; mutable value : 'a } +val locking_set : 'a t -> 'a -> unit +val set : 'a t -> 'a -> unit +val locking_get : 'a t -> 'a +val get : 'a t -> 'a +val create : 'a -> 'a t +val protect : 'a t -> (unit -> 'b) -> 'b +val signal : 'a t -> unit +val wait : 'a t -> unit +val lock : 'a t -> unit +val unlock : 'a t -> unit From 5be835cf7cf52a82ffccda8a815524f7fa7ded60 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Tue, 11 Mar 2025 17:05:50 +0100 Subject: [PATCH 03/31] Moving computation of pipeline in new_commands.ml. Add a lot of TODO. --- src/commands/new_commands.ml | 178 +++++++++++++-------- src/commands/new_commands.mli | 6 +- src/frontend/ocamlmerlin/new/new_merlin.ml | 26 +-- src/frontend/query_commands.ml | 11 +- src/kernel/mpipeline.ml | 12 +- src/kernel/mpipeline.mli | 6 +- src/utils/shared.ml | 3 - src/utils/shared.mli | 2 - 8 files changed, 149 insertions(+), 95 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index ebf1aee4ae..430e89c209 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -35,7 +35,11 @@ type command = * Marg.docstring * ([ `Mandatory | `Optional | `Many ] * 'args Marg.spec) list * 'args - * (Mpipeline.t -> 'args -> json) + * (Mpipeline.shared -> + Mconfig.t -> + Msource.t -> + 'args -> + json * Mpipeline.t option) -> command let command name ?(doc = "") ~spec ~default f = @@ -92,12 +96,15 @@ let find_command name = List.find ~f:(command_is ~name) let find_command_opt name = List.find_opt ~f:(command_is ~name) -let run pipeline query = +let run shared config source query = + let pipeline = Mpipeline.get shared config source in Logger.log ~section:"New_commands" ~title:"run(query)" "%a" Logger.json (fun () -> Query_json.dump query); + + (* Analyse *) let result = Query_commands.dispatch pipeline query in let json = Query_json.json_of_response query result in - json + (json, Some pipeline) let all_commands = [ command "case-analysis" @@ -119,17 +126,19 @@ let all_commands = position}, content]`, where content is string.\n" ~default:(`Offset (-1), `Offset (-1)) begin - fun buffer -> function + fun shared config source -> function | `Offset -1, _ -> failwith "-start is mandatory" | _, `Offset -1 -> failwith "-end is mandatory" | startp, endp -> - run buffer (Query_protocol.Case_analysis (startp, endp)) + run shared config source + (Query_protocol.Case_analysis (startp, endp)) end; command "holes" ~spec:[] ~doc:"Returns the list of the positions of all the holes in the file." ~default:() begin - fun buffer () -> run buffer Query_protocol.Holes + fun shared config source () -> + run shared config source Query_protocol.Holes end; command "construct" ~spec: @@ -160,11 +169,12 @@ let all_commands = inferior depth will not be returned." ~default:(`Offset (-1), None, None) begin - fun buffer (pos, with_values, max_depth) -> + fun shared config source (pos, with_values, max_depth) -> match pos with | `Offset -1 -> failwith "-position is mandatory" | pos -> - run buffer (Query_protocol.Construct (pos, with_values, max_depth)) + run shared config source + (Query_protocol.Construct (pos, with_values, max_depth)) end; command "complete-prefix" ~spec: @@ -217,11 +227,11 @@ let all_commands = like signatures for modules or documentation string." ~default:("", `None, [], false, true) begin - fun buffer (txt, pos, kinds, doc, typ) -> + fun shared config source (txt, pos, kinds, doc, typ) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer + run shared config source (Query_protocol.Complete_prefix (txt, pos, List.rev kinds, doc, typ)) end; @@ -240,11 +250,11 @@ let all_commands = ] ~default:(None, `None) begin - fun buffer (ident, pos) -> + fun shared config source (ident, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Document (ident, pos)) + run shared config source (Query_protocol.Document (ident, pos)) end; command "syntax-document" ~doc: @@ -255,11 +265,11 @@ let all_commands = ] ~default:`None begin - fun buffer pos -> + fun shared config source pos -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Syntax_document pos) + run shared config source (Query_protocol.Syntax_document pos) end; command "expand-ppx" ~doc:"Returns the generated code of a PPX." ~spec: @@ -268,11 +278,11 @@ let all_commands = ] ~default:`None begin - fun buffer pos -> + fun shared config source pos -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Expand_ppx pos) + run shared config source (Query_protocol.Expand_ppx pos) end; command "enclosing" ~spec: @@ -286,11 +296,11 @@ let all_commands = the cursor.)" ~default:`None begin - fun buffer pos -> + fun shared config source pos -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Enclosing pos) + run shared config source (Query_protocol.Enclosing pos) end; command "errors" ~spec: @@ -323,8 +333,9 @@ let all_commands = `message` is the error description to be shown to the user." ~default:(true, true, true) begin - fun buffer (lexing, parsing, typing) -> - run buffer (Query_protocol.Errors { lexing; parsing; typing }) + fun shared config source (lexing, parsing, typing) -> + run shared config source + (Query_protocol.Errors { lexing; parsing; typing }) end; command "expand-prefix" ~doc: @@ -356,11 +367,11 @@ let all_commands = ] ~default:("", `None, [], false) begin - fun buffer (txt, pos, kinds, typ) -> + fun shared config source (txt, pos, kinds, typ) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer + run shared config source (Query_protocol.Expand_prefix (txt, pos, List.rev kinds, typ)) end; command "extension-list" @@ -379,13 +390,15 @@ let all_commands = a list of strings." ~default:`All begin - fun buffer status -> run buffer (Query_protocol.Extension_list status) + fun shared config source status -> + run shared config source (Query_protocol.Extension_list status) end; command "findlib-list" ~doc:"Returns all known findlib packages as a list of string." ~spec:[] ~default:() begin - fun buffer () -> run buffer Query_protocol.Findlib_list + fun shared config source () -> + run shared config source Query_protocol.Findlib_list end; command "flags-list" ~spec:[] ~doc: @@ -393,8 +406,9 @@ let all_commands = implement interactive completion of compiler settings in an IDE." ~default:() begin - fun _ () -> - `List (List.map ~f:Json.string (Mconfig.flags_for_completion ())) + fun _ _ _ () -> + ( `List (List.map ~f:Json.string (Mconfig.flags_for_completion ())), + None ) end; command "jump" ~spec: @@ -411,11 +425,11 @@ let all_commands = module or match expression that contains the cursor\n" ~default:("", `None) begin - fun buffer (target, pos) -> + fun shared config source (target, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Jump (target, pos)) + run shared config source (Query_protocol.Jump (target, pos)) end; command "phrase" ~spec: @@ -433,11 +447,11 @@ let all_commands = definition or module definition)." ~default:(`Next, `None) begin - fun buffer (target, pos) -> + fun shared config source (target, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Phrase (target, pos)) + run shared config source (Query_protocol.Phrase (target, pos)) end; command "list-modules" ~spec: @@ -449,8 +463,9 @@ let all_commands = and prints the corresponding module name." ~default:[] begin - fun buffer extensions -> - run buffer (Query_protocol.List_modules (List.rev extensions)) + fun shared config source extensions -> + run shared config source + (Query_protocol.List_modules (List.rev extensions)) end; command "locate" ~spec: @@ -481,11 +496,12 @@ let all_commands = different file." ~default:(None, `None, `MLI) begin - fun buffer (prefix, pos, lookfor) -> + fun shared config source (prefix, pos, lookfor) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Locate (prefix, lookfor, pos)) + run shared config source + (Query_protocol.Locate (prefix, lookfor, pos)) end; command "locate-type" ~spec: @@ -494,11 +510,11 @@ let all_commands = ] ~doc:"Locate the declaration of the type of the expression" ~default:`None begin - fun buffer pos -> + fun shared config source pos -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Locate_type pos) + run shared config source (Query_protocol.Locate_type pos) end; command "occurrences" ~spec: @@ -518,10 +534,11 @@ let all_commands = position." ~default:(`None, `Buffer) begin - fun buffer -> function + fun shared config source -> function | `None, _ -> failwith "-identifier-at is mandatory" | `Ident_at pos, scope -> - run buffer (Query_protocol.Occurrences (`Ident_at pos, scope)) + run shared config source + (Query_protocol.Occurrences (`Ident_at pos, scope)) end; command "outline" ~spec:[] ~doc: @@ -530,7 +547,8 @@ let all_commands = content of the buffer." ~default:() begin - fun buffer () -> run buffer Query_protocol.Outline + fun shared config source () -> + run shared config source Query_protocol.Outline end; command "path-of-source" ~doc: @@ -542,8 +560,9 @@ let all_commands = ] ~default:[] begin - fun buffer filenames -> - run buffer (Query_protocol.Path_of_source (List.rev filenames)) + fun shared config source filenames -> + run shared config source + (Query_protocol.Path_of_source (List.rev filenames)) end; command "refactor-open" ~doc:"refactor-open -position pos -action \n\tTODO" @@ -559,11 +578,12 @@ let all_commands = ] ~default:(None, `None) begin - fun buffer -> function + fun shared config source -> function | None, _ -> failwith "-action is mandatory" | _, `None -> failwith "-position is mandatory" | Some action, (#Msource.position as pos) -> - run buffer (Query_protocol.Refactor_open (action, pos)) + run shared config source + (Query_protocol.Refactor_open (action, pos)) end; command "search-by-polarity" ~doc:"search-by-polarity -position pos -query ident\n\tTODO" @@ -579,11 +599,12 @@ let all_commands = ] ~default:("", `None) begin - fun buffer (query, pos) -> + fun shared config source (query, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Polarity_search (query, pos)) + run shared config source + (Query_protocol.Polarity_search (query, pos)) end; command "search-by-type" ~doc:"return a list of values that match a query" ~spec: @@ -603,14 +624,14 @@ let all_commands = ] ~default:(None, `None, 100, false) begin - fun buffer (query, pos, limit, with_doc) -> + fun shared config source (query, pos, limit, with_doc) -> match (query, pos) with | None, `None -> failwith "-position and -query are mandatory" | None, _ -> failwith "-query is mandatory" | _, `None -> failwith "-position is mandatory" | Some query, (#Msource.position as pos) -> - run buffer + run shared config source (Query_protocol.Type_search (query, pos, limit, with_doc)) end; command "inlay-hints" @@ -645,14 +666,18 @@ let all_commands = ] ~default:(`None, `None, false, false, true) begin - fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) -> + fun shared + config + source + (start, stop, let_binding, pattern_binding, avoid_ghost) + -> match (start, stop) with | `None, `None -> failwith "-start and -end are mandatory" | `None, _ -> failwith "-start is mandatory" | _, `None -> failwith "-end is mandatory" | (#Msource.position, #Msource.position) as position -> let start, stop = position in - run buffer + run shared config source (Query_protocol.Inlay_hints (start, stop, let_binding, pattern_binding, avoid_ghost)) end; @@ -676,9 +701,10 @@ let all_commands = ] ~default:`None begin - fun buffer -> function + fun shared config source -> function | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> run buffer (Query_protocol.Shape pos) + | #Msource.position as pos -> + run shared config source (Query_protocol.Shape pos) end; command "type-enclosing" ~doc: @@ -725,7 +751,7 @@ let all_commands = ] ~default:("", -1, `None, None) begin - fun buffer (expr, cursor, pos, index) -> + fun shared config source (expr, cursor, pos, index) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> @@ -737,7 +763,8 @@ let all_commands = in Some (expr, cursor) in - run buffer (Query_protocol.Type_enclosing (expr, pos, index)) + run shared config source + (Query_protocol.Type_enclosing (expr, pos, index)) end; command "type-expression" ~doc: @@ -751,11 +778,11 @@ let all_commands = ] ~default:("", `None) begin - fun buffer (expr, pos) -> + fun shared config source (expr, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run buffer (Query_protocol.Type_expr (expr, pos)) + run shared config source (Query_protocol.Type_expr (expr, pos)) end; (* Implemented without support from Query_protocol. This command might be refactored if it proves useful for old protocol too. *) @@ -771,25 +798,29 @@ let all_commands = ```" ~default:() begin - fun pipeline () -> + fun shared config source () -> + (* TODO this is probabably not what we want *) + let pipeline = Mpipeline.get shared config source in let config = Mpipeline.final_config pipeline in - `Assoc - [ (* TODO Remove support for multiple configuration files + ( `Assoc + [ (* TODO Remove support for multiple configuration files The protocol could be changed to: 'config_file': path_to_dot_merlin_or_dune For now, if the configurator is dune, the field 'dot_merlins' will contain the path to the dune file (or jbuild, or dune-project) *) - ( "dot_merlins", - `List - (match Mconfig.(config.merlin.config_path) with - | Some path -> [ Json.string path ] - | None -> []) ); - ( "failures", - `List (List.map ~f:Json.string Mconfig.(config.merlin.failures)) - ) - ] + ( "dot_merlins", + `List + (match Mconfig.(config.merlin.config_path) with + | Some path -> [ Json.string path ] + | None -> []) ); + ( "failures", + `List + (List.map ~f:Json.string Mconfig.(config.merlin.failures)) + ) + ], + Some pipeline ) end; command "signature-help" ~doc:"Returns LSP Signature Help response" ~spec: @@ -798,7 +829,7 @@ let all_commands = ] ~default:("", `None) begin - fun buffer (_, pos) -> + fun shared config source (_, pos) -> match pos with | `None -> failwith "-position is mandatory" | #Msource.position as position -> @@ -809,7 +840,7 @@ let all_commands = active_signature_help = None } in - run buffer (Query_protocol.Signature_help sh) + run shared config source (Query_protocol.Signature_help sh) end; (* Used only for testing *) command "dump" @@ -821,12 +852,17 @@ let all_commands = ] ~default:"" ~doc:"Not for the casual user, used for debugging merlin" begin - fun pipeline what -> run pipeline (Query_protocol.Dump [ `String what ]) + fun shared config source what -> + run shared config source (Query_protocol.Dump [ `String what ]) end; (* Used only for testing *) command "dump-configuration" ~spec:[] ~default:() ~doc:"Not for the casual user, used for merlin tests" begin - fun pipeline () -> Mconfig.dump (Mpipeline.final_config pipeline) + fun shared config source () -> + (* TODO this is probabably not what we want *) + let pipeline = Mpipeline.get shared config source in + + (Mconfig.dump (Mpipeline.final_config pipeline), Some pipeline) end ] diff --git a/src/commands/new_commands.mli b/src/commands/new_commands.mli index 0cb3ad5b24..7890a16f95 100644 --- a/src/commands/new_commands.mli +++ b/src/commands/new_commands.mli @@ -35,7 +35,11 @@ type command = * Marg.docstring * ([ `Mandatory | `Optional | `Many ] * 'args Marg.spec) list * 'args - * (Mpipeline.t -> 'args -> json) + * (Mpipeline.shared -> + Mconfig.t -> + Msource.t -> + 'args -> + json * Mpipeline.t option) -> command val all_commands : command list diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 97c999bfd0..2650cfcd84 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -113,25 +113,26 @@ let run shared = let store = Mpipeline.Cache.get config in Local_store.open_store store; let source = Msource.make (Misc.string_of_file stdin) in - let pipeline = Mpipeline.get shared config source in let json = - let class_, message = + let class_, message, pipeline_opt = Printexc.record_backtrace true; - match command_action pipeline command_args with - | result -> ("return", result) + match command_action shared config source command_args with + | result, pipeline_opt -> ("return", result, pipeline_opt) | exception Failure str -> let trace = Printexc.get_backtrace () in log ~title:"run" "Command error backtrace: %s" trace; - ("failure", `String str) + ("failure", `String str, None) | exception exn -> ( let trace = Printexc.get_backtrace () in log ~title:"run" "Command error backtrace: %s" trace; match Location.error_of_exn exn with | None | Some `Already_displayed -> - ("exception", `String (Printexc.to_string exn ^ "\n" ^ trace)) + ( "exception", + `String (Printexc.to_string exn ^ "\n" ^ trace), + None ) | Some (`Ok err) -> Location.print_main Format.str_formatter err; - ("error", `String (Format.flush_str_formatter ()))) + ("error", `String (Format.flush_str_formatter ()), None)) in Local_store.close_store store; let cpu_time = Misc.time_spent () -. start_cpu in @@ -140,7 +141,11 @@ let run shared = gc_stats.heap_words * (Sys.word_size / 8) / 1_000_000 in let clock_time = (Unix.gettimeofday () *. 1000.) -. start_clock in - let timing = Mpipeline.timing_information pipeline in + let timing = + match pipeline_opt with + | None -> [] (* TODO *) + | Some p -> Mpipeline.timing_information p + in let pipeline_time = List.fold_left (fun acc (_, k) -> k +. acc) 0.0 timing in @@ -159,7 +164,10 @@ let run shared = ("notifications", `List (List.rev_map notify !notifications)); ("timing", `Assoc (List.map format_timing timing)); ("heap_mbytes", `Int heap_mbytes); - ("cache", Mpipeline.cache_information pipeline); + ( "cache", + match pipeline_opt with + | None -> `Assoc [] (* TODO *) + | Some pipeline -> Mpipeline.cache_information pipeline ); ("query_num", `Int !query_num) ] in diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 057a8bacee..27deeae8e3 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -62,8 +62,15 @@ let print_completion_entries ~with_types config source entries = List.rev_map ~f:(Completion.map_entry postprocess) entries) else List.rev_map ~f:(Completion.map_entry (fun _ -> "")) entries -let for_completion pipeline position = - let pipeline = Mpipeline.for_completion position pipeline in +let for_completion pipeline _position = + (* TODO + + This functions is an issue because of the removal of laziness (and the fact that the pipeline computation is now done by another domain than the one calling this function !). + + This quick patch needs to be corrected or at least properly validated. It breaks a single tests that is about completion with labels. +*) + (* + let pipeline = Mpipeline.for_completion position pipeline in *) let typer = Mpipeline.typer_result pipeline in (pipeline, typer) diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 67669b502f..8c1382db15 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -320,7 +320,7 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) } let make config source = process (Mconfig.normalize config) source -let for_completion position +(* let for_completion position { config; state; raw_source; @@ -332,7 +332,7 @@ let for_completion position _ } = process config raw_source ~for_completion:position ~state ~pp_time - ~reader_time ~ppx_time ~typer_time ~error_time + ~reader_time ~ppx_time ~typer_time ~error_time *) let timing_information t = [ ("pp", !(t.pp_time)); @@ -342,9 +342,9 @@ let timing_information t = ("error", !(t.error_time)) ] -let cache_information t = +let cache_information pipeline = let typer = - match !(t.typer_cache_stats) with + match !(pipeline.typer_cache_stats) with | Miss -> `String "miss" | Hit { reused; typed } -> `Assoc [ ("reused", `Int reused); ("typed", `Int typed) ] @@ -358,8 +358,8 @@ let cache_information t = Cmi_cache.clear_cache_stats (); let fmt_bool hit = `String (if hit then "hit" else "miss") in `Assoc - [ ("reader_phase", fmt_bool !(t.reader_cache_hit)); - ("ppx_phase", fmt_bool !(t.ppx_cache_hit)); + [ ("reader_phase", fmt_bool !(pipeline.reader_cache_hit)); + ("ppx_phase", fmt_bool !(pipeline.ppx_cache_hit)); ("typer", typer); ("cmt", cmt); ("cmi", cmi) diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index 87bbe2233a..b1251947ab 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -1,8 +1,12 @@ type t + +(* Except inside Mpipeline, this function should only use in old_merlin *) val make : Mconfig.t -> Msource.t -> t + +(* Except inside Mpipeline, this function should only use in old_merlin *) val with_pipeline : t -> (unit -> 'a) -> 'a -val for_completion : Msource.position -> t -> t +(* val for_completion : Msource.position -> t -> t *) val raw_source : t -> Msource.t diff --git a/src/utils/shared.ml b/src/utils/shared.ml index a666ed5467..630f8fee72 100644 --- a/src/utils/shared.ml +++ b/src/utils/shared.ml @@ -19,7 +19,4 @@ let signal a = Condition.signal a.cond let create a = { mutex = Mutex.create (); cond = Condition.create (); value = a } -let lock a = Mutex.lock a.mutex -let unlock a = Mutex.unlock a.mutex - let wait a = Condition.wait a.cond a.mutex diff --git a/src/utils/shared.mli b/src/utils/shared.mli index 5945a208f9..b2aa9bfcd3 100644 --- a/src/utils/shared.mli +++ b/src/utils/shared.mli @@ -7,5 +7,3 @@ val create : 'a -> 'a t val protect : 'a t -> (unit -> 'b) -> 'b val signal : 'a t -> unit val wait : 'a t -> unit -val lock : 'a t -> unit -val unlock : 'a t -> unit From 371de70a8194f088a7facf98bc0e767903c01048 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Tue, 25 Mar 2025 18:11:10 +0100 Subject: [PATCH 04/31] Add implementation in mtyper for cancelation and partial typing. --- src/commands/new_commands.ml | 2 +- .../ocamlmerlin/ocamlmerlin_server.ml | 4 +- src/frontend/ocamlmerlin/old/old_command.ml | 4 +- src/kernel/domain_msg.ml | 23 ++ src/kernel/mpipeline.ml | 162 ++++++---- src/kernel/mpipeline.mli | 24 +- src/kernel/mtyper.ml | 291 +++++++++++++----- src/kernel/mtyper.mli | 15 +- src/utils/shared.ml | 4 + src/utils/shared.mli | 2 + 10 files changed, 382 insertions(+), 149 deletions(-) create mode 100644 src/kernel/domain_msg.ml diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 430e89c209..e388105798 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -101,7 +101,7 @@ let run shared config source query = Logger.log ~section:"New_commands" ~title:"run(query)" "%a" Logger.json (fun () -> Query_json.dump query); - (* Analyse *) + (* Analyse : need to ask for lock here *) let result = Query_commands.dispatch pipeline query in let json = Query_json.json_of_response query result in (json, Some pipeline) diff --git a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml index e35d6b9ce3..1ccee1d1f4 100644 --- a/src/frontend/ocamlmerlin/ocamlmerlin_server.ml +++ b/src/frontend/ocamlmerlin/ocamlmerlin_server.ml @@ -61,7 +61,7 @@ module Server = struct let shared = Mpipeline.create_shared () in let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in loop (File_id.get Sys.executable_name) server shared; - Mpipeline.closing shared; + Mpipeline.close_typer shared; Domain.join domain_typer; Os_ipc.server_close server end @@ -74,7 +74,7 @@ let main () = let shared = Mpipeline.create_shared () in let domain_typer = Domain.spawn @@ Mpipeline.domain_typer shared in let vexit = New_merlin.run ~new_env:None None args shared in - Mpipeline.closing shared; + Mpipeline.close_typer shared; Domain.join domain_typer; exit vexit | "old-protocol" :: args -> Old_merlin.run args diff --git a/src/frontend/ocamlmerlin/old/old_command.ml b/src/frontend/ocamlmerlin/old/old_command.ml index 829729315b..3d19902e41 100644 --- a/src/frontend/ocamlmerlin/old/old_command.ml +++ b/src/frontend/ocamlmerlin/old/old_command.ml @@ -126,7 +126,9 @@ let checkout_buffer = end; buffer -let make_pipeline config buffer = Mpipeline.make config buffer.source +let make_pipeline config buffer = + let shared = Mpipeline.create_shared () in + Mpipeline.make config buffer.source shared let dispatch_sync config state (type a) : a sync_command -> a = function | Idle_job -> false diff --git a/src/kernel/domain_msg.ml b/src/kernel/domain_msg.ml new file mode 100644 index 0000000000..2f397f4608 --- /dev/null +++ b/src/kernel/domain_msg.ml @@ -0,0 +1,23 @@ +type from_main = [ `Empty | `Closing | `Waiting | `Cancel ] +type from_typer = [ `Empty | `Exn of exn ] + +type msg = { from_main : from_main Atomic.t; from_typer : from_typer Atomic.t } + +let create () = + { from_main = Atomic.make `Empty; from_typer = Atomic.make `Empty } + +let send_msg msg new_msg signal_on = + (* CAS could be replaced by `set` here *) + if Atomic.compare_and_set msg `Empty new_msg then + while Atomic.get msg == new_msg do + Shared.signal signal_on + done + else failwith "send_msg: should not happen." + +exception Closing +exception Cancel + +(* TODO @xvw + Type completion needs to be changed for whatever type you defined to describe how far the typer must go. +*) +type completion = All | Part of int diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 8c1382db15..d2e144aa82 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -219,10 +219,20 @@ end module Ppx_with_cache = Phase_cache.With_cache (Ppx_phase) +type shared = + { msg : Domain_msg.msg; + config : (Mconfig.t * Msource.t) option Shared.t; + (* Partial result *) + partial : t option Shared.t; + (* Use to protect typer computation *) + result : unit Shared.t + } + let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) ?(ppx_time = ref 0.0) ?(typer_time = ref 0.0) ?(error_time = ref 0.0) ?(ppx_cache_hit = ref false) ?(reader_cache_hit = ref false) - ?(typer_cache_stats = ref Mtyper.Miss) ?for_completion config raw_source = + ?(typer_cache_stats = ref Mtyper.Miss) ?for_completion config raw_source + shared = let state = match state with | None -> Cache.get config @@ -293,14 +303,49 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) ppx_cache_hit := cache_was_hit; { Ppx.config; parsetree; errors = !caught }) in + let cache_and_return_typer result = + let errors = timed error_time (fun () -> Mtyper.get_errors result) in + typer_cache_stats := Mtyper.get_cache_stat result; + { Typer.errors; result } + in + let typer = - timed typer_time (fun () -> - let { Ppx.config; parsetree; _ } = ppx in - Mocaml.setup_typer_config config; - let result = Mtyper.run config parsetree in - let errors = timed error_time (fun () -> Mtyper.get_errors result) in - typer_cache_stats := Mtyper.get_cache_stat result; - { Typer.errors; result }) + match + timed typer_time (fun () -> + let { Ppx.config; parsetree; _ } = ppx in + Mocaml.setup_typer_config config; + let result = + Mtyper.( + run config + (make_partial shared.msg shared.result Domain_msg.All) + parsetree) + in + cache_and_return_typer result) + with + | res -> res + | effect Mtyper.(Partial result), k -> + let typer = cache_and_return_typer result in + let mpipeline = + { config; + state; + raw_source; + source; + reader; + ppx; + typer; + pp_time; + reader_time; + ppx_time; + typer_time; + error_time; + ppx_cache_hit; + reader_cache_hit; + typer_cache_stats + } + in + Shared.locking_set shared.partial (Some mpipeline); + (* Back to [Mtyper.run] *) + Effect.Deep.continue k () in { config; state; @@ -318,7 +363,21 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) reader_cache_hit; typer_cache_stats } -let make config source = process (Mconfig.normalize config) source + +(* +Il faut faire : +- calculer source, puis reader et ppx PUIS +- une fonction qui calcul typeur et qui renvoie un résultat partiel quand dispo +puis continue + +- avec une callback (ou un effet -> Partial ) +- ou en interne + +Est-ce que l'utilisation d'un effet ne simplifie pas assez ? + +*) + +let make config source shared = process (Mconfig.normalize config) source shared (* let for_completion position { config; @@ -376,52 +435,31 @@ let cache_information pipeline = *) (* TODO : For message passing, it seems okay to have active waiting but it could be interesting to test both. *) -type mess_main = [ `Empty | `Closing (*| `Waiting | `Cancel *) ] -type mess_typer = [ `Empty | `Exn of exn ] - -type shared = - { (* message from main domain to typer domain *) - mess_main : mess_main Atomic.t; - (* message from typer domain to main domain *) - mess_typer : mess_typer Atomic.t; - (* typer domain uses [config] to passively wait for a new request *) - config : (Mconfig.t * Msource.t) option Shared.t; - (* main domain uses [partial_result] to passively wait for a partial result *) - partial_result : t option Shared.t - (* result is used to pass a full result but also, and mainly to manage the main lock. *) - (* result : t option Shared.t *) - } - -let create_shared () = - { mess_main = Atomic.make `Empty; - mess_typer = Atomic.make `Empty; - config = Shared.create None; - partial_result = Shared.create None - } (** [closing]: called by the main domain *) -let closing shared = - (* CAS could be replaced by `set` here *) - if Atomic.compare_and_set shared.mess_main `Empty `Closing then - while Atomic.get shared.mess_main == `Closing do - Shared.signal shared.config - done - else failwith "closing: should not happen." +let close_typer shared = + Domain_msg.send_msg shared.msg.from_main `Closing shared.config (** [share_exn]: called by the typer domain *) -let share_exn (shared : shared) exn = - let exn_v = `Exn exn in - (* CAS could be replaced by `set` here *) - if Atomic.compare_and_set shared.mess_typer `Empty exn_v then - while Atomic.get shared.mess_typer == exn_v do - Shared.signal shared.partial_result - done - else failwith "shared_exn: should not happen." +let share_exn shared exn = + Domain_msg.send_msg shared.msg.from_typer (`Exn exn) shared.partial + +(** [cancel]: called by the main domain *) +let _cancel shared = + Domain_msg.send_msg shared.msg.from_main `Cancel shared.config let domain_typer shared () = let rec loop () = - match Atomic.get shared.mess_main with - | `Closing -> Atomic.set shared.mess_main `Empty + match Atomic.get shared.msg.from_main with + | `Closing -> Atomic.set shared.msg.from_main `Empty + | `Waiting -> + while Atomic.get shared.msg.Domain_msg.from_main == `Waiting do + Domain.cpu_relax () + done; + loop () + | `Cancel -> + Atomic.set shared.msg.from_main `Empty; + loop () | `Empty -> ( match Shared.get shared.config with | None -> @@ -430,9 +468,12 @@ let domain_typer shared () = | Some (config, source) -> Shared.set shared.config None; (try - let mpipeline = make config source in - Shared.locking_set shared.partial_result (Some mpipeline) - with exn -> share_exn shared exn); + let mpipeline = make config source shared in + Shared.locking_set shared.partial (Some mpipeline) + with + | Domain_msg.Cancel -> () + | Domain_msg.Closing -> () + | exn -> share_exn shared exn); loop ()) in Shared.protect shared.config (fun () -> loop ()) @@ -442,22 +483,29 @@ let get shared config source = let rec loop () = let critical_section () = - match Shared.get shared.partial_result with + match Shared.get shared.partial with | None -> begin - match Atomic.get shared.mess_typer with + match Atomic.get shared.msg.from_typer with | `Empty -> - Shared.wait shared.partial_result; + Shared.wait shared.partial; `Retry | `Exn exn -> - Atomic.set shared.mess_typer `Empty; + Atomic.set shared.msg.from_typer `Empty; raise exn end | Some pipeline -> - Shared.set shared.partial_result None; + Shared.set shared.partial None; `Result pipeline in - match Shared.protect shared.partial_result critical_section with + match Shared.protect shared.partial critical_section with | `Retry -> loop () | `Result pipeline -> pipeline in loop () + +let create_shared () = + { msg = Domain_msg.create (); + result = Shared.create (); + config = Shared.create None; + partial = Shared.create None + } diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index b1251947ab..209eb7fa79 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -1,7 +1,16 @@ type t +type shared = + { msg : Domain_msg.msg; + config : (Mconfig.t * Msource.t) option Shared.t; + (* Partial result *) + partial : t option Shared.t; + (* Use to protect typer computation *) + result : unit Shared.t + } + (* Except inside Mpipeline, this function should only use in old_merlin *) -val make : Mconfig.t -> Msource.t -> t +val make : Mconfig.t -> Msource.t -> shared -> t (* Except inside Mpipeline, this function should only use in old_merlin *) val with_pipeline : t -> (unit -> 'a) -> 'a @@ -33,12 +42,13 @@ val typer_errors : t -> exn list val timing_information : t -> (string * float) list val cache_information : t -> Std.json -type shared -val create_shared : unit -> shared -val domain_typer : shared -> unit -> unit -val get : shared -> Mconfig.t -> Msource.t -> t -val closing : shared -> unit - module Cache : sig val get : Mconfig.t -> Mocaml.typer_state end + +val create_shared : unit -> shared +val close_typer : shared -> unit +val share_exn : shared -> exn -> unit + +val domain_typer : shared -> unit -> unit +val get : shared -> Mconfig.t -> Msource.t -> t diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 942a1808d5..f295b669a0 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -105,50 +105,129 @@ let compatible_prefix result_items tree_items = in aux [] (result_items, tree_items) -let rec type_structure caught env = function - | parsetree_item :: rest -> - let items, _, part_env = - Typemod.merlin_type_structure env [ parsetree_item ] - in - let typedtree_items = - (items.Typedtree.str_items, items.Typedtree.str_type) - in - let item = - { parsetree_item; - typedtree_items; - part_env; - part_snapshot = Btype.snapshot (); - part_stamp = Ident.get_currentstamp (); - part_uid = Shape.Uid.get_current_stamp (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup () - } - in - item :: type_structure caught part_env rest - | [] -> [] +(* TODO @xvw + - type [completion] needs to be changed for whatever type you defined to describe how far the typer must go. + - type [partial] should also change adequatly. +*) +type partial = + { msg : Domain_msg.msg; shared : unit Shared.t; comp : Domain_msg.completion } -let rec type_signature caught env = function - | parsetree_item :: rest -> - let { Typedtree.sig_final_env = part_env; sig_items; sig_type } = - Typemod.merlin_transl_signature env [ parsetree_item ] - in - let item = - { parsetree_item; - typedtree_items = (sig_items, sig_type); - part_env; - part_snapshot = Btype.snapshot (); - part_stamp = Ident.get_currentstamp (); - part_uid = Shape.Uid.get_current_stamp (); - part_errors = !caught; - part_checks = !Typecore.delayed_checks; - part_warnings = Warnings.backup () - } - in - item :: type_signature caught part_env rest - | [] -> [] +let make_partial msg shared comp = { msg; shared; comp } + +exception + Cancel_struc of (Parsetree.structure_item, Typedtree.structure_item) item list + +let type_structure caught { msg; shared; comp } env parsetree = + (* TODO @xvw *) + let _until = + match comp with + | Domain_msg.All -> Int.max_int + | Part i -> i + in + + let rec loop env parsetree acc = + (match Atomic.get msg.Domain_msg.from_main with + | `Empty -> () + | `Waiting -> + while Atomic.get msg.Domain_msg.from_main == `Waiting do + Domain.cpu_relax () + done + | `Closing -> raise Domain_msg.Closing + | `Cancel -> + (* Cancel_struct is catched by type_implementation *) + raise (Cancel_struc acc)); + + Shared.lock shared; + match parsetree with + | parsetree_item :: rest -> + let items, _, part_env = + Typemod.merlin_type_structure env [ parsetree_item ] + in + let typedtree_items = + (items.Typedtree.str_items, items.Typedtree.str_type) + in + let item = + { parsetree_item; + typedtree_items; + part_env; + part_snapshot = Btype.snapshot (); + part_stamp = Ident.get_currentstamp (); + part_uid = Shape.Uid.get_current_stamp (); + part_errors = !caught; + part_checks = !Typecore.delayed_checks; + part_warnings = Warnings.backup () + } + in + Shared.unlock shared; + (* TODO @xvw *) + if false (* until = pos *) then (env, rest, item :: acc) + else loop part_env rest (item :: acc) + | [] -> + Shared.unlock shared; + (env, [], List.rev acc) + in + loop env parsetree [] + +exception + Cancel_sig of (Parsetree.signature_item, Typedtree.signature_item) item list + +let type_signature caught { msg; shared; comp } env parsetree = + (* TODO @xvw *) + let _until = + match comp with + | Domain_msg.All -> Int.max_int + | Part i -> i + in + + let rec loop env parsetree acc = + (match Atomic.get msg.Domain_msg.from_main with + | `Empty -> () + | `Waiting -> + while Atomic.get msg.Domain_msg.from_main == `Waiting do + Domain.cpu_relax () + done + | `Closing -> raise Domain_msg.Closing + | `Cancel -> + (* Cancel_sig is catched by type_interface *) + raise (Cancel_sig acc)); -let type_implementation config caught parsetree = + Shared.lock shared; + + match parsetree with + | parsetree_item :: rest -> + let { Typedtree.sig_final_env = part_env; sig_items; sig_type } = + Typemod.merlin_transl_signature env [ parsetree_item ] + in + let item = + { parsetree_item; + typedtree_items = (sig_items, sig_type); + part_env; + part_snapshot = Btype.snapshot (); + part_stamp = Ident.get_currentstamp (); + part_uid = Shape.Uid.get_current_stamp (); + part_errors = !caught; + part_checks = !Typecore.delayed_checks; + part_warnings = Warnings.backup () + } + in + Shared.unlock shared; + (* TODO @xvw *) + if false (* until = pos *) then (env, rest, item :: acc) + else loop part_env rest (item :: acc) + | [] -> + Shared.unlock shared; + (env, [], List.rev acc) + in + loop env parsetree [] + +open Effect +open Effect.Deep + +type _ Effect.t += + | Internal_partial : typedtree_items cache_result * typer_cache_stats -> unit t + | Partial : result -> unit t + +let type_implementation config caught partial parsetree = let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } = get_cache config in @@ -172,19 +251,40 @@ let type_implementation config caught parsetree = Stamped_hashtable.backtrack !index_changelog ~stamp; Env.cleanup_usage_tables ~stamp:uid_stamp'; Shape.Uid.restore_stamp uid_stamp'; - let suffix = type_structure caught env' parsetree in - let () = - List.iteri - ~f:(fun i { typedtree_items = items, _; _ } -> - let stamp = stamp + i + 1 in - !index_items ~index ~stamp config (`Impl items)) - suffix + let aux preprocessed_suffix suffix = + let () = + List.iteri + ~f:(fun i { typedtree_items = items, _; _ } -> + let stamp = stamp + i + 1 in + !index_items ~index ~stamp config (`Impl items)) + suffix + in + let value = + `Implementation (List.rev_append prefix (preprocessed_suffix @ suffix)) + in + return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index } in - let value = `Implementation (List.rev_append prefix suffix) in - ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index }, - cache_stats ) + try + match partial.comp with + | All -> + let _, _, suffix = type_structure caught partial env' parsetree in + (aux [] suffix, cache_stats) + | Part _ -> + let nenv, nparsetree, first_suffix = + type_structure caught partial env' parsetree + in + let partial_result = aux [] first_suffix in + perform (Internal_partial (partial_result, cache_stats)); + let _, _, second_suffix = + type_structure caught { partial with comp = All } nenv nparsetree + in + (aux first_suffix second_suffix, cache_stats) + with Cancel_struc suffix -> + (* Caching before cancellation *) + aux [] suffix |> ignore; + raise Domain_msg.Cancel -let type_interface config caught parsetree = +let type_interface config caught partial parsetree = let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } = get_cache config in @@ -208,19 +308,40 @@ let type_interface config caught parsetree = Stamped_hashtable.backtrack !index_changelog ~stamp; Env.cleanup_usage_tables ~stamp:uid_stamp'; Shape.Uid.restore_stamp uid_stamp'; - let suffix = type_signature caught env' parsetree in - let () = - List.iteri - ~f:(fun i { typedtree_items = items, _; _ } -> - let stamp = stamp + i + 1 in - !index_items ~index ~stamp config (`Intf items)) - suffix + let aux preprocessed_suffix suffix = + let () = + List.iteri + ~f:(fun i { typedtree_items = items, _; _ } -> + let stamp = stamp + i + 1 in + !index_items ~index ~stamp config (`Intf items)) + suffix + in + let value = + `Interface (List.rev_append prefix (preprocessed_suffix @ suffix)) + in + return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index } in - let value = `Interface (List.rev_append prefix suffix) in - ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index }, - cache_stats ) + try + match partial.comp with + | All -> + let _, _, suffix = type_signature caught partial env' parsetree in + (aux [] suffix, cache_stats) + | Part _ -> + let nenv, nparsetree, first_suffix = + type_signature caught partial env' parsetree + in + let partial_result = aux [] first_suffix in + perform (Internal_partial (partial_result, cache_stats)); + let _, _, second_suffix = + type_signature caught { partial with comp = All } nenv nparsetree + in + (aux first_suffix second_suffix, cache_stats) + with Cancel_sig suffix -> + (* Caching before cancellation *) + aux [] suffix |> ignore; + raise Domain_msg.Cancel -let run config parsetree = +let run config partial parsetree = if not (Env.check_state_consistency ()) then ( (* Resetting the local store will clear the load_path cache. Save it now, reset the store and then restore the path. *) @@ -232,23 +353,33 @@ let run config parsetree = let caught = ref [] in Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> Typecore.reset_delayed_checks (); - let cached_result, cache_stat = - match parsetree with - | `Implementation parsetree -> type_implementation config caught parsetree - | `Interface parsetree -> type_interface config caught parsetree + + let aux cached_result cache_stat = + let stamp = Ident.get_currentstamp () in + Typecore.reset_delayed_checks (); + { config; + initial_env = cached_result.env; + initial_snapshot = cached_result.snapshot; + initial_stamp = cached_result.ident_stamp; + stamp; + initial_uid_stamp = cached_result.uid_stamp; + typedtree = cached_result.value; + index = cached_result.index; + cache_stat + } in - let stamp = Ident.get_currentstamp () in - Typecore.reset_delayed_checks (); - { config; - initial_env = cached_result.env; - initial_snapshot = cached_result.snapshot; - initial_stamp = cached_result.ident_stamp; - stamp; - initial_uid_stamp = cached_result.uid_stamp; - typedtree = cached_result.value; - index = cached_result.index; - cache_stat - } + + match + match parsetree with + | `Implementation parsetree -> + type_implementation config caught partial parsetree + | `Interface parsetree -> type_interface config caught partial parsetree + with + | cached_result, cache_stat -> aux cached_result cache_stat + | effect Internal_partial (cached_result, cache_stat), k -> + let r = aux cached_result cache_stat in + perform (Partial r); + continue k () let get_env ?pos:_ t = Option.value ~default:t.initial_env diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index 5723b721ce..3031bad918 100644 --- a/src/kernel/mtyper.mli +++ b/src/kernel/mtyper.mli @@ -9,6 +9,11 @@ type result +type partial + +val make_partial : + Domain_msg.msg -> unit Shared.t -> Domain_msg.completion -> partial + type typedtree = [ `Interface of Typedtree.signature | `Implementation of Typedtree.structure ] @@ -26,7 +31,15 @@ val set_index_items : unit) -> unit -val run : Mconfig.t -> Mreader.parsetree -> result +type _ Effect.t += Partial : result -> unit Effect.t + +(** [run config partial parsetree] +@perform the effect Partial. It is caught in [Mpipeline.process]). + +@raise [Domain_msg.Cancel] and [Domain_msg.Closing]. Botch are caught in +[Mpipeline.domain_typer]). +*) +val run : Mconfig.t -> partial -> Mreader.parsetree -> result val get_env : ?pos:Msource.position -> result -> Env.t diff --git a/src/utils/shared.ml b/src/utils/shared.ml index 630f8fee72..37a81e7f51 100644 --- a/src/utils/shared.ml +++ b/src/utils/shared.ml @@ -20,3 +20,7 @@ let create a = { mutex = Mutex.create (); cond = Condition.create (); value = a } let wait a = Condition.wait a.cond a.mutex + +let lock a = Mutex.lock a.mutex + +let unlock a = Mutex.unlock a.mutex diff --git a/src/utils/shared.mli b/src/utils/shared.mli index b2aa9bfcd3..5945a208f9 100644 --- a/src/utils/shared.mli +++ b/src/utils/shared.mli @@ -7,3 +7,5 @@ val create : 'a -> 'a t val protect : 'a t -> (unit -> 'b) -> 'b val signal : 'a t -> unit val wait : 'a t -> unit +val lock : 'a t -> unit +val unlock : 'a t -> unit From 064e144ace1a6c26332493a33225616338f5dadf Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 1 Apr 2025 02:50:18 +0200 Subject: [PATCH 05/31] Handle 5.3 for OCamlformat and apply it --- .ocamlformat | 1 + src/analysis/typed_hole.ml | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/.ocamlformat b/.ocamlformat index 409672b79c..6986d1a28e 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,6 @@ version=0.27.0 disable=false +ocaml-version = 5.3 break-cases=fit-or-vertical doc-comments=before diff --git a/src/analysis/typed_hole.ml b/src/analysis/typed_hole.ml index d71bd893c0..52d73e9b0f 100644 --- a/src/analysis/typed_hole.ml +++ b/src/analysis/typed_hole.ml @@ -14,4 +14,3 @@ let is_a_hole = function | (_, Browse_raw.Module_expr { mod_desc = Tmod_typed_hole; _ }) :: (_, _) :: _ | (_, Browse_raw.Expression { exp_desc = Texp_typed_hole; _ }) :: _ -> true | [] | (_, _) :: _ -> false -;; From ae10a16f0659e7b18a8d18d3382db46d3e6c640f Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 1 Apr 2025 02:50:48 +0200 Subject: [PATCH 06/31] Handle position in `Domain_msg.Partial` --- src/kernel/domain_msg.ml | 2 +- src/kernel/mtyper.ml | 42 ++++++++++++++++++++++------------------ 2 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/kernel/domain_msg.ml b/src/kernel/domain_msg.ml index 2f397f4608..3317f39a9b 100644 --- a/src/kernel/domain_msg.ml +++ b/src/kernel/domain_msg.ml @@ -20,4 +20,4 @@ exception Cancel (* TODO @xvw Type completion needs to be changed for whatever type you defined to describe how far the typer must go. *) -type completion = All | Part of int +type completion = All | Partial of { line : int; column : int } diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index f295b669a0..aa175f9a56 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -117,13 +117,19 @@ let make_partial msg shared comp = { msg; shared; comp } exception Cancel_struc of (Parsetree.structure_item, Typedtree.structure_item) item list +let continue_typing comp get_location item = + match comp with + | Domain_msg.All -> true + | Partial { line; column } -> ( + let loc = get_location item in + let start = loc.Location.loc_start in + match Int.compare line start.pos_lnum with + | 0 -> Int.compare column (Lexing.column start) <= 0 + | i -> i <= 0) + let type_structure caught { msg; shared; comp } env parsetree = (* TODO @xvw *) - let _until = - match comp with - | Domain_msg.All -> Int.max_int - | Part i -> i - in + let continue_typing = continue_typing comp (fun i -> i.Parsetree.pstr_loc) in let rec loop env parsetree acc = (match Atomic.get msg.Domain_msg.from_main with @@ -160,7 +166,7 @@ let type_structure caught { msg; shared; comp } env parsetree = in Shared.unlock shared; (* TODO @xvw *) - if false (* until = pos *) then (env, rest, item :: acc) + if not (continue_typing parsetree_item) then (env, rest, item :: acc) else loop part_env rest (item :: acc) | [] -> Shared.unlock shared; @@ -173,11 +179,7 @@ exception let type_signature caught { msg; shared; comp } env parsetree = (* TODO @xvw *) - let _until = - match comp with - | Domain_msg.All -> Int.max_int - | Part i -> i - in + let continue_typing = continue_typing comp (fun i -> i.Parsetree.psig_loc) in let rec loop env parsetree acc = (match Atomic.get msg.Domain_msg.from_main with @@ -212,7 +214,7 @@ let type_signature caught { msg; shared; comp } env parsetree = in Shared.unlock shared; (* TODO @xvw *) - if false (* until = pos *) then (env, rest, item :: acc) + if not (continue_typing parsetree_item) then (env, rest, item :: acc) else loop part_env rest (item :: acc) | [] -> Shared.unlock shared; @@ -224,7 +226,9 @@ open Effect open Effect.Deep type _ Effect.t += - | Internal_partial : typedtree_items cache_result * typer_cache_stats -> unit t + | Internal_partial : + typedtree_items cache_result * typer_cache_stats + -> unit t | Partial : result -> unit t let type_implementation config caught partial parsetree = @@ -269,7 +273,7 @@ let type_implementation config caught partial parsetree = | All -> let _, _, suffix = type_structure caught partial env' parsetree in (aux [] suffix, cache_stats) - | Part _ -> + | Partial _ -> let nenv, nparsetree, first_suffix = type_structure caught partial env' parsetree in @@ -326,7 +330,7 @@ let type_interface config caught partial parsetree = | All -> let _, _, suffix = type_signature caught partial env' parsetree in (aux [] suffix, cache_stats) - | Part _ -> + | Partial _ -> let nenv, nparsetree, first_suffix = type_signature caught partial env' parsetree in @@ -376,10 +380,10 @@ let run config partial parsetree = | `Interface parsetree -> type_interface config caught partial parsetree with | cached_result, cache_stat -> aux cached_result cache_stat - | effect Internal_partial (cached_result, cache_stat), k -> - let r = aux cached_result cache_stat in - perform (Partial r); - continue k () + | effect Internal_partial (cached_result, cache_stat), k -> + let r = aux cached_result cache_stat in + perform (Partial r); + continue k () let get_env ?pos:_ t = Option.value ~default:t.initial_env From 3465d79e0c20f6f2d3a8724471c7100a7598f949 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:40:07 +0200 Subject: [PATCH 07/31] Adapt `Shared` to handle a potential termination location --- src/kernel/mpipeline.ml | 17 +++++++++-------- src/kernel/mpipeline.mli | 6 +++--- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index d2e144aa82..6131351ab7 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -221,14 +221,14 @@ module Ppx_with_cache = Phase_cache.With_cache (Ppx_phase) type shared = { msg : Domain_msg.msg; - config : (Mconfig.t * Msource.t) option Shared.t; + config : (Mconfig.t * Msource.t * (int * int) option) option Shared.t; (* Partial result *) partial : t option Shared.t; (* Use to protect typer computation *) result : unit Shared.t } -let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) +let process ?position ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) ?(ppx_time = ref 0.0) ?(typer_time = ref 0.0) ?(error_time = ref 0.0) ?(ppx_cache_hit = ref false) ?(reader_cache_hit = ref false) ?(typer_cache_stats = ref Mtyper.Miss) ?for_completion config raw_source @@ -317,7 +317,7 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) let result = Mtyper.( run config - (make_partial shared.msg shared.result Domain_msg.All) + (make_partial ?position shared.msg shared.result) parsetree) in cache_and_return_typer result) @@ -377,7 +377,8 @@ Est-ce que l'utilisation d'un effet ne simplifie pas assez ? *) -let make config source shared = process (Mconfig.normalize config) source shared +let make ?position config source shared = + process ?position (Mconfig.normalize config) source shared (* let for_completion position { config; @@ -465,10 +466,10 @@ let domain_typer shared () = | None -> Shared.wait shared.config; loop () - | Some (config, source) -> + | Some (config, source, potential_pos) -> Shared.set shared.config None; (try - let mpipeline = make config source shared in + let mpipeline = make ?position:potential_pos config source shared in Shared.locking_set shared.partial (Some mpipeline) with | Domain_msg.Cancel -> () @@ -478,8 +479,8 @@ let domain_typer shared () = in Shared.protect shared.config (fun () -> loop ()) -let get shared config source = - Shared.locking_set shared.config (Some (config, source)); +let get ?position shared config source = + Shared.locking_set shared.config (Some (config, source, position)); let rec loop () = let critical_section () = diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index 209eb7fa79..eff3a6a34e 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -2,7 +2,7 @@ type t type shared = { msg : Domain_msg.msg; - config : (Mconfig.t * Msource.t) option Shared.t; + config : (Mconfig.t * Msource.t * (int * int) option) option Shared.t; (* Partial result *) partial : t option Shared.t; (* Use to protect typer computation *) @@ -10,7 +10,7 @@ type shared = } (* Except inside Mpipeline, this function should only use in old_merlin *) -val make : Mconfig.t -> Msource.t -> shared -> t +val make : ?position:int * int -> Mconfig.t -> Msource.t -> shared -> t (* Except inside Mpipeline, this function should only use in old_merlin *) val with_pipeline : t -> (unit -> 'a) -> 'a @@ -51,4 +51,4 @@ val close_typer : shared -> unit val share_exn : shared -> exn -> unit val domain_typer : shared -> unit -> unit -val get : shared -> Mconfig.t -> Msource.t -> t +val get : ?position:int * int -> shared -> Mconfig.t -> Msource.t -> t From 77e5d36107c00afe1fc65ef2d3a45cf6d23f4edc Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:40:37 +0200 Subject: [PATCH 08/31] Extract a position (as a pair) from a `Msource.position` --- src/kernel/msource.ml | 4 ++++ src/kernel/msource.mli | 2 ++ 2 files changed, 6 insertions(+) diff --git a/src/kernel/msource.ml b/src/kernel/msource.ml index b975cc556f..59a367c7a1 100644 --- a/src/kernel/msource.ml +++ b/src/kernel/msource.ml @@ -114,6 +114,10 @@ let get_lexing_pos t ~filename pos = pos_cnum = o } +let get_position t pos = + let (`Logical (line, col)) = get_logical t pos in + (line, col) + let substitute t starting ending text = let len = String.length t.text in let (`Offset starting) = get_offset t starting in diff --git a/src/kernel/msource.mli b/src/kernel/msource.mli index ff0b72b9e0..1472fcc0ce 100644 --- a/src/kernel/msource.mli +++ b/src/kernel/msource.mli @@ -29,6 +29,8 @@ val get_logical : t -> [< position ] -> [> `Logical of int * int ] val get_lexing_pos : t -> filename:string -> [< position ] -> Lexing.position +val get_position : t -> [< position ] -> int * int + (** {1 Managing content} *) (** Updating content *) From dd5d918823bb62525caafbe9ddf330fd158abd60 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:41:01 +0200 Subject: [PATCH 09/31] Adapt `mtyper` to deal with interuption --- src/kernel/mtyper.ml | 12 +++++++++--- src/kernel/mtyper.mli | 2 +- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index aa175f9a56..67e7f0cdd4 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -112,7 +112,13 @@ let compatible_prefix result_items tree_items = type partial = { msg : Domain_msg.msg; shared : unit Shared.t; comp : Domain_msg.completion } -let make_partial msg shared comp = { msg; shared; comp } +let make_partial ?position msg shared = + let comp = + match position with + | None -> Domain_msg.All + | Some (line, column) -> Domain_msg.Partial { line; column } + in + { msg; shared; comp } exception Cancel_struc of (Parsetree.structure_item, Typedtree.structure_item) item list @@ -124,8 +130,8 @@ let continue_typing comp get_location item = let loc = get_location item in let start = loc.Location.loc_start in match Int.compare line start.pos_lnum with - | 0 -> Int.compare column (Lexing.column start) <= 0 - | i -> i <= 0) + | 0 -> Int.compare column (Lexing.column start) >= 0 + | i -> i >= 0) let type_structure caught { msg; shared; comp } env parsetree = (* TODO @xvw *) diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index 3031bad918..2fe47a8262 100644 --- a/src/kernel/mtyper.mli +++ b/src/kernel/mtyper.mli @@ -12,7 +12,7 @@ type result type partial val make_partial : - Domain_msg.msg -> unit Shared.t -> Domain_msg.completion -> partial + ?position:int * int -> Domain_msg.msg -> unit Shared.t -> partial type typedtree = [ `Interface of Typedtree.signature | `Implementation of Typedtree.structure ] From 6e49a87e884554c4681bbf5722d5b1a72bd9acb1 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:41:24 +0200 Subject: [PATCH 10/31] Adapt new_commands to pass (sometime) interuption position --- src/commands/new_commands.ml | 85 ++++++++++++++++++++++++++---------- 1 file changed, 63 insertions(+), 22 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index e388105798..40bf9c8303 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -96,8 +96,8 @@ let find_command name = List.find ~f:(command_is ~name) let find_command_opt name = List.find_opt ~f:(command_is ~name) -let run shared config source query = - let pipeline = Mpipeline.get shared config source in +let run ?position shared config source query = + let pipeline = Mpipeline.get ?position shared config source in Logger.log ~section:"New_commands" ~title:"run(query)" "%a" Logger.json (fun () -> Query_json.dump query); @@ -130,7 +130,8 @@ let all_commands = | `Offset -1, _ -> failwith "-start is mandatory" | _, `Offset -1 -> failwith "-end is mandatory" | startp, endp -> - run shared config source + let position = Msource.get_position source endp in + run ~position shared config source (Query_protocol.Case_analysis (startp, endp)) end; command "holes" ~spec:[] @@ -173,7 +174,9 @@ let all_commands = match pos with | `Offset -1 -> failwith "-position is mandatory" | pos -> - run shared config source + (* FIXME: Invalid some tests related to holes. *) + (* let position = Msource.get_position source pos in *) + run (* ~position *) shared config source (Query_protocol.Construct (pos, with_values, max_depth)) end; command "complete-prefix" @@ -231,7 +234,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Complete_prefix (txt, pos, List.rev kinds, doc, typ)) end; @@ -254,7 +258,9 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Document (ident, pos)) + let position = Msource.get_position source pos in + run ~position shared config source + (Query_protocol.Document (ident, pos)) end; command "syntax-document" ~doc: @@ -269,7 +275,9 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Syntax_document pos) + let position = Msource.get_position source pos in + run ~position shared config source + (Query_protocol.Syntax_document pos) end; command "expand-ppx" ~doc:"Returns the generated code of a PPX." ~spec: @@ -282,7 +290,10 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Expand_ppx pos) + (* FIXME: Test loop infinitely. *) + (* let position = Msource.get_position source pos in *) + run (* ~position *) shared config source + (Query_protocol.Expand_ppx pos) end; command "enclosing" ~spec: @@ -300,7 +311,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Enclosing pos) + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Enclosing pos) end; command "errors" ~spec: @@ -371,7 +383,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Expand_prefix (txt, pos, List.rev kinds, typ)) end; command "extension-list" @@ -429,7 +442,13 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Jump (target, pos)) + (* FIXME: Test loops infinitely + We need a more precise heuristic + based on the target. + *) + (* let position = Msource.get_position source pos in *) + run (* ~position *) shared config source + (Query_protocol.Jump (target, pos)) end; command "phrase" ~spec: @@ -451,7 +470,13 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Phrase (target, pos)) + (* FIXME: Test loops infinitely + We need a more precise heuristic + based on the next phrase. + *) + (* let position = Msource.get_position source pos in *) + run (* ~position *) shared config source + (Query_protocol.Phrase (target, pos)) end; command "list-modules" ~spec: @@ -500,7 +525,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Locate (prefix, lookfor, pos)) end; command "locate-type" @@ -514,7 +540,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Locate_type pos) + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Locate_type pos) end; command "occurrences" ~spec: @@ -537,6 +564,8 @@ let all_commands = fun shared config source -> function | `None, _ -> failwith "-identifier-at is mandatory" | `Ident_at pos, scope -> + (* TODO: Guess we have to typecheck everything + to get every occurence? *) run shared config source (Query_protocol.Occurrences (`Ident_at pos, scope)) end; @@ -582,7 +611,10 @@ let all_commands = | None, _ -> failwith "-action is mandatory" | _, `None -> failwith "-position is mandatory" | Some action, (#Msource.position as pos) -> - run shared config source + (* FIXME: break the test-suite, should we try to keep it? + Need to investigate the command. *) + (* let position = Msource.get_position source pos in *) + run (* ~position *) shared config source (Query_protocol.Refactor_open (action, pos)) end; command "search-by-polarity" @@ -603,7 +635,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Polarity_search (query, pos)) end; command "search-by-type" ~doc:"return a list of values that match a query" @@ -631,7 +664,8 @@ let all_commands = | None, _ -> failwith "-query is mandatory" | _, `None -> failwith "-position is mandatory" | Some query, (#Msource.position as pos) -> - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Type_search (query, pos, limit, with_doc)) end; command "inlay-hints" @@ -677,7 +711,8 @@ let all_commands = | _, `None -> failwith "-end is mandatory" | (#Msource.position, #Msource.position) as position -> let start, stop = position in - run shared config source + let position = Msource.get_position source stop in + run ~position shared config source (Query_protocol.Inlay_hints (start, stop, let_binding, pattern_binding, avoid_ghost)) end; @@ -704,7 +739,8 @@ let all_commands = fun shared config source -> function | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Shape pos) + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Shape pos) end; command "type-enclosing" ~doc: @@ -763,7 +799,8 @@ let all_commands = in Some (expr, cursor) in - run shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Type_enclosing (expr, pos, index)) end; command "type-expression" @@ -782,7 +819,9 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - run shared config source (Query_protocol.Type_expr (expr, pos)) + let position = Msource.get_position source pos in + run ~position shared config source + (Query_protocol.Type_expr (expr, pos)) end; (* Implemented without support from Query_protocol. This command might be refactored if it proves useful for old protocol too. *) @@ -840,7 +879,9 @@ let all_commands = active_signature_help = None } in - run shared config source (Query_protocol.Signature_help sh) + let position = Msource.get_position source position in + run ~position shared config source + (Query_protocol.Signature_help sh) end; (* Used only for testing *) command "dump" From 3de17e5f8b4190b7b25accc17cf320ce3568413d Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:42:06 +0200 Subject: [PATCH 11/31] Repromote `application_context.t` (that seems correct) --- tests/test-dirs/completion/application_context.t/run.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/completion/application_context.t/run.t b/tests/test-dirs/completion/application_context.t/run.t index ec9fd7f409..09aedf73c5 100644 --- a/tests/test-dirs/completion/application_context.t/run.t +++ b/tests/test-dirs/completion/application_context.t/run.t @@ -4,7 +4,7 @@ [ "application", { - "argument_type": "'a", + "argument_type": "int", "labels": [ { "name": "~j", From 8ee7cad5d60c0935aa8f3ae1681694d2a7d0bd48 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Wed, 2 Apr 2025 21:08:49 +0200 Subject: [PATCH 12/31] Fix a few bugs. --- src/commands/new_commands.ml | 18 +++++++++++++++--- src/kernel/domain_msg.ml | 3 +-- src/kernel/mpipeline.ml | 10 +++++++--- src/kernel/mtyper.ml | 26 ++++++++++++++++---------- src/kernel/mtyper.mli | 1 + 5 files changed, 40 insertions(+), 18 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 40bf9c8303..9159d1b31e 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -102,9 +102,21 @@ let run ?position shared config source query = (fun () -> Query_json.dump query); (* Analyse : need to ask for lock here *) - let result = Query_commands.dispatch pipeline query in - let json = Query_json.json_of_response query result in - (json, Some pipeline) + (* Main domain signals it wants the lock *) + if Atomic.compare_and_set shared.msg.from_main `Empty `Waiting then + let result = + Shared.protect shared.result (fun () -> + (* The write on mess_main needed + to happen in the lock to ensure the main domain got it, before + releasing the typer domain of its active wait *) + Atomic.set shared.msg.from_main `Empty; + Query_commands.dispatch pipeline query) + in + let json = Query_json.json_of_response query result in + (json, Some pipeline) + else + (* This can happen when the typer domain found an exception *) + failwith "To debug." let all_commands = [ command "case-analysis" diff --git a/src/kernel/domain_msg.ml b/src/kernel/domain_msg.ml index 3317f39a9b..8041112491 100644 --- a/src/kernel/domain_msg.ml +++ b/src/kernel/domain_msg.ml @@ -14,8 +14,7 @@ let send_msg msg new_msg signal_on = done else failwith "send_msg: should not happen." -exception Closing -exception Cancel +exception Cancel_or_Closing (* TODO @xvw Type completion needs to be changed for whatever type you defined to describe how far the typer must go. diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 6131351ab7..05f0b7f06e 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -470,10 +470,14 @@ let domain_typer shared () = Shared.set shared.config None; (try let mpipeline = make ?position:potential_pos config source shared in - Shared.locking_set shared.partial (Some mpipeline) + match potential_pos with + | None -> Shared.locking_set shared.partial (Some mpipeline) + | _ -> (* result already shared *) () with - | Domain_msg.Cancel -> () - | Domain_msg.Closing -> () + | Domain_msg.Cancel_or_Closing -> () + | Mtyper.Exn_after_partial -> + (* An exception has happened after sharing partial result: we can dump it *) + () | exn -> share_exn shared exn); loop ()) in diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 67e7f0cdd4..43530420c7 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -144,7 +144,7 @@ let type_structure caught { msg; shared; comp } env parsetree = while Atomic.get msg.Domain_msg.from_main == `Waiting do Domain.cpu_relax () done - | `Closing -> raise Domain_msg.Closing + | `Closing -> raise Domain_msg.Cancel_or_Closing | `Cancel -> (* Cancel_struct is catched by type_implementation *) raise (Cancel_struc acc)); @@ -194,7 +194,7 @@ let type_signature caught { msg; shared; comp } env parsetree = while Atomic.get msg.Domain_msg.from_main == `Waiting do Domain.cpu_relax () done - | `Closing -> raise Domain_msg.Closing + | `Closing -> raise Domain_msg.Cancel_or_Closing | `Cancel -> (* Cancel_sig is catched by type_interface *) raise (Cancel_sig acc)); @@ -292,7 +292,9 @@ let type_implementation config caught partial parsetree = with Cancel_struc suffix -> (* Caching before cancellation *) aux [] suffix |> ignore; - raise Domain_msg.Cancel + raise Domain_msg.Cancel_or_Closing + +exception Exn_after_partial let type_interface config caught partial parsetree = let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } = @@ -336,20 +338,24 @@ let type_interface config caught partial parsetree = | All -> let _, _, suffix = type_signature caught partial env' parsetree in (aux [] suffix, cache_stats) - | Partial _ -> + | Partial _ -> ( let nenv, nparsetree, first_suffix = type_signature caught partial env' parsetree in let partial_result = aux [] first_suffix in - perform (Internal_partial (partial_result, cache_stats)); - let _, _, second_suffix = - type_signature caught { partial with comp = All } nenv nparsetree - in - (aux first_suffix second_suffix, cache_stats) + try + begin + perform (Internal_partial (partial_result, cache_stats)); + let _, _, second_suffix = + type_signature caught { partial with comp = All } nenv nparsetree + in + (aux first_suffix second_suffix, cache_stats) + end + with _ -> raise Exn_after_partial) with Cancel_sig suffix -> (* Caching before cancellation *) aux [] suffix |> ignore; - raise Domain_msg.Cancel + raise Domain_msg.Cancel_or_Closing let run config partial parsetree = if not (Env.check_state_consistency ()) then ( diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index 2fe47a8262..c040f1a384 100644 --- a/src/kernel/mtyper.mli +++ b/src/kernel/mtyper.mli @@ -32,6 +32,7 @@ val set_index_items : unit type _ Effect.t += Partial : result -> unit Effect.t +exception Exn_after_partial (** [run config partial parsetree] @perform the effect Partial. It is caught in [Mpipeline.process]). From 1613edf6ae12f69bf49732670a08fa5f98567291 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Thu, 3 Apr 2025 13:49:07 +0200 Subject: [PATCH 13/31] Better check to determine if the pipeline has already been shared. --- src/frontend/ocamlmerlin/old/old_command.ml | 2 +- src/kernel/mpipeline.ml | 60 ++++++++++----------- src/kernel/mpipeline.mli | 2 +- 3 files changed, 29 insertions(+), 35 deletions(-) diff --git a/src/frontend/ocamlmerlin/old/old_command.ml b/src/frontend/ocamlmerlin/old/old_command.ml index 3d19902e41..10bdb7cbd8 100644 --- a/src/frontend/ocamlmerlin/old/old_command.ml +++ b/src/frontend/ocamlmerlin/old/old_command.ml @@ -128,7 +128,7 @@ let checkout_buffer = let make_pipeline config buffer = let shared = Mpipeline.create_shared () in - Mpipeline.make config buffer.source shared + Mpipeline.make config buffer.source shared |> Option.get let dispatch_sync config state (type a) : a sync_command -> a = function | Idle_job -> false diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 05f0b7f06e..a7429cf4d3 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -309,6 +309,7 @@ let process ?position ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) { Typer.errors; result } in + let typer_has_been_shared = ref false in let typer = match timed typer_time (fun () -> @@ -344,38 +345,32 @@ let process ?position ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0) } in Shared.locking_set shared.partial (Some mpipeline); + typer_has_been_shared := true; (* Back to [Mtyper.run] *) Effect.Deep.continue k () in - { config; - state; - raw_source; - source; - reader; - ppx; - typer; - pp_time; - reader_time; - ppx_time; - typer_time; - error_time; - ppx_cache_hit; - reader_cache_hit; - typer_cache_stats - } - -(* -Il faut faire : -- calculer source, puis reader et ppx PUIS -- une fonction qui calcul typeur et qui renvoie un résultat partiel quand dispo -puis continue - -- avec une callback (ou un effet -> Partial ) -- ou en interne - -Est-ce que l'utilisation d'un effet ne simplifie pas assez ? - -*) + if !typer_has_been_shared then + (* assert (Option.is_some position); *) + None + else + (* assert (position = None); *) + Some + { config; + state; + raw_source; + source; + reader; + ppx; + typer; + pp_time; + reader_time; + ppx_time; + typer_time; + error_time; + ppx_cache_hit; + reader_cache_hit; + typer_cache_stats + } let make ?position config source shared = process ?position (Mconfig.normalize config) source shared @@ -469,10 +464,9 @@ let domain_typer shared () = | Some (config, source, potential_pos) -> Shared.set shared.config None; (try - let mpipeline = make ?position:potential_pos config source shared in - match potential_pos with - | None -> Shared.locking_set shared.partial (Some mpipeline) - | _ -> (* result already shared *) () + match make ?position:potential_pos config source shared with + | Some _ as pipeline -> Shared.locking_set shared.partial pipeline + | None -> (* result already shared *) () with | Domain_msg.Cancel_or_Closing -> () | Mtyper.Exn_after_partial -> diff --git a/src/kernel/mpipeline.mli b/src/kernel/mpipeline.mli index eff3a6a34e..8a5402ecbc 100644 --- a/src/kernel/mpipeline.mli +++ b/src/kernel/mpipeline.mli @@ -10,7 +10,7 @@ type shared = } (* Except inside Mpipeline, this function should only use in old_merlin *) -val make : ?position:int * int -> Mconfig.t -> Msource.t -> shared -> t +val make : ?position:int * int -> Mconfig.t -> Msource.t -> shared -> t option (* Except inside Mpipeline, this function should only use in old_merlin *) val with_pipeline : t -> (unit -> 'a) -> 'a From 3710e95f24616f6d483ab3e3bac8f270858160ba Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Thu, 3 Apr 2025 13:54:39 +0200 Subject: [PATCH 14/31] Add a few comments and a todo --- src/kernel/mtyper.ml | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 43530420c7..cf63f20aa7 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -105,10 +105,6 @@ let compatible_prefix result_items tree_items = in aux [] (result_items, tree_items) -(* TODO @xvw - - type [completion] needs to be changed for whatever type you defined to describe how far the typer must go. - - type [partial] should also change adequatly. -*) type partial = { msg : Domain_msg.msg; shared : unit Shared.t; comp : Domain_msg.completion } @@ -120,8 +116,11 @@ let make_partial ?position msg shared = in { msg; shared; comp } +exception Exn_after_partial exception Cancel_struc of (Parsetree.structure_item, Typedtree.structure_item) item list +exception + Cancel_sig of (Parsetree.signature_item, Typedtree.signature_item) item list let continue_typing comp get_location item = match comp with @@ -133,6 +132,9 @@ let continue_typing comp get_location item = | 0 -> Int.compare column (Lexing.column start) >= 0 | i -> i >= 0) +(* TODO It should be possible to cache the result in case an exception is raised +during typing by encapsulating the partial result (before the exception) and the +exception in an other exception, catched by type_implementation. *) let type_structure caught { msg; shared; comp } env parsetree = (* TODO @xvw *) let continue_typing = continue_typing comp (fun i -> i.Parsetree.pstr_loc) in @@ -146,7 +148,8 @@ let type_structure caught { msg; shared; comp } env parsetree = done | `Closing -> raise Domain_msg.Cancel_or_Closing | `Cancel -> - (* Cancel_struct is catched by type_implementation *) + (* Cancel_struct is catched by type_implementation where the partial + result is going to get cached *) raise (Cancel_struc acc)); Shared.lock shared; @@ -180,9 +183,6 @@ let type_structure caught { msg; shared; comp } env parsetree = in loop env parsetree [] -exception - Cancel_sig of (Parsetree.signature_item, Typedtree.signature_item) item list - let type_signature caught { msg; shared; comp } env parsetree = (* TODO @xvw *) let continue_typing = continue_typing comp (fun i -> i.Parsetree.psig_loc) in @@ -196,7 +196,8 @@ let type_signature caught { msg; shared; comp } env parsetree = done | `Closing -> raise Domain_msg.Cancel_or_Closing | `Cancel -> - (* Cancel_sig is catched by type_interface *) + (* Cancel_sig is catched by type_interface where the partial + result is going to get cached *) raise (Cancel_sig acc)); Shared.lock shared; @@ -294,8 +295,6 @@ let type_implementation config caught partial parsetree = aux [] suffix |> ignore; raise Domain_msg.Cancel_or_Closing -exception Exn_after_partial - let type_interface config caught partial parsetree = let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } = get_cache config From 009bb6e35afa577e5b1c8ea548666a2d2a6d6005 Mon Sep 17 00:00:00 2001 From: xvw Date: Thu, 3 Apr 2025 14:39:21 +0200 Subject: [PATCH 15/31] Reintroduce some early interuption --- src/commands/new_commands.ml | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 9159d1b31e..d0a516b63d 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -186,9 +186,8 @@ let all_commands = match pos with | `Offset -1 -> failwith "-position is mandatory" | pos -> - (* FIXME: Invalid some tests related to holes. *) - (* let position = Msource.get_position source pos in *) - run (* ~position *) shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Construct (pos, with_values, max_depth)) end; command "complete-prefix" @@ -302,7 +301,7 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - (* FIXME: Test loop infinitely. *) + (* FIXME: Failwith abnormal termination. *) (* let position = Msource.get_position source pos in *) run (* ~position *) shared config source (Query_protocol.Expand_ppx pos) @@ -454,12 +453,8 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - (* FIXME: Test loops infinitely - We need a more precise heuristic - based on the target. - *) - (* let position = Msource.get_position source pos in *) - run (* ~position *) shared config source + let position = Msource.get_position source pos in + run ~position shared config source (Query_protocol.Jump (target, pos)) end; command "phrase" @@ -482,9 +477,7 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - (* FIXME: Test loops infinitely - We need a more precise heuristic - based on the next phrase. + (* FIXME: Breaks test motion/phrase.t *) (* let position = Msource.get_position source pos in *) run (* ~position *) shared config source From abd60b5a336a06b6c8a6ad8f6b091c0c0b0276d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 8 Apr 2025 10:05:36 -0400 Subject: [PATCH 16/31] Add changelog entry --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index cde92d2fa9..06d19ac6c1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,6 +7,7 @@ unreleased - `locate` can now disambiguate between files with identical names and contents (#1882) - `occurrences` now reports stale files (#1885) + - Introduce parallel typer (#1920) + ocaml-index - Improve the granularity of index reading by segmenting the marshalization of the involved data-structures. (#1889) From 4945df59ca97fd7a2b839180c5e72987d259cb51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 26 Mar 2025 18:16:16 +0100 Subject: [PATCH 17/31] Add more module test cases for renaming --- .../for-renaming/r-modules-and-types.t | 95 +++++++++++++++++-- 1 file changed, 88 insertions(+), 7 deletions(-) diff --git a/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t b/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t index 8f84dfc978..9365daacec 100644 --- a/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t +++ b/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t @@ -8,34 +8,46 @@ > module type S = sig > val x : unit > end + > let () = + > let module X : S = struct let x = () end in + > X.x > EOF $ cat >main.ml <<'EOF' > module M : Lib.S = struct > let x = () > end - > let () = M.x + > module N = M + > let () = let open M in N.x > EOF $ ocamlc -bin-annot -bin-annot-occurrences -c lib.mli lib.ml main.ml $ ocaml-index aggregate *.cmti *.cmt $ ocaml-index dump project.ocaml-index - 6 uids: + 8 uids: {uid: [intf]Lib.0; locs: "x": File "lib.mli", line 2, characters 6-7 uid: Lib.0; locs: "x": File "lib.ml", line 2, characters 6-7 uid: [intf]Lib.1; locs: "S": File "lib.mli", line 1, characters 12-13 uid: Lib.1; locs: "S": File "lib.ml", line 1, characters 12-13; + "S": File "lib.ml", line 5, characters 17-18; "Lib.S": File "main.ml", line 1, characters 11-16 + uid: Lib.2; locs: + "x": File "lib.ml", line 5, characters 32-33; + "X.x": File "lib.ml", line 6, characters 2-5 uid: Main.0; locs: "x": File "main.ml", line 2, characters 6-7; - "M.x": File "main.ml", line 4, characters 9-12 - uid: Main.1; locs: "M": File "main.ml", line 1, characters 7-8 }, + "N.x": File "main.ml", line 5, characters 23-26 + uid: Main.1; locs: + "M": File "main.ml", line 1, characters 7-8; + "M": File "main.ml", line 4, characters 11-12; + "M": File "main.ml", line 5, characters 18-19 + uid: Main.2; locs: "N": File "main.ml", line 4, characters 7-8 }, 0 approx shapes: {}, and shapes for CUS . - and related uids:{([intf]Lib.1 Lib.1); ([intf]Lib.0 Lib.0 Main.0)} + and related uids:{([intf]Lib.1 Lib.1); ([intf]Lib.0 Lib.0 Lib.2 Main.0)} - $ $MERLIN single occurrences -scope renaming -identifier-at 4:11 \ + $ $MERLIN single occurrences -scope renaming -identifier-at 5:25 \ > -index-file project.ocaml-index \ > -filename main.ml -index-file project.ocaml-index \ + > -filename main.ml Date: Wed, 9 Apr 2025 16:53:13 +0200 Subject: [PATCH 18/31] Make `inlay-hints` triggerable for function params --- src/analysis/inlay_hints.ml | 39 +++++------ src/analysis/inlay_hints.mli | 1 + src/commands/new_commands.ml | 115 +++++++++++++++++++++++++++++---- src/commands/query_json.ml | 9 ++- src/frontend/query_commands.ml | 10 ++- src/frontend/query_protocol.ml | 2 +- 6 files changed, 139 insertions(+), 37 deletions(-) diff --git a/src/analysis/inlay_hints.ml b/src/analysis/inlay_hints.ml index 54de9cda65..f9c9c1c4e6 100644 --- a/src/analysis/inlay_hints.ml +++ b/src/analysis/inlay_hints.ml @@ -17,7 +17,7 @@ let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) = pattern.pat_extra let structure_iterator hint_let_binding hint_pattern_binding - avoid_ghost_location typedtree range callback = + hint_function_params avoid_ghost_location typedtree range callback = let case_iterator hint_lhs (iterator : Iterator.iterator) case = let () = log ~title:"case" "on case" in let () = if hint_lhs then iterator.pat iterator case.Typedtree.c_lhs in @@ -63,20 +63,18 @@ let structure_iterator hint_let_binding hint_pattern_binding let () = log ~title:"expression" "on match" in let () = iterator.expr iterator expr in List.iter ~f:(case_iterator hint_pattern_binding iterator) cases - | Texp_function - ( _, - Tfunction_cases - { cases = - [ { c_rhs = - { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ }; - _ - } - ]; - _ - } ) -> + | Texp_function (args, body) -> ( let () = log ~title:"expression" "on function" in - let () = iterator.pat iterator vb_pat in - iterator.expr iterator body + if hint_function_params then + List.iter args ~f:(fun Typedtree.{ fp_kind; _ } -> + match fp_kind with + | Tparam_pat pat | Tparam_optional_default (pat, _) -> + iterator.pat iterator pat); + match body with + | Tfunction_cases { cases; _ } -> + List.iter cases ~f:(fun case -> + case_iterator hint_pattern_binding iterator case) + | Tfunction_body body -> iterator.expr iterator body) | _ when is_ghost_location avoid_ghost_location expr.exp_loc -> (* Stop iterating when we see a ghost location to avoid annotating generated code *) @@ -138,21 +136,24 @@ let create_hint env typ loc = let position = loc.Location.loc_end in (position, label) -let of_structure ~hint_let_binding ~hint_pattern_binding ~avoid_ghost_location - ~start ~stop structure = +let of_structure ~hint_let_binding ~hint_pattern_binding ~hint_function_params + ~avoid_ghost_location ~start ~stop structure = let () = log ~title:"start" "%a" Logger.fmt (fun fmt -> Format.fprintf fmt - "Start on %s to %s with : let: %b, pat: %b, ghost: %b" + "Start on %s to %s with : let: %b, pat: %b, function_param: %b, \ + ghost: %b" (Lexing.print_position () start) (Lexing.print_position () stop) - hint_let_binding hint_pattern_binding avoid_ghost_location) + hint_let_binding hint_pattern_binding hint_function_params + avoid_ghost_location) in let range = (start, stop) in let hints = ref [] in let () = structure_iterator hint_let_binding hint_pattern_binding - avoid_ghost_location structure range (fun env typ loc -> + hint_function_params avoid_ghost_location structure range + (fun env typ loc -> let () = log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt -> Format.fprintf fmt "%s - %a" diff --git a/src/analysis/inlay_hints.mli b/src/analysis/inlay_hints.mli index 575f8b7778..632b6d208e 100644 --- a/src/analysis/inlay_hints.mli +++ b/src/analysis/inlay_hints.mli @@ -5,6 +5,7 @@ type hint = Lexing.position * string val of_structure : hint_let_binding:bool -> hint_pattern_binding:bool -> + hint_function_params:bool -> avoid_ghost_location:bool -> start:Lexing.position -> stop:Lexing.position -> diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index d0a516b63d..dc2caaac0b 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -678,37 +678,121 @@ let all_commands = ~spec: [ arg "-start" " Where inlay-hints generation start" (marg_position - (fun start (_start, stop, let_binding, pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); + (fun + start + ( _start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))); arg "-end" " Where inlay-hints generation stop" (marg_position - (fun stop (start, _stop, let_binding, pattern_binding, ghost) -> - (start, stop, let_binding, pattern_binding, ghost))); + (fun + stop + ( start, + _stop, + let_binding, + pattern_binding, + function_params, + ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))); optional "-let-binding" " Hint let-binding (default is false)" (Marg.bool (fun let_binding - (start, stop, _let_binding, pattern_binding, ghost) - -> (start, stop, let_binding, pattern_binding, ghost))); + ( start, + stop, + _let_binding, + pattern_binding, + function_params, + ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))); optional "-pattern-binding" " Hint pattern-binding (default is false)" (Marg.bool (fun pattern_binding - (start, stop, let_binding, _pattern_binding, ghost) - -> (start, stop, let_binding, pattern_binding, ghost))); + ( start, + stop, + let_binding, + _pattern_binding, + function_params, + ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))); + optional "-function-params" + " Hint function parameters (default is false)" + (Marg.bool + (fun + function_params + ( start, + stop, + let_binding, + pattern_binding, + _function_params, + ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))); optional "-avoid-ghost-location" " Avoid hinting ghost location (default is true)" (Marg.bool - (fun ghost (start, stop, let_binding, pattern_binding, _ghost) -> - (start, stop, let_binding, pattern_binding, ghost))) + (fun + ghost + ( start, + stop, + let_binding, + pattern_binding, + function_params, + _ghost ) + -> + ( start, + stop, + let_binding, + pattern_binding, + function_params, + ghost ))) ] - ~default:(`None, `None, false, false, true) + ~default:(`None, `None, false, false, false, true) begin fun shared config source - (start, stop, let_binding, pattern_binding, avoid_ghost) + ( start, + stop, + let_binding, + pattern_binding, + function_params, + avoid_ghost ) -> match (start, stop) with | `None, `None -> failwith "-start and -end are mandatory" @@ -719,7 +803,12 @@ let all_commands = let position = Msource.get_position source stop in run ~position shared config source (Query_protocol.Inlay_hints - (start, stop, let_binding, pattern_binding, avoid_ghost)) + ( start, + stop, + let_binding, + pattern_binding, + function_params, + avoid_ghost )) end; command "shape" ~doc: diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 4ded2cf581..69e2e336f5 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -134,12 +134,19 @@ let dump (type a) : a t -> json = | Some `Local -> `String "local" ); ("depth", `Int depth) ] - | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var, ghost) -> + | Inlay_hints + ( start, + stop, + hint_let_binding, + hint_pattern_var, + hint_function_params, + ghost ) -> mk "inlay-hints" [ ("start", mk_position start); ("stop", mk_position stop); ("hint-let-binding", `Bool hint_let_binding); ("hint-pattern-variable", `Bool hint_pattern_var); + ("hint-function-params", `Bool hint_function_params); ("avoid-ghost-location", `Bool ghost) ] | Outline -> mk "outline" [] diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 27deeae8e3..b5376800be 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -803,8 +803,12 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function in (occurrences, status) | Inlay_hints - (start, stop, hint_let_binding, hint_pattern_binding, avoid_ghost_location) - -> + ( start, + stop, + hint_let_binding, + hint_pattern_binding, + hint_function_params, + avoid_ghost_location ) -> let start = Mpipeline.get_lexing_pos pipeline start and stop = Mpipeline.get_lexing_pos pipeline stop in let typer_result = Mpipeline.typer_result pipeline in @@ -813,7 +817,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | `Interface _ -> [] | `Implementation structure -> Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding - ~avoid_ghost_location ~start ~stop structure + ~hint_function_params ~avoid_ghost_location ~start ~stop structure end | Signature_help { position; _ } -> ( (* Todo: additionnal contextual information could help us provide better diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 0c867ca1f0..4c9e9ffaea 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -202,7 +202,7 @@ type _ t = Msource.position * [ `None | `Local ] option * int option -> (Location.t * string list) t | Inlay_hints : - Msource.position * Msource.position * bool * bool * bool + Msource.position * Msource.position * bool * bool * bool * bool -> (Lexing.position * string) list t | Outline (* *) : outline t | Shape (* *) : Msource.position -> shape list t From bae30031ed51b5ec80073fa08347d6a9d3eed638 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 9 Apr 2025 16:53:36 +0200 Subject: [PATCH 19/31] Test cases for `inlay-hints` on function params --- tests/test-dirs/inlay-hint/samples.t | 89 +++++++++++++++++++++++++++- 1 file changed, 88 insertions(+), 1 deletion(-) diff --git a/tests/test-dirs/inlay-hint/samples.t b/tests/test-dirs/inlay-hint/samples.t index de3be2b4ba..ee3eed780f 100644 --- a/tests/test-dirs/inlay-hint/samples.t +++ b/tests/test-dirs/inlay-hint/samples.t @@ -1,6 +1,77 @@ +Regular function + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params true \ + > -filename inlay.ml < let f a b c d e f = (a + b, c ^ d, e +. (float_of_string f)) + > EOF + { + "class": "return", + "value": [ + { + "pos": { + "line": 1, + "col": 17 + }, + "label": "string" + }, + { + "pos": { + "line": 1, + "col": 15 + }, + "label": "float" + }, + { + "pos": { + "line": 1, + "col": 13 + }, + "label": "string" + }, + { + "pos": { + "line": 1, + "col": 11 + }, + "label": "string" + }, + { + "pos": { + "line": 1, + "col": 9 + }, + "label": "int" + }, + { + "pos": { + "line": 1, + "col": 7 + }, + "label": "int" + } + ], + "notifications": [] + } + +Regular function without function-params + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params false \ + > -filename inlay.ml < let f a b c d e f = (a + b, c ^ d, e +. (float_of_string f)) + > EOF + { + "class": "return", + "value": [], + "notifications": [] + } + + Optional argument $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params true \ > -filename inlay.ml < let f ?x () = x () > EOF @@ -18,9 +89,22 @@ Optional argument "notifications": [] } +Optional argument without function-params + + $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -filename inlay.ml < let f ?x () = x () + > EOF + { + "class": "return", + "value": [], + "notifications": [] + } + Optional argument with value $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params true \ > -filename inlay.ml < let f ?(x = 1) () = x > EOF @@ -41,6 +125,7 @@ Optional argument with value Labeled argument $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params true \ > -filename inlay.ml < let f ~x = x + 1 > EOF @@ -61,6 +146,7 @@ Labeled argument Case argument $ $MERLIN single inlay-hints -start 1:0 -end 2:26 -avoid-ghost-location false \ + > -function-params true \ > -filename inlay.ml < let f (Some x) = x + 1 > EOF @@ -81,6 +167,7 @@ Case argument Pattern variables without pattern-binding hint $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ + > -function-params true \ > -filename inlay.ml < let f x = > match x with @@ -104,7 +191,7 @@ Pattern variables without pattern-binding hint Pattern variables with pattern-binding hint $ $MERLIN single inlay-hints -start 1:0 -end 4:26 -avoid-ghost-location false \ - > -pattern-binding true \ + > -pattern-binding true -function-params true \ > -filename inlay.ml < let f x = > match x with From f3b1ec85201f08859fdba260afed5a10222a05c3 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 9 Apr 2025 16:56:51 +0200 Subject: [PATCH 20/31] Add CHANGES entry --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 06d19ac6c1..f2a7238c86 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -7,7 +7,7 @@ unreleased - `locate` can now disambiguate between files with identical names and contents (#1882) - `occurrences` now reports stale files (#1885) - - Introduce parallel typer (#1920) + - `inlay-hints` fix inlay hints on function parameters (#1923) + ocaml-index - Improve the granularity of index reading by segmenting the marshalization of the involved data-structures. (#1889) From a748855f1f6d9c2b6a2bc3fbf7b8f19af32c98d7 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 9 Apr 2025 19:44:47 +0200 Subject: [PATCH 21/31] Fix test since `dune` release --- tests/test-dirs/issue1900.t/run.t | 35 +++++++++---------------------- 1 file changed, 10 insertions(+), 25 deletions(-) diff --git a/tests/test-dirs/issue1900.t/run.t b/tests/test-dirs/issue1900.t/run.t index ea0c643f77..e4575479e1 100644 --- a/tests/test-dirs/issue1900.t/run.t +++ b/tests/test-dirs/issue1900.t/run.t @@ -1,36 +1,14 @@ $ dune exec ./main.exe test -FIXME: There should be no error. +There should be no error. $ $MERLIN single errors -filename main.ml jq '.value.merlin.flags_applied' [ - { - "workdir": "$TESTCASE_ROOT", - "workval": [ - "-open", - "Dune__exe" - ] - }, { "workdir": "$TESTCASE_ROOT", "workval": [ @@ -44,6 +22,13 @@ FIXME: Dune should communicate the -open Dune__exe flag after the others. "Lib", "-g" ] + }, + { + "workdir": "$TESTCASE_ROOT", + "workval": [ + "-open", + "Dune__exe" + ] } ] From 15e0b829540b9fffbf0a76eb8b2ebcd5987d257f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 15 Apr 2025 17:36:49 -0400 Subject: [PATCH 22/31] Fix issue with ident filtering --- src/analysis/locate.ml | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 3ce56b3b67..51967b5f45 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -620,14 +620,16 @@ let find_loc_of_comp_unit ~config uid comp_unit = log ~title "Failed to load the CU's cmt"; `None -let find_loc_of_uid ~config ~local_defs ~ident ?fallback (uid : Shape.Uid.t) = +let find_loc_of_uid ~config ~local_defs ?ident ?fallback (uid : Shape.Uid.t) = let find_loc_of_item ~comp_unit = - match (find_loc_of_item ~config ~local_defs uid comp_unit, fallback) with - | Some { loc; txt }, _ when String.equal txt ident -> + match find_loc_of_item ~config ~local_defs uid comp_unit, fallback, ident with + | Some { loc; txt }, _, Some ident when String.equal txt ident -> (* Checking the ident prevent returning nonsensical results when some uid were swaped but the cmt files were not rebuilt. *) Some (uid, loc) - | (Some _ | None), Some fallback -> + | Some { loc; _ }, _, None -> + Some (uid, loc) + | (Some _ | None), Some fallback, _ -> find_loc_of_item ~config ~local_defs fallback comp_unit |> Option.map ~f:(fun { Location.loc; _ } -> (fallback, loc)) | _ -> None @@ -705,7 +707,7 @@ let rec uid_of_result ~traverse_aliases = function | Approximated _ | Unresolved _ | Internal_error_missing_uid -> (None, true) (** This is the main function here *) -let from_path ~config ~env ~local_defs ~decl path = +let from_path ~config ~env ~local_defs ~decl ?ident:_ path = let title = "from_path" in let unalias (decl : Env_lookup.item) = if not config.traverse_aliases then (path, decl.uid) @@ -752,11 +754,14 @@ let from_path ~config ~env ~local_defs ~decl path = in (* Step 2: Uid => Location *) let loc = - let ident = Path.last path in + let ident = + (* TODO it might not be useful to check the ident without impl_uid *) + Path.last path + in match impl_uid with | Some impl_uid -> find_loc_of_uid ~config ~local_defs ~ident ~fallback:uid impl_uid - | None -> find_loc_of_uid ~config ~local_defs ~ident uid + | None -> find_loc_of_uid ~config ~local_defs uid in let loc = match loc with @@ -792,7 +797,9 @@ let from_longident ~config ~env ~local_defs nss ident = in match Env_lookup.by_longident nss ident env with | None -> `Not_in_env str_ident - | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path + | Some (path, decl) -> + let ident = Longident.last ident in + from_path ~config ~env ~local_defs ~decl ~ident path let from_path ~config ~env ~local_defs ~namespace path = File_switching.reset (); From bf7961179c9ceb9e1241fa8851ab730dd44454de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 16 Apr 2025 15:47:25 -0400 Subject: [PATCH 23/31] Fix Lid comparison --- src/index-format/lid.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/index-format/lid.ml b/src/index-format/lid.ml index a21da307b4..91bfafe351 100644 --- a/src/index-format/lid.ml +++ b/src/index-format/lid.ml @@ -39,9 +39,7 @@ let pp fmt t = let compare_pos p1 p2 = Int.compare p1.cnum p2.cnum let compare_filename t1 t2 = - String.compare - (Filename.basename (G.fetch t1.filename)) - (Filename.basename (G.fetch t2.filename)) + String.compare (G.fetch t1.filename) (G.fetch t2.filename) let compare t1 t2 = match compare_filename t1 t2 with From 172396713a0b5a385f7a1ef4b292e7a4377fd63f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 16 Apr 2025 15:53:22 -0400 Subject: [PATCH 24/31] Add a changelog entry --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index f2a7238c86..88e294e377 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,6 +8,7 @@ unreleased (#1882) - `occurrences` now reports stale files (#1885) - `inlay-hints` fix inlay hints on function parameters (#1923) + - Fix issues with ident validation and Lid comparison for occurrences (#1924) + ocaml-index - Improve the granularity of index reading by segmenting the marshalization of the involved data-structures. (#1889) From 3b459d46f98f088b50eb0c7e003f21370ae44d6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 16 Apr 2025 16:42:29 -0400 Subject: [PATCH 25/31] Promote ordering changes in tests --- .../for-renaming/r-modules-and-types.t | 24 +++++----- .../for-renaming/r-with-functors.t/run.t | 10 ++-- .../occurrences/project-wide/mli-vs-ml.t | 40 ++++++++-------- .../occurrences/project-wide/prefix.t/run.t | 48 +++++++++---------- .../occurrences/project-wide/pwo-basic.t | 24 +++++----- .../project-wide/pwo-canonicalize.t | 20 ++++---- .../occurrences/project-wide/pwo-ml-gen.t | 2 +- .../occurrences/project-wide/stale-index.t | 24 +++++----- 8 files changed, 96 insertions(+), 96 deletions(-) diff --git a/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t b/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t index 9365daacec..7c23e048f3 100644 --- a/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t +++ b/tests/test-dirs/occurrences/project-wide/for-renaming/r-modules-and-types.t @@ -65,6 +65,18 @@ }, "stale": false }, + { + "file": "$TESTCASE_ROOT/main.ml", + "start": { + "line": 5, + "col": 25 + }, + "end": { + "line": 5, + "col": 26 + }, + "stale": false + }, { "file": "$TESTCASE_ROOT/lib.ml", "start": { @@ -112,18 +124,6 @@ "col": 7 }, "stale": false - }, - { - "file": "$TESTCASE_ROOT/main.ml", - "start": { - "line": 5, - "col": 25 - }, - "end": { - "line": 5, - "col": 26 - }, - "stale": false } ], "notifications": [] diff --git a/tests/test-dirs/occurrences/project-wide/for-renaming/r-with-functors.t/run.t b/tests/test-dirs/occurrences/project-wide/for-renaming/r-with-functors.t/run.t index d28346bf3b..dee8c73d25 100644 --- a/tests/test-dirs/occurrences/project-wide/for-renaming/r-with-functors.t/run.t +++ b/tests/test-dirs/occurrences/project-wide/for-renaming/r-with-functors.t/run.t @@ -12,6 +12,11 @@ We expect 2 occurrences in func.ml, 1 in func.mli and 2 in main.ml "line": 1, "col": 22 } + "$TESTCASE_ROOT/main.ml" + { + "line": 4, + "col": 16 + } "$TESTCASE_ROOT/func.ml" { "line": 1, @@ -27,8 +32,3 @@ We expect 2 occurrences in func.ml, 1 in func.mli and 2 in main.ml "line": 1, "col": 24 } - "$TESTCASE_ROOT/main.ml" - { - "line": 4, - "col": 16 - } diff --git a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t index 058a905548..f6d3fe52e2 100644 --- a/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t +++ b/tests/test-dirs/occurrences/project-wide/mli-vs-ml.t @@ -48,37 +48,37 @@ the interface and the implementation. "stale": false }, { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/main.mli", "start": { "line": 2, - "col": 5 + "col": 8 }, "end": { "line": 2, - "col": 6 + "col": 9 }, "stale": false }, { "file": "$TESTCASE_ROOT/main.ml", "start": { - "line": 3, - "col": 8 + "line": 2, + "col": 5 }, "end": { - "line": 3, - "col": 9 + "line": 2, + "col": 6 }, "stale": false }, { - "file": "$TESTCASE_ROOT/main.mli", + "file": "$TESTCASE_ROOT/main.ml", "start": { - "line": 2, + "line": 3, "col": 8 }, "end": { - "line": 2, + "line": 3, "col": 9 }, "stale": false @@ -107,37 +107,37 @@ Same when the cursor is at the origin: "stale": false }, { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/main.mli", "start": { "line": 2, - "col": 5 + "col": 8 }, "end": { "line": 2, - "col": 6 + "col": 9 }, "stale": false }, { "file": "$TESTCASE_ROOT/main.ml", "start": { - "line": 3, - "col": 8 + "line": 2, + "col": 5 }, "end": { - "line": 3, - "col": 9 + "line": 2, + "col": 6 }, "stale": false }, { - "file": "$TESTCASE_ROOT/main.mli", + "file": "$TESTCASE_ROOT/main.ml", "start": { - "line": 2, + "line": 3, "col": 8 }, "end": { - "line": 2, + "line": 3, "col": 9 }, "stale": false diff --git a/tests/test-dirs/occurrences/project-wide/prefix.t/run.t b/tests/test-dirs/occurrences/project-wide/prefix.t/run.t index a01b2988c9..138fd05477 100644 --- a/tests/test-dirs/occurrences/project-wide/prefix.t/run.t +++ b/tests/test-dirs/occurrences/project-wide/prefix.t/run.t @@ -99,38 +99,38 @@ Merlin successfully finds occurrences outside file when UNIT_NAME directive is u "stale": false }, { - "file": "$TESTCASE_ROOT/a.ml", + "file": "$TESTCASE_ROOT/b.ml", "start": { - "line": 1, - "col": 12 + "line": 2, + "col": 8 }, "end": { - "line": 1, - "col": 13 + "line": 2, + "col": 9 }, "stale": false }, { "file": "$TESTCASE_ROOT/a.ml", "start": { - "line": 2, - "col": 18 + "line": 1, + "col": 12 }, "end": { - "line": 2, - "col": 19 + "line": 1, + "col": 13 }, "stale": false }, { - "file": "$TESTCASE_ROOT/b.ml", + "file": "$TESTCASE_ROOT/a.ml", "start": { "line": 2, - "col": 8 + "col": 18 }, "end": { "line": 2, - "col": 9 + "col": 19 }, "stale": false } @@ -162,38 +162,38 @@ Merlin successfully finds occurrences outside file when WRAPPING_PREFIX directiv "stale": false }, { - "file": "$TESTCASE_ROOT/a.ml", + "file": "$TESTCASE_ROOT/b.ml", "start": { - "line": 1, - "col": 12 + "line": 2, + "col": 8 }, "end": { - "line": 1, - "col": 13 + "line": 2, + "col": 9 }, "stale": false }, { "file": "$TESTCASE_ROOT/a.ml", "start": { - "line": 2, - "col": 18 + "line": 1, + "col": 12 }, "end": { - "line": 2, - "col": 19 + "line": 1, + "col": 13 }, "stale": false }, { - "file": "$TESTCASE_ROOT/b.ml", + "file": "$TESTCASE_ROOT/a.ml", "start": { "line": 2, - "col": 8 + "col": 18 }, "end": { "line": 2, - "col": 9 + "col": 19 }, "stale": false } diff --git a/tests/test-dirs/occurrences/project-wide/pwo-basic.t b/tests/test-dirs/occurrences/project-wide/pwo-basic.t index f0d234181f..3b58a1c65f 100644 --- a/tests/test-dirs/occurrences/project-wide/pwo-basic.t +++ b/tests/test-dirs/occurrences/project-wide/pwo-basic.t @@ -29,38 +29,38 @@ "class": "return", "value": [ { - "file": "$TESTCASE_ROOT/lib.ml", + "file": "$TESTCASE_ROOT/main.ml", "start": { "line": 1, - "col": 4 + "col": 26 }, "end": { "line": 1, - "col": 7 + "col": 29 }, "stale": false }, { "file": "$TESTCASE_ROOT/lib.ml", "start": { - "line": 2, - "col": 22 + "line": 1, + "col": 4 }, "end": { - "line": 2, - "col": 25 + "line": 1, + "col": 7 }, "stale": false }, { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/lib.ml", "start": { - "line": 1, - "col": 26 + "line": 2, + "col": 22 }, "end": { - "line": 1, - "col": 29 + "line": 2, + "col": 25 }, "stale": false } diff --git a/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t b/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t index 3684710fd6..cd7ee00804 100644 --- a/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t +++ b/tests/test-dirs/occurrences/project-wide/pwo-canonicalize.t @@ -31,26 +31,26 @@ "stale": false }, { - "file": "$TESTCASE_ROOT/lib.ml", + "file": "$TESTCASE_ROOT/main.ml", "start": { - "line": 2, - "col": 22 + "line": 1, + "col": 26 }, "end": { - "line": 2, - "col": 25 + "line": 1, + "col": 29 }, "stale": false }, { - "file": "$TESTCASE_ROOT/main.ml", + "file": "$TESTCASE_ROOT/lib.ml", "start": { - "line": 1, - "col": 26 + "line": 2, + "col": 22 }, "end": { - "line": 1, - "col": 29 + "line": 2, + "col": 25 }, "stale": false } diff --git a/tests/test-dirs/occurrences/project-wide/pwo-ml-gen.t b/tests/test-dirs/occurrences/project-wide/pwo-ml-gen.t index b1c7a824e4..2b81b77096 100644 --- a/tests/test-dirs/occurrences/project-wide/pwo-ml-gen.t +++ b/tests/test-dirs/occurrences/project-wide/pwo-ml-gen.t @@ -57,6 +57,6 @@ We should not index generated modules (lib.ml-gen) $ $MERLIN single occurrences -scope project -identifier-at 3:23 \ > -filename main.ml -index-file project.ocaml-index \ > -filename main.ml < main.ml | jq .value [ - { - "file": "$TESTCASE_ROOT/lib.ml", - "start": { - "line": 2, - "col": 4 - }, - "end": { - "line": 2, - "col": 7 - }, - "stale": true - }, { "file": "$TESTCASE_ROOT/main.ml", "start": { @@ -43,5 +31,17 @@ Foo was defined on line 2 when the index was built, but is now defined on line 1 "col": 29 }, "stale": false + }, + { + "file": "$TESTCASE_ROOT/lib.ml", + "start": { + "line": 2, + "col": 4 + }, + "end": { + "line": 2, + "col": 7 + }, + "stale": true } ] From 807b036b52e49dcead6cfa049e4d9f60abc08562 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 16 Apr 2025 16:52:12 -0400 Subject: [PATCH 26/31] Fix compat check --- .github/workflows/ocaml-lsp-compat.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ocaml-lsp-compat.yml b/.github/workflows/ocaml-lsp-compat.yml index 440e03e72b..ddb6690747 100644 --- a/.github/workflows/ocaml-lsp-compat.yml +++ b/.github/workflows/ocaml-lsp-compat.yml @@ -51,6 +51,6 @@ jobs: - name: Check that Merlin and OCaml-LSP are co-installable run: | - opam --cli=2.1 pin --with-version=dev --no-action https://github.com/liam923/ocaml-lsp.git#stale-occurrences + opam --cli=2.1 pin --with-version=dev --no-action https://github.com/liam923/ocaml-lsp.git opam --cli=2.1 pin --with-version=5.4-503 --no-action . opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat From eb9531a32e9a8736abefccf92408f1a2a118b4cf Mon Sep 17 00:00:00 2001 From: Ulysse <5031221+voodoos@users.noreply.github.com> Date: Wed, 16 Apr 2025 17:19:08 -0400 Subject: [PATCH 27/31] Update ocaml-lsp-compat.yml --- .github/workflows/ocaml-lsp-compat.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ocaml-lsp-compat.yml b/.github/workflows/ocaml-lsp-compat.yml index ddb6690747..8def1b2091 100644 --- a/.github/workflows/ocaml-lsp-compat.yml +++ b/.github/workflows/ocaml-lsp-compat.yml @@ -51,6 +51,6 @@ jobs: - name: Check that Merlin and OCaml-LSP are co-installable run: | - opam --cli=2.1 pin --with-version=dev --no-action https://github.com/liam923/ocaml-lsp.git + opam --cli=2.1 pin --with-version=dev --no-action https://github.com/ocaml/ocaml-lsp.git opam --cli=2.1 pin --with-version=5.4-503 --no-action . opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat From 67b93735197b8c56d038c6edef94c9e12f7f08ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 28 Apr 2025 13:44:31 +0200 Subject: [PATCH 28/31] Add a test illustrating issue #1523 --- tests/test-dirs/signature-help/issue1523.t | 54 ++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 tests/test-dirs/signature-help/issue1523.t diff --git a/tests/test-dirs/signature-help/issue1523.t b/tests/test-dirs/signature-help/issue1523.t new file mode 100644 index 0000000000..955a9ef6ba --- /dev/null +++ b/tests/test-dirs/signature-help/issue1523.t @@ -0,0 +1,54 @@ + $ cat >test.ml <<'EOF' + > module M : sig + > val f : int -> unit + > end = struct + > let f (_ : int) = () + > end + > + > let () = M.f (* keep whitespace *) + > EOF + + $ $MERLIN single signature-help -position 7:13 -filename test unit", + "parameters": [ + { + "label": [ + 6, + 9 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +FIXME: Signature help does not appear for M.f: + + $ cat >test.ml <<'EOF' + > + > type t = int -> unit + > + > module M : sig + > val f : t + > end = struct + > let f (_ : int) = () + > end + > + > let () = M.f (* keep whitespace *) + > EOF + + $ $MERLIN single signature-help -position 7:13 -filename test Date: Mon, 28 Apr 2025 13:46:35 +0200 Subject: [PATCH 29/31] Use merlin issue number --- tests/test-dirs/signature-help/{issue1523.t => issue1927.t} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename tests/test-dirs/signature-help/{issue1523.t => issue1927.t} (100%) diff --git a/tests/test-dirs/signature-help/issue1523.t b/tests/test-dirs/signature-help/issue1927.t similarity index 100% rename from tests/test-dirs/signature-help/issue1523.t rename to tests/test-dirs/signature-help/issue1927.t From 417621c1d439b0edfb2f5fe5df10097c553eb393 Mon Sep 17 00:00:00 2001 From: Carine Morel Date: Tue, 11 Mar 2025 17:05:50 +0100 Subject: [PATCH 30/31] Moving computation of pipeline in new_commands.ml. Add a lot of TODO. --- src/commands/new_commands.ml | 4 ++-- src/utils/shared.mli | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index dc2caaac0b..08e39614f5 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -569,8 +569,6 @@ let all_commands = fun shared config source -> function | `None, _ -> failwith "-identifier-at is mandatory" | `Ident_at pos, scope -> - (* TODO: Guess we have to typecheck everything - to get every occurence? *) run shared config source (Query_protocol.Occurrences (`Ident_at pos, scope)) end; @@ -893,6 +891,7 @@ let all_commands = in Some (expr, cursor) in + let position = Msource.get_position source pos in run ~position shared config source (Query_protocol.Type_enclosing (expr, pos, index)) @@ -973,6 +972,7 @@ let all_commands = active_signature_help = None } in + let position = Msource.get_position source position in run ~position shared config source (Query_protocol.Signature_help sh) diff --git a/src/utils/shared.mli b/src/utils/shared.mli index 5945a208f9..b2aa9bfcd3 100644 --- a/src/utils/shared.mli +++ b/src/utils/shared.mli @@ -7,5 +7,3 @@ val create : 'a -> 'a t val protect : 'a t -> (unit -> 'b) -> 'b val signal : 'a t -> unit val wait : 'a t -> unit -val lock : 'a t -> unit -val unlock : 'a t -> unit From c544360aa8c5cfbaa3e117886d8e0647f9069ab1 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 2 Apr 2025 05:41:24 +0200 Subject: [PATCH 31/31] Adapt new_commands to pass (sometime) interuption position --- src/commands/new_commands.ml | 7 +++---- src/utils/shared.mli | 2 ++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 08e39614f5..0b2d288efa 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -477,8 +477,7 @@ let all_commands = match pos with | `None -> failwith "-position is mandatory" | #Msource.position as pos -> - (* FIXME: Breaks test motion/phrase.t - *) + (* FIXME: Breaks test motion/phrase.t *) (* let position = Msource.get_position source pos in *) run (* ~position *) shared config source (Query_protocol.Phrase (target, pos)) @@ -569,6 +568,8 @@ let all_commands = fun shared config source -> function | `None, _ -> failwith "-identifier-at is mandatory" | `Ident_at pos, scope -> + (* TODO: Guess we have to typecheck everything + to get every occurence? *) run shared config source (Query_protocol.Occurrences (`Ident_at pos, scope)) end; @@ -891,7 +892,6 @@ let all_commands = in Some (expr, cursor) in - let position = Msource.get_position source pos in run ~position shared config source (Query_protocol.Type_enclosing (expr, pos, index)) @@ -972,7 +972,6 @@ let all_commands = active_signature_help = None } in - let position = Msource.get_position source position in run ~position shared config source (Query_protocol.Signature_help sh) diff --git a/src/utils/shared.mli b/src/utils/shared.mli index b2aa9bfcd3..5945a208f9 100644 --- a/src/utils/shared.mli +++ b/src/utils/shared.mli @@ -7,3 +7,5 @@ val create : 'a -> 'a t val protect : 'a t -> (unit -> 'b) -> 'b val signal : 'a t -> unit val wait : 'a t -> unit +val lock : 'a t -> unit +val unlock : 'a t -> unit