@@ -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