Add native fsevents library

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

src/fsevents/bin/dune

@@ -0,0 +1,5 @@
+;; a little binary to test out our fsevents bindings
+
+(executable
+ (name dune_fsevents)
+ (libraries threads.posix dyn fsevents))

src/fsevents/bin/dune_fsevents.ml

@@ -0,0 +1,15 @@
+let paths, latency =
+  let latency = ref 0. in
+  let paths = ref [] in
+  let anon p = paths := p :: !paths in
+  Arg.parse
+    [ ("--latency", Arg.Set_float latency, "latency") ]
+    anon "dune_fsevents [--latency float] [path]+";
+  (!paths, !latency)
+
+let fsevents =
+  Fsevents.create ~paths ~latency ~f:(fun _ events ->
+      ListLabels.iter events ~f:(fun evt ->
+          Printf.printf "%s\n%!" (Dyn.to_string (Fsevents.Event.to_dyn_raw evt))))
+
+let () = Fsevents.start fsevents

src/fsevents/dune

@@ -0,0 +1,9 @@
+(library
+ (name fsevents)
+ (synopsis "minimal bindings for fsvents on macos")
+ (library_flags
+  (:include flags/sexp))
+ (foreign_stubs
+  (language c)
+  (names fsevents_stubs))
+ (libraries dyn stdune))

src/fsevents/flags/dune

@@ -0,0 +1,10 @@
+(executable
+ (name gen_flags))
+
+(rule
+ (deps
+  (:script gen_flags.ml))
+ (action
+  (with-stdout-to
+   sexp
+   (run ./gen_flags.exe %{system}))))

src/fsevents/flags/gen_flags.ml

@@ -0,0 +1,6 @@
+let () =
+  if Sys.argv.(1) = "macosx" then
+    Printf.printf
+      {|(-cclib "-framework Foundation" -cclib "-framework CoreServices")|}
+  else
+    print_string "()"

src/fsevents/fsevents.ml

@@ -0,0 +1,197 @@
+open Stdune
+
+module Event = struct
+  module Id = struct
+    type t
+  end
+
+  type t =
+    { path : string
+    ; id : Id.t
+    ; flags : Int32.t
+    }
+
+  module Raw = struct
+    type t =
+      { must_scan_subdirs : bool
+      ; user_dropped : bool
+      ; kernel_dropped : bool
+      ; event_ids_wrapped : bool
+      ; history_done : bool
+      ; root_changed : bool
+      ; mount : bool
+      ; unmount : bool
+      ; item_created : bool
+      ; item_removed : bool
+      ; item_inode_meta_mod : bool
+      ; item_renamed : bool
+      ; item_modified : bool
+      ; item_finder_info_mod : bool
+      ; item_change_owner : bool
+      ; item_xattr_mod : bool
+      ; item_is_file : bool
+      ; item_is_dir : bool
+      ; item_is_symlink : bool
+      ; own_event : bool
+      ; item_is_hardlink : bool
+      ; item_is_last_hardlink : bool
+      ; item_cloned : bool
+      }
+
+    let to_dyn
+        { must_scan_subdirs
+        ; user_dropped
+        ; kernel_dropped
+        ; event_ids_wrapped
+        ; history_done
+        ; root_changed
+        ; mount
+        ; unmount
+        ; own_event
+        ; item_created
+        ; item_removed
+        ; item_inode_meta_mod
+        ; item_renamed
+        ; item_modified
+        ; item_finder_info_mod
+        ; item_change_owner
+        ; item_xattr_mod
+        ; item_is_file
+        ; item_is_dir
+        ; item_is_symlink
+        ; item_is_hardlink
+        ; item_is_last_hardlink
+        ; item_cloned
+        } =
+      let open Dyn.Encoder in
+      record
+        [ ("must_scan_subdirs", bool must_scan_subdirs)
+        ; ("user_dropped", bool user_dropped)
+        ; ("kernel_dropped", bool kernel_dropped)
+        ; ("event_ids_wrapped", bool event_ids_wrapped)
+        ; ("history_done", bool history_done)
+        ; ("root_changed", bool root_changed)
+        ; ("mount", bool mount)
+        ; ("unmount", bool unmount)
+        ; ("own_event", bool own_event)
+        ; ("item_created", bool item_created)
+        ; ("item_removed", bool item_removed)
+        ; ("item_inode_meta_mod", bool item_inode_meta_mod)
+        ; ("item_renamed", bool item_renamed)
+        ; ("item_modified", bool item_modified)
+        ; ("item_finder_info_mod", bool item_finder_info_mod)
+        ; ("item_change_owner", bool item_change_owner)
+        ; ("item_xattr_mod", bool item_xattr_mod)
+        ; ("item_is_file", bool item_is_file)
+        ; ("item_is_dir", bool item_is_dir)
+        ; ("item_is_symlink", bool item_is_symlink)
+        ; ("item_is_hardlink", bool item_is_hardlink)
+        ; ("item_is_last_hardlink", bool item_is_last_hardlink)
+        ; ("item_cloned", bool item_cloned)
+        ]
+  end
+
+  external raw : Int32.t -> Raw.t = "dune_fsevents_raw"
+
+  let to_dyn_raw t =
+    let open Dyn.Encoder in
+    record [ ("flags", Raw.to_dyn (raw t.flags)); ("path", string t.path) ]
+
+  let id t = t.id
+
+  let path t = t.path
+
+  type kind =
+    | Dir
+    | File
+    | Dir_and_descendants
+
+  let dyn_of_kind kind =
+    Dyn.Encoder.string
+      (match kind with
+      | Dir -> "Dir"
+      | File -> "File"
+      | Dir_and_descendants -> "Dir_and_descendants")
+
+  external kind : Int32.t -> kind = "dune_fsevents_kind"
+
+  let kind t = kind t.flags
+
+  type action =
+    | Unknown
+    | Create
+    | Remove
+    | Modify
+
+  external action : Int32.t -> action = "dune_fsevents_action"
+
+  let action t = action t.flags
+
+  let dyn_of_action a =
+    Dyn.Encoder.string
+      (match a with
+      | Create -> "Create"
+      | Remove -> "Remove"
+      | Modify -> "Modify"
+      | Unknown -> "Unknown")
+
+  let to_dyn t =
+    let open Dyn.Encoder in
+    record
+      [ ("action", dyn_of_action (action t))
+      ; ("kind", dyn_of_kind (kind t))
+      ; ("path", string t.path)
+      ]
+end
+
+type t
+
+external available : unit -> bool = "dune_fsevents_available"
+
+external stop : t -> unit = "dune_fsevents_stop"
+
+external start : t -> unit = "dune_fsevents_start"
+
+external loop : t -> unit = "dune_fsevents_loop"
+
+let loop t =
+  match loop t with
+  | exception exn -> Error exn
+  | () -> Ok ()
+
+external break : t -> unit = "dune_fsevents_break"
+
+external flush_sync : t -> unit = "dune_fsevents_flush_sync"
+
+external destroy : t -> unit = "dune_fsevents_destroy"
+
+external dune_fsevents_create :
+  string list -> float -> (t -> Event.t list -> unit) -> t
+  = "dune_fsevents_create"
+
+let create ~paths ~latency ~f =
+  (match paths with
+  | [] -> Code_error.raise "Fsevents.create: paths empty" []
+  | _ -> ());
+  dune_fsevents_create paths latency f
+
+(* external flush_async : t -> Event.Id.t = "dune_fsevents_flush_async" *)
+
+external set_exclusion_paths : t -> string list -> unit
+  = "dune_fsevents_set_exclusion_paths"
+
+let set_exclusion_paths t ~paths =
+  if List.length paths > 8 then
+    Code_error.raise
+      "Fsevents.set_exclusion_paths: 8 directories should be enough for anybody"
+      [ ("paths", Dyn.Encoder.(list string) paths) ];
+  set_exclusion_paths t paths
+
+(* let flush_async t = *)
+(*   let res = flush_async t in *)
+(*   if UInt64.equal res UInt64.zero then *)
+(*     `No_events_queued *)
+(*   else *)
+(*     `Last res *)
+
+let flush_async _ = failwith "temporarily disabled"

src/fsevents/fsevents.mli

@@ -0,0 +1,89 @@
+(** Minimal bindings for fsevents on macos.
+
+    We only bind to the subset of fsevents relevant to dune. *)
+
+val available : unit -> bool
+
+module Event : sig
+  module Id : sig
+    (** monotonically increasing id *)
+    type t
+  end
+
+  (** file system event *)
+  type t
+
+  val to_dyn_raw : t -> Dyn.t
+
+  val to_dyn : t -> Dyn.t
+
+  (** [id t] return the id of the event *)
+  val id : t -> Id.t
+
+  (** [path t] returns the file path this event applies to *)
+  val path : t -> string
+
+  type kind =
+    | Dir  (** directory *)
+    | File  (** file event *)
+    | Dir_and_descendants
+        (** non-specific directory event. all descendants of this directory are
+            invalidated *)
+
+  val dyn_of_kind : kind -> Dyn.t
+
+  (** [kind t] describes the [kind] of [path t] *)
+  val kind : t -> kind
+
+  type action =
+    | Unknown
+        (** multiple actions merged into one by debouncing or an uninformative
+            "rename". inspect the FS to see what happened *)
+    | Create (* [path t] guaranteed to exist *)
+    | Remove (* [path t] guaranteed to be absent *)
+    | Modify
+  (* [path t] guaranteed to exist *)
+
+  val dyn_of_action : action -> Dyn.t
+
+  (** [action t] describes the action occured to [path t] *)
+  val action : t -> action
+end
+
+(** the type of fsevents watcher *)
+type t
+
+(** [create ~paths ~latency ~f] create a new watcher watching [paths], with
+    debouncing based on [latency]. [f] is called for every new event *)
+val create :
+  paths:string list -> latency:float -> f:(t -> Event.t list -> unit) -> t
+
+(** [start t] will start listening for fsevents. Note that the callback will not
+    be called until [loop t] is called. *)
+val start : t -> unit
+
+(** [stop t] stop listening to events. Note that this will not make [loop]
+    return until [break] is called. *)
+val stop : t -> unit
+
+(** [loop t] start the event loop and execute the callback for the fsevents. *)
+val loop : t -> (unit, exn) result
+
+(** [break t] stop the event loop. This will make [loop t] terminate. *)
+val break : t -> unit
+
+(** [destroy t] cleanup the resources held by [t] *)
+val destroy : t -> unit
+
+(** [flush_sync t] flush all pending events that might be held up by debouncing.
+    this function blocks until the final invocation of the callback for all
+    buffered events completes. *)
+val flush_sync : t -> unit
+
+(** Set a list of directories to ignore. A maximum of 8 directories may be
+    specified *)
+val set_exclusion_paths : t -> paths:string list -> unit
+
+(** [flush_async t] ask to flush buffered events but do not block. returns the
+    id of the last event buffered (if it exists) *)
+val flush_async : t -> [ `Last of Event.Id.t | `No_events_queued ]