@@ -0,0 +1,120 @@
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.Retry
10+import Data.IORef
11+import Test.HUnit.Lang
12+import Test.Hspec
13+
14+spec :: Spec
15+spec = describe "mkDebounce" $ do
16+ describe "Leading edge" $ do
17+ it "works for a single event" $ do
18+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
19+
20+ debounced
21+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
22+
23+ returnFromWait
24+ pause
25+ readIORef ref >>= (`shouldBe` 1)
26+
27+ -- Try another round
28+ debounced
29+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
30+
31+ returnFromWait
32+ pause
33+ readIORef ref >>= (`shouldBe` 2)
34+
35+ it "works for multiple events" $ do
36+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
37+
38+ debounced
39+ waitForBatonToBeTaken baton
40+ debounced
41+ pause
42+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
43+
44+ returnFromWait
45+ pause
46+ readIORef ref >>= (`shouldBe` 2)
47+
48+ describe "Trailing edge" $ do
49+ it "works for a single event" $ do
50+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
51+
52+ debounced
53+ pause
54+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
55+
56+ returnFromWait
57+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
58+
59+ -- Try another round
60+ debounced
61+ pause
62+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
63+
64+ returnFromWait
65+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
66+
67+ it "works for multiple events" $ do
68+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
69+
70+ debounced
71+ waitForBatonToBeTaken baton
72+ debounced
73+ pause
74+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
75+
76+ returnFromWait
77+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
78+
79+
80+-- | Make a controllable delay function
81+getWaitAction :: IO (p -> IO (), IO ())
82+getWaitAction = do
83+ waitVar <- newEmptyMVar
84+ let waitAction _ = takeMVar waitVar
85+ let returnFromWait = putMVar waitVar ()
86+ return (waitAction, returnFromWait)
87+
88+-- | Get a debounce system with access to the internals for testing
89+getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())
90+getDebounce edge = do
91+ ref :: IORef Int <- newIORef 0
92+ let action = modifyIORef ref (+ 1)
93+
94+ (waitAction, returnFromWait) <- getWaitAction
95+
96+ baton <- newEmptyMVar
97+
98+ debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {
99+ debounceFreq = 5000000 -- unused
100+ , debounceAction = action
101+ , debounceEdge = edge
102+ }
103+
104+ return (ref, debounced, baton, returnFromWait)
105+
106+-- | Pause briefly (100ms)
107+pause :: IO ()
108+pause = threadDelay 100000
109+
110+waitForBatonToBeTaken :: MVar () -> IO ()
111+waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)
112+
113+-- | Wait up to n seconds for an action to complete without throwing an HUnitFailure
114+waitUntil :: Int -> IO a -> IO ()
115+waitUntil n action = recovering policy [handler] (\_status -> void action)
116+ where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds
117+ handler _status = Handler (\(HUnitFailure {}) -> return True)
118+
119+main :: IO ()
120+main = hspec spec