auto-update 0.1.6 → 0.2.0

raw patch · 12 files changed

+341/−237 lines, 12 filesdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• Control/AutoUpdate.hs +54/−35
• Control/AutoUpdate/Util.hs +4/−3
• Control/Debounce.hs +29/−28
• Control/Debounce/Internal.hs +35/−30
• Control/Reaper.hs +112/−79
• Control/Reaper/Internal.hs +28/−0
• Setup.hs +1/−0
• auto-update.cabal +4/−2
• test/Control/AutoUpdateSpec.hs +28/−26
• test/Control/DebounceSpec.hs +33/−30
• test/Control/ReaperSpec.hs +5/−4

@@ -1,5 +1,13 @@ # ChangeLog for auto-update +## 0.2.0++* Creating Reaper.Internal to export Reaper constructor.+* Hiding Reaper constructor.+* Add `reaperModify` to the `Reaper` API, allowing workload modification outside+  of the main `reaperAction` loop.+  [#985](https://github.com/yesodweb/wai/pull/985)+ ## 0.1.6  * Add control of activation on leading vs. trailing edges for Control.Debounce

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ -- | In a multithreaded environment, running actions on a regularly scheduled -- background thread can dramatically improve performance. -- For example, web servers need to return the current time with each HTTP response.@@ -6,12 +7,12 @@ -- 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,38 +30,52 @@ -- -- 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, +    -- * Accessors+    updateAction,+    updateFreq,+    updateSpawnThreshold,++    -- * Creation+    mkAutoUpdate,+    mkAutoUpdateWithModify,+) where+ #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)+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)  -- | Default value for creating an 'UpdateSettings'. -- -- @since 0.1.0 defaultUpdateSettings :: UpdateSettings ()-defaultUpdateSettings = UpdateSettings-    { updateFreq = 1000000-    , updateSpawnThreshold = 3-    , updateAction = return ()-    }+defaultUpdateSettings =+    UpdateSettings+        { updateFreq = 1000000+        , updateSpawnThreshold = 3+        , updateAction = return ()+        }  -- | Settings to control how values are updated. --@@ -73,7 +88,7 @@ -- -- @since 0.1.0 data UpdateSettings a = UpdateSettings-    { updateFreq           :: Int+    { updateFreq :: Int     -- ^ Microseconds between update calls. Same considerations as     -- 'threadDelay' apply.     --@@ -90,7 +105,7 @@     -- Default: 3     --     -- @since 0.1.0-    , updateAction         :: IO a+    , updateAction :: IO a     -- ^ Action to be performed to get the current value.     --     -- Default: does nothing.@@ -136,12 +151,16 @@     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"+                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@@ -162,7 +181,7 @@                 takeMVar needsRunning                  -- new value requested, so run the updateAction-                a <- catchSome $ maybe (updateAction us) id (updateActionModify <*> maybea)+                a <- catchSome $ fromMaybe (updateAction us) (updateActionModify <*> maybea)                  -- we got a new value, update currRef and lastValue                 writeIORef currRef $ Right a

@@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-}-module Control.AutoUpdate.Util-    ( atomicModifyIORef'-    ) where++module Control.AutoUpdate.Util (+    atomicModifyIORef',+) where  #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1

@@ -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,55 @@ -- 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 (+    -- * Type+    DI.DebounceSettings,+    defaultDebounceSettings, -import           Control.Concurrent      (newEmptyMVar, threadDelay)+    -- * Accessors+    DI.debounceFreq,+    DI.debounceAction,+    DI.debounceEdge,+    DI.leadingEdge,+    DI.trailingEdge,++    -- * Creation+    mkDebounce,+) where++import Control.Concurrent (newEmptyMVar, 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+        }  -- | Generate an action which will trigger the debounced action to be performed. -- -- @since 0.1.2 mkDebounce :: DI.DebounceSettings -> IO (IO ()) mkDebounce settings = do-  baton <- newEmptyMVar-  DI.mkDebounceInternal baton threadDelay settings+    baton <- newEmptyMVar+    DI.mkDebounceInternal baton threadDelay settings

@@ -2,17 +2,22 @@  -- | Unstable API which exposes internals for testing. module Control.Debounce.Internal (-  DebounceSettings(..)-  , DebounceEdge(..)-  , leadingEdge-  , trailingEdge-  , mkDebounceInternal-  ) where+    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)+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (+    MVar,+    takeMVar,+    tryPutMVar,+    tryTakeMVar,+ )+import Control.Exception (SomeException, handle, mask_)+import Control.Monad (forever, void)  -- | Settings to control how debouncing should work. --@@ -25,7 +30,7 @@ -- -- @since 0.1.2 data DebounceSettings = DebounceSettings-    { debounceFreq   :: Int+    { debounceFreq :: Int     -- ^ Length of the debounce timeout period in microseconds.     --     -- Default: 1 second (1000000)@@ -52,16 +57,15 @@ -- 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+    | -- | Start a cooldown period and perform the action when the period ends. If another trigger+      -- happens during the cooldown, it has no effect.+      Trailing+    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@@ -78,19 +82,20 @@ trailingEdge :: DebounceEdge trailingEdge = Trailing -mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())+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+            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 () 

@@ -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,29 +12,39 @@ -- 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, +    -- * Accessors+    reaperAction,+    reaperDelay,+    reaperCons,+    reaperNull,+    reaperEmpty,++    -- * Type+    Reaper,+    reaperAdd,+    reaperRead,+    reaperModify,+    reaperStop,+    reaperKill,++    -- * Creation+    mkReaper,++    -- * Helper+    mkListAction,+) where+ import Control.AutoUpdate.Util (atomicModifyIORef')-import Control.Concurrent (forkIO, threadDelay, killThread, ThreadId)+import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) import Control.Exception (mask_)+import Control.Reaper.Internal import Data.IORef (IORef, newIORef, readIORef, writeIORef)  -- | Settings for creating a reaper. This type has two parameters:@@ -90,30 +100,21 @@ -- -- @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 = []+        }  -- | 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 +124,70 @@ 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     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.@@ -181,15 +200,15 @@     next <- atomicModifyIORef' stateRef (check merge)     next   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, writeIORef tidRef Nothing)+        -- If there are jobs, carry them out.+        | otherwise = (Workload wl', reaper settings stateRef tidRef)       where         wl' = merge wl @@ -199,23 +218,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').

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

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,5 +1,5 @@ name:                auto-update-version:             0.1.6+version:             0.2.0 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,9 @@                        Control.Debounce                        Control.Debounce.Internal                        Control.Reaper+                       Control.Reaper.Internal   other-modules:       Control.AutoUpdate.Util-  build-depends:       base >= 4 && < 5+  build-depends:       base >= 4.12 && < 5   default-language:    Haskell2010   if impl(ghc >= 8)       default-extensions:  Strict StrictData@@ -35,4 +36,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

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

@@ -1,5 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Control.DebounceSpec (spec) where+module Control.DebounceSpec (main, spec) where  import Control.Concurrent import Control.Debounce@@ -15,22 +14,22 @@ 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 +38,30 @@             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 "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)+            waitUntil 5 $ 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,11 +70,10 @@             waitForBatonToBeTaken baton             debounced             pause-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 0)+            waitUntil 5 $ readIORef ref `shouldReturn` 0              returnFromWait-            waitUntil 5 $ readIORef ref >>= (`shouldBe` 1)-+            waitUntil 5 $ readIORef ref `shouldReturn` 1  -- | Make a controllable delay function getWaitAction :: IO (p -> IO (), IO ())@@ -88,33 +86,38 @@ -- | 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)+    ref <- newIORef 0+    let action = modifyIORef ref (+ 1) -  (waitAction, returnFromWait) <- getWaitAction+    (waitAction, returnFromWait) <- getWaitAction -  baton <- newEmptyMVar+    baton <- newEmptyMVar -  debounced <- DI.mkDebounceInternal baton waitAction defaultDebounceSettings {-    debounceFreq = 5000000 -- unused-    , debounceAction = action-    , debounceEdge = edge-    }+    debounced <-+        DI.mkDebounceInternal+            baton+            waitAction+            defaultDebounceSettings+                { debounceFreq = 5000000 -- unused+                , debounceAction = action+                , debounceEdge = edge+                } -  return (ref, debounced, baton, returnFromWait)+    return (ref, debounced, baton, returnFromWait)  -- | Pause briefly (100ms) pause :: IO () pause = threadDelay 100000  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)+  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

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