Domains

src/analysis/index_occurrences.ml

@@ -87,7 +87,7 @@ let items ~index ~stamp (config : Mconfig.t) items =
         None
   end) in
   let current_buffer_path =
-    Filename.concat config.query.directory config.query.filename
+    Filename.concat config.query.directory (Mconfig.query_filename config.query)
   in
   let reduce_for_uid = Shape_reduce.reduce_for_uid in
   let iterator = iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid in

src/analysis/locate.ml

@@ -251,8 +251,8 @@ module Utils = struct
     List.dedup_adjacent files ~cmp:String.compare
 
   let find_file_with_path ~config ?(with_fallback = false) file path =
-    if File.name file = Misc.unitname Mconfig.(config.query.filename) then
-      Some Mconfig.(config.query.filename)
+    if File.name file = Misc.unitname Mconfig.(query_filename config.query) then
+      Mconfig.(config.query.filename)
     else
       let attempt_search src_suffix_pair =
         let fallback =

src/analysis/occurrences.ml

@@ -175,7 +175,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
       (None, `Buffer)
   in
   let current_buffer_path =
-    Filename.concat config.query.directory config.query.filename
+    Filename.concat config.query.directory (Mconfig.query_filename config.query)
   in
   match def with
   | Some (def_uid, def_loc) ->
@@ -208,7 +208,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
                         match config.merlin.source_root with
                         | Some root ->
                           (Filename.concat root file, current_buffer_path)
-                        | None -> (file, config.query.filename)
+                        | None -> (file, Mconfig.query_filename config.query)
                       in
                       let file = Misc.canonicalize_filename file in
                       let buf = Misc.canonicalize_filename buf in

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 ~get_pipeline =
   let query_num = ref (-1) in
   function
   | [] ->
@@ -110,12 +110,18 @@ let run =
             ();
           File_id.with_cache @@ fun () ->
           let source = Msource.make (Misc.string_of_file stdin) in
-          let pipeline = Mpipeline.make config source in
+          let file = config.Mconfig.query.filename in
+          let pipeline =
+            match get_pipeline file config source with
+            | None -> failwith "Why on earth is the pipeline domain down?"
+            | Some p -> p
+          in
           let json =
             let class_, message =
               Printexc.record_backtrace true;
               match
-                Mpipeline.with_pipeline pipeline @@ fun () ->
+                (* No with_pipeline needed here anymore: with_pipeline makes sure the typer and reader states are locked. We do that now on Pipeline.make instead*)
+                (* Mpipeline.with_pipeline pipeline @@ fun () -> *)
                 command_action pipeline command_args
               with
               | result -> ("return", result)
@@ -186,7 +192,7 @@ let with_wd ~wd ~old_wd f args =
       old_wd;
     f args
 
-let run ~new_env wd args =
+let run ~get_pipeline ~new_env wd args =
   begin
     match new_env with
     | Some env ->
@@ -197,10 +203,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 ~get_pipeline) args
     | None ->
       log ~title:"run" "No working directory specified (old wd: %S)" old_wd;
-      run args
+      run ~get_pipeline args
   in
   let `Log_file_path log_file, `Log_sections sections = Log_info.get () in
   Logger.with_log_file log_file ~sections @@ run args

src/frontend/ocamlmerlin/ocamlmerlin_server.ml

@@ -2,19 +2,20 @@ 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 ~get_pipeline { Os_ipc.wd; environ; argv; context = _ } =
     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 ~get_pipeline ~new_env:(Some environ) (Some wd) args
 
-  let process_client client =
+  let process_client ~get_pipeline client =
     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 ~get_pipeline client with
     | code -> close_with code
     | exception Exit ->
       close_with (-1);
@@ -38,36 +39,39 @@ module Server = struct
     | Some _ as result -> result
     | None -> loop 1.0
 
-  let rec loop merlinid server =
+  let rec loop merlinid server ~get_pipeline =
     match server_accept merlinid server with
     | None ->
       (* Timeout *)
       ()
     | Some client ->
       let continue =
-        match process_client client with
+        match process_client ~get_pipeline client with
         | exception Exit -> false
         | () -> true
       in
-      if continue then loop merlinid server
-
-  let start socket_path socket_fd =
-    match Os_ipc.server_setup socket_path socket_fd with
-    | None -> Logger.log ~section:"server" ~title:"cannot setup listener" ""
-    | 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;
-      Os_ipc.server_close server
+      if continue then loop merlinid server ~get_pipeline
 end
 
 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 get_pipeline _ a b = Some (Mpipeline.make a b) in
+    exit (New_merlin.run ~get_pipeline ~new_env:None None args)
   | "old-protocol" :: args -> Old_merlin.run args
-  | [ "server"; socket_path; socket_fd ] -> Server.start socket_path socket_fd
+  | [ "server"; socket_path; socket_fd ] -> begin
+    match Os_ipc.server_setup socket_path socket_fd with
+    | None -> Logger.log ~section:"server" ~title:"cannot setup listener" ""
+    | 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;
+      ignore
+      @@ Mpipeline.make_with_cache
+           (Server.loop (File_id.get Sys.executable_name) server);
+      Os_ipc.server_close server
+  end
   | ("-help" | "--help" | "-h" | "server") :: _ ->
     Printf.eprintf
       "Usage: %s <frontend> <arguments...>\n\

src/frontend/ocamlmerlin/old/old_command.ml

@@ -90,7 +90,7 @@ let configure (state : buffer) =
         | None -> config.Mconfig.query
         | Some path ->
           { config.Mconfig.query with
-            Mconfig.filename = Filename.basename path;
+            Mconfig.filename = Some (Filename.basename path);
             directory = Misc.canonicalize_filename (Filename.dirname path)
           })
     }
@@ -249,7 +249,7 @@ let dispatch (type a) (context : Context.t) (cmd : a command) : a =
   match cmd with
   | Query q ->
     let pipeline = make_pipeline config state.buffer in
-    Mpipeline.with_pipeline pipeline @@ fun () ->
+    (* Mpipeline.with_pipeline pipeline @@ fun () -> *)
     Query_commands.dispatch pipeline q
   | Sync (Checkout context) when state == Lazy.force default_state ->
     let buffer = checkout_buffer context in

src/kernel/mconfig.ml

@@ -165,15 +165,19 @@ module Verbosity = struct
 end
 
 type query =
-  { filename : string;
+  { filename : string option;
     directory : string;
     printer_width : int;
     verbosity : Verbosity.t
   }
 
+let query_filename q =
+  match q.filename with
+  | None -> "*buffer*"
+  | Some filename -> filename
 let dump_query x =
   `Assoc
-    [ ("filename", `String x.filename);
+    [ ("filename", `String (query_filename x));
       ("directory", `String x.directory);
       ("printer_width", `Int x.printer_width);
       ("verbosity", Verbosity.to_json x.verbosity)
@@ -683,7 +687,7 @@ let initial =
         cache_lifespan = 5
       };
     query =
-      { filename = "*buffer*";
+      { filename = None;
         directory = Sys.getcwd ();
         verbosity = Verbosity.default;
         printer_width = 0
@@ -699,7 +703,7 @@ let global_flags =
       marg_path (fun path t ->
           let query = t.query in
           let path = Misc.canonicalize_filename path in
-          let filename = Filename.basename path in
+          let filename = Some (Filename.basename path) in
           let directory = Filename.dirname path in
           let t = { t with query = { query with filename; directory } } in
           Logger.with_log_file t.merlin.log_file ~sections:t.merlin.log_sections
@@ -811,21 +815,22 @@ let cmt_path config =
 
 let global_modules ?(include_current = false) config =
   let modules = Misc.modules_in_path ~ext:".cmi" (build_path config) in
+  (* TODO: What's the deal here? Shouldn't it check for "*buffer*" instead of ""? In that case, match on the option *)
   if include_current then modules
   else
-    match config.query.filename with
+    match query_filename config.query with
     | "" -> modules
     | filename -> List.remove (Misc.unitname filename) modules
 
 (** {1 Accessors for other information} *)
 
-let filename t = t.query.filename
+let filename t = query_filename t.query
 
 let unitname t =
   match t.merlin.unit_name with
   | Some name -> Misc.unitname name
   | None ->
-    let basename = Misc.unitname t.query.filename in
+    let basename = Misc.unitname @@ filename t in
     begin
       match t.merlin.wrapping_prefix with
       | Some prefix -> prefix ^ basename

src/kernel/mconfig.mli

@@ -72,12 +72,14 @@ module Verbosity : sig
 end
 
 type query =
-  { filename : string;
+  { filename : string option;
     directory : string;
     printer_width : int;
     verbosity : Verbosity.t
   }
 
+val query_filename : query -> string
+
 (** {1 Main configuration} *)
 
 type t = { ocaml : ocaml; merlin : merlin; query : query }

src/kernel/mocaml.ml

@@ -36,7 +36,7 @@ let setup_reader_config config =
   let open Clflags in
   let ocaml = config.ocaml in
   Env.set_unit_name (Mconfig.unitname config);
-  Location.input_name := config.query.filename;
+  Location.input_name := query_filename config.query;
   fast := ocaml.unsafe;
   classic := ocaml.classic;
   principal := ocaml.principal;