    {-# 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)
            success <- MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar ()
    baton
            case 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)
                isTriggered <- MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar ()
    trigger
                case 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)
            success <- MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar ()
    baton
            case 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)
            success <- MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar ()
    baton
            case 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)
            now <- IO Word64
    getMonotonicTimeNSec
            -- 2)
            success <- tryTakeMVar baton
            case 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
                    oldTime <- TVar Word64 -> STM Word64
    forall a. TVar a -> STM a
    readTVar TVar Word64
    timeTVar
                    when (oldTime < now) $ writeTVar timeTVar 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
                lastTrigger <- TVar Word64 -> IO Word64
    forall a. TVar a -> IO a
    readTVarIO TVar Word64
    timeTVar
                now <- getMonotonicTimeNSec
                -- 5)
                let 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 = Int
    diff Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    freq
                if shouldWait
                    -- 6)
                    then loop $ freq - diff
                    else do
                        ignoreExc action
                        timeAfterAction <- readTVarIO timeTVar
                        -- 7)
                        let wasTriggered = Word64
    timeAfterAction Word64 -> Word64 -> Bool
    forall a. Ord a => a -> a -> Bool
    > Word64
    now
                        if wasTriggered
                            then do
                                updatedNow <- getMonotonicTimeNSec
                                let 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
                                loop $ freq - newDiff
                            -- 8)
                            else putMVar baton ()
        forkAndLabel :: IO () -> IO ()
    forkAndLabel IO ()
    act = do
            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
            labelThread tid 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 ()