-- |
-- Module: Control.FoldDebounce
-- Description: Fold multiple events that happen in a given period of time
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- Synopsis:
--
-- > module Main (main) where
-- >
-- > import System.IO (putStrLn)
-- > import Control.Concurrent (threadDelay)
-- >
-- > import qualified Control.FoldDebounce as Fdeb
-- >
-- > printValue :: Int -> IO ()
-- > printValue v = putStrLn ("value = " ++ show v)
-- >
-- > main :: IO ()
-- > main = do
-- >   trigger <- Fdeb.new Fdeb.Args { Fdeb.cb = printValue, Fdeb.fold = (+), Fdeb.init = 0 }
-- >                       Fdeb.def { Fdeb.delay = 500000 }
-- >   let send' = Fdeb.send trigger
-- >   send' 1
-- >   send' 2
-- >   send' 3
-- >   threadDelay 1000000 -- During this period, "value = 6" is printed.
-- >   send' 4
-- >   threadDelay 1000    -- Nothing is printed.
-- >   send' 5
-- >   threadDelay 1000000 -- During this period, "value = 9" is printed.
-- >   Fdeb.close trigger
--
-- This module is similar to "Control.Debounce". It debouces input
-- events and regulates the frequency at which the action (callback)
-- is executed.
--
-- The difference from "Control.Debounce" is:
--
-- * With "Control.Debounce", you cannot pass values to the callback
-- action. This module folds (accumulates) the input events (type @i@)
-- and passes the folded output event (type @o@) to the callback.
--
-- * "Control.Debounce" immediately runs the callback at the first
-- input event. This module just starts a timer at the first input,
-- and runs the callback when the timer expires.
--
-- The API and documentation is borrowed from a Perl module called
-- AnyEvent::Debounce. See <https://metacpan.org/pod/AnyEvent::Debounce>
--
--
module Control.FoldDebounce
    ( -- * Create the trigger
      new
    , Trigger
      -- * Parameter types
    , Args (..)
    , Opts
    , def
      -- ** Accessors for 'Opts'
      -- $opts_accessors
    , delay
    , alwaysResetTimer
      -- ** Preset parameters
    , forStack
    , forMonoid
    , forVoid
      -- * Use the trigger
    , send
      -- * Finish the trigger
    , close
      -- * Exception types
    , OpException (..)
    ) where

import           Control.Applicative          ((<$>), (<|>))
import           Control.Concurrent           (forkFinally)
import           Control.Exception            (Exception, SomeException, bracket)
import           Control.Monad                (void)
import           Data.Monoid                  (Monoid, mappend, mempty)
import           Data.Ratio                   ((%))
import           Data.Typeable                (Typeable)
import           Prelude                      hiding (init)

import           Control.Concurrent.STM       (STM, TChan, TVar, atomically, newTChanIO, newTVarIO,
                                               readTChan, readTVar, retry, throwSTM, writeTChan,
                                               writeTVar)
import           Control.Concurrent.STM.Delay (cancelDelay, newDelay, waitDelay)
import           Data.Default.Class           (Default (def))
import           Data.Time                    (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)

-- | Mandatory parameters for 'new'.
data Args i o
  = Args
      { -- | The callback to be called when the output event is
        -- emitted. Note that this action is run in a different thread than
        -- the one calling 'send'.
        --
        -- The callback should not throw any exception. In this case, the
        -- 'Trigger' is abnormally closed, causing
        -- 'UnexpectedClosedException' when 'close'.
        forall i o. Args i o -> o -> IO ()
cb   :: o -> IO ()
        -- | The binary operation of left-fold. The left-fold is evaluated strictly.
      , forall i o. Args i o -> o -> i -> o
fold :: o -> i -> o
        -- | The initial value of the left-fold.
      , forall i o. Args i o -> o
init :: o
      }

-- $opts_accessors
-- You can update fields in 'Opts' via these accessors.
--



-- | Optional parameters for 'new'. You can get the default by 'def'
-- function.
data Opts i o
  = Opts
      { -- | The time (in microsecond) to wait after receiving an event
        -- before sending it, in case more events happen in the interim.
        --
        -- Default: 1 second (1000000)
        forall i o. Opts i o -> Int
delay            :: Int
        -- | Normally, when an event is received and it's the first of a
        -- series, a timer is started, and when that timer expires, all
        -- events are sent. If you set this parameter to True, then
        -- the timer is reset after each event is received.
        --
        -- Default: False
      , forall i o. Opts i o -> Bool
alwaysResetTimer :: Bool
      }

instance Default (Opts i o) where
  def :: Opts i o
def = Opts {
    delay :: Int
delay = Int
1000000,
    alwaysResetTimer :: Bool
alwaysResetTimer = Bool
False
    }

-- | 'Args' for stacks. Input events are accumulated in a stack, i.e.,
-- the last event is at the head of the list.
forStack :: ([i] -> IO ()) -- ^ 'cb' field.
         -> Args i [i]
forStack :: forall i. ([i] -> IO ()) -> Args i [i]
forStack [i] -> IO ()
mycb = Args { cb :: [i] -> IO ()
cb = [i] -> IO ()
mycb, fold :: [i] -> i -> [i]
fold = (forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)),  init :: [i]
init = []}

-- | 'Args' for monoids. Input events are appended to the tail.
forMonoid :: Monoid i
             => (i -> IO ()) -- ^ 'cb' field.
             -> Args i i
forMonoid :: forall i. Monoid i => (i -> IO ()) -> Args i i
forMonoid i -> IO ()
mycb = Args { cb :: i -> IO ()
cb = i -> IO ()
mycb, fold :: i -> i -> i
fold = forall a. Monoid a => a -> a -> a
mappend, init :: i
init = forall a. Monoid a => a
mempty }

-- | 'Args' that discards input events. Although input events are not
-- folded, they still start the timer and activate the callback.
forVoid :: IO () -- ^ 'cb' field.
        -> Args i ()
forVoid :: forall i. IO () -> Args i ()
forVoid IO ()
mycb = Args { cb :: () -> IO ()
cb = forall a b. a -> b -> a
const IO ()
mycb, fold :: () -> i -> ()
fold = (\()
_ i
_ -> ()), init :: ()
init = () }

type SendTime = UTCTime
type ExpirationTime = UTCTime

-- | Internal input to the worker thread.
data ThreadInput i
  = TIEvent i SendTime -- ^ A new input event is made
  | TIFinish

-- | Internal state of the worker thread.
data ThreadState
  = TSOpen -- ^ the thread is open and running
  | TSClosedNormally -- ^ the thread is successfully closed
  | TSClosedAbnormally SomeException

-- | A trigger to send input events to FoldDebounce. You input data of
-- type @i@ to the trigger, and it outputs data of type @o@.
data Trigger i o
  = Trigger
      { forall i o. Trigger i o -> TChan (ThreadInput i)
trigInput :: TChan (ThreadInput i)
      , forall i o. Trigger i o -> TVar ThreadState
trigState :: TVar ThreadState
      }

-- | Create a FoldDebounce trigger.
new :: Args i o -- ^ mandatory parameters
    -> Opts i o -- ^ optional parameters
    -> IO (Trigger i o) -- ^ action to create the trigger.
new :: forall i o. Args i o -> Opts i o -> IO (Trigger i o)
new Args i o
args Opts i o
opts = do
  TChan (ThreadInput i)
chan <- forall a. IO (TChan a)
newTChanIO
  TVar ThreadState
state_tvar <- forall a. a -> IO (TVar a)
newTVarIO ThreadState
TSOpen
  let putState :: ThreadState -> IO ()
putState = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> a -> STM ()
writeTVar TVar ThreadState
state_tvar
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall i o. Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
threadAction Args i o
args Opts i o
opts TChan (ThreadInput i)
chan)
                     (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ThreadState -> IO ()
putState forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ThreadState
TSClosedAbnormally) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ ThreadState -> IO ()
putState ThreadState
TSClosedNormally))
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall i o.
TChan (ThreadInput i) -> TVar ThreadState -> Trigger i o
Trigger TChan (ThreadInput i)
chan TVar ThreadState
state_tvar

getThreadState :: Trigger i o -> STM ThreadState
getThreadState :: forall i o. Trigger i o -> STM ThreadState
getThreadState Trigger i o
trig = forall a. TVar a -> STM a
readTVar (forall i o. Trigger i o -> TVar ThreadState
trigState Trigger i o
trig)

-- | Send an input event.
--
-- If the 'Trigger' is already closed, it throws
-- 'AlreadyClosedException'. If the 'Trigger' has been abnormally
-- closed, it throws 'UnexpectedClosedException'.
send :: Trigger i o -> i -> IO ()
send :: forall i o. Trigger i o -> i -> IO ()
send Trigger i o
trig i
in_event = do
  UTCTime
send_time <- IO UTCTime
getCurrentTime
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    ThreadState
state <- forall i o. Trigger i o -> STM ThreadState
getThreadState Trigger i o
trig
    case ThreadState
state of
      ThreadState
TSOpen               -> forall a. TChan a -> a -> STM ()
writeTChan (forall i o. Trigger i o -> TChan (ThreadInput i)
trigInput Trigger i o
trig) (forall i. i -> UTCTime -> ThreadInput i
TIEvent i
in_event UTCTime
send_time)
      ThreadState
TSClosedNormally     -> forall e a. Exception e => e -> STM a
throwSTM OpException
AlreadyClosedException
      TSClosedAbnormally SomeException
e -> forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ SomeException -> OpException
UnexpectedClosedException SomeException
e

-- | Close and release the 'Trigger'. If there is a pending output event, the event is fired immediately.
--
-- If the 'Trigger' has been abnormally closed, it throws 'UnexpectedClosedException'.
close :: Trigger i o -> IO ()
close :: forall i o. Trigger i o -> IO ()
close Trigger i o
trig = do
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM () -> STM ()
whenOpen forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan (forall i o. Trigger i o -> TChan (ThreadInput i)
trigInput Trigger i o
trig) forall i. ThreadInput i
TIFinish
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM () -> STM ()
whenOpen forall a b. (a -> b) -> a -> b
$ forall a. STM a
retry -- wait for closing
  where
    whenOpen :: STM () -> STM ()
whenOpen STM ()
stm_action = do
      ThreadState
state <- forall i o. Trigger i o -> STM ThreadState
getThreadState Trigger i o
trig
      case ThreadState
state of
        ThreadState
TSOpen               -> STM ()
stm_action
        ThreadState
TSClosedNormally     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        TSClosedAbnormally SomeException
e -> forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ SomeException -> OpException
UnexpectedClosedException SomeException
e

-- | Exception type used by FoldDebounce operations
data OpException
  = AlreadyClosedException -- ^ You attempted to 'send' after the trigger is already 'close'd.
  | UnexpectedClosedException SomeException -- ^ The 'SomeException' is thrown in the background thread.
  deriving (Int -> OpException -> ShowS
[OpException] -> ShowS
OpException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpException] -> ShowS
$cshowList :: [OpException] -> ShowS
show :: OpException -> String
$cshow :: OpException -> String
showsPrec :: Int -> OpException -> ShowS
$cshowsPrec :: Int -> OpException -> ShowS
Show, Typeable)

instance Exception OpException

---

threadAction :: Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
threadAction :: forall i o. Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
threadAction Args i o
args Opts i o
opts TChan (ThreadInput i)
in_chan = Maybe UTCTime -> Maybe o -> IO ()
threadAction' forall a. Maybe a
Nothing forall a. Maybe a
Nothing where
  threadAction' :: Maybe UTCTime -> Maybe o -> IO ()
threadAction' Maybe UTCTime
mexpiration Maybe o
mout_event = do
    Maybe (ThreadInput i)
mgot <- forall a. TChan a -> Maybe UTCTime -> IO (Maybe a)
waitInput TChan (ThreadInput i)
in_chan Maybe UTCTime
mexpiration
    case Maybe (ThreadInput i)
mgot of
      Maybe (ThreadInput i)
Nothing -> forall i o. Args i o -> Maybe o -> IO ()
fireCallback Args i o
args Maybe o
mout_event forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe UTCTime -> Maybe o -> IO ()
threadAction' forall a. Maybe a
Nothing forall a. Maybe a
Nothing
      Just (ThreadInput i
TIFinish) -> forall i o. Args i o -> Maybe o -> IO ()
fireCallback Args i o
args Maybe o
mout_event
      Just (TIEvent i
in_event UTCTime
send_time) ->
        let next_out :: o
next_out = forall i o. Args i o -> Maybe o -> i -> o
doFold Args i o
args Maybe o
mout_event i
in_event
            next_expiration :: UTCTime
next_expiration = forall i o. Opts i o -> Maybe UTCTime -> UTCTime -> UTCTime
nextExpiration Opts i o
opts Maybe UTCTime
mexpiration UTCTime
send_time
        in o
next_out seq :: forall a b. a -> b -> b
`seq` Maybe UTCTime -> Maybe o -> IO ()
threadAction' (forall a. a -> Maybe a
Just UTCTime
next_expiration) (forall a. a -> Maybe a
Just o
next_out)

waitInput :: TChan a      -- ^ input channel
          -> Maybe ExpirationTime  -- ^ If 'Nothing', it never times out.
          -> IO (Maybe a) -- ^ 'Nothing' if timed out
waitInput :: forall a. TChan a -> Maybe UTCTime -> IO (Maybe a)
waitInput TChan a
in_chan Maybe UTCTime
mexpiration = do
  UTCTime
cur_time <- IO UTCTime
getCurrentTime
  let mwait_duration :: Maybe Int
mwait_duration = (UTCTime -> UTCTime -> Int
`diffTimeUsec` UTCTime
cur_time) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mexpiration
  case Maybe Int
mwait_duration of
    Just Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Maybe Int
Nothing -> forall a. STM a -> IO a
atomically STM (Maybe a)
readInputSTM
    Just Int
dur -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO Delay
newDelay Int
dur) Delay -> IO ()
cancelDelay forall a b. (a -> b) -> a -> b
$ \Delay
timer -> do
      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM (Maybe a)
readInputSTM forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. a -> b -> a
const forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delay -> STM ()
waitDelay Delay
timer)
  where
    readInputSTM :: STM (Maybe a)
readInputSTM = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
readTChan TChan a
in_chan

fireCallback :: Args i o -> Maybe o -> IO ()
fireCallback :: forall i o. Args i o -> Maybe o -> IO ()
fireCallback Args i o
_ Maybe o
Nothing             = forall (m :: * -> *) a. Monad m => a -> m a
return ()
fireCallback Args i o
args (Just o
out_event) = forall i o. Args i o -> o -> IO ()
cb Args i o
args o
out_event

doFold :: Args i o -> Maybe o -> i -> o
doFold :: forall i o. Args i o -> Maybe o -> i -> o
doFold Args i o
args Maybe o
mcurrent i
in_event = let current :: o
current = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall i o. Args i o -> o
init Args i o
args) forall a. a -> a
id Maybe o
mcurrent
                                in forall i o. Args i o -> o -> i -> o
fold Args i o
args o
current i
in_event

noNegative :: Int -> Int
noNegative :: Int -> Int
noNegative Int
x = if Int
x forall a. Ord a => a -> a -> Bool
< Int
0 then Int
0 else Int
x

diffTimeUsec :: UTCTime -> UTCTime -> Int
diffTimeUsec :: UTCTime -> UTCTime -> Int
diffTimeUsec UTCTime
a UTCTime
b = Int -> Int
noNegative forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a -> a
* Rational
1000000) forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
a UTCTime
b

addTimeUsec :: UTCTime -> Int -> UTCTime
addTimeUsec :: UTCTime -> Int -> UTCTime
addTimeUsec UTCTime
t Int
d = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a. Fractional a => Rational -> a
fromRational (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d forall a. Integral a => a -> a -> Ratio a
% Integer
1000000)) UTCTime
t

nextExpiration :: Opts i o -> Maybe ExpirationTime -> SendTime -> ExpirationTime
nextExpiration :: forall i o. Opts i o -> Maybe UTCTime -> UTCTime -> UTCTime
nextExpiration Opts i o
opts Maybe UTCTime
mlast_expiration UTCTime
send_time
  | forall i o. Opts i o -> Bool
alwaysResetTimer Opts i o
opts = UTCTime
fullDelayed
  | Bool
otherwise = forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTCTime
fullDelayed forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Maybe UTCTime
mlast_expiration
  where
    fullDelayed :: UTCTime
fullDelayed = (UTCTime -> Int -> UTCTime
`addTimeUsec` forall i o. Opts i o -> Int
delay Opts i o
opts) UTCTime
send_time