From 2c33a83733f1489757472ae3a34f6c91c805e1d8 Mon Sep 17 00:00:00 2001
From: Sridhar Ratnakumar <3998+srid@users.noreply.github.com>
Date: Mon, 17 May 2021 18:26:31 -0400
Subject: [PATCH] FileSystem.mount: group multiple actions (#31)

* Group initial actions

* refactor
---
 src/Ema/Helper/FileSystem.hs | 29 ++++++++++++++++++++---------
 1 file changed, 20 insertions(+), 9 deletions(-)

diff --git a/src/Ema/Helper/FileSystem.hs b/src/Ema/Helper/FileSystem.hs
index 80eec4f..d149230 100644
--- a/src/Ema/Helper/FileSystem.hs
+++ b/src/Ema/Helper/FileSystem.hs
@@ -25,6 +25,7 @@ import Control.Monad.Logger
 import Data.Default (Default (..))
 import Data.LVar (LVar)
 import qualified Data.LVar as LVar
+import qualified Data.Map.Strict as Map
 import System.Directory (canonicalizePath)
 import System.FSNotify
   ( ActionPredicate,
@@ -48,7 +49,8 @@ mountOnLVar ::
     MonadUnliftIO m,
     MonadLogger m,
     Default model,
-    Show b
+    Show b,
+    Ord b
   ) =>
   -- | The directory to mount.
   FilePath ->
@@ -64,18 +66,23 @@ mountOnLVar ::
   -- to reflect the given `FileAction`.
   --
   -- If the action throws an exception, it will be logged and ignored.
-  ((b, FilePath) -> FileAction -> m (model -> model)) ->
+  ([(b, [FilePath])] -> FileAction -> m (model -> model)) ->
   m ()
 mountOnLVar folder pats var toAction' = do
   let toAction x = interceptExceptions id . toAction' x
   log LevelInfo $ "Mounting path " <> toText folder <> " (filter: " <> show pats <> ") onto LVar"
   LVar.set var =<< do
     fs <- filesMatchingWithTag folder pats
-    initialActions <- traverse (`toAction` Update) fs
-    pure $ foldl' (flip ($)) def initialActions
+    initialAction <- toAction fs Update
+    pure $ initialAction def
   onChange folder $ \fp change -> do
-    whenJust (getTag pats fp) $ \tag ->
-      LVar.modify var =<< toAction (tag, fp) change
+    whenJust (getTag pats fp) $ \tag -> do
+      -- TODO: We should probably debounce and group frequently-firing events
+      -- here, but do so such that `change` is the same for the events in the
+      -- group.
+      let groupOfOne = one (tag, one fp)
+      action <- toAction groupOfOne change
+      LVar.modify var action
   where
     -- Log and ignore exceptions
     interceptExceptions :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => a -> m a -> m a
@@ -96,10 +103,14 @@ filesMatching parent' pats = do
 
 -- | Like `filesMatching` but with a tag associated with a pattern so as to be
 -- able to tell which pattern a resulting filepath is associated with.
-filesMatchingWithTag :: (MonadIO m, MonadLogger m) => FilePath -> [(b, FilePattern)] -> m [(b, FilePath)]
+filesMatchingWithTag :: (MonadIO m, MonadLogger m, Ord b) => FilePath -> [(b, FilePattern)] -> m [(b, [FilePath])]
 filesMatchingWithTag parent' pats = do
-  filesMatching parent' (snd <$> pats) <&> \xs ->
-    mapMaybe (\x -> (,x) <$> getTag pats x) xs
+  fs <- filesMatching parent' (snd <$> pats)
+  let m = Map.fromListWith (<>) $
+        flip mapMaybe fs $ \fp -> do
+          tag <- getTag pats fp
+          pure (tag, one fp)
+  pure $ Map.toList m
 
 getTag :: [(b, FilePattern)] -> FilePath -> Maybe b
 getTag pats fp =