Squashed commit of the following:

commit ddb4081
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 14:03:24 2024 +0100

    add PR number and URL to Changelog

commit ffecec5
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 14:02:58 2024 +0100

    remove custom build directory

commit 1eeceb4
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 13:06:49 2024 +0100

    and fix the CI

commit 27c6ff9
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:50:20 2024 +0100

    upped version in cabal file

commit 4246ff5
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:49:41 2024 +0100

    documentation fix

commit 16a20ca
Merge: b9e7aad 23b8c4c
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:42:07 2024 +0100

    Merge branch 'master' into trying-to-rework-Control-Debounce

commit b9e7aad
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:26:54 2024 +0100

    added to Changelog

commit 73deb77
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:26:39 2024 +0100

    auto-update/test: adjusted tests for new 'DebounceEdge' tests

commit f0ba37b
Author: Felix Paulusma <[email protected]>
Date:   Sun Oct 27 12:26:08 2024 +0100

    auto-update: fixed debounce to not leak threads and also added two new 'DebounceEdge' types. Also improved (hopefully) the documentation

commit a0f9e92
Author: Felix Paulusma <[email protected]>
Date:   Sat Jun 8 23:17:01 2024 +0200

    auto-update: reworked 'mkDebounce', and it should work... but i'Leading' only works if I put a 'trace' in a specific spot???

auto-update/ChangeLog.md

@@ -1,5 +1,15 @@
 # ChangeLog for auto-update
 
+## 0.2.2
+
+* [#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.1
 
 * Labeling threads.
@@ -8,19 +18,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
 

auto-update/Control/Debounce.hs

@@ -23,22 +23,26 @@
 --
 -- @since 0.1.2
 module Control.Debounce (
-    -- * Type
+    -- * Creation
+    mkDebounce,
+
+    -- * Settings
     DI.DebounceSettings,
     defaultDebounceSettings,
 
-    -- * Accessors
+    -- ** Accessors
     DI.debounceFreq,
     DI.debounceAction,
     DI.debounceEdge,
+
+    -- ** 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'.
@@ -54,8 +58,11 @@ defaultDebounceSettings =
 
 -- | 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

auto-update/Control/Debounce/Internal.hs

@@ -5,19 +5,24 @@ module Control.Debounce.Internal (
     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,7 +54,7 @@ data DebounceSettings = DebounceSettings
     -- ^ Whether to perform the action on the leading edge or trailing edge of
     -- the timeout.
     --
-    -- Default: 'trailingEdge'.
+    -- Default: 'leadingEdge'.
     --
     -- @since 0.1.6
     }
@@ -63,42 +68,229 @@ data DebounceEdge
       -- 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) = do
-    tid <- mask_ $ forkIO $ forever $ do
-        takeMVar baton
-        case edge of
-            Leading -> do
+-- \* 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
+mkDebounceInternal baton delayFn (DebounceSettings freq action Leading) = do
+    trigger <- newEmptyMVar
+    pure $ do
+        -- 1)
+        success <- tryTakeMVar baton
+        case success of
+            -- 2)
+            Nothing -> void $ tryPutMVar trigger ()
+            Just () -> do
+                void $ tryTakeMVar trigger
+                startWorker trigger
+  where
+    startWorker trigger =
+        let loop = do
+                -- 3)
                 ignoreExc action
+                -- 4)
                 delayFn freq
-            Trailing -> do
-                delayFn freq
-                -- Empty the baton of any other activations during the interval
-                void $ tryTakeMVar baton
-                ignoreExc action
-    labelThread tid "Denounce"
-    return $ void $ tryPutMVar baton ()
+                -- 5)
+                isTriggered <- tryTakeMVar trigger
+                case isTriggered of
+                    -- 6)
+                    Nothing -> putMVar baton ()
+                    Just () -> loop
+         in forkAndLabel "Leading" 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
+mkDebounceInternal baton delayFn (DebounceSettings freq action LeadingMute) =
+    pure $ do
+        -- 1)
+        success <- tryTakeMVar baton
+        case success of
+            -- 2)
+            Nothing -> pure ()
+            Just () ->
+                forkAndLabel "LeadingMute" $ 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
+mkDebounceInternal baton delayFn (DebounceSettings freq action Trailing) =
+    pure $ do
+        -- 1)
+        success <- tryTakeMVar baton
+        case success of
+            -- 2)
+            Nothing -> pure ()
+            Just () ->
+                forkAndLabel "Trailing" $ 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
+mkDebounceInternal baton delayFn (DebounceSettings freq action TrailingDelay) = do
+    -- 1)
+    timeTVar <- newTVarIO minBound
+    pure $ do
+        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 "TrailingDelay" $ go timeTVar freq
+  where
+    go timeTVar = loop
+      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 :: String -> IO () -> IO ()
+forkAndLabel s act = do
+    tid <- mask_ $ forkIO act
+    labelThread tid $ "Debounce (" <> s <> "): " <> show tid
 
 ignoreExc :: IO () -> IO ()
 ignoreExc = handle $ \(_ :: SomeException) -> return ()

auto-update/auto-update.cabal

@@ -1,5 +1,5 @@
 name:                auto-update
-version:             0.2.1
+version:             0.2.2
 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