Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Lock-less debouncer (minimal change) #2469

Merged
merged 2 commits into from Dec 11, 2021
Merged

Lock-less debouncer (minimal change) #2469

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
d3fac9c
lockless debouncer
pepeiborra Dec 11, 2021
ca13d42
Merge branch 'master' into lockless-debouncer-safe
pepeiborra Dec 11, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
28 changes: 14 additions & 14 deletions ghcide/src/Development/IDE/Core/Debouncer.hs
View file
Open in desktop
Expand Up @@ -9,13 +9,13 @@ module Development.IDE.Core.Debouncer
) where

import Control.Concurrent.Async
import Control.Concurrent.Strict
import Control.Concurrent.STM.Stats (atomically, atomicallyNamed)
import Control.Exception
import Control.Monad (join)
import Data.Foldable (traverse_)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import Control.Monad (join)
import Data.Foldable (traverse_)
import Data.Hashable
import qualified Focus
import qualified StmContainers.Map as STM
import System.Time.Extra

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

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

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

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