Add native polling mode support on Windows

CHANGES.md

@@ -139,6 +139,8 @@ Unreleased
 - Auto-detect `dune-workspace` files as `dune` files in Emacs (#7061,
   @ilankri)
 
+- Add native support for polling mode on Windows (#7010, @yams-yams, @nojb)
+
 3.6.2 (2022-12-21)
 ------------------
 

boot/libs.ml

@@ -48,6 +48,7 @@ let local_libraries =
   ; ("vendor/ocaml-inotify/src", Some "Ocaml_inotify", false, None)
   ; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", false,
     None)
+  ; ("src/fswatch_win", Some "Fswatch_win", false, None)
   ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None)
   ; ("src/dune_engine", Some "Dune_engine", false, None)
   ; ("src/dune_config", Some "Dune_config", false, None)

src/dune_file_watcher/dune

@@ -9,7 +9,8 @@
   threads.posix
   ocaml_inotify
   async_inotify_for_dune
-  dune_re)
+  dune_re
+  fswatch_win)
  (synopsis "Internal Dune library, do not use!")
  (instrumentation
   (backend bisect_ppx)))

src/dune_file_watcher/dune_file_watcher.ml

@@ -137,6 +137,10 @@ type kind =
       ; latency : float
       }
   | Inotify of Inotify_lib.t
+  | Fswatch_win of
+      { t : Fswatch_win.t
+      ; scheduler : Scheduler.t
+      }
 
 type t =
   { kind : kind
@@ -156,6 +160,9 @@ let exclude_patterns =
   ; {|/#[^#]*#$|}
   ; {|^4913$|} (* https://github.com/neovim/neovim/issues/3460 *)
   ; {|/4913$|}
+  ; {|/.git|}
+  ; {|/.hg|}
+  ; {|:/windows|}
   ]
 
 module Re = Dune_re
@@ -203,6 +210,7 @@ let shutdown t =
         Fsevents.stop fsevents.sync;
         Watch_trie.to_list fsevents.external_
         |> List.iter ~f:(fun (_, fs) -> Fsevents.stop fs))
+  | Fswatch_win { t; _ } -> `Thunk (fun () -> Fswatch_win.shutdown t)
 
 let buffer_capacity = 65536
 
@@ -354,6 +362,7 @@ let select_watcher_backend () =
     assert (Ocaml_inotify.Inotify.supported_by_the_os ());
     `Inotify_lib)
   else if Fsevents.available () then `Fsevents
+  else if Sys.win32 then `Fswatch_win
   else fswatch_backend ()
 
 let prepare_sync () =
@@ -582,6 +591,48 @@ let create_fsevents ?(latency = 0.2) ~(scheduler : Scheduler.t) () =
   ; sync_table
   }
 
+let fswatch_win_callback ~(scheduler : Scheduler.t) ~sync_table event =
+  let dir = Fswatch_win.Event.directory event in
+  let filename = Filename.concat dir (Fswatch_win.Event.path event) in
+  let localized_path =
+    Path.Expert.try_localize_external (Path.of_string filename)
+  in
+  match localized_path with
+  | In_build_dir _ -> (
+    if Fs_sync.is_special_file_fsevents localized_path then
+      match Fswatch_win.Event.action event with
+      | Added | Modified -> (
+        match Fs_sync.consume_event sync_table filename with
+        | None -> ()
+        | Some id ->
+          scheduler.thread_safe_send_emit_events_job (fun () -> [ Sync id ]))
+      | Removed | Renamed_new | Renamed_old -> ())
+  | path ->
+    let normalized_filename =
+      String.concat ~sep:"/"
+        (String.split_on_char ~sep:'\\' (String.lowercase_ascii filename))
+    in
+    if not (should_exclude normalized_filename) then
+      scheduler.thread_safe_send_emit_events_job (fun () ->
+          let kind =
+            match Fswatch_win.Event.action event with
+            | Added | Renamed_new -> Fs_memo_event.Created
+            | Removed | Renamed_old -> Deleted
+            | Modified -> File_changed
+          in
+          [ Fs_memo_event { kind; path } ])
+
+let create_fswatch_win ~(scheduler : Scheduler.t) ~debounce_interval:sleep =
+  let sync_table = Table.create (module String) 64 in
+  let t = Fswatch_win.create () in
+  Fswatch_win.add t (Path.to_absolute_filename Path.root);
+  scheduler.spawn_thread (fun () ->
+      while true do
+        let events = Fswatch_win.wait t ~sleep in
+        List.iter ~f:(fswatch_win_callback ~scheduler ~sync_table) events
+      done);
+  { kind = Fswatch_win { t; scheduler }; sync_table }
+
 let create_external ~root ~debounce_interval ~scheduler ~backend =
   match debounce_interval with
   | None -> create_no_buffering ~root ~scheduler ~backend
@@ -597,15 +648,31 @@ let create_default ?fsevents_debounce ~scheduler () =
       ~debounce_interval:(Some 0.5 (* seconds *)) ~backend
   | `Fsevents -> create_fsevents ?latency:fsevents_debounce ~scheduler ()
   | `Inotify_lib -> create_inotifylib ~scheduler
+  | `Fswatch_win ->
+    create_fswatch_win ~scheduler ~debounce_interval:500 (* milliseconds *)
 
 let wait_for_initial_watches_established_blocking t =
   match t.kind with
   | Fswatch c -> c.wait_for_watches_established ()
-  | Fsevents _ | Inotify _ ->
+  | Fsevents _ | Inotify _ | Fswatch_win _ ->
     (* no initial watches needed: all watches should be set up at the time just
        before file access *)
     ()
 
+(* Return the parent directory of [ext] if [ext] denotes a file. *)
+let parent_directory ext =
+  let rec loop p =
+    if Path.is_directory (Path.external_ p) then Some ext
+    else
+      match Path.External.parent p with
+      | None ->
+        User_warning.emit
+          [ Pp.textf "Refusing to watch %s" (Path.External.to_string ext) ];
+        None
+      | Some ext -> loop ext
+  in
+  loop ext
+
 let add_watch t path =
   match t.kind with
   | Fsevents f -> (
@@ -614,21 +681,7 @@ let add_watch t path =
     | In_build_dir _ ->
       Code_error.raise "attempted to watch a directory in build" []
     | External ext -> (
-      let ext =
-        let rec loop p =
-          if Path.is_directory (Path.external_ p) then Some ext
-          else
-            match Path.External.parent p with
-            | None ->
-              User_warning.emit
-                [ Pp.textf "Refusing to watch %s" (Path.External.to_string ext)
-                ];
-              None
-            | Some ext -> loop ext
-        in
-        loop ext
-      in
-      match ext with
+      match parent_directory ext with
       | None -> Ok ()
       | Some ext -> (
         let watch =
@@ -652,5 +705,16 @@ let add_watch t path =
   | Inotify inotify -> (
     try Ok (Inotify_lib.add inotify (Path.to_string path))
     with Unix.Unix_error (ENOENT, _, _) -> Error `Does_not_exist)
+  | Fswatch_win fswatch -> (
+    match path with
+    | In_build_dir _ ->
+      Code_error.raise "attempted to watch a directory in build" []
+    | Path.In_source_tree _ -> Ok ()
+    | External ext -> (
+      match parent_directory ext with
+      | None -> Ok ()
+      | Some _ ->
+        Fswatch_win.add fswatch.t (Path.to_absolute_filename path);
+        Ok ()))
 
 let emit_sync = Fs_sync.emit

src/fswatch_win/bin/dune

@@ -0,0 +1,5 @@
+;; A little binary to test out Windows file watcher library
+
+(executable
+ (name dune_fswatch_win)
+ (libraries fswatch_win stdune dyn))

src/fswatch_win/bin/dune_fswatch_win.ml

@@ -0,0 +1,17 @@
+open! Stdune
+
+let paths =
+  let paths = ref [] in
+  let anon p = paths := p :: !paths in
+  Arg.parse [] anon "dune_fswatch_win [path]+";
+  List.rev !paths
+
+let () =
+  let t = Fswatch_win.create () in
+  List.iter ~f:(Fswatch_win.add t) paths;
+  let f event =
+    Printf.printf "%s\n%!" (Dyn.to_string (Fswatch_win.Event.to_dyn event))
+  in
+  while true do
+    List.iter ~f (Fswatch_win.wait t ~sleep:500)
+  done

src/fswatch_win/dune

@@ -0,0 +1,6 @@
+(library
+ (name fswatch_win)
+ (libraries stdune dune_util)
+ (foreign_stubs
+  (language c)
+  (names fswatch_win_stubs)))

src/fswatch_win/fswatch_win.ml

@@ -0,0 +1,53 @@
+module Event = struct
+  type action =
+    | Added
+    | Removed
+    | Modified
+    | Renamed_old
+    | Renamed_new
+
+  type t =
+    { directory : string
+    ; path : string
+    ; action : action
+    }
+
+  let directory t = t.directory
+
+  let path t = t.path
+
+  let action t = t.action
+
+  let dyn_of_action = function
+    | Added -> Dyn.variant "Added" []
+    | Removed -> Dyn.variant "Removed" []
+    | Modified -> Dyn.variant "Modified" []
+    | Renamed_old -> Dyn.variant "Renamed_old" []
+    | Renamed_new -> Dyn.variant "Renamed_new" []
+
+  let to_dyn t =
+    Dyn.record
+      [ ("directory", Dyn.string t.directory)
+      ; ("path", Dyn.String t.path)
+      ; ("action", dyn_of_action t.action)
+      ]
+end
+
+type t
+
+external create : unit -> t = "fswatch_win_create"
+
+external wait : t -> sleep:int -> Event.t list = "fswatch_win_wait"
+
+external add : t -> string -> unit = "fswatch_win_add"
+
+let wait t ~sleep =
+  List.filter
+    (function
+      | { Event.action = Modified; path; directory } -> (
+        try not (Sys.is_directory (Filename.concat directory path))
+        with Sys_error _ -> true)
+      | _ -> true)
+    (wait t ~sleep)
+
+external shutdown : t -> unit = "fswatch_win_shutdown"

src/fswatch_win/fswatch_win.mli

@@ -0,0 +1,52 @@
+(** File-watching support under Windows *)
+
+module Event : sig
+  (** The type of events *)
+  type action =
+    | Added  (** The file was added. *)
+    | Removed  (** The file was removed. *)
+    | Modified  (** The file was modified. *)
+    | Renamed_old
+        (** The file was renamed. This corresponds to the old name. *)
+    | Renamed_new
+        (** The file was renamed. This corresponds to the new name. *)
+
+  type t
+
+  (** The directory being watched. *)
+  val directory : t -> string
+
+  (** The path to the file relevant to the event. Relative to the directory
+      being watched (see {!directory}). *)
+  val path : t -> string
+
+  (** The description of the event action. *)
+  val action : t -> action
+
+  (** For debugging. *)
+  val to_dyn : t -> Dyn.t
+end
+
+(** The type of file watchers. Each file watcher can watch an arbitrary
+    collection of directories. Multiple file watchers can be used
+    simultaneously, if needed. *)
+type t
+
+(** Create a file watcher. This creates a native thread that will monitor for
+    changes in the background. *)
+val create : unit -> t
+
+(** Start watching a directory for changes. The watching is recursive: all
+    subdirectories are watched as well. Watching a single file is not possible. *)
+val add : t -> string -> unit
+
+(** Wait for events. This function will block until it receives some file change
+    notifications. After it receives a notification, it will wait for [sleep]
+    milliseconds before retrieving them and returning them to the user. This is
+    done to avoid triggering multiple rebuilds in close succession. *)
+val wait : t -> sleep:int -> Event.t list
+
+(** Shutdown the file watcher. This tears down the background thread and frees
+    all allocated resources. It is an error to call [add] or [wait] after this
+    function returns. *)
+val shutdown : t -> unit