fix(fsevents): deduplicate fsevents watches

Since all watches are recursive, we need a special trie to do this
easily

Signed-off-by: Rudi Grinberg <[email protected]>

Author: rgrinberg

src/dune_file_watcher/dune_file_watcher.ml

@@ -65,13 +65,87 @@ module Scheduler = struct
     }
 end
 
+module Watch_trie : sig
+  (** Specialized trie for fsevent watches *)
+  type 'a t
+
+  val empty : 'a t
+
+  val to_list : 'a t -> (Path.External.t * 'a) list
+
+  type 'a add =
+    | Under_existing_node
+    | Inserted of
+        { new_t : 'a t
+        ; removed : (Path.External.t * 'a) list
+        }
+
+  val add : 'a t -> Path.External.t -> 'a Lazy.t -> 'a add
+end = struct
+  (* the invariant is that a node can contain either a value or branches, but
+     not both *)
+  type 'a t =
+    | Leaf of Path.External.t * 'a
+    | Branch of 'a t String.Map.t
+
+  type 'a add =
+    | Under_existing_node
+    | Inserted of
+        { new_t : 'a t
+        ; removed : (Path.External.t * 'a) list
+        }
+
+  let empty = Branch String.Map.empty
+
+  let to_list t =
+    let rec loop t acc =
+      match t with
+      | Leaf (k, v) -> (k, v) :: acc
+      | Branch m -> String.Map.fold m ~init:acc ~f:loop
+    in
+    loop t []
+
+  let rec path p a = function
+    | [] -> Leaf (p, a)
+    | x :: xs -> Branch (String.Map.singleton x (path p a xs))
+
+  let add t key v =
+    (* wrong in general, but this is only needed for fsevents *)
+    let comps =
+      match String.split ~on:'/' (Path.External.to_string key) with
+      | "" :: comps -> comps
+      | _ ->
+        (* fsevents gives us only absolute paths *)
+        assert false
+    in
+    let rec add comps t =
+      match (comps, t) with
+      | _, Leaf (_, _) -> Under_existing_node
+      | [], Branch _ ->
+        Inserted { new_t = Leaf (key, Lazy.force v); removed = to_list t }
+      | x :: xs, Branch m -> (
+        match String.Map.find m x with
+        | None ->
+          Inserted
+            { new_t = Branch (String.Map.set m x (path key (Lazy.force v) xs))
+            ; removed = []
+            }
+        | Some m' -> (
+          match add xs m' with
+          | Under_existing_node -> Under_existing_node
+          | Inserted i ->
+            Inserted { i with new_t = Branch (String.Map.set m x i.new_t) }))
+    in
+    add comps t
+end
+
 type kind =
   | Fswatch of
       { pid : Pid.t
       ; wait_for_watches_established : unit -> unit
       }
   | Fsevents of
-      { mutable external_ : Fsevents.t Path.External.Map.t
+      { mutable external_ : Fsevents.t Watch_trie.t
       ; runloop : Fsevents.RunLoop.t
       ; scheduler : Scheduler.t
       ; source : Fsevents.t
@@ -179,7 +253,8 @@ let shutdown t =
       (fun () ->
         Fsevents.stop fsevents.source;
         Fsevents.stop fsevents.sync;
-        Path.External.Map.iter fsevents.external_ ~f:Fsevents.stop;
+        Watch_trie.to_list fsevents.external_
+        |> List.iter ~f:(fun (_, fs) -> Fsevents.stop fs);
         Fsevents.RunLoop.stop fsevents.runloop)
 
 let buffer_capacity = 65536
@@ -522,7 +597,7 @@ let create_fsevents ~(scheduler : Scheduler.t) =
       | Ok () -> ()
       | Error exn ->
         Code_error.raise "fsevents callback raised" [ ("exn", Exn.to_dyn exn) ]);
-  let external_ = Path.External.Map.empty in
+  let external_ = Watch_trie.empty in
   let runloop =
     Mutex.lock mutex;
     while !runloop_ref = None do
@@ -567,17 +642,19 @@ let add_watch t path =
     | Path.In_source_tree _ -> (* already watched by source watcher *) ()
     | In_build_dir _ ->
       Code_error.raise "attempted to watch a directory in build" []
-    | External ext ->
-      f.external_ <-
-        Path.External.Map.update f.external_ ext ~f:(function
-          | Some _ as s -> s
-          | None ->
-            let watch =
-              fsevents f.scheduler ~paths:[ path ]
-                (fsevents_standard_event ~ignored_files:t.ignored_files)
-            in
-            Fsevents.start watch f.runloop;
-            Some watch));
+    | External ext -> (
+      let watch =
+        lazy
+          (fsevents f.scheduler ~paths:[ path ]
+             (fsevents_standard_event ~ignored_files:t.ignored_files))
+      in
+      match Watch_trie.add f.external_ ext watch with
+      | Watch_trie.Under_existing_node -> ()
+      | Inserted { new_t; removed } ->
+        let watch = Lazy.force watch in
+        Fsevents.start watch f.runloop;
+        List.iter removed ~f:(fun (_, fs) -> Fsevents.stop fs);
+        f.external_ <- new_t));
     Ok ()
   | Fswatch _ ->
     (* Here we assume that the path is already being watched because the coarse