packages feed

auto-update 0.1.6 → 0.2.6

raw patch · 16 files changed

Files

ChangeLog.md view
@@ -1,14 +1,56 @@ # ChangeLog for auto-update +## 0.2.6++* Using the thread version of AutoUpdate for non-threaded RTS.+  [#1020](https://github.com/yesodweb/wai/pull/1020)++## 0.2.5++* Thread less autoupdate+  [#1018](https://github.com/yesodweb/wai/pull/1018)++## 0.2.4++* Simple refactoring.++## 0.2.3++* [#996](https://github.com/yesodweb/wai/pull/996):+  Refactored the `Control.Debounce` logic to not leak threads.+* [#996](https://github.com/yesodweb/wai/pull/996):+  Added extra `DebounceEdge` options for different types of debouncing.+  * `LeadingMute`: Action on first trigger, and ignore any triggers during cooldown+  * `TrailingDelay`: First trigger starts cooldown, and+    triggers during cooldown extend the cooldown. Action when cooldown expires.++## 0.2.2++* NewAPI: updateThreadName, reaperThreadName, debounceThreadName:+  Names can be given via this field to threads+  for GHC.Conc.Sync.listThreads.++## 0.2.1++* Labeling threads.++## 0.2.0++* Creating Reaper.Internal to export Reaper constructor.+* Hiding Reaper constructor.+* [#985](https://github.com/yesodweb/wai/pull/985):+  Add `reaperModify` to the `Reaper` API, allowing workload modification outside+  of the main `reaperAction` loop.+ ## 0.1.6 -* Add control of activation on leading vs. trailing edges for Control.Debounce-  [#756](https://github.com/yesodweb/wai/pull/756)+* [#756](https://github.com/yesodweb/wai/pull/756):+  Add control of activation on leading vs. trailing edges for Control.Debounce  ## 0.1.5 -* Using the Strict and StrictData language extensions for GHC >8.-  [#752](https://github.com/yesodweb/wai/pull/752)+* [#752](https://github.com/yesodweb/wai/pull/752):+  Using the Strict and StrictData language extensions for GHC >8.  ## 0.1.4.1
Control/AutoUpdate.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-}--- | In a multithreaded environment, running actions on a regularly scheduled--- background thread can dramatically improve performance.++-- | In a multithreaded environment, sharing results of actions can dramatically improve performance. -- For example, web servers need to return the current time with each HTTP response. -- For a high-volume server, it's much faster for a dedicated thread to run every -- second, and write the current time to a shared 'IORef', than it is for each -- request to make its own call to 'getCurrentTime'. ----- But for a low-volume server, whose request frequency is less than once per --- second, that approach will result in /more/ calls to 'getCurrentTime' than +-- But for a low-volume server, whose request frequency is less than once per+-- second, that approach will result in /more/ calls to 'getCurrentTime' than -- necessary, and worse, kills idle GC. -- -- This library solves that problem by allowing you to define actions which will--- either be performed by a dedicated thread, or, in times of low volume, will +-- either be performed by a dedicated thread, or, in times of low volume, will -- be executed by the calling thread. -- -- Example usage:@@ -29,173 +29,42 @@ -- -- For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing this library>. module Control.AutoUpdate (-      -- * Type-      UpdateSettings-    , defaultUpdateSettings-      -- * Accessors-    , updateAction-    , updateFreq-    , updateSpawnThreshold-      -- * Creation-    , mkAutoUpdate-    , mkAutoUpdateWithModify-    ) where+    -- * Type+    UpdateSettings,+    defaultUpdateSettings, -#if __GLASGOW_HASKELL__ < 709-import           Control.Applicative     ((<*>))-#endif-import           Control.Concurrent      (forkIO, threadDelay)-import           Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,-                                          takeMVar, tryPutMVar)-import           Control.Exception       (SomeException, catch, mask_, throw,-                                          try)-import           Control.Monad           (void)-import           Data.IORef              (newIORef, readIORef, writeIORef)+    -- * Accessors+    updateAction,+    updateFreq,+    updateSpawnThreshold,+    updateThreadName, --- | Default value for creating an 'UpdateSettings'.------ @since 0.1.0-defaultUpdateSettings :: UpdateSettings ()-defaultUpdateSettings = UpdateSettings-    { updateFreq = 1000000-    , updateSpawnThreshold = 3-    , updateAction = return ()-    }+    -- * Creation+    mkAutoUpdate,+    mkAutoUpdateWithModify,+)+where --- | Settings to control how values are updated.------ This should be constructed using 'defaultUpdateSettings' and record--- update syntax, e.g.:------ @--- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }--- @------ @since 0.1.0-data UpdateSettings a = UpdateSettings-    { updateFreq           :: Int-    -- ^ Microseconds between update calls. Same considerations as-    -- 'threadDelay' apply.-    ---    -- Default: 1 second (1000000)-    ---    -- @since 0.1.0-    , updateSpawnThreshold :: Int-    -- ^ NOTE: This value no longer has any effect, since worker threads are-    -- dedicated instead of spawned on demand.-    ---    -- Previously, this determined how many times the data must be requested-    -- before we decide to spawn a dedicated thread.-    ---    -- Default: 3-    ---    -- @since 0.1.0-    , updateAction         :: IO a-    -- ^ Action to be performed to get the current value.-    ---    -- Default: does nothing.-    ---    -- @since 0.1.0-    }+import Control.AutoUpdate.Types+#ifdef mingw32_HOST_OS+import Control.AutoUpdate.Thread+#else+import qualified Control.AutoUpdate.Event as Event+import qualified Control.AutoUpdate.Thread as Thread --- | Generate an action which will either read from an automatically--- updated value, or run the update action in the current thread.------ @since 0.1.0+import GHC.Event+ mkAutoUpdate :: UpdateSettings a -> IO (IO a)-mkAutoUpdate us = mkAutoUpdateHelper us Nothing+mkAutoUpdate settings = do+    mmgr <- getSystemEventManager+    case mmgr of+      Nothing -> Thread.mkAutoUpdate settings+      Just _m -> Event.mkAutoUpdate settings --- | Generate an action which will either read from an automatically--- updated value, or run the update action in the current thread if--- the first time or the provided modify action after that.------ @since 0.1.4 mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)-mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)--mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)-mkAutoUpdateHelper us updateActionModify = do-    -- A baton to tell the worker thread to generate a new value.-    needsRunning <- newEmptyMVar--    -- The initial response variable. Response variables allow the requesting-    -- thread to block until a value is generated by the worker thread.-    responseVar0 <- newEmptyMVar--    -- The current value, if available. We start off with a Left value-    -- indicating no value is available, and the above-created responseVar0 to-    -- give a variable to block on.-    currRef <- newIORef $ Left responseVar0--    -- This is used to set a value in the currRef variable when the worker-    -- thread exits. In reality, that value should never be used, since the-    -- worker thread exiting only occurs if an async exception is thrown, which-    -- should only occur if there are no references to needsRunning left.-    -- However, this handler will make error messages much clearer if there's a-    -- bug in the implementation.-    let fillRefOnExit f = do-            eres <- try f-            case eres of-                Left e -> writeIORef currRef $ error $-                    "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "-                    ++ show (e :: SomeException)-                Right () -> writeIORef currRef $ error $-                    "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "-                    ++ "which should be impossible due to usage of infinite loop"--    -- fork the worker thread immediately. Note that we mask async exceptions,-    -- but *not* in an uninterruptible manner. This will allow a-    -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take-    -- down this thread when all references to the returned function are-    -- garbage collected, and therefore there is no thread that can fill the-    -- needsRunning MVar.-    ---    -- Note that since we throw away the ThreadId of this new thread and never-    -- calls myThreadId, normal async exceptions can never be thrown to it,-    -- only RTS exceptions.-    mask_ $ void $ forkIO $ fillRefOnExit $ do-        -- This infinite loop makes up out worker thread. It takes an a-        -- responseVar value where the next value should be putMVar'ed to for-        -- the benefit of any requesters currently blocked on it.-        let loop responseVar maybea = do-                -- block until a value is actually needed-                takeMVar needsRunning--                -- new value requested, so run the updateAction-                a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)--                -- we got a new value, update currRef and lastValue-                writeIORef currRef $ Right a-                putMVar responseVar a--                -- delay until we're needed again-                threadDelay $ updateFreq us--                -- delay's over. create a new response variable and set currRef-                -- to use it, so that the next requester will block on that-                -- variable. Then loop again with the updated response-                -- variable.-                responseVar' <- newEmptyMVar-                writeIORef currRef $ Left responseVar'-                loop responseVar' (Just a)--        -- Kick off the loop, with the initial responseVar0 variable.-        loop responseVar0 Nothing--    return $ do-        mval <- readIORef currRef-        case mval of-            Left responseVar -> do-                -- no current value, force the worker thread to run...-                void $ tryPutMVar needsRunning ()--                -- and block for the result from the worker-                readMVar responseVar-            -- we have a current value, use it-            Right val -> return val---- | Turn a runtime exception into an impure exception, so that all 'IO'--- actions will complete successfully. This simply defers the exception until--- the value is forced.-catchSome :: IO a -> IO a-catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)+mkAutoUpdateWithModify settings f = do+    mmgr <- getSystemEventManager+    case mmgr of+      Nothing -> Thread.mkAutoUpdateWithModify settings f+      Just _m -> Event.mkAutoUpdateWithModify settings f+#endif
+ Control/AutoUpdate/Event.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE RecordWildCards #-}++module Control.AutoUpdate.Event (+    -- * Creation+    mkAutoUpdate,+    mkAutoUpdateWithModify,++    -- * Internal+    UpdateState (..),+    mkClosableAutoUpdate,+    mkClosableAutoUpdate',+)+where++import Control.Concurrent.STM+import Control.Monad+import Data.IORef+import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout)++import Control.AutoUpdate.Types++--------------------------------------------------------------------------------++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread.+--+-- @since 0.1.0+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread if+-- the first time or the provided modify action after that.+--+-- @since 0.1.4+mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)+mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f++--------------------------------------------------------------------------------++{- FOURMOLU_DISABLE -}+data UpdateState a =+    UpdateState+    { usUpdateAction_   :: a -> IO a+    , usLastResult_     :: IORef a+    , usIntervalMicro_  :: Int+    , usTimeHasCome_    :: TVar Bool+    , usDeleteTimeout_  :: IORef (IO ())+    }+{- FOURMOLU_ENABLE -}++--------------------------------------------------------------------------------++mkAutoUpdateThings+    :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b+mkAutoUpdateThings mk settings@UpdateSettings{..} =+    mkAutoUpdateThingsWithModify mk settings (const updateAction)++mkAutoUpdateThingsWithModify+    :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> (a -> IO a) -> IO b+mkAutoUpdateThingsWithModify mk settings update1 = do+    us <- openUpdateState settings update1+    pure $ mk (getUpdateResult us) (closeUpdateState us) us++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -XNumericUnderscores+-- >>> import Control.Concurrent++-- |+-- >>> iref <- newIORef (0 :: Int)+-- >>> action = modifyIORef iref (+ 1) >> readIORef iref+-- >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action }+-- >>> getValue+-- 1+-- >>> threadDelay 100_000 >> getValue+-- 1+-- >>> threadDelay 200_000 >> getValue+-- 2+-- >>> closeState+mkClosableAutoUpdate :: UpdateSettings a -> IO (IO a, IO ())+mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c)++-- | provide `UpdateState` for debugging+mkClosableAutoUpdate' :: UpdateSettings a -> IO (IO a, IO (), UpdateState a)+mkClosableAutoUpdate' = mkAutoUpdateThings (,,)++--------------------------------------------------------------------------------++mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ())+mkDeleteTimeout thc micro = do+    mgr <- getSystemTimerManager+    key <- registerTimeout mgr micro (atomically $ writeTVar thc True)+    pure $ unregisterTimeout mgr key++openUpdateState :: UpdateSettings a -> (a -> IO a) -> IO (UpdateState a)+openUpdateState UpdateSettings{..} update1 = do+    thc <- newTVarIO False+    UpdateState update1+        <$> (newIORef =<< updateAction)+        <*> pure updateFreq+        <*> pure thc+        <*> (newIORef =<< mkDeleteTimeout thc updateFreq)++closeUpdateState :: UpdateState a -> IO ()+closeUpdateState UpdateState{..} = do+    delete <- readIORef usDeleteTimeout_+    delete++onceOnTimeHasCome :: UpdateState a -> IO () -> IO ()+onceOnTimeHasCome UpdateState{..} action = do+    action' <- atomically $ do+        timeHasCome <- readTVar usTimeHasCome_+        when timeHasCome $ writeTVar usTimeHasCome_ False+        pure $ when timeHasCome action+    action'++getUpdateResult :: UpdateState a -> IO a+getUpdateResult us@UpdateState{..} = do+    onceOnTimeHasCome us $ do+        writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_+        writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_+    readIORef usLastResult_
+ Control/AutoUpdate/Internal.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE RecordWildCards #-}++module Control.AutoUpdate.Internal (+    -- * Debugging+    UpdateState (..),+    mkClosableAutoUpdate,+    mkClosableAutoUpdate',+)+where++import Control.AutoUpdate.Event
+ Control/AutoUpdate/Thread.hs view
@@ -0,0 +1,133 @@+module Control.AutoUpdate.Thread (+    -- * Creation+    mkAutoUpdate,+    mkAutoUpdateWithModify,+) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (+    newEmptyMVar,+    putMVar,+    readMVar,+    takeMVar,+    tryPutMVar,+ )+import Control.Exception (+    SomeException,+    catch,+    mask_,+    throw,+    try,+ )+import Control.Monad (void)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import GHC.Conc.Sync (labelThread)++import Control.AutoUpdate.Types++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread.+--+-- @since 0.1.0+mkAutoUpdate :: UpdateSettings a -> IO (IO a)+mkAutoUpdate us = mkAutoUpdateHelper us Nothing++-- | Generate an action which will either read from an automatically+-- updated value, or run the update action in the current thread if+-- the first time or the provided modify action after that.+--+-- @since 0.1.4+mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)+mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)++mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a)+mkAutoUpdateHelper us updateActionModify = do+    -- A baton to tell the worker thread to generate a new value.+    needsRunning <- newEmptyMVar++    -- The initial response variable. Response variables allow the requesting+    -- thread to block until a value is generated by the worker thread.+    responseVar0 <- newEmptyMVar++    -- The current value, if available. We start off with a Left value+    -- indicating no value is available, and the above-created responseVar0 to+    -- give a variable to block on.+    currRef <- newIORef $ Left responseVar0++    -- This is used to set a value in the currRef variable when the worker+    -- thread exits. In reality, that value should never be used, since the+    -- worker thread exiting only occurs if an async exception is thrown, which+    -- should only occur if there are no references to needsRunning left.+    -- However, this handler will make error messages much clearer if there's a+    -- bug in the implementation.+    let fillRefOnExit f = do+            eres <- try f+            case eres of+                Left e ->+                    writeIORef currRef $+                        error $+                            "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "+                                ++ show (e :: SomeException)+                Right () ->+                    writeIORef currRef $+                        error $+                            "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "+                                ++ "which should be impossible due to usage of infinite loop"++    -- fork the worker thread immediately. Note that we mask async exceptions,+    -- but *not* in an uninterruptible manner. This will allow a+    -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take+    -- down this thread when all references to the returned function are+    -- garbage collected, and therefore there is no thread that can fill the+    -- needsRunning MVar.+    --+    -- Note that since we throw away the ThreadId of this new thread and never+    -- calls myThreadId, normal async exceptions can never be thrown to it,+    -- only RTS exceptions.+    tid <- mask_ $ forkIO $ fillRefOnExit $ do+        -- This infinite loop makes up out worker thread. It takes an a+        -- responseVar value where the next value should be putMVar'ed to for+        -- the benefit of any requesters currently blocked on it.+        let loop responseVar maybea = do+                -- block until a value is actually needed+                takeMVar needsRunning++                -- new value requested, so run the updateAction+                a <- catchSome $ fromMaybe (updateAction us) (updateActionModify <*> maybea)++                -- we got a new value, update currRef and lastValue+                writeIORef currRef $ Right a+                putMVar responseVar a++                -- delay until we're needed again+                threadDelay $ updateFreq us++                -- delay's over. create a new response variable and set currRef+                -- to use it, so that the next requester will block on that+                -- variable. Then loop again with the updated response+                -- variable.+                responseVar' <- newEmptyMVar+                writeIORef currRef $ Left responseVar'+                loop responseVar' (Just a)++        -- Kick off the loop, with the initial responseVar0 variable.+        loop responseVar0 Nothing+    labelThread tid $ updateThreadName us+    return $ do+        mval <- readIORef currRef+        case mval of+            Left responseVar -> do+                -- no current value, force the worker thread to run...+                void $ tryPutMVar needsRunning ()++                -- and block for the result from the worker+                readMVar responseVar+            -- we have a current value, use it+            Right val -> return val++-- | Turn a runtime exception into an impure exception, so that all 'IO'+-- actions will complete successfully. This simply defers the exception until+-- the value is forced.+catchSome :: IO a -> IO a+catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException)
+ Control/AutoUpdate/Types.hs view
@@ -0,0 +1,49 @@+module Control.AutoUpdate.Types where++-- | Settings to control how values are updated.+--+-- This should be constructed using 'defaultUpdateSettings' and record+-- update syntax, e.g.:+--+-- @+-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' }+-- @+--+-- @since 0.1.0+data UpdateSettings a = UpdateSettings+    { updateFreq :: Int+    -- ^ Microseconds between update calls. Same considerations as+    -- 'threadDelay' apply.+    --+    -- Default: 1000000 microseconds (1 second)+    --+    -- @since 0.1.0+    , updateSpawnThreshold :: Int+    -- ^ Obsoleted field.+    --+    -- @since 0.1.0+    , updateAction :: IO a+    -- ^ Action to be performed to get the current value.+    --+    -- Default: does nothing.+    --+    -- @since 0.1.0+    , updateThreadName :: String+    -- ^ Label of the thread being forked.+    --+    -- Default: @"AutoUpdate"@+    --+    -- @since 0.2.2+    }++-- | Default value for creating an 'UpdateSettings'.+--+-- @since 0.1.0+defaultUpdateSettings :: UpdateSettings ()+defaultUpdateSettings =+    UpdateSettings+        { updateFreq = 1000000+        , updateSpawnThreshold = 3+        , updateAction = return ()+        , updateThreadName = "AutoUpdate"+        }
− Control/AutoUpdate/Util.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE CPP #-}-module Control.AutoUpdate.Util-    ( atomicModifyIORef'-    ) where--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#if MIN_VERSION_base(4,6,0)-import           Data.IORef         (atomicModifyIORef')-#else-import           Data.IORef         (IORef, atomicModifyIORef)--- | Strict version of 'atomicModifyIORef'.  This forces both the value stored--- in the 'IORef' as well as the value returned.-atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef' ref f = do-    c <- atomicModifyIORef ref-            (\x -> let (a, b) = f x    -- Lazy application of "f"-                    in (a, a `seq` b)) -- Lazy application of "seq"-    -- The following forces "a `seq` b", so it also forces "f x".-    c `seq` return c-#endif
Control/Debounce.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} -- | Debounce an action, ensuring it doesn't occur more than once for a given -- period of time. --@@ -8,53 +7,64 @@ -- Example usage: -- -- @--- printString <- 'mkDebounce' 'defaultDebounceSettings'+-- > printString <- 'mkDebounce' 'defaultDebounceSettings' --                  { 'debounceAction' = putStrLn "Running action" --                  , 'debounceFreq' = 5000000 -- 5 seconds --                  , 'debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge --                  }--- @------ >>> printString+-- > printString -- Running action--- >>> printString--- <Wait five seconds>+-- > printString+-- \<Wait five seconds> -- Running action+-- @ -- -- See the fast-logger package ("System.Log.FastLogger") for real-world usage. -- -- @since 0.1.2-module Control.Debounce-    ( -- * Type-      DI.DebounceSettings-    , defaultDebounceSettings-      -- * Accessors-    , DI.debounceFreq-    , DI.debounceAction-    , DI.debounceEdge-    , DI.leadingEdge-    , DI.trailingEdge-      -- * Creation-    , mkDebounce-    ) where+module Control.Debounce (+    -- * Creation+    mkDebounce, -import           Control.Concurrent      (newEmptyMVar, threadDelay)+    -- * Settings+    DI.DebounceSettings,+    defaultDebounceSettings,++    -- ** Accessors+    DI.debounceFreq,+    DI.debounceAction,+    DI.debounceEdge,+    DI.debounceThreadName,++    -- ** Edge types+    DI.leadingEdge,+    DI.leadingMuteEdge,+    DI.trailingEdge,+    DI.trailingDelayEdge,+) where++import Control.Concurrent (newMVar, threadDelay) import qualified Control.Debounce.Internal as DI  -- | Default value for creating a 'DebounceSettings'. -- -- @since 0.1.2 defaultDebounceSettings :: DI.DebounceSettings-defaultDebounceSettings = DI.DebounceSettings-    { DI.debounceFreq = 1000000-    , DI.debounceAction = return ()-    , DI.debounceEdge = DI.leadingEdge-    }+defaultDebounceSettings =+    DI.DebounceSettings+        { DI.debounceFreq = 1000000+        , DI.debounceAction = return ()+        , DI.debounceEdge = DI.leadingEdge+        , DI.debounceThreadName = "Debounce"+        }  -- | Generate an action which will trigger the debounced action to be performed. --+-- /N.B. The generated action will always immediately return, regardless of the 'debounceFreq',/+-- /as the debounced action (and the delay\/cooldown) is always performed in a separate thread./+-- -- @since 0.1.2 mkDebounce :: DI.DebounceSettings -> IO (IO ()) mkDebounce settings = do-  baton <- newEmptyMVar-  DI.mkDebounceInternal baton threadDelay settings+    baton <- newMVar ()+    DI.mkDebounceInternal baton threadDelay settings
Control/Debounce/Internal.hs view
@@ -2,17 +2,28 @@  -- | Unstable API which exposes internals for testing. module Control.Debounce.Internal (-  DebounceSettings(..)-  , DebounceEdge(..)-  , leadingEdge-  , trailingEdge-  , mkDebounceInternal-  ) where+    DebounceSettings (..),+    DebounceEdge (..),+    leadingEdge,+    leadingMuteEdge,+    trailingEdge,+    trailingDelayEdge,+    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)+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (+    MVar,+    newEmptyMVar,+    putMVar,+    tryPutMVar,+    tryTakeMVar,+ )+import Control.Exception (SomeException, handle, mask_)+import Control.Monad (void, when)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Conc (atomically, newTVarIO, readTVar, readTVarIO, writeTVar)+import GHC.Conc.Sync (labelThread)  -- | Settings to control how debouncing should work. --@@ -25,7 +36,7 @@ -- -- @since 0.1.2 data DebounceSettings = DebounceSettings-    { debounceFreq   :: Int+    { debounceFreq :: Int     -- ^ Length of the debounce timeout period in microseconds.     --     -- Default: 1 second (1000000)@@ -43,56 +54,244 @@     -- ^ Whether to perform the action on the leading edge or trailing edge of     -- the timeout.     ---    -- Default: 'trailingEdge'.+    -- Default: 'leadingEdge'.     --     -- @since 0.1.6+    , debounceThreadName :: String+    -- ^ Label of the thread spawned when debouncing.+    --+    -- Default: @"Debounce"@.+    --+    -- @since 0.2.2     }  -- | 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)-+data DebounceEdge+    = -- | 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.+      Leading+    | -- | Perform the action immediately, and then begin a cooldown period.+      -- If the trigger happens again during the cooldown, it is ignored.+      LeadingMute+    | -- | Start a cooldown period and perform the action when the period ends. If another trigger+      -- happens during the cooldown, it has no effect.+      Trailing+    | -- | Start a cooldown period and perform the action when the period ends. If another trigger+      -- happens during the cooldown, it restarts the cooldown again.+      TrailingDelay+    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. --+-- Example of how this style debounce works:+--+-- > ! = function execution+-- > . = cooldown period+-- > X = debounced code execution+-- >+-- > !   !         !            !+-- >  ....... ....... .......    .......+-- > X       X       X          X+-- -- @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.+-- | Perform the action immediately, and then begin a cooldown period.+-- If the trigger happens again during the cooldown, it is ignored. --+-- Example of how this style debounce works:+--+-- > ! = function execution+-- > . = cooldown period+-- > X = debounced code execution+-- >+-- > !   !      !     !+-- >  .......    .......+-- > X          X+-- -- @since 0.1.6+leadingMuteEdge :: DebounceEdge+leadingMuteEdge = LeadingMute++-- | Start a cooldown period and perform the action when the period ends.+-- If another trigger happens during the cooldown, it has no effect.+--+-- Example of how this style debounce works:+--+-- @+-- ! = function execution+-- . = cooldown period+-- X = debounced code execution+--+-- !     !     !  !+--  .......     .......+--         X           X+-- @+--+-- @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+-- | Start a cooldown period and perform the action when the period ends.+-- If another trigger happens during the cooldown, it restarts the cooldown again.+--+-- /N.B. If a trigger happens DURING the 'debounceAction' it starts a new cooldown./+-- /So if the 'debounceAction' takes longer than the 'debounceFreq', it might run/+-- /again before the previous action has ended./+--+-- Example of how this style debounce works:+--+-- @+-- ! = function execution+-- . = cooldown period+-- X = debounced code execution+--+-- !           !  !    !+--  .......     ...............+--         X                   X+-- @+--+-- @since 0.1.6+trailingDelayEdge :: DebounceEdge+trailingDelayEdge = TrailingDelay++mkDebounceInternal+    :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())+mkDebounceInternal baton delayFn (DebounceSettings freq action edge name) =+    case edge of+        Leading -> leadingDebounce <$> newEmptyMVar+        LeadingMute -> pure leadingMuteDebounce+        Trailing -> pure trailingDebounce+        TrailingDelay -> trailingDelayDebounce <$> newTVarIO minBound+  where+    -- LEADING+    --+    --   1) try take baton to start+    --   2) succes -> empty trigger & start worker, failed -> fill trigger+    --   3) worker do action+    --   4) delay+    --   5) try take trigger+    --   6) success -> repeat action, failed -> put baton back+    leadingDebounce trigger = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> void $ tryPutMVar trigger ()+            Just () -> do+                void $ tryTakeMVar trigger+                forkAndLabel loop+      where+        loop = do+            -- 3)             ignoreExc action-            delayFn freq-          Trailing -> do+            -- 4)             delayFn freq-            -- Empty the baton of any other activations during the interval-            void $ tryTakeMVar baton-            ignoreExc action--    return $ void $ tryPutMVar baton ()+            -- 5)+            isTriggered <- tryTakeMVar trigger+            case isTriggered of+                -- 6)+                Nothing -> putMVar baton ()+                Just () -> loop+    -- LEADING MUTE+    --+    --   1) try take baton to start+    --   2) success -> start worker, failed -> die+    --   3) worker delay+    --   4) do action+    --   5) put baton back+    leadingMuteDebounce = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> pure ()+            Just () ->+                forkAndLabel $ do+                    -- 3)+                    ignoreExc action+                    -- 4)+                    delayFn freq+                    -- 5)+                    putMVar baton ()+    -- TRAILING+    --+    --   1) try take baton to start+    --   2) success -> start worker, failed -> die+    --   3) worker delay+    --   4) do action+    --   5) put baton back+    trailingDebounce = do+        -- 1)+        success <- tryTakeMVar baton+        case success of+            -- 2)+            Nothing -> pure ()+            Just () ->+                forkAndLabel $ do+                    -- 3)+                    delayFn freq+                    -- 4)+                    ignoreExc action+                    -- 5)+                    putMVar baton ()+        -- TRAILING DELAY+        --+        --   1) get current time -> /now/+        --   2) try take baton to start+        --   3) success -> set time var to /now/ & start worker, failed -> update time var to /now/+        --   4) worker waits minimum delay+        --   5) check diff of time var with /now/+        --   6) less -> wait the difference, same/more -> do action+        --   7) after action, recheck if there was any trigger+        --   8) put baton back+    trailingDelayDebounce timeTVar = do+        -- 1)+        now <- getMonotonicTimeNSec+        -- 2)+        success <- tryTakeMVar baton+        case success of+            -- 3)+            Nothing -> atomically $ do+                oldTime <- readTVar timeTVar+                when (oldTime < now) $ writeTVar timeTVar now+            Just () -> do+                atomically $ writeTVar timeTVar now+                forkAndLabel $ loop freq+      where+        loop delay = do+            -- 4)+            delayFn delay+            lastTrigger <- readTVarIO timeTVar+            now <- getMonotonicTimeNSec+            -- 5)+            let diff = fromIntegral (now - lastTrigger) `div` 1000+                shouldWait = diff < freq+            if shouldWait+                -- 6)+                then loop $ freq - diff+                else do+                    ignoreExc action+                    timeAfterAction <- readTVarIO timeTVar+                    -- 7)+                    let wasTriggered = timeAfterAction > now+                    if wasTriggered+                        then do+                            updatedNow <- getMonotonicTimeNSec+                            let newDiff = fromIntegral (updatedNow - timeAfterAction) `div` 1000+                            loop $ freq - newDiff+                        -- 8)+                        else putMVar baton ()+    forkAndLabel act = do+        tid <- mask_ $ forkIO act+        labelThread tid name  ignoreExc :: IO () -> IO () ignoreExc = handle $ \(_ :: SomeException) -> return ()
Control/Reaper.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards    #-}-{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}  -- | This module provides the ability to create reapers: dedicated cleanup -- threads. These threads will automatically spawn and die based on the@@ -12,30 +12,41 @@ -- For real-world usage, search the <https://github.com/yesodweb/wai WAI family of packages> -- for imports of "Control.Reaper". module Control.Reaper (-      -- * Example: Regularly cleaning a cache-      -- $example1+    -- * Example: Regularly cleaning a cache+    -- $example1 -      -- * Settings-      ReaperSettings-    , defaultReaperSettings-      -- * Accessors-    , reaperAction-    , reaperDelay-    , reaperCons-    , reaperNull-    , reaperEmpty-      -- * Type-    , Reaper(..)-      -- * Creation-    , mkReaper-      -- * Helper-    , mkListAction-    ) where+    -- * Settings+    ReaperSettings,+    defaultReaperSettings, -import Control.AutoUpdate.Util (atomicModifyIORef')-import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)+    -- * Accessors+    reaperAction,+    reaperDelay,+    reaperCons,+    reaperNull,+    reaperEmpty,+    reaperThreadName,++    -- * Type+    Reaper,+    reaperAdd,+    reaperRead,+    reaperModify,+    reaperStop,+    reaperKill,++    -- * Creation+    mkReaper,++    -- * Helper+    mkListAction,+) where++import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) import Control.Exception (mask_)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Control.Reaper.Internal+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import GHC.Conc.Sync (labelThread)  -- | Settings for creating a reaper. This type has two parameters: -- @workload@ gives the entire workload, whereas @item@ gives an@@ -83,6 +94,12 @@     -- Default: empty list.     --     -- @since 0.1.1+    , reaperThreadName :: String+    -- ^ Label of the thread spawned by the reaper.+    --+    -- Default: @"Reaper"@.+    --+    -- @since 0.2.2     }  -- | Default @ReaperSettings@ value, biased towards having a list of work@@ -90,30 +107,22 @@ -- -- @since 0.1.1 defaultReaperSettings :: ReaperSettings [item] item-defaultReaperSettings = ReaperSettings-    { reaperAction = \wl -> return (wl ++)-    , reaperDelay = 30000000-    , reaperCons = (:)-    , reaperNull = null-    , reaperEmpty = []-    }---- | A data structure to hold reaper APIs.-data Reaper workload item = Reaper {-    -- | Adding an item to the workload-    reaperAdd  :: item -> IO ()-    -- | Reading workload.-  , reaperRead :: IO workload-    -- | Stopping the reaper thread if exists.-    --   The current workload is returned.-  , reaperStop :: IO workload-    -- | Killing the reaper thread immediately if exists.-  , reaperKill :: IO ()-  }+defaultReaperSettings =+    ReaperSettings+        { reaperAction = \wl -> return (wl ++)+        , reaperDelay = 30000000+        , reaperCons = (:)+        , reaperNull = null+        , reaperEmpty = []+        , reaperThreadName = "Reaper"+        }  -- | State of reaper.-data State workload = NoReaper           -- ^ No reaper thread-                    | Workload !workload  -- ^ The current jobs+data State workload+    = -- | No reaper thread+      NoReaper+    | -- | The current jobs+      Workload !workload  -- | Create a reaper addition function. This function can be used to add -- new items to the workload. Spawning of reaper threads will be handled@@ -123,52 +132,71 @@ mkReaper :: ReaperSettings workload item -> IO (Reaper workload item) mkReaper settings@ReaperSettings{..} = do     stateRef <- newIORef NoReaper-    tidRef   <- newIORef Nothing-    return Reaper {-        reaperAdd  = add settings stateRef tidRef-      , reaperRead = readRef stateRef-      , reaperStop = stop stateRef-      , reaperKill = kill tidRef-      }+    tidRef <- newIORef Nothing+    return+        Reaper+            { reaperAdd = add settings stateRef tidRef+            , reaperRead = readRef stateRef+            , reaperModify = modifyRef stateRef+            , reaperStop = stop stateRef+            , reaperKill = kill tidRef+            }   where     readRef stateRef = do         mx <- readIORef stateRef         case mx of-            NoReaper    -> return reaperEmpty+            NoReaper -> return reaperEmpty             Workload wl -> return wl+    modifyRef stateRef modifier = atomicModifyIORef' stateRef $ \mx ->+        case mx of+            NoReaper ->+                (NoReaper, reaperEmpty)+            Workload wl ->+                let !wl' = modifier wl+                 in (Workload wl', wl')     stop stateRef = atomicModifyIORef' stateRef $ \mx ->         case mx of-            NoReaper   -> (NoReaper, reaperEmpty)+            NoReaper -> (NoReaper, reaperEmpty)             Workload x -> (Workload reaperEmpty, x)     kill tidRef = do         mtid <- readIORef tidRef         case mtid of-            Nothing  -> return ()+            Nothing -> return ()             Just tid -> killThread tid -add :: ReaperSettings workload item-    -> IORef (State workload) -> IORef (Maybe ThreadId)-    -> item -> IO ()+add+    :: ReaperSettings workload item+    -> IORef (State workload)+    -> IORef (Maybe ThreadId)+    -> item+    -> IO () add settings@ReaperSettings{..} stateRef tidRef item =     mask_ $ do-      next <- atomicModifyIORef' stateRef cons-      next+        next <- atomicModifyIORef' stateRef cons+        next   where-    cons NoReaper      = let wl = reaperCons item reaperEmpty-                         in (Workload wl, spawn settings stateRef tidRef)-    cons (Workload wl) = let wl' = reaperCons item wl-                         in (Workload wl', return ())+    cons NoReaper =+        let wl = reaperCons item reaperEmpty+         in (Workload wl, spawn settings stateRef tidRef)+    cons (Workload wl) =+        let wl' = reaperCons item wl+         in (Workload wl', return ()) -spawn :: ReaperSettings workload item-      -> IORef (State workload) -> IORef (Maybe ThreadId)-      -> IO ()+spawn+    :: ReaperSettings workload item+    -> IORef (State workload)+    -> IORef (Maybe ThreadId)+    -> IO () spawn settings stateRef tidRef = do     tid <- forkIO $ reaper settings stateRef tidRef+    labelThread tid $ reaperThreadName settings     writeIORef tidRef $ Just tid -reaper :: ReaperSettings workload item-       -> IORef (State workload) -> IORef (Maybe ThreadId)-       -> IO ()+reaper+    :: ReaperSettings workload item+    -> IORef (State workload)+    -> IORef (Maybe ThreadId)+    -> IO () reaper settings@ReaperSettings{..} stateRef tidRef = do     threadDelay reaperDelay     -- Getting the current jobs. Push an empty job to the reference.@@ -178,18 +206,22 @@     !merge <- reaperAction wl     -- Merging the left jobs and new jobs.     -- If there is no jobs, this thread finishes.-    next <- atomicModifyIORef' stateRef (check merge)-    next+    cont <- atomicModifyIORef' stateRef (check merge)+    if cont+        then+            reaper settings stateRef tidRef+        else+            writeIORef tidRef Nothing   where-    swapWithEmpty NoReaper      = error "Control.Reaper.reaper: unexpected NoReaper (1)"+    swapWithEmpty NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (1)"     swapWithEmpty (Workload wl) = (Workload reaperEmpty, wl) -    check _ NoReaper   = error "Control.Reaper.reaper: unexpected NoReaper (2)"+    check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"     check merge (Workload wl)-      -- If there is no job, reaper is terminated.-      | reaperNull wl' = (NoReaper, writeIORef tidRef Nothing)-      -- If there are jobs, carry them out.-      | otherwise      = (Workload wl', reaper settings stateRef tidRef)+        -- If there is no job, reaper is terminated.+        | reaperNull wl' = (NoReaper, False)+        -- If there are jobs, carry them out.+        | otherwise = (Workload wl', True)       where         wl' = merge wl @@ -199,23 +231,37 @@ -- expired. -- -- @since 0.1.1-mkListAction :: (item -> IO (Maybe item'))-             -> [item]-             -> IO ([item'] -> [item'])+mkListAction+    :: (item -> IO (Maybe item'))+    -> [item]+    -> IO ([item'] -> [item']) mkListAction f =     go id   where     go !front [] = return front-    go !front (x:xs) = do+    go !front (x : xs) = do         my <- f x         let front' =                 case my of                     Nothing -> front-                    Just y  -> front . (y:)+                    Just y -> front . (y :)         go front' xs  -- $example1 -- In this example code, we use a 'Data.Map.Strict.Map' to cache fibonacci numbers, and a 'Reaper' to prune the cache.+--+-- NOTE: When using this module as a cache you should keep in mind that while+-- the reaper thread is active running your "reaperAction", the cache will+-- appear empty to concurrently running threads.  Any newly created cache+-- entries will be on the temporary worklist, and will merged back into the the+-- main cache only once the "reaperAction" completes (together with the portion+-- of the extant worklist that the @cleaner@ callback decided to retain).+--+-- If you're looking for a cache that supports concurrent purging of stale+-- items, but without exposing a transient empty cache during cleanup, this is+-- not the cache implementation you need.  This module was primarily designed+-- for cleaning up /stuck/ processes, or idle threads in a thread pool.  The cache+-- use-case was not a primary design focus. -- -- The @main@ function first creates a 'Reaper', with fields to initialize the -- cache ('reaperEmpty'), add items to it ('reaperCons'), and prune it ('reaperAction').
+ Control/Reaper/Internal.hs view
@@ -0,0 +1,28 @@+module Control.Reaper.Internal (Reaper (..)) where++-- | A data structure to hold reaper APIs.+data Reaper workload item = Reaper+    { reaperAdd :: item -> IO ()+    -- ^ Adding an item to the workload+    , reaperRead :: IO workload+    -- ^ Reading workload.+    , reaperModify :: (workload -> workload) -> IO workload+    -- ^ Modify the workload. The resulting workload is returned.+    --+    --   If there is no reaper thread, the modifier will not be applied and+    --   'reaperEmpty' will be returned.+    --+    --   If the reaper is currently executing jobs, those jobs will not be in+    --   the given workload and the workload might appear empty.+    --+    --   If all jobs are removed by the modifier, the reaper thread will not be+    --   killed. The reaper thread will only terminate if 'reaperKill' is called+    --   or the result of 'reaperAction' satisfies 'reaperNull'.+    --+    --  @since 0.2.0+    , reaperStop :: IO workload+    -- ^ Stopping the reaper thread if exists.+    --   The current workload is returned.+    , reaperKill :: IO ()+    -- ^ Killing the reaper thread immediately if exists.+    }
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
auto-update.cabal view
@@ -1,5 +1,5 @@ name:                auto-update-version:             0.1.6+version:             0.2.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@@ -19,8 +19,14 @@                        Control.Debounce                        Control.Debounce.Internal                        Control.Reaper-  other-modules:       Control.AutoUpdate.Util-  build-depends:       base >= 4 && < 5+                       Control.Reaper.Internal+  other-modules:       Control.AutoUpdate.Types+                       Control.AutoUpdate.Thread+  if !os(windows)+    exposed-modules:   Control.AutoUpdate.Internal+    other-modules:     Control.AutoUpdate.Event+  build-depends:       base >= 4.12 && < 5,+                       stm   default-language:    Haskell2010   if impl(ghc >= 8)       default-extensions:  Strict StrictData@@ -35,4 +41,5 @@   hs-source-dirs:  test   type:            exitcode-stdio-1.0   build-depends:   base, auto-update, exceptions, hspec, retry, HUnit+  build-tool-depends: hspec-discover:hspec-discover   default-language:    Haskell2010
test/Control/AutoUpdateSpec.hs view
@@ -1,35 +1,37 @@ module Control.AutoUpdateSpec (spec) where -import Control.AutoUpdate-import Control.Concurrent (threadDelay)-import Control.Monad (replicateM_, forM_)-import Data.IORef+-- import Control.AutoUpdate+-- import Control.Concurrent (threadDelay)+-- import Control.Monad (replicateM_, forM_)+-- import Data.IORef import Test.Hspec-import Test.Hspec.QuickCheck +-- 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+-- 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+--           } -  --       replicateM_ 50 $ do-  --           i <- next-  --           i `shouldBe` st + 2+--       forM_ [1..st + 1] $ \i -> do+--           j <- next+--           j `shouldBe` i -  --       threadDelay 60000-  --       last1 <- readIORef ref-  --       threadDelay 20000-  --       last2 <- readIORef ref-  --       last2 `shouldBe` last1+--       replicateM_ 50 $ do+--           i <- next+--           i `shouldBe` st + 2++--       threadDelay 60000+--       last1 <- readIORef ref+--       threadDelay 20000+--       last2 <- readIORef ref+--       last2 `shouldBe` last1
test/Control/DebounceSpec.hs view
@@ -1,36 +1,54 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Control.DebounceSpec (spec) where+{-# LANGUAGE NumericUnderscores #-}+module Control.DebounceSpec (main, spec) where -import Control.Concurrent-import Control.Debounce+import Control.Concurrent (+    MVar,+    newEmptyMVar,+    takeMVar,+    putMVar,+    newMVar,+    threadDelay,+    tryReadMVar,+ )+import Control.Debounce (+    DebounceSettings(..),+    leadingEdge,+    leadingMuteEdge,+    trailingEdge,+    trailingDelayEdge,+    defaultDebounceSettings,+ ) import qualified Control.Debounce.Internal as DI-import Control.Monad+import Control.Monad (void) import Control.Monad.Catch-import Control.Retry-import Data.IORef-import Test.HUnit.Lang-import Test.Hspec+import Control.Retry (recovering, constantDelay, limitRetries)+import Data.IORef (IORef, readIORef, newIORef, modifyIORef)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTime)+import Test.Hspec (Spec, describe, it, shouldReturn, hspec)+import Test.HUnit (assertBool)+import Test.HUnit.Lang (HUnitFailure (HUnitFailure))  spec :: Spec spec = describe "mkDebounce" $ do     describe "Leading edge" $ do         it "works for a single event" $ do-            (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge+            (ref, debounced, _baton, returnFromWait) <- getDebounce leadingEdge              debounced-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)+            waitUntil 5 $ readIORef ref `shouldReturn` 1              returnFromWait             pause-            readIORef ref >>= (`shouldBe` 1)+            readIORef ref `shouldReturn` 1              -- Try another round             debounced-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)+            waitUntil 5 $ readIORef ref `shouldReturn` 2              returnFromWait             pause-            readIORef ref >>= (`shouldBe` 2)+            readIORef ref `shouldReturn` 2          it "works for multiple events" $ do             (ref, debounced, baton, returnFromWait) <- getDebounce leadingEdge@@ -39,30 +57,63 @@             waitForBatonToBeTaken baton             debounced             pause-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)+            waitUntil 5 $ readIORef ref `shouldReturn` 1              returnFromWait             pause-            readIORef ref >>= (`shouldBe` 2)+            readIORef ref `shouldReturn` 2+    describe "LeadingMute edge" $ do+        it "works for a single event" $ do+            (ref, debounced, _baton, returnFromWait) <- getDebounce leadingMuteEdge +            debounced+            waitUntil 5 $ readIORef ref `shouldReturn` 1++            returnFromWait+            pause+            readIORef ref `shouldReturn` 1++            -- Try another round+            debounced+            waitUntil 5 $ readIORef ref `shouldReturn` 2++            returnFromWait+            pause+            readIORef ref `shouldReturn` 2++        it "works for multiple events" $ do+            (ref, debounced, baton, returnFromWait) <- getDebounce leadingMuteEdge++            debounced+            waitForBatonToBeTaken baton+            debounced+            pause+            debounced+            waitUntil 5 $ readIORef ref `shouldReturn` 1+            debounced++            returnFromWait+            pause+            readIORef ref `shouldReturn` 1+     describe "Trailing edge" $ do         it "works for a single event" $ do-            (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge+            (ref, debounced, _baton, returnFromWait) <- getDebounce trailingEdge              debounced             pause-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)+            readIORef ref `shouldReturn` 0              returnFromWait-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)+            waitUntil 5 $ readIORef ref `shouldReturn` 1              -- Try another round             debounced             pause-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)+            waitUntil 5 $ readIORef ref `shouldReturn` 1              returnFromWait-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 2)+            waitUntil 5 $ readIORef ref `shouldReturn` 2          it "works for multiple events" $ do             (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge@@ -71,12 +122,54 @@             waitForBatonToBeTaken baton             debounced             pause-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)+            readIORef ref `shouldReturn` 0              returnFromWait-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)+            waitUntil 5 $ readIORef ref `shouldReturn` 1 +    describe "TrailingDelay edge" $ do+        it "works for a single event" $ do+            (ref, debounced, _baton, _returnFromWait) <- getDebounce' True trailingDelayEdge +            debounced+            readIORef ref `shouldReturn` 0++            waitUntil 1 $ readIORef ref `shouldReturn` 1++            -- Try another round+            debounced+            readIORef ref `shouldReturn` 1++            waitUntil 1 $ readIORef ref `shouldReturn` 2++        it "works for multiple events" $ do+            (ref, debounced, _baton, _returnFromWait) <- getDebounce' True trailingDelayEdge++            start <- getMonotonicTime++            debounced+            readIORef ref `shouldReturn` 0+            -- Asserts at end check that this timing gets added to the cooldown time+            threadDelay 500_000++            readIORef ref `shouldReturn` 0+            before2nd <- getMonotonicTime+            debounced+            readIORef ref `shouldReturn` 0+            threadDelay 500_000++            readIORef ref `shouldReturn` 0+            threadDelay 250_000++            readIORef ref `shouldReturn` 0++            waitUntil 1 $ readIORef ref `shouldReturn` 1+            end <- getMonotonicTime+            assertBool "Took less than 1 sec after retrigger" $+                end - before2nd > 1+            assertBool "Took less than 1.5 sec total" $+                end - start > 1.5+ -- | Make a controllable delay function getWaitAction :: IO (p -> IO (), IO ()) getWaitAction = do@@ -85,36 +178,49 @@     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)+getDebounce = getDebounce' False -  (waitAction, returnFromWait) <- getWaitAction+-- | Get a debounce system with access to the internals for testing+getDebounce' :: Bool -> DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())+getDebounce' useThreadDelay edge = do+    ref <- newIORef 0+    let action = modifyIORef ref (+ 1) -  baton <- newEmptyMVar+    (waitAction, returnFromWait) <-+        if useThreadDelay+            then pure (threadDelay, pure ())+            else getWaitAction -  debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {-    debounceFreq = 5000000 -- unused-    , debounceAction = action-    , debounceEdge = edge-    }+    baton <- newMVar () -  return (ref, debounced, baton, returnFromWait)+    debounced <-+        DI.mkDebounceInternal+            baton+            waitAction+            defaultDebounceSettings+                { debounceFreq = 1_000_000 -- !!! used in 'TrailingDelay' test+                , debounceAction = action+                , debounceEdge = edge+                } +    return (ref, debounced, baton, returnFromWait)+ -- | Pause briefly (100ms) pause :: IO ()-pause = threadDelay 100000+pause = threadDelay 100_000  waitForBatonToBeTaken :: MVar () -> IO ()-waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton >>= (`shouldBe` Nothing)+waitForBatonToBeTaken baton =+    waitUntil 5 $ tryReadMVar baton `shouldReturn` 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)+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
test/Control/ReaperSpec.hs view
@@ -1,14 +1,15 @@ module Control.ReaperSpec (spec) where -import Control.Concurrent-import Control.Reaper-import Data.IORef+-- import Control.Concurrent+-- import Control.Reaper+-- import Data.IORef import Test.Hspec-import Test.Hspec.QuickCheck +-- import Test.Hspec.QuickCheck  spec :: Spec spec = return ()+ --   prop "works" $ \is -> do --     reaper <- mkReaper defaultReaperSettings --         { reaperAction = action