packages feed

auto-update-unliftio (empty) → 0.1.0

raw patch · 17 files changed

+1616/−0 lines, 17 filesdep +HUnitdep +auto-update-unliftiodep +base

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

Files

+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Changelog++All notable changes to `auto-update-unliftio` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org).++## [Unreleased]++## [0.1.0] - 26.06.2026++### Added++- `AutoUpdate`, `Debounce` and `Reaper` code adapted from the original [auto-update](https://hackage.haskell.org/package/auto-update) package.+- Test suite copied (and uncommented) from the original package.++[unreleased]: https://github.com/fpringle/auto-update-unliftio/compare/v0.1.0...HEAD+[0.1.0]: https://github.com/fpringle/auto-update-unliftio/releases/tag/v0.1.0+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2026, Frederick Pringle++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Frederick Pringle nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+## auto-update-unliftio++This is an almost direct clone of yesod's [auto-update](https://hackage.haskell.org/package/auto-update), but generalised to [MonadUnliftIO](https://hackage-content.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#t:MonadUnliftIO).
+ auto-update-unliftio.cabal view
@@ -0,0 +1,80 @@+cabal-version:      3.0+name:               auto-update-unliftio+version:            0.1.0+synopsis:           auto-update unlifted to MonadUnliftIO+description:        Efficiently run periodic, on-demand actions, in instances of [MonadUnliftIO](https://hackage-content.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#t:MonadUnliftIO)+license:            BSD-3-Clause+license-file:       LICENSE+author:             Frederick Pringle+maintainer:         frederick.pringle@fpringle.com+category:           Control+copyright:          Copyright(c) Frederick Pringle 2026+homepage:           https://github.com/fpringle/auto-update-unliftio+build-type:         Simple+extra-doc-files:    CHANGELOG.md+                    README.md++tested-with:+    GHC == 8.8.4+  , GHC == 8.10.7+  , GHC == 9.0.2+  , GHC == 9.2.8+  , GHC == 9.4.5+  , GHC == 9.6.1+  , GHC == 9.6.7+  , GHC == 9.8.2+  , GHC == 9.10.2+  , GHC == 9.12.2++source-repository head+  type:           git+  location:       https://github.com/fpringle/auto-update-unliftio++common warnings+  ghc-options: -Wall -Wno-unused-do-bind++common deps+  build-depends:+    , base >= 4 && < 5+    , unliftio >= 0.2.1.0 && < 0.3++library+  import:+      warnings+    , deps+  exposed-modules:+      UnliftIO.AutoUpdate+      UnliftIO.AutoUpdate.Internal+      UnliftIO.AutoUpdate.Types+      UnliftIO.AutoUpdate.Thread+      UnliftIO.AutoUpdate.Event++      UnliftIO.Debounce+      UnliftIO.Debounce.Internal++      UnliftIO.Reaper+      UnliftIO.Reaper.Internal+  hs-source-dirs:   src+  default-language: Haskell2010++test-suite auto-update-unliftio-test+  import:+      warnings+    , deps+  default-language: Haskell2010+  other-modules:+      UnliftIO.AutoUpdateSpec+      UnliftIO.DebounceSpec+      UnliftIO.ReaperSpec+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Spec.hs+  build-tool-depends:+      hspec-discover:hspec-discover+  ghc-options:      -Wno-orphans+  build-depends:+    , auto-update-unliftio+    , exceptions+    , hspec+    , retry+    , HUnit
+ src/UnliftIO/AutoUpdate.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}++{- | This is an almost direct copy of [Control.AutoUpdate](https://hackage.haskell.org/package/auto-update/docs/Control-AutoUpdate.html)+ from the /auto-update/ package. The salient difference is that this module allows us to define auto-updating actions in arbitrary+ monads using 'MonadUnliftIO'.++ 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 'Data.IORef.IORef', than it is for each+ request to make its own call to 'Data.Time.Clock.getCurrentTime'.++ But for a low-volume server, whose request frequency is less than once per+ second, that approach will result in /more/ calls to 'Data.Time.Clock.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+ be executed by the calling thread.++ Example usage:++ @+ import "Data.Time"+ import "Control.AutoUpdate"++ getTime <- 'mkAutoUpdate' 'defaultUpdateSettings'+              { 'updateAction' = 'Data.Time.Clock.getCurrentTime'+              , 'updateFreq' = 1000000 -- The default frequency, once per second+              }+ currentTime <- getTime+ @++ For more examples, <http://www.yesodweb.com/blog/2014/08/announcing-auto-update see the blog post introducing the original library>.+-}+module UnliftIO.AutoUpdate+  ( -- * Type+    UpdateSettings+  , defaultUpdateSettings++    -- * Accessors+  , updateAction+  , updateFreq+  , updateThreadName++    -- * Creation+  , mkAutoUpdate+  , mkAutoUpdateWithModify+  )+where++import Control.Monad.IO.Class (liftIO)+import UnliftIO (MonadUnliftIO)+import UnliftIO.AutoUpdate.Types+#ifdef mingw32_HOST_OS+import UnliftIO.AutoUpdate.Thread+#else+import qualified UnliftIO.AutoUpdate.Event as Event+import qualified UnliftIO.AutoUpdate.Thread as Thread++import GHC.Event++{- | 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 :: MonadUnliftIO m => UpdateSettings m a -> m (m a)+mkAutoUpdate settings = do+    mmgr <- liftIO 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.0+-}+mkAutoUpdateWithModify :: MonadUnliftIO m => UpdateSettings m a -> (a -> m a) -> m (m a)+mkAutoUpdateWithModify settings f = do+    mmgr <- liftIO getSystemEventManager+    case mmgr of+      Nothing -> Thread.mkAutoUpdateWithModify settings f+      Just _m -> Event.mkAutoUpdateWithModify settings f+#endif
+ src/UnliftIO/AutoUpdate/Event.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards #-}++module UnliftIO.AutoUpdate.Event+  ( -- * Creation+    mkAutoUpdate+  , mkAutoUpdateWithModify++    -- * Internal+  , UpdateState (..)+  , mkClosableAutoUpdate+  , mkClosableAutoUpdate'+  )+where++import Control.Monad+import Control.Monad.IO.Class (MonadIO (..))+import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout)+import UnliftIO (MonadUnliftIO)+import UnliftIO.AutoUpdate.Types+import UnliftIO.IORef+import UnliftIO.STM++--------------------------------------------------------------------------------++{- | 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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m 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.0+-}+mkAutoUpdateWithModify :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (m a)+mkAutoUpdateWithModify = mkAutoUpdateThingsWithModify (\g _ _ -> g)++--------------------------------------------------------------------------------++data UpdateState m a = UpdateState+  { usUpdateAction_ :: a -> m a+  , usLastResult_ :: IORef a+  , usIntervalMicro_ :: Int+  , usTimeHasCome_ :: TVar Bool+  , usDeleteTimeout_ :: IORef (m ())+  }++--------------------------------------------------------------------------------++mkAutoUpdateThings ::+  (MonadUnliftIO m) =>+  (m a -> m () -> UpdateState m a -> b) ->+  UpdateSettings m a ->+  m b+mkAutoUpdateThings mk settings@UpdateSettings {..} =+  mkAutoUpdateThingsWithModify mk settings (const updateAction)++mkAutoUpdateThingsWithModify ::+  (MonadUnliftIO m) =>+  (m a -> m () -> UpdateState m a -> b) ->+  UpdateSettings m a ->+  (a -> m a) ->+  m b+mkAutoUpdateThingsWithModify mk settings update1 = do+  us <- openUpdateState settings update1+  pure $ mk (getUpdateResult us) (closeUpdateState us) us++--------------------------------------------------------------------------------++{- $setup+ >>> :seti -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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m a, m ())+mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c)++-- | provide `UpdateState` for debugging+mkClosableAutoUpdate' :: (MonadUnliftIO m) => UpdateSettings m a -> m (m a, m (), UpdateState m a)+mkClosableAutoUpdate' = mkAutoUpdateThings (,,)++--------------------------------------------------------------------------------++mkDeleteTimeout :: (MonadUnliftIO m) => TVar Bool -> Int -> m (m ())+mkDeleteTimeout thc micro = do+  mgr <- liftIO getSystemTimerManager+  key <- liftIO $ registerTimeout mgr micro (atomically $ writeTVar thc True)+  pure $ liftIO $ unregisterTimeout mgr key++openUpdateState :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (UpdateState m a)+openUpdateState UpdateSettings {..} update1 = do+  thc <- newTVarIO False+  UpdateState update1+    <$> (newIORef =<< updateAction)+    <*> pure updateFreq+    <*> pure thc+    <*> (newIORef =<< mkDeleteTimeout thc updateFreq)++closeUpdateState :: (MonadUnliftIO m) => UpdateState m a -> m ()+closeUpdateState UpdateState {..} = do+  join $ readIORef usDeleteTimeout_++onceOnTimeHasCome :: (MonadUnliftIO m) => UpdateState m a -> m () -> m ()+onceOnTimeHasCome UpdateState {..} action = do+  join . atomically $ do+    timeHasCome <- readTVar usTimeHasCome_+    when timeHasCome $ writeTVar usTimeHasCome_ False+    pure $ when timeHasCome action++getUpdateResult :: (MonadUnliftIO m) => UpdateState m a -> m a+getUpdateResult us@UpdateState {..} = do+  onceOnTimeHasCome us $ do+    writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_+    writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_+  readIORef usLastResult_
+ src/UnliftIO/AutoUpdate/Internal.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_HADDOCK not-home #-}++module UnliftIO.AutoUpdate.Internal+  ( -- * Debugging+    UpdateState (..)+  , mkClosableAutoUpdate+  , mkClosableAutoUpdate'+  )+where++import UnliftIO.AutoUpdate.Event
+ src/UnliftIO/AutoUpdate/Thread.hs view
@@ -0,0 +1,138 @@+module UnliftIO.AutoUpdate.Thread+  ( -- * Creation+    mkAutoUpdate+  , mkAutoUpdateWithModify+  )+where++import Control.Exception (throw)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Maybe (fromMaybe)+import GHC.Conc.Sync (labelThread)+import UnliftIO (MonadUnliftIO)+import UnliftIO.AutoUpdate.Types+import UnliftIO.Concurrent (forkIO, threadDelay)+import UnliftIO.Exception+  ( SomeException+  , catch+  , mask_+  , try+  )+import UnliftIO.IORef (newIORef, readIORef, writeIORef)+import UnliftIO.MVar+  ( newEmptyMVar+  , putMVar+  , readMVar+  , takeMVar+  , tryPutMVar+  )++{- | 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 :: (MonadUnliftIO m) => UpdateSettings m a -> m (m 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.0+-}+mkAutoUpdateWithModify :: (MonadUnliftIO m) => UpdateSettings m a -> (a -> m a) -> m (m a)+mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f)++mkAutoUpdateHelper :: (MonadUnliftIO m) => UpdateSettings m a -> Maybe (a -> m a) -> m (m 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+  liftIO . labelThread tid $ updateThreadName us+  pure $ 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 -> pure 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 :: (MonadUnliftIO m) => m a -> m a+catchSome act = UnliftIO.Exception.catch act $ \e -> pure $ throw (e :: SomeException)
+ src/UnliftIO/AutoUpdate/Types.hs view
@@ -0,0 +1,48 @@+module UnliftIO.AutoUpdate.Types where++import Data.Functor.Identity++{- | 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 m a = UpdateSettings+  { updateFreq :: Int+  -- ^ Microseconds between update calls. Same considerations as+  -- 'Control.Concurrent.threadDelay' apply.+  --+  -- Default: 1000000 microseconds (1 second)+  --+  -- @since 0.1.0+  , updateAction :: m 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.1.0+  }++{- | Default value for creating an 'UpdateSettings'.++ @since 0.1.0+-}+defaultUpdateSettings :: UpdateSettings Identity ()+defaultUpdateSettings =+  UpdateSettings+    { updateFreq = 1000000+    , updateAction = pure ()+    , updateThreadName = "AutoUpdate"+    }
+ src/UnliftIO/Debounce.hs view
@@ -0,0 +1,81 @@+{- | This is an almost direct copy of [Control.Debounce](https://hackage.haskell.org/package/auto-update/docs/Control-Debounce.html)+ from the /auto-update/ package. The salient difference is that this module allows us to debounce actions in arbitrary+ monads using 'MonadUnliftIO'.++ Debounce an action, ensuring it doesn't occur more than once for a given+ period of time.++ This is useful as an optimization, for example to ensure that logs are only+ flushed to disk at most once per second.++ Example usage:++ @+ > printString <- 'mkDebounce' 'DI.defaultDebounceSettings'+                  { 'DI.debounceAction' = putStrLn "Running action"+                  , 'DI.debounceFreq' = 5000000 -- 5 seconds+                  , 'DI.debounceEdge' = 'DI.trailingEdge' -- Trigger on the trailing edge+                  }+ > printString+ Running action+ > printString+ \<Wait five seconds>+ Running action+ @++ See the fast-logger package ("System.Log.FastLogger") for real-world usage.++ @since 0.1.0+-}+module UnliftIO.Debounce+  ( -- * Creation+    mkDebounce++    -- * Settings+  , DI.DebounceSettings+  , defaultDebounceSettings++    -- ** Accessors+  , DI.debounceFreq+  , DI.debounceAction+  , DI.debounceEdge+  , DI.debounceThreadName++    -- ** Edge types+  , DI.DebounceEdge+  , DI.leadingEdge+  , DI.leadingMuteEdge+  , DI.trailingEdge+  , DI.trailingDelayEdge+  )+where++import Data.Functor.Identity+import UnliftIO (MonadUnliftIO)+import UnliftIO.Concurrent (newMVar, threadDelay)+import qualified UnliftIO.Debounce.Internal as DI++{- | Default value for creating a 'DI.DebounceSettings'.++ @since 0.1.0+-}+defaultDebounceSettings :: DI.DebounceSettings Identity+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 'DI.debounceFreq',/+ /as the debounced action (and the delay\/cooldown) is always performed in a separate thread./++ @since 0.1.0+-}+mkDebounce :: (MonadUnliftIO m) => DI.DebounceSettings m -> m (m ())+mkDebounce settings = do+  baton <- newMVar ()+  DI.mkDebounceInternal baton threadDelay settings
+ src/UnliftIO/Debounce/Internal.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Unstable API which exposes internals for testing.+module UnliftIO.Debounce.Internal+  ( DebounceSettings (..)+  , DebounceEdge (..)+  , leadingEdge+  , leadingMuteEdge+  , trailingEdge+  , trailingDelayEdge+  , mkDebounceInternal+  )+where++import Control.Monad (void, when)+import Control.Monad.IO.Class (liftIO)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Conc.Sync (labelThread)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Concurrent (forkIO)+import UnliftIO.Exception (SomeException, handle, mask_)+import UnliftIO.MVar+  ( MVar+  , newEmptyMVar+  , putMVar+  , tryPutMVar+  , tryTakeMVar+  )+import UnliftIO.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar)++{- | Settings to control how debouncing should work.++ This should be constructed using 'UnliftIO.Debounce.defaultDebounceSettings' and record+ update syntax, e.g.:++ @+ let settings = 'UnliftIO.Debounce.defaultDebounceSettings' { 'debounceAction' = flushLog }+ @++ @since 0.1.0+-}+data DebounceSettings m = DebounceSettings+  { debounceFreq :: Int+  -- ^ Length of the debounce timeout period in microseconds.+  --+  -- Default: 1 second (1000000)+  --+  -- @since 0.1.0+  , debounceAction :: m ()+  -- ^ Action to be performed.+  --+  -- Note: all exceptions thrown by this action will be silently discarded.+  --+  -- Default: does nothing.+  --+  -- @since 0.1.0+  , debounceEdge :: DebounceEdge+  -- ^ Whether to perform the action on the leading edge or trailing edge of+  -- the timeout.+  --+  -- Default: 'leadingEdge'.+  --+  -- @since 0.1.0+  , debounceThreadName :: String+  -- ^ Label of the thread spawned when debouncing.+  --+  -- Default: @"Debounce"@.+  --+  -- @since 0.1.0+  }++{- | Setting to control whether the action happens at the leading and/or trailing+ edge of the timeout.++ @since 0.1.0+-}+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.0+-}+leadingEdge :: DebounceEdge+leadingEdge = Leading++{- | 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.0+-}+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.0+-}+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.0+-}+trailingDelayEdge :: DebounceEdge+trailingDelayEdge = TrailingDelay++mkDebounceInternal ::+  forall m.+  (MonadUnliftIO m) =>+  MVar () ->+  (Int -> m ()) ->+  DebounceSettings m ->+  m (m ())+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 <- liftIO 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 <- liftIO getMonotonicTimeNSec+          -- 5)+          let diff = fromIntegral (now - lastTrigger) `div` 1000+              shouldWait = diff < freq+          if shouldWait+            then -- 6)+              loop $ freq - diff+            else do+              ignoreExc action+              timeAfterAction <- readTVarIO timeTVar+              -- 7)+              let wasTriggered = timeAfterAction > now+              if wasTriggered+                then do+                  updatedNow <- liftIO getMonotonicTimeNSec+                  let newDiff = fromIntegral (updatedNow - timeAfterAction) `div` 1000+                  loop $ freq - newDiff+                else -- 8)+                  putMVar baton ()++    forkAndLabel act = do+      tid <- mask_ $ forkIO act+      liftIO $ labelThread tid name++ignoreExc :: (MonadUnliftIO m) => m () -> m ()+ignoreExc = handle $ \(_ :: SomeException) -> pure ()
+ src/UnliftIO/Reaper.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++{- | This is an almost direct copy of [Control.Reaper](https://hackage.haskell.org/package/auto-update/docs/Control-Reaper.html)+ from the /auto-update/ package. The salient difference is that this module allows us to define cleanup threads in arbitrary+ monads using 'MonadUnliftIO'.++ This module provides the ability to create reapers: dedicated cleanup+ threads. These threads will automatically spawn and die based on the+ presence of a workload to process on. Example uses include:++ * Killing long-running jobs+ * Closing unused connections in a connection pool+ * Pruning a cache of old items (see example below)++ For real-world usage, search the <https://github.com/yesodweb/wai WAI family of packages>+ for imports of "Control.Reaper".+-}+module UnliftIO.Reaper+  ( -- * Example: Regularly cleaning a cache+    -- $example1++    -- * Settings+    ReaperSettings+  , defaultReaperSettings++    -- * Accessors+  , reaperAction+  , reaperDelay+  , reaperCons+  , reaperNull+  , reaperEmpty+  , reaperThreadName++    -- * Type+  , Reaper+  , reaperAdd+  , reaperRead+  , reaperModify+  , reaperStop+  , reaperKill++    -- * Creation+  , mkReaper++    -- * Helper+  , mkListAction+  )+where++import Control.Monad (forM_, join)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Functor.Identity+import GHC.Conc.Sync (labelThread)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Concurrent (ThreadId, forkIO, killThread, threadDelay)+import UnliftIO.Exception (mask_)+import UnliftIO.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import UnliftIO.Reaper.Internal++{- | Settings for creating a reaper. This type has two parameters:+ @workload@ gives the entire workload, whereas @item@ gives an+ individual piece of the queue. A common approach is to have @workload@+ be a list of @item@s. This is encouraged by 'defaultReaperSettings' and+ 'mkListAction'.++ @since 0.1.0+-}+data ReaperSettings m workload item = ReaperSettings+  { reaperAction :: workload -> m (workload -> workload)+  -- ^ The action to perform on a workload. The result of this is a+  -- \"workload modifying\" function. In the common case of using lists,+  -- the result should be a difference list that prepends the remaining+  -- workload to the temporary workload. The temporary workload here+  -- refers to items added to the workload while the reaper action is+  -- running. For help with setting up such an action, see 'mkListAction'.+  --+  -- Default: do nothing with the workload, and then prepend it to the+  -- temporary workload. This is incredibly useless; you should+  -- definitely override this default.+  --+  -- @since 0.1.0+  , reaperDelay :: {-# UNPACK #-} !Int+  -- ^ Number of microseconds to delay between calls of 'reaperAction'.+  --+  -- Default: 30 seconds.+  --+  -- @since 0.1.0+  , reaperCons :: item -> workload -> workload+  -- ^ Add an item onto a workload.+  --+  -- Default: list consing.+  --+  -- @since 0.1.0+  , reaperNull :: workload -> Bool+  -- ^ Check if a workload is empty, in which case the worker thread+  -- will shut down.+  --+  -- Default: 'null'.+  --+  -- @since 0.1.0+  , reaperEmpty :: workload+  -- ^ An empty workload.+  --+  -- Default: empty list.+  --+  -- @since 0.1.0+  , reaperThreadName :: String+  -- ^ Label of the thread spawned by the reaper.+  --+  -- Default: @"Reaper"@.+  --+  -- @since 0.1.0+  }++{- | Default @ReaperSettings@ value, biased towards having a list of work+ items.++ @since 0.1.0+-}+defaultReaperSettings :: ReaperSettings Identity [item] item+defaultReaperSettings =+  ReaperSettings+    { reaperAction = \wl -> pure (wl ++)+    , reaperDelay = 30000000+    , reaperCons = (:)+    , reaperNull = null+    , reaperEmpty = []+    , reaperThreadName = "Reaper"+    }++-- | State of reaper.+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+ for you automatically.++ @since 0.1.0+-}+mkReaper :: (MonadUnliftIO m) => ReaperSettings m workload item -> m (Reaper m workload item)+mkReaper settings@ReaperSettings {..} = do+  stateRef <- newIORef NoReaper+  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+        Workload wl -> return wl+    modifyRef stateRef modifier = atomicModifyIORef' stateRef $ \case+      NoReaper ->+        (NoReaper, reaperEmpty)+      Workload wl ->+        let !wl' = modifier wl+        in  (Workload wl', wl')+    stop stateRef = atomicModifyIORef' stateRef $ \case+      NoReaper -> (NoReaper, reaperEmpty)+      Workload x -> (Workload reaperEmpty, x)+    kill tidRef = do+      mtid <- readIORef tidRef+      forM_ mtid killThread++add ::+  (MonadUnliftIO m) =>+  ReaperSettings m workload item ->+  IORef (State workload) ->+  IORef (Maybe ThreadId) ->+  item ->+  m ()+add settings@ReaperSettings {..} stateRef tidRef item =+  mask_ $ join $ atomicModifyIORef' stateRef cons+  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 ())++spawn ::+  (MonadUnliftIO m) =>+  ReaperSettings m workload item ->+  IORef (State workload) ->+  IORef (Maybe ThreadId) ->+  m ()+spawn settings stateRef tidRef = do+  tid <- forkIO $ reaper settings stateRef tidRef+  liftIO . labelThread tid $ reaperThreadName settings+  writeIORef tidRef $ Just tid++reaper ::+  (MonadUnliftIO m) =>+  ReaperSettings m workload item ->+  IORef (State workload) ->+  IORef (Maybe ThreadId) ->+  m ()+reaper settings@ReaperSettings {..} stateRef tidRef = do+  threadDelay reaperDelay+  -- Getting the current jobs. Push an empty job to the reference.+  wl <- atomicModifyIORef' stateRef swapWithEmpty+  -- Do the jobs. A function to merge the left jobs and+  -- new jobs is returned.+  !merge <- reaperAction wl+  -- Merging the left jobs and new jobs.+  -- If there is no jobs, this thread finishes.+  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)++    check _ NoReaper = error "Control.Reaper.reaper: unexpected NoReaper (2)"+    check merge (Workload wl)+      -- 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++{- | A helper function for creating 'reaperAction' functions. You would+ provide this function with a function to process a single work item and+ return either a new work item, or @Nothing@ if the work item is+ expired.++ @since 0.1.0+-}+mkListAction ::+  (Monad m) =>+  (item -> m (Maybe item')) ->+  [item] ->+  m ([item'] -> [item'])+mkListAction f =+  go id+  where+    go !front [] = pure front+    go !front (x : xs) = do+      my <- f x+      let front' =+            case my of+              Nothing -> front+              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').+ The reaper will run every two seconds ('reaperDelay'), but will stop running while+ 'reaperNull' is true.++ @main@ then loops infinitely ('Control.Monad.forever'). Each second it calculates the fibonacci number+ for a value between 30 and 34, first trying the cache ('reaperRead' and 'Data.Map.Strict.lookup'),+ then falling back to manually calculating it (@fib@)+ and updating the cache with the result ('reaperAdd')++ @clean@ simply removes items cached for more than 10 seconds.+ This function is where you would perform IO-related cleanup,+ like killing threads or closing connections, if that was the purpose of your reaper.++ @+ module Main where++ import "Data.Time" (UTCTime, getCurrentTime, diffUTCTime)+ import "Control.Reaper"+ import "Control.Concurrent" (threadDelay)+ import "Data.Map.Strict" (Map)+ import qualified "Data.Map.Strict" as Map+ import "Control.Monad" (forever)+ import "System.Random" (getStdRandom, randomR)++ fib :: 'Int' -> 'Int'+ fib 0 = 0+ fib 1 = 1+ fib n = fib (n-1) + fib (n-2)++ type Cache = 'Data.Map.Strict.Map' 'Int' ('Int', 'Data.Time.Clock.UTCTime')++ main :: IO ()+ main = do+   reaper <- 'mkReaper' 'defaultReaperSettings'+     { 'reaperEmpty' = Map.'Data.Map.Strict.empty'+     , 'reaperCons' = \\(k, v, time) workload -> Map.'Data.Map.Strict.insert' k (v, time) workload+     , 'reaperAction' = clean+     , 'reaperDelay' = 1000000 * 2 -- Clean every 2 seconds+     , 'reaperNull' = Map.'Data.Map.Strict.null'+     }+   forever $ do+     fibArg <- 'System.Random.getStdRandom' ('System.Random.randomR' (30,34))+     cache <- 'reaperRead' reaper+     let cachedResult = Map.'Data.Map.Strict.lookup' fibArg cache+     case cachedResult of+       'Just' (fibResult, _createdAt) -> 'putStrLn' $ "Found in cache: `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult+       'Nothing' -> do+         let fibResult = fib fibArg+         'putStrLn' $ "Calculating `fib " ++ 'show' fibArg ++ "` " ++ 'show' fibResult+         time <- 'Data.Time.Clock.getCurrentTime'+         ('reaperAdd' reaper) (fibArg, fibResult, time)+     'threadDelay' 1000000 -- 1 second++ -- Remove items > 10 seconds old+ clean :: Cache -> IO (Cache -> Cache)+ clean oldMap = do+   currentTime <- 'Data.Time.Clock.getCurrentTime'+   let pruned = Map.'Data.Map.Strict.filter' (\\(_, createdAt) -> currentTime \`diffUTCTime\` createdAt < 10.0) oldMap+   return (\\newData -> Map.'Data.Map.Strict.union' pruned newData)+ @+-}
+ src/UnliftIO/Reaper/Internal.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_HADDOCK not-home #-}++module UnliftIO.Reaper.Internal (Reaper (..)) where++-- | A data structure to hold reaper APIs.+data Reaper m workload item = Reaper+  { reaperAdd :: item -> m ()+  -- ^ Adding an item to the workload+  , reaperRead :: m workload+  -- ^ Reading workload.+  , reaperModify :: (workload -> workload) -> m workload+  -- ^ Modify the workload. The resulting workload is returned.+  --+  --   If there is no reaper thread, the modifier will not be applied and+  --   'UnliftIO.Reaper.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 'UnliftIO.Reaper.reaperAction' satisfies 'UnliftIO.Reaper.reaperNull'.+  --+  --  @since 0.1.0+  , reaperStop :: m workload+  -- ^ Stopping the reaper thread if exists.+  --   The current workload is returned.+  , reaperKill :: m ()+  -- ^ Killing the reaper thread immediately if exists.+  }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/UnliftIO/AutoUpdateSpec.hs view
@@ -0,0 +1,36 @@+module UnliftIO.AutoUpdateSpec (spec) where++-- import UnliftIO.AutoUpdate+-- import Control.Concurrent (threadDelay)+-- import Control.Monad (replicateM_, forM_)+-- import Data.IORef+import Test.Hspec++-- import Test.Hspec.QuickCheck++spec :: Spec+spec = return ()++-- do+--   prop "incrementer" $ \st' -> do+--       let st = abs st' `mod` 10000+--       ref <- newIORef 0+--       next <- mkAutoUpdate defaultUpdateSettings+--           { updateAction = atomicModifyIORef ref $ \i ->+--               let i' = succ i in i' `seq` (i', i')+--           , updateFreq = 10000+--           }++--       forM_ [1..st + 1] $ \i -> do+--           j <- next+--           j `shouldBe` i++--       replicateM_ 50 $ do+--           i <- next+--           i `shouldBe` st + 2++--       threadDelay 60000+--       last1 <- readIORef ref+--       threadDelay 20000+--       last2 <- readIORef ref+--       last2 `shouldBe` last1
+ test/UnliftIO/DebounceSpec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE NumericUnderscores #-}++module UnliftIO.DebounceSpec (main, spec) where++import Control.Concurrent+  ( MVar+  , newEmptyMVar+  , newMVar+  , putMVar+  , takeMVar+  , threadDelay+  , tryReadMVar+  )+import Control.Monad (void)+import Control.Monad.Catch+import Control.Retry (constantDelay, limitRetries, recovering)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import GHC.Clock (getMonotonicTime)+import Test.HUnit (assertBool)+import Test.HUnit.Lang (HUnitFailure (HUnitFailure))+import Test.Hspec (Spec, describe, hspec, it, shouldReturn)+import UnliftIO.Debounce+  ( DebounceSettings (..)+  , defaultDebounceSettings+  , leadingEdge+  , leadingMuteEdge+  , trailingDelayEdge+  , trailingEdge+  )+import qualified UnliftIO.Debounce.Internal as DI++spec :: Spec+spec = describe "mkDebounce" $ do+  describe "Leading edge" $ do+    it "works for a single event" $ do+      (ref, debounced, _baton, returnFromWait) <- getDebounce leadingEdge++      debounced+      waitUntil 5 $ readIORef ref `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 leadingEdge++      debounced+      waitForBatonToBeTaken baton+      debounced+      pause+      waitUntil 5 $ readIORef ref `shouldReturn` 1++      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+      (ref, debounced, _baton, returnFromWait) <- getDebounce trailingEdge++      debounced+      pause+      readIORef ref `shouldReturn` 0++      returnFromWait+      waitUntil 5 $ readIORef ref `shouldReturn` 1++      -- Try another round+      debounced+      pause+      waitUntil 5 $ readIORef ref `shouldReturn` 1++      returnFromWait+      waitUntil 5 $ readIORef ref `shouldReturn` 2++    it "works for multiple events" $ do+      (ref, debounced, baton, returnFromWait) <- getDebounce trailingEdge++      debounced+      waitForBatonToBeTaken baton+      debounced+      pause+      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+  waitVar <- newEmptyMVar+  let waitAction _ = takeMVar waitVar+  let returnFromWait = putMVar waitVar ()+  return (waitAction, returnFromWait)++getDebounce :: DI.DebounceEdge -> IO (IORef Int, IO (), MVar (), IO ())+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) <-+    if useThreadDelay+      then pure (threadDelay, pure ())+      else getWaitAction++  baton <- newMVar ()++  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 100_000++waitForBatonToBeTaken :: MVar () -> IO ()+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)++main :: IO ()+main = hspec spec
+ test/UnliftIO/ReaperSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}++module UnliftIO.ReaperSpec (spec) where++import Control.Concurrent+import Data.IORef+import Test.Hspec+import Test.Hspec.QuickCheck+import UnliftIO.Reaper++spec :: Spec+spec = do+  prop "works" $ \(is :: [Int]) -> do+    reaper <-+      mkReaper+        defaultReaperSettings+          { reaperAction = action+          , reaperDelay = 1000+          }++    let mkTestCase i = do+          ref <- newIORef 0+          let expected = (abs i `mod` 10) + 1+          reaperAdd reaper (expected, ref)+          return (expected, ref)+    testCases <- mapM mkTestCase is++    let test (expected, ref) = do+          actual <- readIORef ref+          actual `shouldBe` (expected :: Int)+    threadDelay 100000+    mapM_ test testCases+    [] <- reaperRead reaper+    return ()++type Item = (Int, IORef Int)++action :: [Item] -> IO ([Item] -> [Item])+action = mkListAction $ \(i, ref) -> do+  modifyIORef ref succ+  return $+    if i > 1+      then Just (pred i, ref)+      else Nothing