Skip to content

Commit 3a271a4

Browse files
authored
lockless debouncer (#2469)
1 parent c570656 commit 3a271a4

File tree

1 file changed

+14
-14
lines changed

1 file changed

+14
-14
lines changed

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

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -9,13 +9,13 @@ module Development.IDE.Core.Debouncer
99
) where
1010

1111
import Control.Concurrent.Async
12-
import Control.Concurrent.Strict
12+
import Control.Concurrent.STM.Stats (atomically, atomicallyNamed)
1313
import Control.Exception
14-
import Control.Monad (join)
15-
import Data.Foldable (traverse_)
16-
import Data.HashMap.Strict (HashMap)
17-
import qualified Data.HashMap.Strict as Map
14+
import Control.Monad (join)
15+
import Data.Foldable (traverse_)
1816
import Data.Hashable
17+
import qualified Focus
18+
import qualified StmContainers.Map as STM
1919
import System.Time.Extra
2020

2121
-- | A debouncer can be used to avoid triggering many events
@@ -31,28 +31,28 @@ newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO (
3131

3232
-- | Debouncer used in the IDE that delays events as expected.
3333
newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
34-
newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
34+
newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM.newIO
3535

3636
-- | Register an event that will fire after the given delay if no other event
3737
-- for the same key gets registered until then.
3838
--
3939
-- If there is a pending event for the same key, the pending event will be killed.
4040
-- Events are run unmasked so it is up to the user of `registerEvent`
4141
-- to mask if required.
42-
asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
42+
asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (Async ()) -> Seconds -> k -> IO () -> IO ()
4343
asyncRegisterEvent d 0 k fire = do
44-
join $ modifyVar d $ \m -> do
45-
(cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m
46-
return (m', cancel)
44+
join $ atomically $ do
45+
prev <- STM.focus Focus.lookupAndDelete k d
46+
return $ traverse_ cancel prev
4747
fire
4848
asyncRegisterEvent d delay k fire = mask_ $ do
4949
a <- asyncWithUnmask $ \unmask -> unmask $ do
5050
sleep delay
5151
fire
52-
modifyVar_ d (evaluate . Map.delete k)
53-
join $ modifyVar d $ \m -> do
54-
(cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m
55-
return (m', cancel)
52+
atomically $ STM.delete k d
53+
do
54+
prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d
55+
traverse_ cancel prev
5656

5757
-- | Debouncer used in the DAML CLI compiler that emits events immediately.
5858
noopDebouncer :: Debouncer k

0 commit comments

Comments
 (0)