Tighten the Debouncer

Author: pepeiborra

ghcide/src/Development/IDE/Core/Debouncer.hs

@@ -11,7 +11,8 @@ module Development.IDE.Core.Debouncer
 import           Control.Concurrent.Async
 import           Control.Concurrent.Extra
 import           Control.Exception
-import           Control.Monad.Extra
+import           Control.Monad            (join)
+import           Data.Foldable            (traverse_)
 import           Data.HashMap.Strict      (HashMap)
 import qualified Data.HashMap.Strict      as Map
 import           Data.Hashable
@@ -40,18 +41,18 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
 -- to mask if required.
 asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
 asyncRegisterEvent d 0 k fire = do
-    modifyVar_ d $ \m -> mask_ $ do
-        whenJust (Map.lookup k m) cancel
-        pure $ Map.delete k m
+    join $ modifyVar d $ \m -> do
+        (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m
+        return (m', cancel)
     fire
 asyncRegisterEvent d delay k fire = do
     a <- asyncWithUnmask $ \unmask -> unmask $ do
         sleep delay
         fire
-        modifyVar_ d (pure . Map.delete k)
-    modifyVar_ d $ \m -> mask_ $ do
-        whenJust (Map.lookup k m) cancel
-        pure $ Map.insert k a m
+        modifyVar_ d (evaluate . Map.delete k)
+    join $ modifyVar d $ \m -> mask_ $ do
+        (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m
+        return (m', cancel)
 
 -- | Debouncer used in the DAML CLI compiler that emits events immediately.
 noopDebouncer :: Debouncer k