summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2019-07-09 07:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-09 07:41:00 (GMT)
commitee794e5f0d16d01dea0b98c840b903c6a14b1439 (patch)
tree2ada3f6e1b6e6b93467b7c9c3dc73628d40cb498
parentd77f8792f1ab443b8e89c486441fee21ed1f3e7d (diff)
version 0.1.6HEAD0.1.6master
-rw-r--r--ChangeLog.md5
-rw-r--r--Control/Debounce.hs72
-rw-r--r--Control/Debounce/Internal.hs98
-rw-r--r--auto-update.cabal20
-rw-r--r--test/Control/AutoUpdateSpec.hs35
-rw-r--r--test/Control/DebounceSpec.hs120
-rw-r--r--test/Control/ReaperSpec.hs39
-rw-r--r--test/Spec.hs1
8 files changed, 328 insertions, 62 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 087d76d..7a0a8ab 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,10 @@
# ChangeLog for auto-update
+## 0.1.6
+
+* Add control of activation on leading vs. trailing edges for Control.Debounce
+ [#756](https://github.com/yesodweb/wai/pull/756)
+
## 0.1.5
* Using the Strict and StrictData language extensions for GHC >8.
diff --git a/Control/Debounce.hs b/Control/Debounce.hs
index e2a2ce6..ce3cb46 100644
--- a/Control/Debounce.hs
+++ b/Control/Debounce.hs
@@ -11,6 +11,7 @@
-- printString <- 'mkDebounce' 'defaultDebounceSettings'
-- { 'debounceAction' = putStrLn "Running action"
-- , 'debounceFreq' = 5000000 -- 5 seconds
+-- , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge
-- }
-- @
--
@@ -25,70 +26,35 @@
-- @since 0.1.2
module Control.Debounce
( -- * Type
- DebounceSettings
+ DI.DebounceSettings
, defaultDebounceSettings
-- * Accessors
- , debounceFreq
- , debounceAction
+ , DI.debounceFreq
+ , DI.debounceAction
+ , DI.debounceEdge
+ , DI.leadingEdge
+ , DI.trailingEdge
-- * Creation
, mkDebounce
) where
-import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
-import Control.Exception (SomeException, handle, mask_)
-import Control.Monad (forever, void)
-
--- | Settings to control how debouncing should work.
---
--- This should be constructed using 'defaultDebounceSettings' and record
--- update syntax, e.g.:
---
--- @
--- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
--- @
---
--- @since 0.1.2
-data DebounceSettings = DebounceSettings
- { debounceFreq :: Int
- -- ^ Microseconds lag required between subsequence calls to the debounced
- -- action.
- --
- -- Default: 1 second (1000000)
- --
- -- @since 0.1.2
- , debounceAction :: IO ()
- -- ^ Action to be performed.
- --
- -- Note: all exceptions thrown by this action will be silently discarded.
- --
- -- Default: does nothing.
- --
- -- @since 0.1.2
- }
+import Control.Concurrent (newEmptyMVar, threadDelay)
+import qualified Control.Debounce.Internal as DI
-- | Default value for creating a 'DebounceSettings'.
--
-- @since 0.1.2
-defaultDebounceSettings :: DebounceSettings
-defaultDebounceSettings = DebounceSettings
- { debounceFreq = 1000000
- , debounceAction = return ()
+defaultDebounceSettings :: DI.DebounceSettings
+defaultDebounceSettings = DI.DebounceSettings
+ { DI.debounceFreq = 1000000
+ , DI.debounceAction = return ()
+ , DI.debounceEdge = DI.leadingEdge
}
--- | Generate an action which will trigger the debounced action to be
--- performed. The action will either be performed immediately, or after the
--- current cooldown period has expired.
+-- | Generate an action which will trigger the debounced action to be performed.
--
-- @since 0.1.2
-mkDebounce :: DebounceSettings -> IO (IO ())
-mkDebounce (DebounceSettings freq action) = do
- baton <- newEmptyMVar
- mask_ $ void $ forkIO $ forever $ do
- takeMVar baton
- ignoreExc action
- threadDelay freq
- return $ void $ tryPutMVar baton ()
-
-ignoreExc :: IO () -> IO ()
-ignoreExc = handle $ \(_ :: SomeException) -> return ()
+mkDebounce :: DI.DebounceSettings -> IO (IO ())
+mkDebounce settings = do
+ baton <- newEmptyMVar
+ DI.mkDebounceInternal baton threadDelay settings
diff --git a/Control/Debounce/Internal.hs b/Control/Debounce/Internal.hs
new file mode 100644
index 0000000..1cdb970
--- /dev/null
+++ b/Control/Debounce/Internal.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Unstable API which exposes internals for testing.
+module Control.Debounce.Internal (
+ DebounceSettings(..)
+ , DebounceEdge(..)
+ , leadingEdge
+ , trailingEdge
+ , mkDebounceInternal
+ ) where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (takeMVar, tryPutMVar, tryTakeMVar, MVar)
+import Control.Exception (SomeException, handle, mask_)
+import Control.Monad (forever, void)
+
+-- | Settings to control how debouncing should work.
+--
+-- This should be constructed using 'defaultDebounceSettings' and record
+-- update syntax, e.g.:
+--
+-- @
+-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
+-- @
+--
+-- @since 0.1.2
+data DebounceSettings = DebounceSettings
+ { debounceFreq :: Int
+ -- ^ Length of the debounce timeout period in microseconds.
+ --
+ -- Default: 1 second (1000000)
+ --
+ -- @since 0.1.2
+ , debounceAction :: IO ()
+ -- ^ Action to be performed.
+ --
+ -- Note: all exceptions thrown by this action will be silently discarded.
+ --
+ -- Default: does nothing.
+ --
+ -- @since 0.1.2
+ , debounceEdge :: DebounceEdge
+ -- ^ Whether to perform the action on the leading edge or trailing edge of
+ -- the timeout.
+ --
+ -- Default: 'trailingEdge'.
+ --
+ -- @since 0.1.6
+ }
+
+-- | Setting to control whether the action happens at the leading and/or trailing
+-- edge of the timeout.
+--
+-- @since 0.1.6
+data DebounceEdge =
+ Leading
+ -- ^ Perform the action immediately, and then begin a cooldown period.
+ -- If the trigger happens again during the cooldown, wait until the end of the cooldown
+ -- and then perform the action again, then enter a new cooldown period.
+ | Trailing
+ -- ^ Start a cooldown period and perform the action when the period ends. If another trigger
+ -- happens during the cooldown, it has no effect.
+ deriving (Show, Eq)
+
+
+-- | Perform the action immediately, and then begin a cooldown period.
+-- If the trigger happens again during the cooldown, wait until the end of the cooldown
+-- and then perform the action again, then enter a new cooldown period.
+--
+-- @since 0.1.6
+leadingEdge :: DebounceEdge
+leadingEdge = Leading
+
+-- | Start a cooldown period and perform the action when the period ends. If another trigger
+-- happens during the cooldown, it has no effect.
+--
+-- @since 0.1.6
+trailingEdge :: DebounceEdge
+trailingEdge = Trailing
+
+mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
+mkDebounceInternal baton delayFn (DebounceSettings freq action edge) = do
+ mask_ $ void $ forkIO $ forever $ do
+ takeMVar baton
+ case edge of
+ Leading -> do
+ ignoreExc action
+ delayFn freq
+ Trailing -> do
+ delayFn freq
+ -- Empty the baton of any other activations during the interval
+ void $ tryTakeMVar baton
+ ignoreExc action
+
+ return $ void $ tryPutMVar baton ()
+
+ignoreExc :: IO () -> IO ()
+ignoreExc = handle $ \(_ :: SomeException) -> return ()
diff --git a/auto-update.cabal b/auto-update.cabal
index 4fe1f90..136e2cd 100644
--- a/auto-update.cabal
+++ b/auto-update.cabal
@@ -1,5 +1,5 @@
name: auto-update
-version: 0.1.5
+version: 0.1.6
synopsis: Efficiently run periodic, on-demand actions
description: API docs and the README are available at <http://www.stackage.org/package/auto-update>.
homepage: https://github.com/yesodweb/wai
@@ -17,6 +17,7 @@ library
ghc-options: -Wall
exposed-modules: Control.AutoUpdate
Control.Debounce
+ Control.Debounce.Internal
Control.Reaper
other-modules: Control.AutoUpdate.Util
build-depends: base >= 4 && < 5
@@ -26,11 +27,12 @@ library
-- Test suite is currently not robust enough, gives too many false negatives.
--- test-suite spec
--- main-is: Spec.hs
--- other-modules: Control.AutoUpdateSpec
--- Control.ReaperSpec
--- hs-source-dirs: test
--- type: exitcode-stdio-1.0
--- build-depends: base, auto-update, hspec
--- default-language: Haskell2010
+test-suite spec
+ main-is: Spec.hs
+ other-modules: Control.AutoUpdateSpec
+ Control.DebounceSpec
+ Control.ReaperSpec
+ hs-source-dirs: test
+ type: exitcode-stdio-1.0
+ build-depends: base, auto-update, exceptions, hspec, retry, HUnit
+ default-language: Haskell2010
diff --git a/test/Control/AutoUpdateSpec.hs b/test/Control/AutoUpdateSpec.hs
new file mode 100644
index 0000000..99b3d90
--- /dev/null
+++ b/test/Control/AutoUpdateSpec.hs
@@ -0,0 +1,35 @@
+module Control.AutoUpdateSpec (spec) where
+
+import Control.AutoUpdate
+import Control.Concurrent (threadDelay)
+import Control.Monad (replicateM_, forM_)
+import Data.IORef
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+spec :: Spec
+spec = return ()
+ -- do
+ -- prop "incrementer" $ \st' -> do
+ -- let st = abs st' `mod` 10000
+ -- ref <- newIORef 0
+ -- next <- mkAutoUpdate defaultUpdateSettings
+ -- { updateAction = atomicModifyIORef ref $ \i ->
+ -- let i' = succ i in i' `seq` (i', i')
+ -- , updateSpawnThreshold = st
+ -- , updateFreq = 10000
+ -- }
+
+ -- forM_ [1..st + 1] $ \i -> do
+ -- j <- next
+ -- j `shouldBe` i
+
+ -- replicateM_ 50 $ do
+ -- i <- next
+ -- i `shouldBe` st + 2
+
+ -- threadDelay 60000
+ -- last1 <- readIORef ref
+ -- threadDelay 20000
+ -- last2 <- readIORef ref
+ -- last2 `shouldBe` last1
diff --git a/test/Control/DebounceSpec.hs b/test/Control/DebounceSpec.hs
new file mode 100644
index 0000000..ec9dcc2
--- /dev/null
+++ b/test/Control/DebounceSpec.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Control.DebounceSpec (spec) where
+
+import Control.Concurrent
+import Control.Debounce
+import qualified Control.Debounce.Internal as DI
+import Control.Monad
+import Control.Monad.Catch
+import Control.Retry
+import Data.IORef
+import Test.HUnit.Lang
+import Test.Hspec
+
+spec :: Spec
+spec = describe "mkDebounce" $ do
+ describe "Leading edge" $ do
+ it "works for a single event" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
+
+ debounced
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 1)
+
+ -- Try another round
+ debounced
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 2)
+
+ it "works for multiple events" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge
+
+ debounced
+ waitForBatonToBeTaken baton
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ pause
+ readIORef ref >>= (`shouldBe` 2)
+
+ describe "Trailing edge" $ do
+ it "works for a single event" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
+
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ -- Try another round
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)
+
+ it "works for multiple events" $ do
+ (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge
+
+ debounced
+ waitForBatonToBeTaken baton
+ debounced
+ pause
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)
+
+ returnFromWait
+ waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)
+
+
+-- | Make a controllable delay function
+getWaitAction :: IO (p -> IO (), IO ())
+getWaitAction = do
+ waitVar <- newEmptyMVar
+ let waitAction _ = takeMVar waitVar
+ let returnFromWait = putMVar waitVar ()
+ return (waitAction, returnFromWait)
+
+-- | Get a debounce system with access to the internals for testing
+getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())
+getDebounce edge = do
+ ref :: IORef Int <- newIORef 0
+ let action = modifyIORef ref (+ 1)
+
+ (waitAction, returnFromWait) <- getWaitAction
+
+ baton <- newEmptyMVar
+
+ debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {
+ debounceFreq = 5000000 -- unused
+ , debounceAction = action
+ , debounceEdge = edge
+ }
+
+ return (ref, debounced, baton, returnFromWait)
+
+-- | Pause briefly (100ms)
+pause :: IO ()
+pause = threadDelay 100000
+
+waitForBatonToBeTaken :: MVar () -> IO ()
+waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)
+
+-- | Wait up to n seconds for an action to complete without throwing an HUnitFailure
+waitUntil :: Int -> IO a -> IO ()
+waitUntil n action = recovering policy [handler] (\_status -> void action)
+ where policy = constantDelay 1000 `mappend` limitRetries (n * 1000) -- 1ms * n * 1000 tries = n seconds
+ handler _status = Handler (\(HUnitFailure {}) -> return True)
+
+main :: IO ()
+main = hspec spec
diff --git a/test/Control/ReaperSpec.hs b/test/Control/ReaperSpec.hs
new file mode 100644
index 0000000..ff55d67
--- /dev/null
+++ b/test/Control/ReaperSpec.hs
@@ -0,0 +1,39 @@
+module Control.ReaperSpec (spec) where
+
+import Control.Concurrent
+import Control.Reaper
+import Data.IORef
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+
+spec :: Spec
+spec = return ()
+-- prop "works" $ \is -> do
+-- reaper <- mkReaper defaultReaperSettings
+-- { reaperAction = action
+-- , reaperDelay = 1000
+-- }
+
+-- let mkTestCase i = do
+-- ref <- newIORef 0
+-- let expected = (abs i `mod` 10) + 1
+-- reaperAdd reaper (expected, ref)
+-- return (expected, ref)
+-- testCases <- mapM mkTestCase is
+
+-- let test (expected, ref) = do
+-- actual <- readIORef ref
+-- actual `shouldBe` (expected :: Int)
+-- threadDelay 100000
+-- mapM_ test testCases
+-- [] <- reaperRead reaper
+-- return ()
+
+-- type Item = (Int, IORef Int)
+
+-- action = mkListAction $ \(i, ref) -> do
+-- modifyIORef ref succ
+-- return $ if i > 1
+-- then Just (pred i, ref)
+-- else Nothing
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}