Fix FSEvents kind and action decoding

doc/changes/fixed/14725.md

@@ -0,0 +1 @@
+- Fix decoding coalesced MacOS file notification events. (#14725, @rgrinberg)

src/dune_scheduler/file_watcher.ml

@@ -506,8 +506,8 @@ let create_fsevents ?(latency = Time.Span.of_secs 0.2) ~event_queue ~should_excl
            match Fsevents.Event.action event with
            | Remove -> None
            | Rename | Unknown | Create | Modify ->
-             Option.map (Fs_sync.consume_event sync_table path) ~f:(fun id ->
-               Event.Sync id)))
+             Fs_sync.consume_event sync_table path
+             |> Option.map ~f:(fun id -> Event.Sync id)))
   in
   let on_event = fsevents_standard_event ~should_exclude in
   let source =

src/dune_scheduler/fsevents.ml

@@ -179,43 +179,84 @@ module Event = struct
   let id t = t.id
   let path t = t.path
 
-  type kind =
-    | Dir
-    | File
-    | Dir_and_descendants
-
-  let dyn_of_kind kind =
-    Dyn.string
-      (match kind with
-       | Dir -> "Dir"
-       | File -> "File"
-       | Dir_and_descendants -> "Dir_and_descendants")
-  ;;
+  module Kind = struct
+    type t =
+      | Dir
+      | File
+      | Dir_and_descendants
+
+    let repr =
+      Repr.variant
+        "fsevents-kind"
+        [ Repr.case0 "Dir" ~test:(function
+            | Dir -> true
+            | File | Dir_and_descendants -> false)
+        ; Repr.case0 "File" ~test:(function
+            | File -> true
+            | Dir | Dir_and_descendants -> false)
+        ; Repr.case0 "Dir_and_descendants" ~test:(function
+            | Dir_and_descendants -> true
+            | Dir | File -> false)
+        ]
+    ;;
+
+    include Repr.Poly (struct
+        type nonrec t = t
 
-  external kind : Int32.t -> kind = "dune_fsevents_kind"
+        let repr = repr
+      end)
 
-  let kind t = kind t.flags
+    let to_dyn = Repr.to_dyn repr
+  end
 
-  type action =
-    | Create
-    | Remove
-    | Modify
-    | Rename
-    | Unknown
+  let dyn_of_kind = Kind.to_dyn
 
-  external action : Int32.t -> action = "dune_fsevents_action"
+  external kind_of_flags : Int32.t -> Kind.t = "dune_fsevents_kind"
 
-  let action t = action t.flags
+  let kind t = kind_of_flags t.flags
 
-  let dyn_of_action a =
-    Dyn.string
-      (match a with
-       | Create -> "Create"
-       | Remove -> "Remove"
-       | Modify -> "Modify"
-       | Unknown -> "Unknown"
-       | Rename -> "Rename")
-  ;;
+  module Action = struct
+    type t =
+      | Create
+      | Remove
+      | Modify
+      | Rename
+      | Unknown
+
+    let repr =
+      Repr.variant
+        "fsevents-action"
+        [ Repr.case0 "Create" ~test:(function
+            | Create -> true
+            | Remove | Modify | Rename | Unknown -> false)
+        ; Repr.case0 "Remove" ~test:(function
+            | Remove -> true
+            | Create | Modify | Rename | Unknown -> false)
+        ; Repr.case0 "Modify" ~test:(function
+            | Modify -> true
+            | Create | Remove | Rename | Unknown -> false)
+        ; Repr.case0 "Rename" ~test:(function
+            | Rename -> true
+            | Create | Remove | Modify | Unknown -> false)
+        ; Repr.case0 "Unknown" ~test:(function
+            | Unknown -> true
+            | Create | Remove | Modify | Rename -> false)
+        ]
+    ;;
+
+    include Repr.Poly (struct
+        type nonrec t = t
+
+        let repr = repr
+      end)
+
+    let to_dyn = Repr.to_dyn repr
+  end
+
+  external action_of_flags : Int32.t -> Action.t = "dune_fsevents_action"
+
+  let action t = action_of_flags t.flags
+  let dyn_of_action = Action.to_dyn
 
   let to_dyn t =
     let open Dyn in
@@ -225,6 +266,51 @@ module Event = struct
       ; "path", string t.path
       ]
   ;;
+
+  external flag_examples : unit -> (string * Int32.t) list = "dune_fsevents_flag_examples"
+
+  let%expect_test "fsevents flag decoding" =
+    if available ()
+    then (
+      let decoded =
+        flag_examples ()
+        |> List.map ~f:(fun (name, flags) ->
+          name, action_of_flags flags, kind_of_flags flags)
+      in
+      let expected =
+        [ "created_file", Action.Create, Kind.File
+        ; "removed_file", Action.Remove, Kind.File
+        ; "modified_file", Action.Modify, Kind.File
+        ; "renamed_file", Action.Rename, Kind.File
+        ; "created_dir", Action.Create, Kind.Dir
+        ; "must_scan_subdirs", Action.Unknown, Kind.Dir_and_descendants
+        ; "must_scan_dir", Action.Unknown, Kind.Dir_and_descendants
+        ; "created_and_modified", Action.Unknown, Kind.File
+        ; "removed_and_renamed", Action.Unknown, Kind.File
+        ]
+      in
+      let module Decoded = struct
+        type t = string * Action.t * Kind.t
+
+        let repr = Repr.triple Repr.string Action.repr Kind.repr
+
+        include Repr.Poly (struct
+            type nonrec t = t
+
+            let repr = repr
+          end)
+
+        let to_dyn = Repr.to_dyn repr
+      end
+      in
+      if not (List.equal Decoded.equal decoded expected)
+      then
+        Code_error.raise
+          "unexpected fsevents flag decoding"
+          [ "decoded", Dyn.list Decoded.to_dyn decoded
+          ; "expected", Dyn.list Decoded.to_dyn expected
+          ])
+  ;;
 end
 
 module Raw = struct

src/dune_scheduler/fsevents.mli

@@ -31,31 +31,35 @@ module Event : sig
   (** [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
+  module Kind : sig
+    type t =
+      | Dir (** directory *)
+      | File (** file event *)
+      | Dir_and_descendants
+      (** non-specific directory event. all descendants of this directory are
+          invalidated *)
+
+    val to_dyn : t -> Dyn.t
+  end
 
   (** [kind t] describes the [kind] of [path t] *)
-  val kind : t -> kind
-
-  type action =
-    | Create (* [path t] guaranteed to exist *)
-    | Remove (* [path t] guaranteed to be absent *)
-    | Modify (* [path t] guaranteed to exist *)
-    | Rename
-    | Unknown
-    (** multiple actions merged into one by debouncing or an uninformative
-        "rename". inspect the FS to see what happened *)
-
-  val dyn_of_action : action -> Dyn.t
+  val kind : t -> Kind.t
+
+  module Action : sig
+    type t =
+      | Create (* [path t] guaranteed to exist *)
+      | Remove (* [path t] guaranteed to be absent *)
+      | Modify (* [path t] guaranteed to exist *)
+      | Rename
+      | Unknown
+      (** multiple actions merged into one by debouncing or an uninformative
+          "rename". inspect the FS to see what happened *)
+
+    val to_dyn : t -> Dyn.t
+  end
 
   (** [action t] describes the action occurred to [path t] *)
-  val action : t -> action
+  val action : t -> Action.t
 end
 
 (** the type of fsevents watcher *)

src/dune_scheduler/fsevents_stubs.c

@@ -345,41 +345,108 @@ CAMLprim value dune_fsevents_flush_sync(value v_t) {
   CAMLreturn(Val_unit);
 }
 
+// Keep in sync with the Event.Kind.t variant in fsevents.ml.
+enum dune_fsevents_kind_tag {
+  DUNE_FSEVENTS_KIND_DIR = 0,
+  DUNE_FSEVENTS_KIND_FILE = 1,
+  DUNE_FSEVENTS_KIND_DIR_AND_DESCENDANTS = 2,
+};
+
+static value dune_fsevents_kind_of_flags(FSEventStreamEventFlags flags) {
+  if (flags & kFSEventStreamEventFlagMustScanSubDirs) {
+    return Val_int(DUNE_FSEVENTS_KIND_DIR_AND_DESCENDANTS);
+  } else if (flags & kFSEventStreamEventFlagItemIsDir) {
+    return Val_int(DUNE_FSEVENTS_KIND_DIR);
+  } else {
+    return Val_int(DUNE_FSEVENTS_KIND_FILE);
+  }
+}
+
 CAMLprim value dune_fsevents_kind(value v_flags) {
   CAMLparam1(v_flags);
-  CAMLlocal1(v_kind);
-  uint32_t flags = Int32_val(v_flags);
-  if (flags & kFSEventStreamEventFlagItemIsDir) {
-    v_kind = Val_int(flags & kFSEventStreamEventFlagMustScanSubDirs ? 2 : 0);
-  } else {
-    v_kind = Val_int(1);
-  };
-  CAMLreturn(v_kind);
+  CAMLreturn(dune_fsevents_kind_of_flags(Int32_val(v_flags)));
 }
 
 static const FSEventStreamEventFlags action_mask =
     kFSEventStreamEventFlagItemCreated | kFSEventStreamEventFlagItemRemoved |
     kFSEventStreamEventFlagItemRenamed | kFSEventStreamEventFlagItemModified;
 
-CAMLprim value dune_fsevents_action(value v_flags) {
-  CAMLparam1(v_flags);
-  CAMLlocal1(v_action);
-
-  uint32_t flags = Int32_val(v_flags) & action_mask;
-  if (flags & kFSEventStreamEventFlagItemCreated) {
-    v_action = Val_int(0);
-  } else if (flags & kFSEventStreamEventFlagItemRemoved) {
-    v_action = Val_int(1);
-  } else if (flags & kFSEventStreamEventFlagItemModified) {
-    v_action = Val_int(2);
-  } else if (flags & kFSEventStreamEventFlagItemRenamed) {
-    v_action = Val_int(3);
+// Keep in sync with the Event.action variant in fsevents.ml.
+enum dune_fsevents_action_tag {
+  DUNE_FSEVENTS_ACTION_CREATE = 0,
+  DUNE_FSEVENTS_ACTION_REMOVE = 1,
+  DUNE_FSEVENTS_ACTION_MODIFY = 2,
+  DUNE_FSEVENTS_ACTION_RENAME = 3,
+  DUNE_FSEVENTS_ACTION_UNKNOWN = 4,
+};
+
+static value dune_fsevents_action_of_flags(FSEventStreamEventFlags flags) {
+  flags &= action_mask;
+  if (flags == kFSEventStreamEventFlagItemCreated) {
+    return Val_int(DUNE_FSEVENTS_ACTION_CREATE);
+  } else if (flags == kFSEventStreamEventFlagItemRemoved) {
+    return Val_int(DUNE_FSEVENTS_ACTION_REMOVE);
+  } else if (flags == kFSEventStreamEventFlagItemModified) {
+    return Val_int(DUNE_FSEVENTS_ACTION_MODIFY);
+  } else if (flags == kFSEventStreamEventFlagItemRenamed) {
+    return Val_int(DUNE_FSEVENTS_ACTION_RENAME);
   } else {
-    v_action = Val_int(4);
+    return Val_int(DUNE_FSEVENTS_ACTION_UNKNOWN);
   }
+}
 
-  CAMLreturn(v_action);
+CAMLprim value dune_fsevents_action(value v_flags) {
+  CAMLparam1(v_flags);
+  CAMLreturn(dune_fsevents_action_of_flags(Int32_val(v_flags)));
+}
+
+typedef struct dune_fsevents_flag_example {
+  const char *name;
+  FSEventStreamEventFlags flags;
+} dune_fsevents_flag_example;
+
+static const dune_fsevents_flag_example flag_examples[] = {
+    {"created_file", kFSEventStreamEventFlagItemCreated |
+                         kFSEventStreamEventFlagItemIsFile},
+    {"removed_file", kFSEventStreamEventFlagItemRemoved |
+                         kFSEventStreamEventFlagItemIsFile},
+    {"modified_file", kFSEventStreamEventFlagItemModified |
+                          kFSEventStreamEventFlagItemIsFile},
+    {"renamed_file", kFSEventStreamEventFlagItemRenamed |
+                         kFSEventStreamEventFlagItemIsFile},
+    {"created_dir", kFSEventStreamEventFlagItemCreated |
+                        kFSEventStreamEventFlagItemIsDir},
+    {"must_scan_subdirs", kFSEventStreamEventFlagMustScanSubDirs},
+    {"must_scan_dir", kFSEventStreamEventFlagMustScanSubDirs |
+                          kFSEventStreamEventFlagItemIsDir},
+    {"created_and_modified", kFSEventStreamEventFlagItemCreated |
+                               kFSEventStreamEventFlagItemModified |
+                               kFSEventStreamEventFlagItemIsFile},
+    {"removed_and_renamed", kFSEventStreamEventFlagItemRemoved |
+                             kFSEventStreamEventFlagItemRenamed |
+                             kFSEventStreamEventFlagItemIsFile},
+};
+
+CAMLprim value dune_fsevents_flag_examples(value v_unit) {
+  CAMLparam1(v_unit);
+  CAMLlocal5(v_list, v_cons, v_tuple, v_name, v_flags);
+  size_t len = sizeof(flag_examples) / sizeof(dune_fsevents_flag_example);
+  v_list = Val_emptylist;
+  for (size_t i = len; i > 0; i--) {
+    dune_fsevents_flag_example example = flag_examples[i - 1];
+    v_name = caml_copy_string(example.name);
+    v_flags = caml_copy_int32(example.flags);
+    v_tuple = caml_alloc_tuple(2);
+    Store_field(v_tuple, 0, v_name);
+    Store_field(v_tuple, 1, v_flags);
+    v_cons = caml_alloc(2, 0);
+    Store_field(v_cons, 0, v_tuple);
+    Store_field(v_cons, 1, v_list);
+    v_list = v_cons;
+  }
+  CAMLreturn(v_list);
 }
+
 static const FSEventStreamEventFlags all_flags[] = {
     kFSEventStreamEventFlagMustScanSubDirs,
     kFSEventStreamEventFlagUserDropped,
@@ -471,6 +538,10 @@ CAMLprim value dune_fsevents_action(value v_flags) {
   (void)v_flags;
   caml_failwith(unavailable_message);
 }
+CAMLprim value dune_fsevents_flag_examples(value v_unit) {
+  (void)v_unit;
+  caml_failwith(unavailable_message);
+}
 CAMLprim value dune_fsevents_raw(value v_flags) {
   (void)v_flags;
   caml_failwith(unavailable_message);

test/expect-tests/fsevents/fsevents_tests.ml

@@ -85,8 +85,8 @@ let print_event ~logger ~cwd e =
   let dyn =
     let open Dyn in
     record
-      [ "action", Event.dyn_of_action (Event.action e)
-      ; "kind", Event.dyn_of_kind (Event.kind e)
+      [ "action", Event.Action.to_dyn (Event.action e)
+      ; "kind", Event.Kind.to_dyn (Event.kind e)
       ; ( "path"
         , string
             (let path = Event.path e in