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