Merge pull request #5729 from unisonweb/file-watch-tweak

Author: aryairani

unison-cli/src/Unison/Codebase/Watch.hs

@@ -4,11 +4,11 @@ module Unison.Codebase.Watch
 where
 
 import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM (STM)
 import Control.Concurrent.STM qualified as STM
 import Control.Exception (MaskingState (..))
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.Map qualified as Map
-import Data.Time (getCurrentTime)
 import Data.Time.Clock (UTCTime, diffUTCTime)
 import GHC.Conc (registerDelay)
 import GHC.IO (unsafeUnmask)
@@ -21,7 +21,7 @@ import UnliftIO.STM (atomically)
 
 watchDirectory :: Ki.Scope -> FSNotify.WatchManager -> FilePath -> (FilePath -> Bool) -> IO (IO (FilePath, Text))
 watchDirectory scope mgr dir allow = do
-  eventQueue <- forkDirWatcherThread scope mgr dir allow
+  readLatestEvent <- forkDirWatcherThread scope mgr dir allow
 
   -- Await an event from the event queue with the following simple debounce logic, which is intended to work around the
   -- tendency for modern editors to create a flurry of rapid filesystem events when a file is saved:
@@ -40,17 +40,14 @@ watchDirectory scope mgr dir allow = do
               var <- registerDelay 50_000
               (join . atomically . asum)
                 [ do
-                    event1 <- STM.readTQueue eventQueue
+                    event1 <- readLatestEvent
                     pure (go event1),
                   do
                     STM.readTVar var >>= STM.check
                     pure (pure event0)
                 ]
-        event@(_, eventTime) <- atomically (STM.readTQueue eventQueue)
-        now <- getCurrentTime
-        if (now `diffUTCTime` eventTime) <= 1.0
-          then go event
-          else awaitEvent0
+        event <- atomically readLatestEvent
+        go event
 
   -- Enhance the previous "await event" action with a small file cache that serves as a second debounce implementation.
   -- We keep in memory the file contents of previously-saved files, so that we can avoid emitting events for files that
@@ -74,16 +71,21 @@ watchDirectory scope mgr dir allow = do
 
 -- | `forkDirWatcherThread scope mgr dir allow` forks a background thread into `scope` that, using "file watcher
 -- manager" `mgr` (just a boilerplate argument the caller is responsible for creating), watches directory `dir` for
--- all "added" and "modified" filesystem events that occur on files that pass the `allow` predicate. It returns a queue
--- of such event that is (obviously) meant to be read or flushed, never written.
-forkDirWatcherThread :: Ki.Scope -> FSNotify.WatchManager -> FilePath -> (FilePath -> Bool) -> IO (STM.TQueue (FilePath, UTCTime))
+-- all "added" and "modified" filesystem events that occur on files that pass the `allow` predicate. It returns an STM
+-- action that reads (and clears) the latest event, blocking if one isn't available.
+forkDirWatcherThread ::
+  Ki.Scope ->
+  FSNotify.WatchManager ->
+  FilePath ->
+  (FilePath -> Bool) ->
+  IO (STM (FilePath, UTCTime))
 forkDirWatcherThread scope mgr dir allow = do
-  queue <- STM.newTQueueIO
+  latestEventVar <- STM.newTVarIO Nothing
 
   let handler :: Event -> IO ()
       handler = \case
-        Added fp t FSNotify.IsFile | allow fp -> atomically (STM.writeTQueue queue (fp, t))
-        Modified fp t FSNotify.IsFile | allow fp -> atomically (STM.writeTQueue queue (fp, t))
+        Added fp t FSNotify.IsFile | allow fp -> atomically (STM.writeTVar latestEventVar (Just (fp, t)))
+        Modified fp t FSNotify.IsFile | allow fp -> atomically (STM.writeTVar latestEventVar (Just (fp, t)))
         _ -> pure ()
 
   -- A bit of a "one too many threads" situation but there's not much we can easily do about it. The `fsnotify` API
@@ -98,4 +100,11 @@ forkDirWatcherThread scope mgr dir allow = do
     stopListening <- unsafeUnmask (FSNotify.watchDir mgr dir (const True) handler) <|> pure (pure ())
     unsafeUnmask (forever (threadDelay maxBound)) `finally` stopListening
 
-  pure queue
+  let readLatestEvent =
+        STM.readTVar latestEventVar >>= \case
+          Nothing -> STM.retry
+          Just event -> do
+            STM.writeTVar latestEventVar Nothing
+            pure event
+
+  pure readLatestEvent

unison-cli/src/Unison/CommandLine/Main.hs

@@ -157,8 +157,7 @@ main dir welcome ppIds initialInputs runtime sbRuntime nRuntime codebase serverB
       _ <- Ki.fork scope (Codebase.expectProjectBranchRoot codebase ppIds.project ppIds.branch)
       -- IOSource takes a while to compile, we should start compiling it on startup
       _ <- Ki.fork scope (IO.evaluate IOSource.typecheckedFile)
-      -- Fork the file watcher thread, which returns an IO action we can call to get one filesystem event (automatically
-      -- first tossing all that have accumulated since the last call)
+      -- Fork the file watcher thread, which returns an IO action we can call to get one filesystem event.
       awaitFileEvent <- do
         (fmap . fmap)
           (\(file, contents) -> UnisonFileChanged (Text.pack file) contents)