auto-update 0.1.5 → 0.1.6

raw patch · 8 files changed

+328/−62 lines, 8 filesdep +HUnitdep +auto-updatedep +exceptionsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, auto-update, exceptions, hspec, retry

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Control/Debounce.hs +19/−53
• Control/Debounce/Internal.hs +98/−0
• auto-update.cabal +11/−9
• test/Control/AutoUpdateSpec.hs +35/−0
• test/Control/DebounceSpec.hs +120/−0
• test/Control/ReaperSpec.hs +39/−0
• test/Spec.hs +1/−0

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

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

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

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

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

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

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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}