{-# 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
  { forall (m :: * -> *). DebounceSettings m -> Int
debounceFreq :: Int
  -- ^ Length of the debounce timeout period in microseconds.
  --
  -- Default: 1 second (1000000)
  --
  -- @since 0.1.0
  , forall (m :: * -> *). DebounceSettings m -> m ()
debounceAction :: m ()
  -- ^ Action to be performed.
  --
  -- Note: all exceptions thrown by this action will be silently discarded.
  --
  -- Default: does nothing.
  --
  -- @since 0.1.0
  , forall (m :: * -> *). DebounceSettings m -> DebounceEdge
debounceEdge :: DebounceEdge
  -- ^ Whether to perform the action on the leading edge or trailing edge of
  -- the timeout.
  --
  -- Default: 'leadingEdge'.
  --
  -- @since 0.1.0
  , forall (m :: * -> *). DebounceSettings m -> String
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 (Int -> DebounceEdge -> ShowS
[DebounceEdge] -> ShowS
DebounceEdge -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DebounceEdge] -> ShowS
$cshowList :: [DebounceEdge] -> ShowS
show :: DebounceEdge -> String
$cshow :: DebounceEdge -> String
showsPrec :: Int -> DebounceEdge -> ShowS
$cshowsPrec :: Int -> DebounceEdge -> ShowS
Show, DebounceEdge -> DebounceEdge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DebounceEdge -> DebounceEdge -> Bool
$c/= :: DebounceEdge -> DebounceEdge -> Bool
== :: DebounceEdge -> DebounceEdge -> Bool
$c== :: 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.0
-}
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.0
-}
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.0
-}
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.0
-}
trailingDelayEdge :: DebounceEdge
trailingDelayEdge :: DebounceEdge
trailingDelayEdge = DebounceEdge
TrailingDelay

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

    forkAndLabel :: m () -> m ()
forkAndLabel m ()
act = do
      ThreadId
tid <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO m ()
act
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ThreadId -> String -> IO ()
labelThread ThreadId
tid String
name

ignoreExc :: MonadUnliftIO m => m () -> m ()
ignoreExc :: forall {m :: * -> *}. MonadUnliftIO m => m () -> m ()
ignoreExc = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()