git.iko.soy/typeable/wai
on master help sign in
First pass leading vs. trailing edges for Control.Debounce
68d4f81Tom McLaughlin
auto-update/Control/Debounce.hs+18−53
compare with master
unifiedsplit
@@ -11,6 +11,7 @@
11-- printString <- 'mkDebounce' 'defaultDebounceSettings'
11-- printString <- 'mkDebounce' 'defaultDebounceSettings'
12-- { 'debounceAction' = putStrLn "Running action"
12-- { 'debounceAction' = putStrLn "Running action"
13-- , 'debounceFreq' = 5000000 -- 5 seconds
13-- , 'debounceFreq' = 5000000 -- 5 seconds
14+-- , 'debounceEdge' = 'Trailing' -- Trigger on the trailing edge
14-- }
15-- }
15-- @
16-- @
16--
17--
@@ -25,70 +26,34 @@
25-- @since 0.1.2
26-- @since 0.1.2
26module Control.Debounce
27module Control.Debounce
27 ( -- * Type
28 ( -- * Type
28− DebounceSettings
29+ DI.DebounceSettings
29 , defaultDebounceSettings
30 , defaultDebounceSettings
30 -- * Accessors
31 -- * Accessors
31− , debounceFreq
32+ , DI.debounceFreq
32− , debounceAction
33+ , DI.debounceAction
34+ , DI.debounceEdge
35+ , DI.DebounceEdge(..)
33 -- * Creation
36 -- * Creation
34 , mkDebounce
37 , mkDebounce
35 ) where
38 ) where
36
39
37−import Control.Concurrent (forkIO, threadDelay)
40+import Control.Concurrent (newEmptyMVar, threadDelay)
38−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
41+import qualified Control.Debounce.Internal as DI
39−import Control.Exception (SomeException, handle, mask_)
40−import Control.Monad (forever, void)
41−
42−-- | Settings to control how debouncing should work.
43−--
44−-- This should be constructed using 'defaultDebounceSettings' and record
45−-- update syntax, e.g.:
46−--
47−-- @
48−-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
49−-- @
50−--
51−-- @since 0.1.2
52−data DebounceSettings = DebounceSettings
53− { debounceFreq :: Int
54− -- ^ Microseconds lag required between subsequence calls to the debounced
55− -- action.
56− --
57− -- Default: 1 second (1000000)
58− --
59− -- @since 0.1.2
60− , debounceAction :: IO ()
61− -- ^ Action to be performed.
62− --
63− -- Note: all exceptions thrown by this action will be silently discarded.
64− --
65− -- Default: does nothing.
66− --
67− -- @since 0.1.2
68− }
69
42
70-- | Default value for creating a 'DebounceSettings'.
43-- | Default value for creating a 'DebounceSettings'.
71--
44--
72-- @since 0.1.2
45-- @since 0.1.2
73−defaultDebounceSettings :: DebounceSettings
46+defaultDebounceSettings :: DI.DebounceSettings
74−defaultDebounceSettings = DebounceSettings
47+defaultDebounceSettings = DI.DebounceSettings
75− { debounceFreq = 1000000
48+ { DI.debounceFreq = 1000000
76− , debounceAction = return ()
49+ , DI.debounceAction = return ()
50+ , DI.debounceEdge = DI.Leading
77 }
51 }
78
52
79−-- | Generate an action which will trigger the debounced action to be
53+-- | Generate an action which will trigger the debounced action to be performed.
80−-- performed. The action will either be performed immediately, or after the
81−-- current cooldown period has expired.
82--
54--
83-- @since 0.1.2
55-- @since 0.1.2
84−mkDebounce :: DebounceSettings -> IO (IO ())
56+mkDebounce :: DI.DebounceSettings -> IO (IO ())
85−mkDebounce (DebounceSettings freq action) = do
57+mkDebounce settings = do
86− baton <- newEmptyMVar
58+ baton <- newEmptyMVar
87− mask_ $ void $ forkIO $ forever $ do
88− takeMVar baton
89− ignoreExc action
90− threadDelay freq
59+ DI.mkDebounce baton threadDelay settings
91− return $ void $ tryPutMVar baton ()
92−
93−ignoreExc :: IO () -> IO ()
94−ignoreExc = handle $ \(_ :: SomeException) -> return ()
auto-update/Control/Debounce/Internal.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+
3+module Control.Debounce.Internal (
4+ DebounceSettings(..)
5+ , DebounceEdge(..)
6+ , mkDebounce
7+ ) where
8+
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar)
11+import Control.Exception (SomeException, handle, mask_)
12+import Control.Monad (forever, void, when)
13+import Data.Maybe (isJust)
14+
15+-- | Settings to control how debouncing should work.
16+--
17+-- This should be constructed using 'defaultDebounceSettings' and record
18+-- update syntax, e.g.:
19+--
20+-- @
21+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
22+-- @
23+--
24+-- @since 0.1.2
25+data DebounceSettings = DebounceSettings
26+ { debounceFreq :: Int
27+ -- ^ Microseconds lag required between subsequence calls to the debounced
28+ -- action.
29+ --
30+ -- Default: 1 second (1000000)
31+ --
32+ -- @since 0.1.2
33+ , debounceAction :: IO ()
34+ -- ^ Action to be performed.
35+ --
36+ -- Note: all exceptions thrown by this action will be silently discarded.
37+ --
38+ -- Default: does nothing.
39+ --
40+ -- @since 0.1.2
41+ , debounceEdge :: DebounceEdge
42+ -- ^ Whether to perform the action on the leading edge or trailing edge of
43+ -- the timeout.
44+ --
45+ -- Default: Leading.
46+ --
47+ -- @since 0.2.0
48+ }
49+
50+data DebounceEdge =
51+ Leading
52+ -- ^ The action will either be performed immediately, or after the current cooldown period has expired.
53+ | Trailing
54+ -- ^ The action will be performed at the end of the current cooldown period.
55+ | LeadingAndTrailing
56+ -- ^ The action is performed on the leading edge. It's also performed on the trailing edge if
57+ -- the debounced function was invoked again during the cooldown.
58+ deriving (Show, Eq)
59+
60+mkDebounce :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
61+mkDebounce baton delayFn (DebounceSettings freq action edge) = do
62+ mask_ $ void $ forkIO $ forever $ do
63+ takeMVar baton
64+ if edge `elem` [Leading, LeadingAndTrailing] then ignoreExc action >> runDelay False baton
65+ else runDelay True baton
66+
67+ return $ void $ tryPutMVar baton ()
68+
69+ where runDelay hasDelayedInitialActivation baton = do
70+ delayFn freq
71+
72+ case edge of
73+ Trailing -> do
74+ firedDuringInterval <- isJust <$> tryTakeMVar baton
75+ when (firedDuringInterval || hasDelayedInitialActivation) $ ignoreExc action
76+ Leading ->
77+ -- We already fired at the beginning of the interval so do nothing
78+ return ()
79+ LeadingAndTrailing -> do
80+ firedDuringInterval <- isJust <$> tryTakeMVar baton
81+ when firedDuringInterval $ ignoreExc action
82+
83+ignoreExc :: IO () -> IO ()
84+ignoreExc = handle $ \(_ :: SomeException) -> return ()
auto-update/auto-update.cabal+11−9
@@ -1,5 +1,5 @@
1name: auto-update
1name: auto-update
2−version: 0.1.5
2+version: 0.2.0
3synopsis: Efficiently run periodic, on-demand actions
3synopsis: Efficiently run periodic, on-demand actions
4description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
4description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
5homepage: https://github.com/yesodweb/wai
5homepage: https://github.com/yesodweb/wai
@@ -17,6 +17,7 @@ library
17 ghc-options: -Wall
17 ghc-options: -Wall
18 exposed-modules: Control.AutoUpdate
18 exposed-modules: Control.AutoUpdate
19 Control.Debounce
19 Control.Debounce
20+ Control.Debounce.Internal
20 Control.Reaper
21 Control.Reaper
21 other-modules: Control.AutoUpdate.Util
22 other-modules: Control.AutoUpdate.Util
22 build-depends: base >= 4 && < 5
23 build-depends: base >= 4 && < 5
@@ -26,11 +27,12 @@ library
26
27
27-- Test suite is currently not robust enough, gives too many false negatives.
28-- Test suite is currently not robust enough, gives too many false negatives.
28
29
29−-- test-suite spec
30+test-suite spec
30−-- main-is: Spec.hs
31+ main-is: Spec.hs
31−-- other-modules: Control.AutoUpdateSpec
32+ other-modules: Control.AutoUpdateSpec
33+ Control.DebounceSpec
32−-- Control.ReaperSpec
34+ Control.ReaperSpec
33−-- hs-source-dirs: test
35+ hs-source-dirs: test
34−-- type: exitcode-stdio-1.0
36+ type: exitcode-stdio-1.0
35−-- build-depends: base, auto-update, hspec
37+ build-depends: base, auto-update, exceptions, hspec, retry, HUnit
36−-- default-language: Haskell2010
38+ default-language: Haskell2010
auto-update/test/Control/AutoUpdateSpec.hs+26−25
@@ -1,34 +1,35 @@
1module Control.AutoUpdateSpec (spec) where
1module Control.AutoUpdateSpec (spec) where
2
2
3−import Test.Hspec
3+import Control.AutoUpdate
4−import Test.Hspec.QuickCheck
5−import Data.IORef
6import Control.Concurrent (threadDelay)
4import Control.Concurrent (threadDelay)
7import Control.Monad (replicateM_, forM_)
5import Control.Monad (replicateM_, forM_)
8−import Control.AutoUpdate
6+import Data.IORef
7+import Test.Hspec
8+import Test.Hspec.QuickCheck
9
9
10spec :: Spec
10spec :: Spec
11−spec = do
11+spec = return ()
12+ -- do
12− prop "incrementer" $ \st' -> do
13+ -- prop "incrementer" $ \st' -> do
13− let st = abs st' `mod` 10000
14+ -- let st = abs st' `mod` 10000
14− ref <- newIORef 0
15+ -- ref <- newIORef 0
15− next <- mkAutoUpdate defaultUpdateSettings
16+ -- next <- mkAutoUpdate defaultUpdateSettings
16− { updateAction = atomicModifyIORef ref $ \i ->
17+ -- { updateAction = atomicModifyIORef ref $ \i ->
17− let i' = succ i in i' `seq` (i', i')
18+ -- let i' = succ i in i' `seq` (i', i')
18− , updateSpawnThreshold = st
19+ -- , updateSpawnThreshold = st
19− , updateFreq = 10000
20+ -- , updateFreq = 10000
20− }
21+ -- }
21
22
22− forM_ [1..st + 1] $ \i -> do
23+ -- forM_ [1..st + 1] $ \i -> do
23− j <- next
24+ -- j <- next
24− j `shouldBe` i
25+ -- j `shouldBe` i
25
26
26− replicateM_ 50 $ do
27+ -- replicateM_ 50 $ do
27− i <- next
28+ -- i <- next
28− i `shouldBe` st + 2
29+ -- i `shouldBe` st + 2
29
30
30− threadDelay 60000
31+ -- threadDelay 60000
31− last1 <- readIORef ref
32+ -- last1 <- readIORef ref
32− threadDelay 20000
33+ -- threadDelay 20000
33− last2 <- readIORef ref
34+ -- last2 <- readIORef ref
34− last2 `shouldBe` last1
35+ -- last2 `shouldBe` last1
auto-update/test/Control/DebounceSpec.hsnew file+152
@@ -0,0 +1,152 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+module Control.DebounceSpec (spec) where
3+
4+import Control.Concurrent
5+import Control.Debounce
6+import qualified Control.Debounce.Internal as DI
7+import Control.Monad
8+import Control.Monad.Catch
9+import Control.Monad.IO.Class
10+import Control.Retry
11+import Data.IORef
12+import Test.HUnit.Lang
13+import Test.Hspec
14+
15+spec :: Spec
16+spec = describe "mkDebounce" $ do
17+ describe "Leading edge" $ do
18+ it "works for a single event" $ do
19+ (ref, debounced, baton, returnFromWait) <- getDebounce Leading
20+
21+ debounced
22+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
23+
24+ returnFromWait
25+ pause
26+ readIORef ref >>= (`shouldBe` 1)
27+
28+ -- Try another round
29+ debounced
30+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
31+
32+ returnFromWait
33+ pause
34+ readIORef ref >>= (`shouldBe` 2)
35+
36+ it "works for multiple events" $ do
37+ (ref, debounced, baton, returnFromWait) <- getDebounce Leading
38+
39+ debounced
40+ waitForBatonToBeTaken baton
41+ debounced
42+ pause
43+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
44+
45+ returnFromWait
46+ pause
47+ readIORef ref >>= (`shouldBe` 2)
48+
49+ describe "Trailing edge" $ do
50+ it "works for a single event" $ do
51+ (ref, debounced, baton, returnFromWait) <- getDebounce Trailing
52+
53+ debounced
54+ pause
55+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
56+
57+ returnFromWait
58+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
59+
60+ -- Try another round
61+ debounced
62+ pause
63+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
64+
65+ returnFromWait
66+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
67+
68+ it "works for multiple events" $ do
69+ (ref, debounced, baton, returnFromWait) <- getDebounce Trailing
70+
71+ debounced
72+ waitForBatonToBeTaken baton
73+ debounced
74+ pause
75+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
76+
77+ returnFromWait
78+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
79+
80+ describe "Leading or trailing edge" $ do
81+ it "works for a single event" $ do
82+ (ref, debounced, baton, returnFromWait) <- getDebounce LeadingAndTrailing
83+
84+ debounced
85+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
86+
87+ returnFromWait
88+ pause
89+ readIORef ref >>= (`shouldBe` 1)
90+
91+ -- Try another round
92+ debounced
93+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
94+
95+ returnFromWait
96+ pause
97+ readIORef ref >>= (`shouldBe` 2)
98+
99+ it "works for multiple events" $ do
100+ (ref, debounced, baton, returnFromWait) <- getDebounce LeadingAndTrailing
101+
102+ debounced
103+ waitForBatonToBeTaken baton
104+ debounced
105+
106+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
107+
108+ returnFromWait
109+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
110+
111+
112+-- | Make a controllable delay function
113+getWaitAction :: IO (p -> IO (), IO ())
114+getWaitAction = do
115+ waitVar <- newEmptyMVar
116+ let waitAction _ = takeMVar waitVar
117+ let returnFromWait = putMVar waitVar ()
118+ return (waitAction, returnFromWait)
119+
120+-- | Get a debounce system with access to the internals for testing
121+getDebounce :: DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())
122+getDebounce edge = do
123+ ref :: IORef Int <- newIORef 0
124+ let action = modifyIORef ref (+ 1)
125+
126+ (waitAction, returnFromWait) <- getWaitAction
127+
128+ baton <- newEmptyMVar
129+
130+ debounced <- DI.mkDebounce baton waitAction defaultDebounceSettings {
131+ debounceFreq = 5000000 -- unused
132+ , debounceAction = action
133+ , debounceEdge = edge
134+ }
135+
136+ return (ref, debounced, baton, returnFromWait)
137+
138+-- | Pause briefly (100ms)
139+pause :: IO ()
140+pause = threadDelay 100000
141+
142+waitForBatonToBeTaken :: MVar () -> IO ()
143+waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)
144+
145+-- | Wait up to n seconds for an actual to complete without throwing an HUnitFailure
146+waitUntil :: (MonadIO m, MonadMask m) => Int -> m a -> m ()
147+waitUntil n action = recovering policy [handler] (\_status -> void action)
148+ where policy = constantDelay 1000 <> limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds
149+ handler _status = Handler (\(HUnitFailure {}) -> return True)
150+
151+main :: IO ()
152+main = hspec spec
auto-update/test/Control/ReaperSpec.hs+29−27
@@ -1,37 +1,39 @@
1module Control.ReaperSpec (spec) where
1module Control.ReaperSpec (spec) where
2
2
3−import Control.Reaper
4import Control.Concurrent
3import Control.Concurrent
4+import Control.Reaper
5+import Data.IORef
5import Test.Hspec
6import Test.Hspec
6import Test.Hspec.QuickCheck
7import Test.Hspec.QuickCheck
7−import Data.IORef
8
8
9−type Item = (Int, IORef Int)
10−
11−action = mkListAction $ \(i, ref) -> do
12− modifyIORef ref succ
13− return $ if i > 1
14− then Just (pred i, ref)
15− else Nothing
16
9
17spec :: Spec
10spec :: Spec
11+spec = return ()
18−spec = prop "works" $ \is -> do
12+-- prop "works" $ \is -> do
19− reaper <- mkReaper defaultReaperSettings
13+-- reaper <- mkReaper defaultReaperSettings
20− { reaperAction = action
14+-- { reaperAction = action
21− , reaperDelay = 1000
15+-- , reaperDelay = 1000
22− }
16+-- }
17+
18+-- let mkTestCase i = do
19+-- ref <- newIORef 0
20+-- let expected = (abs i `mod` 10) + 1
21+-- reaperAdd reaper (expected, ref)
22+-- return (expected, ref)
23+-- testCases <- mapM mkTestCase is
24+
25+-- let test (expected, ref) = do
26+-- actual <- readIORef ref
27+-- actual `shouldBe` (expected :: Int)
28+-- threadDelay 100000
29+-- mapM_ test testCases
30+-- [] <- reaperRead reaper
31+-- return ()
23
32
24− let mkTestCase i = do
33+-- type Item = (Int, IORef Int)
25− ref <- newIORef 0
26− let expected = (abs i `mod` 10) + 1
27− reaperAdd reaper (expected, ref)
28− return (expected, ref)
29− testCases <- mapM mkTestCase is
30
34
31− let test (expected, ref) = do
35+-- action = mkListAction $ \(i, ref) -> do
32− actual <- readIORef ref
36+-- modifyIORef ref succ
33− actual `shouldBe` (expected :: Int)
34− threadDelay 100000
35− mapM_ test testCases
36− [] <- reaperRead reaper
37− return ()
37+-- return $ if i > 1
38+-- then Just (pred i, ref)
39+-- else Nothing