{-# LANGUAGE ScopedTypeVariables #-}

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

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (
    MVar,
    takeMVar,
    tryPutMVar,
    tryTakeMVar,
 )
import Control.Exception (SomeException, handle, mask_)
import Control.Monad (forever, void)
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: 'trailingEdge'.
    --
    -- @since 0.1.6
    , DebounceSettings -> String
debounceThreadName :: String
    }

-- | 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
    | -- | Start a cooldown period and perform the action when the period ends. If another trigger
      -- happens during the cooldown, it has no effect.
      Trailing
    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.
--
-- @since 0.1.6
leadingEdge :: DebounceEdge
leadingEdge :: DebounceEdge
leadingEdge = DebounceEdge
Leading

-- | Start a cooldown period and perform the action when the period ends. If another trigger
-- happens during the cooldown, it has no effect.
--
-- @since 0.1.6
trailingEdge :: DebounceEdge
trailingEdge :: DebounceEdge
trailingEdge = DebounceEdge
Trailing

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) = 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 () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
baton
        case DebounceEdge
edge of
            DebounceEdge
Leading -> do
                IO () -> IO ()
ignoreExc IO ()
action
                Int -> IO ()
delayFn Int
freq
            DebounceEdge
Trailing -> do
                Int -> IO ()
delayFn Int
freq
                -- Empty the baton of any other activations during the interval
                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 ()
baton
                IO () -> IO ()
ignoreExc IO ()
action
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
name
    IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ 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 ()
baton ()

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 ()