@@ -9,13 +9,13 @@ module Development.IDE.Core.Debouncer
9
9
) where
10
10
11
11
import Control.Concurrent.Async
12
- import Control.Concurrent.Strict
12
+ import Control.Concurrent.STM.Stats ( atomically , atomicallyNamed )
13
13
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_ )
18
16
import Data.Hashable
17
+ import qualified Focus
18
+ import qualified StmContainers.Map as STM
19
19
import System.Time.Extra
20
20
21
21
-- | A debouncer can be used to avoid triggering many events
@@ -31,28 +31,28 @@ newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO (
31
31
32
32
-- | Debouncer used in the IDE that delays events as expected.
33
33
newAsyncDebouncer :: (Eq k , Hashable k ) => IO (Debouncer k )
34
- newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map. empty
34
+ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> STM. newIO
35
35
36
36
-- | Register an event that will fire after the given delay if no other event
37
37
-- for the same key gets registered until then.
38
38
--
39
39
-- If there is a pending event for the same key, the pending event will be killed.
40
40
-- Events are run unmasked so it is up to the user of `registerEvent`
41
41
-- 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 ()
43
43
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
47
47
fire
48
48
asyncRegisterEvent d delay k fire = mask_ $ do
49
49
a <- asyncWithUnmask $ \ unmask -> unmask $ do
50
50
sleep delay
51
51
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
56
56
57
57
-- | Debouncer used in the DAML CLI compiler that emits events immediately.
58
58
noopDebouncer :: Debouncer k
0 commit comments