@@ -0,0 +1,78 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+-- | Debounce an action, ensuring it doesn't occur more than once for a given
3+-- period of time.
4+--
5+-- This is useful as an optimization, for example to ensure that logs are only
6+-- flushed to disk at most once per second. See the fast-logger package for an
7+-- example usage.
8+--
9+-- Since 0.1.2
10+module Control.Debounce
11+ ( -- * Type
12+ DebounceSettings
13+ , defaultDebounceSettings
14+ -- * Accessors
15+ , debounceFreq
16+ , debounceAction
17+ -- * Creation
18+ , mkDebounce
19+ ) where
20+
21+import Control.Concurrent (forkIO, threadDelay)
22+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
23+import Control.Exception (SomeException, handle, mask_)
24+import Control.Monad (forever, void)
25+
26+-- | Settings to control how debouncing should work.
27+--
28+-- This should be constructed using @defaultDebounceSettings@ and record
29+-- update syntax, e.g.:
30+--
31+-- @
32+-- let set = defaultDebounceSettings { debounceAction = flushLog }
33+-- @
34+--
35+-- Since 0.1.2
36+data DebounceSettings = DebounceSettings
37+ { debounceFreq :: Int
38+ -- ^ Microseconds lag required between subsequence calls to the debounced
39+ -- action.
40+ --
41+ -- Default: 1 second (1000000)
42+ --
43+ -- Since 0.1.2
44+ , debounceAction :: IO ()
45+ -- ^ Action to be performed.
46+ --
47+ -- Note: all exceptions thrown by this action will be silently discarded.
48+ --
49+ -- Default: does nothing.
50+ --
51+ -- Since 0.1.2
52+ }
53+
54+-- | Default value for creating a @DebounceSettings@.
55+--
56+-- Since 0.1.2
57+defaultDebounceSettings :: DebounceSettings
58+defaultDebounceSettings = DebounceSettings
59+ { debounceFreq = 1000000
60+ , debounceAction = return ()
61+ }
62+
63+-- | Generate an action which will trigger the debounced action to be
64+-- performed. The action will either be performed immediately, or after the
65+-- current cooldown period has expired.
66+--
67+-- Since 0.1.2
68+mkDebounce :: DebounceSettings -> IO (IO ())
69+mkDebounce (DebounceSettings freq action) = do
70+ baton <- newEmptyMVar
71+ mask_ $ void $ forkIO $ forever $ do
72+ takeMVar baton
73+ ignoreExc action
74+ threadDelay freq
75+ return $ void $ tryPutMVar baton ()
76+
77+ignoreExc :: IO () -> IO ()
78+ignoreExc = handle $ \(_ :: SomeException) -> return ()