{-# LANGUAGE ScopedTypeVariables #-}

-- | Unstable API which exposes internals for testing.
module Control.Debounce.Internal (
    DebounceSettings (..),
    DebounceEdge (..),
    leadingEdge,
    leadingMuteEdge,
    trailingEdge,
    trailingDelayEdge,
    mkDebounceInternal,
) where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (
    MVar,
    newEmptyMVar,
    putMVar,
    tryPutMVar,
    tryTakeMVar,
 )
import Control.Exception (SomeException, handle, mask_)
import Control.Monad (void, when)
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc (atomically, newTVarIO, readTVar, readTVarIO, writeTVar)
import GHC.Conc.Sync (labelThread)

-- | Settings to control how debouncing should work.
--
-- This should be constructed using 'defaultDebounceSettings' and record
-- update syntax, e.g.:
--
-- @
-- let settings = 'defaultDebounceSettings' { 'debounceAction' = flushLog }
-- @
--
-- @since 0.1.2
data DebounceSettings = DebounceSettings
    { DebounceSettings -> Int
debounceFreq :: Int
    -- ^ Length of the debounce timeout period in microseconds.
    --
    -- Default: 1 second (1000000)
    --
    -- @since 0.1.2
    , DebounceSettings -> IO ()
debounceAction :: IO ()
    -- ^ Action to be performed.
    --
    -- Note: all exceptions thrown by this action will be silently discarded.
    --
    -- Default: does nothing.
    --
    -- @since 0.1.2
    , DebounceSettings -> DebounceEdge
debounceEdge :: DebounceEdge
    -- ^ Whether to perform the action on the leading edge or trailing edge of
    -- the timeout.
    --
    -- Default: 'leadingEdge'.
    --
    -- @since 0.1.6
    , DebounceSettings -> String
debounceThreadName :: String
    -- ^ Label of the thread spawned when debouncing.
    --
    -- Default: @"Debounce"@.
    --
    -- @since 0.2.2
    }

-- | Setting to control whether the action happens at the leading and/or trailing
-- edge of the timeout.
--
-- @since 0.1.6
data DebounceEdge
    = -- | 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 (Int -> DebounceEdge -> ShowS
[DebounceEdge] -> ShowS
DebounceEdge -> String
(Int -> DebounceEdge -> ShowS)
-> (DebounceEdge -> String)
-> ([DebounceEdge] -> ShowS)
-> Show DebounceEdge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebounceEdge -> ShowS
showsPrec :: Int -> DebounceEdge -> ShowS
$cshow :: DebounceEdge -> String
show :: DebounceEdge -> String
$cshowList :: [DebounceEdge] -> ShowS
showList :: [DebounceEdge] -> ShowS
Show, DebounceEdge -> DebounceEdge -> Bool
(DebounceEdge -> DebounceEdge -> Bool)
-> (DebounceEdge -> DebounceEdge -> Bool) -> Eq DebounceEdge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebounceEdge -> DebounceEdge -> Bool
== :: DebounceEdge -> DebounceEdge -> Bool
$c/= :: DebounceEdge -> DebounceEdge -> Bool
/= :: DebounceEdge -> DebounceEdge -> Bool
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 :: DebounceEdge
leadingEdge = DebounceEdge
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.6
leadingMuteEdge :: DebounceEdge
leadingMuteEdge :: DebounceEdge
leadingMuteEdge = DebounceEdge
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 :: DebounceEdge
trailingEdge = DebounceEdge
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 :: DebounceEdge
trailingDelayEdge = DebounceEdge
TrailingDelay

mkDebounceInternal
    :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
mkDebounceInternal :: MVar () -> (Int -> IO ()) -> DebounceSettings -> IO (IO ())
mkDebounceInternal MVar ()
baton Int -> IO ()
delayFn (DebounceSettings Int
freq IO ()
action DebounceEdge
edge String
name) =
    case DebounceEdge
edge of
        DebounceEdge
Leading -> MVar () -> IO ()
leadingDebounce (MVar () -> IO ()) -> IO (MVar ()) -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
        DebounceEdge
LeadingMute -> IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO ()
leadingMuteDebounce
        DebounceEdge
Trailing -> IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO ()
trailingDebounce
        DebounceEdge
TrailingDelay -> TVar Word64 -> IO ()
trailingDelayDebounce (TVar Word64 -> IO ()) -> IO (TVar Word64) -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> IO (TVar Word64)
forall a. a -> IO (TVar a)
newTVarIO Word64
forall a. Bounded a => a
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 :: MVar () -> IO ()
leadingDebounce MVar ()
trigger = do
        -- 1)
        Maybe ()
success <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
baton
        case Maybe ()
success of
            -- 2)
            Maybe ()
Nothing -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
trigger ()
            Just () -> do
                IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
trigger
                IO () -> IO ()
forkAndLabel IO ()
loop
      where
        loop :: IO ()
loop = do
            -- 3)
            IO () -> IO ()
ignoreExc IO ()
action
            -- 4)
            Int -> IO ()
delayFn Int
freq
            -- 5)
            Maybe ()
isTriggered <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
trigger
            case Maybe ()
isTriggered of
                -- 6)
                Maybe ()
Nothing -> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
baton ()
                Just () -> IO ()
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 :: IO ()
leadingMuteDebounce = do
        -- 1)
        Maybe ()
success <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
baton
        case Maybe ()
success of
            -- 2)
            Maybe ()
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just () ->
                IO () -> IO ()
forkAndLabel (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    -- 3)
                    IO () -> IO ()
ignoreExc IO ()
action
                    -- 4)
                    Int -> IO ()
delayFn Int
freq
                    -- 5)
                    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
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 :: IO ()
trailingDebounce = do
        -- 1)
        Maybe ()
success <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
baton
        case Maybe ()
success of
            -- 2)
            Maybe ()
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just () ->
                IO () -> IO ()
forkAndLabel (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    -- 3)
                    Int -> IO ()
delayFn Int
freq
                    -- 4)
                    IO () -> IO ()
ignoreExc IO ()
action
                    -- 5)
                    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
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 :: TVar Word64 -> IO ()
trailingDelayDebounce TVar Word64
timeTVar = do
        -- 1)
        Word64
now <- IO Word64
getMonotonicTimeNSec
        -- 2)
        Maybe ()
success <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
baton
        case Maybe ()
success of
            -- 3)
            Maybe ()
Nothing -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Word64
oldTime <- TVar Word64 -> STM Word64
forall a. TVar a -> STM a
readTVar TVar Word64
timeTVar
                Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
oldTime Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
now) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TVar Word64 -> Word64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Word64
timeTVar Word64
now
            Just () -> do
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Word64 -> Word64 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Word64
timeTVar Word64
now
                IO () -> IO ()
forkAndLabel (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop Int
freq
      where
        loop :: Int -> IO ()
loop Int
delay = do
            -- 4)
            Int -> IO ()
delayFn Int
delay
            Word64
lastTrigger <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO TVar Word64
timeTVar
            Word64
now <- IO Word64
getMonotonicTimeNSec
            -- 5)
            let diff :: Int
diff = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
lastTrigger) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000
                shouldWait :: Bool
shouldWait = Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
freq
            if Bool
shouldWait
                -- 6)
                then Int -> IO ()
loop (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
freq Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
diff
                else do
                    IO () -> IO ()
ignoreExc IO ()
action
                    Word64
timeAfterAction <- TVar Word64 -> IO Word64
forall a. TVar a -> IO a
readTVarIO TVar Word64
timeTVar
                    -- 7)
                    let wasTriggered :: Bool
wasTriggered = Word64
timeAfterAction Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
now
                    if Bool
wasTriggered
                        then do
                            Word64
updatedNow <- IO Word64
getMonotonicTimeNSec
                            let newDiff :: Int
newDiff = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
updatedNow Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
timeAfterAction) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
1000
                            Int -> IO ()
loop (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
freq Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
newDiff
                        -- 8)
                        else MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
baton ()
    forkAndLabel :: IO () -> IO ()
forkAndLabel IO ()
act = do
        ThreadId
tid <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
act
        ThreadId -> String -> IO ()
labelThread ThreadId
tid String
name

ignoreExc :: IO () -> IO ()
ignoreExc :: IO () -> IO ()
ignoreExc = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO ()) -> IO () -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()