1{-# LANGUAGE ScopedTypeVariables #-}
2module Control.DebounceSpec (spec) where
3
4import Control.Concurrent
5import Control.Debounce
6import qualified Control.Debounce.Internal as DI
7import Control.Monad
8import Control.Monad.Catch
9import Control.Retry
10import Data.IORef
11import Test.HUnit.Lang
12import Test.Hspec
13
14spec :: Spec
15spec = 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
81getWaitAction :: IO (p -> IO (), IO ())
82getWaitAction = 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
89getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())
90getDebounce 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)
107pause :: IO ()
108pause = threadDelay 100000
109
110waitForBatonToBeTaken :: MVar () -> IO ()
111waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)
112
113-- | Wait up to n seconds for an action to complete without throwing an HUnitFailure
114waitUntil :: Int -> IO a -> IO ()
115waitUntil 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
119main :: IO ()
120main = hspec spec
121