Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-auto-update for openSUSE:Factory
checked in at 2024-12-20 23:10:06
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-auto-update (Old)
and /work/SRC/openSUSE:Factory/.ghc-auto-update.new.1881 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-auto-update"
Fri Dec 20 23:10:06 2024 rev:20 rq:1231418 version:0.2.4
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-auto-update/ghc-auto-update.changes
2024-11-12 19:20:37.345459271 +0100
+++
/work/SRC/openSUSE:Factory/.ghc-auto-update.new.1881/ghc-auto-update.changes
2024-12-20 23:10:16.135604696 +0100
@@ -1,0 +2,9 @@
+Tue Nov 19 20:58:13 UTC 2024 - Peter Simons <[email protected]>
+
+- Update auto-update to version 0.2.4.
+ Upstream has edited the change log file since the last release in
+ a non-trivial way, i.e. they did more than just add a new entry
+ at the top. You can review the file at:
+ http://hackage.haskell.org/package/auto-update-0.2.4/src/ChangeLog.md
+
+-------------------------------------------------------------------
Old:
----
auto-update-0.2.2.tar.gz
New:
----
auto-update-0.2.4.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-auto-update.spec ++++++
--- /var/tmp/diff_new_pack.vHbE1Y/_old 2024-12-20 23:10:16.631625125 +0100
+++ /var/tmp/diff_new_pack.vHbE1Y/_new 2024-12-20 23:10:16.635625289 +0100
@@ -20,7 +20,7 @@
%global pkgver %{pkg_name}-%{version}
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.2.2
+Version: 0.2.4
Release: 0
Summary: Efficiently run periodic, on-demand actions
License: MIT
++++++ auto-update-0.2.2.tar.gz -> auto-update-0.2.4.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/ChangeLog.md
new/auto-update-0.2.4/ChangeLog.md
--- old/auto-update-0.2.2/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200
+++ new/auto-update-0.2.4/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200
@@ -1,5 +1,19 @@
# ChangeLog for auto-update
+## 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:
@@ -14,19 +28,19 @@
* Creating Reaper.Internal to export Reaper constructor.
* Hiding Reaper constructor.
-* Add `reaperModify` to the `Reaper` API, allowing workload modification
outside
+* [#985](https://github.com/yesodweb/wai/pull/985):
+ 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
- [#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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/Control/AutoUpdate.hs
new/auto-update-0.2.4/Control/AutoUpdate.hs
--- old/auto-update-0.2.2/Control/AutoUpdate.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/auto-update-0.2.4/Control/AutoUpdate.hs 2001-09-09 03:46:40.000000000
+0200
@@ -115,6 +115,11 @@
--
-- @since 0.1.0
, updateThreadName :: String
+ -- ^ Label of the thread being forked.
+ --
+ -- Default: @"AutoUpdate"@
+ --
+ -- @since 0.2.2
}
-- | Generate an action which will either read from an automatically
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/Control/Debounce/Internal.hs
new/auto-update-0.2.4/Control/Debounce/Internal.hs
--- old/auto-update-0.2.2/Control/Debounce/Internal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/auto-update-0.2.4/Control/Debounce/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -5,19 +5,24 @@
DebounceSettings (..),
DebounceEdge (..),
leadingEdge,
+ leadingMuteEdge,
trailingEdge,
+ trailingDelayEdge,
mkDebounceInternal,
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (
MVar,
- takeMVar,
+ newEmptyMVar,
+ putMVar,
tryPutMVar,
tryTakeMVar,
)
import Control.Exception (SomeException, handle, mask_)
-import Control.Monad (forever, void)
+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.
@@ -49,10 +54,15 @@
-- ^ 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
@@ -64,42 +74,224 @@
-- 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
+-- | 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) = do
- tid <- mask_ $ 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
- labelThread tid name
- return $ void $ tryPutMVar baton ()
+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
+ -- 4)
+ delayFn freq
+ -- 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 ()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/Control/Debounce.hs
new/auto-update-0.2.4/Control/Debounce.hs
--- old/auto-update-0.2.2/Control/Debounce.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/auto-update-0.2.4/Control/Debounce.hs 2001-09-09 03:46:40.000000000
+0200
@@ -23,23 +23,27 @@
--
-- @since 0.1.2
module Control.Debounce (
- -- * Type
+ -- * Creation
+ mkDebounce,
+
+ -- * Settings
DI.DebounceSettings,
defaultDebounceSettings,
- -- * Accessors
+ -- ** Accessors
DI.debounceFreq,
DI.debounceAction,
DI.debounceEdge,
DI.debounceThreadName,
+
+ -- ** Edge types
DI.leadingEdge,
+ DI.leadingMuteEdge,
DI.trailingEdge,
-
- -- * Creation
- mkDebounce,
+ DI.trailingDelayEdge,
) where
-import Control.Concurrent (newEmptyMVar, threadDelay)
+import Control.Concurrent (newMVar, threadDelay)
import qualified Control.Debounce.Internal as DI
-- | Default value for creating a 'DebounceSettings'.
@@ -56,8 +60,11 @@
-- | 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
+ baton <- newMVar ()
DI.mkDebounceInternal baton threadDelay settings
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/Control/Reaper.hs
new/auto-update-0.2.4/Control/Reaper.hs
--- old/auto-update-0.2.2/Control/Reaper.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/auto-update-0.2.4/Control/Reaper.hs 2001-09-09 03:46:40.000000000
+0200
@@ -96,6 +96,11 @@
--
-- @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
@@ -202,8 +207,12 @@
!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 (Workload wl) = (Workload reaperEmpty, wl)
@@ -211,9 +220,9 @@
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)
+ | reaperNull wl' = (NoReaper, False)
-- If there are jobs, carry them out.
- | otherwise = (Workload wl', reaper settings stateRef tidRef)
+ | otherwise = (Workload wl', True)
where
wl' = merge wl
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/auto-update.cabal
new/auto-update-0.2.4/auto-update.cabal
--- old/auto-update-0.2.2/auto-update.cabal 2001-09-09 03:46:40.000000000
+0200
+++ new/auto-update-0.2.4/auto-update.cabal 2001-09-09 03:46:40.000000000
+0200
@@ -1,5 +1,5 @@
name: auto-update
-version: 0.2.2
+version: 0.2.4
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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/auto-update-0.2.2/test/Control/DebounceSpec.hs
new/auto-update-0.2.4/test/Control/DebounceSpec.hs
--- old/auto-update-0.2.2/test/Control/DebounceSpec.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/auto-update-0.2.4/test/Control/DebounceSpec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,14 +1,33 @@
+{-# 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
@@ -43,6 +62,39 @@
returnFromWait
pause
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
@@ -50,7 +102,7 @@
debounced
pause
- waitUntil 5 $ readIORef ref `shouldReturn` 0
+ readIORef ref `shouldReturn` 0
returnFromWait
waitUntil 5 $ readIORef ref `shouldReturn` 1
@@ -70,11 +122,54 @@
waitForBatonToBeTaken baton
debounced
pause
- waitUntil 5 $ readIORef ref `shouldReturn` 0
+ readIORef ref `shouldReturn` 0
returnFromWait
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
@@ -83,22 +178,28 @@
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
+getDebounce = getDebounce' False
+
+-- | 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)
- (waitAction, returnFromWait) <- getWaitAction
+ (waitAction, returnFromWait) <-
+ if useThreadDelay
+ then pure (threadDelay, pure ())
+ else getWaitAction
- baton <- newEmptyMVar
+ baton <- newMVar ()
debounced <-
DI.mkDebounceInternal
baton
waitAction
defaultDebounceSettings
- { debounceFreq = 5000000 -- unused
+ { debounceFreq = 1_000_000 -- !!! used in 'TrailingDelay' test
, debounceAction = action
, debounceEdge = edge
}
@@ -107,14 +208,16 @@
-- | Pause briefly (100ms)
pause :: IO ()
-pause = threadDelay 100000
+pause = threadDelay 100_000
waitForBatonToBeTaken :: MVar () -> IO ()
-waitForBatonToBeTaken baton = waitUntil 5 $ tryReadMVar baton `shouldReturn`
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)
+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)
