module Control.FoldDebounce
(
new
, Trigger
, Args (..)
, Opts
, def
, delay
, alwaysResetTimer
, forStack
, forMonoid
, forVoid
, send
, close
, 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)
data Args i o
= Args
{
forall i o. Args i o -> o -> IO ()
cb :: o -> IO ()
, forall i o. Args i o -> o -> i -> o
fold :: o -> i -> o
, forall i o. Args i o -> o
init :: o
}
data Opts i o
= Opts
{
forall i o. Opts i o -> Int
delay :: Int
, 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
}
forStack :: ([i] -> IO ())
-> 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 = ((i -> [i] -> [i]) -> [i] -> i -> [i]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)), init :: [i]
init = []}
forMonoid :: Monoid i
=> (i -> IO ())
-> 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 = i -> i -> i
forall a. Monoid a => a -> a -> a
mappend, init :: i
init = i
forall a. Monoid a => a
mempty }
forVoid :: IO ()
-> Args i ()
forVoid :: forall i. IO () -> Args i ()
forVoid IO ()
mycb = Args { cb :: () -> IO ()
cb = IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
mycb, fold :: () -> i -> ()
fold = (\()
_ i
_ -> ()), init :: ()
init = () }
type SendTime = UTCTime
type ExpirationTime = UTCTime
data ThreadInput i
= TIEvent i SendTime
| TIFinish
data ThreadState
= TSOpen
| TSClosedNormally
| TSClosedAbnormally SomeException
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
}
new :: Args i o
-> Opts i o
-> IO (Trigger i o)
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 <- IO (TChan (ThreadInput i))
forall a. IO (TChan a)
newTChanIO
TVar ThreadState
state_tvar <- ThreadState -> IO (TVar ThreadState)
forall a. a -> IO (TVar a)
newTVarIO ThreadState
TSOpen
let putState :: ThreadState -> IO ()
putState = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> (ThreadState -> STM ()) -> ThreadState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar ThreadState -> ThreadState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ThreadState
state_tvar
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
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)
((SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ThreadState -> IO ()
putState (ThreadState -> IO ())
-> (SomeException -> ThreadState) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ThreadState
TSClosedAbnormally) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadState -> IO ()
putState ThreadState
TSClosedNormally))
Trigger i o -> IO (Trigger i o)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Trigger i o -> IO (Trigger i o))
-> Trigger i o -> IO (Trigger i o)
forall a b. (a -> b) -> a -> b
$ TChan (ThreadInput i) -> TVar ThreadState -> Trigger i o
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 = TVar ThreadState -> STM ThreadState
forall a. TVar a -> STM a
readTVar (Trigger i o -> TVar ThreadState
forall i o. Trigger i o -> TVar ThreadState
trigState Trigger i o
trig)
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
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ThreadState
state <- Trigger i o -> STM ThreadState
forall i o. Trigger i o -> STM ThreadState
getThreadState Trigger i o
trig
case ThreadState
state of
ThreadState
TSOpen -> TChan (ThreadInput i) -> ThreadInput i -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Trigger i o -> TChan (ThreadInput i)
forall i o. Trigger i o -> TChan (ThreadInput i)
trigInput Trigger i o
trig) (i -> UTCTime -> ThreadInput i
forall i. i -> UTCTime -> ThreadInput i
TIEvent i
in_event UTCTime
send_time)
ThreadState
TSClosedNormally -> OpException -> STM ()
forall e a. Exception e => e -> STM a
throwSTM OpException
AlreadyClosedException
TSClosedAbnormally SomeException
e -> OpException -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (OpException -> STM ()) -> OpException -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> OpException
UnexpectedClosedException SomeException
e
close :: Trigger i o -> IO ()
close :: forall i o. Trigger i o -> IO ()
close Trigger i o
trig = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> STM ()
whenOpen (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TChan (ThreadInput i) -> ThreadInput i -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Trigger i o -> TChan (ThreadInput i)
forall i o. Trigger i o -> TChan (ThreadInput i)
trigInput Trigger i o
trig) ThreadInput i
forall i. ThreadInput i
TIFinish
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> STM ()
whenOpen (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ STM ()
forall a. STM a
retry
where
whenOpen :: STM () -> STM ()
whenOpen STM ()
stm_action = do
ThreadState
state <- Trigger i o -> STM ThreadState
forall i o. Trigger i o -> STM ThreadState
getThreadState Trigger i o
trig
case ThreadState
state of
ThreadState
TSOpen -> STM ()
stm_action
ThreadState
TSClosedNormally -> () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TSClosedAbnormally SomeException
e -> OpException -> STM ()
forall e a. Exception e => e -> STM a
throwSTM (OpException -> STM ()) -> OpException -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> OpException
UnexpectedClosedException SomeException
e
data OpException
= AlreadyClosedException
| UnexpectedClosedException SomeException
deriving (Int -> OpException -> ShowS
[OpException] -> ShowS
OpException -> String
(Int -> OpException -> ShowS)
-> (OpException -> String)
-> ([OpException] -> ShowS)
-> Show OpException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpException -> ShowS
showsPrec :: Int -> OpException -> ShowS
$cshow :: OpException -> String
show :: OpException -> String
$cshowList :: [OpException] -> ShowS
showList :: [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' Maybe UTCTime
forall a. Maybe a
Nothing Maybe o
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 <- TChan (ThreadInput i)
-> Maybe UTCTime -> IO (Maybe (ThreadInput i))
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 -> Args i o -> Maybe o -> IO ()
forall i o. Args i o -> Maybe o -> IO ()
fireCallback Args i o
args Maybe o
mout_event IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe UTCTime -> Maybe o -> IO ()
threadAction' Maybe UTCTime
forall a. Maybe a
Nothing Maybe o
forall a. Maybe a
Nothing
Just (ThreadInput i
TIFinish) -> Args i o -> Maybe o -> IO ()
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 = Args i o -> Maybe o -> i -> o
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 = Opts i o -> Maybe UTCTime -> UTCTime -> UTCTime
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 o -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Maybe UTCTime -> Maybe o -> IO ()
threadAction' (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
next_expiration) (o -> Maybe o
forall a. a -> Maybe a
Just o
next_out)
waitInput :: TChan a
-> Maybe ExpirationTime
-> IO (Maybe a)
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) (UTCTime -> Int) -> Maybe UTCTime -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mexpiration
case Maybe Int
mwait_duration of
Just Int
0 -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Maybe Int
Nothing -> STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically STM (Maybe a)
readInputSTM
Just Int
dur -> IO Delay
-> (Delay -> IO ()) -> (Delay -> IO (Maybe a)) -> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Int -> IO Delay
newDelay Int
dur) Delay -> IO ()
cancelDelay ((Delay -> IO (Maybe a)) -> IO (Maybe a))
-> (Delay -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Delay
timer -> do
STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ STM (Maybe a)
readInputSTM STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe a -> () -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing (() -> Maybe a) -> STM () -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delay -> STM ()
waitDelay Delay
timer)
where
readInputSTM :: STM (Maybe a)
readInputSTM = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM a
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fireCallback Args i o
args (Just o
out_event) = Args i o -> o -> IO ()
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 = o -> (o -> o) -> Maybe o -> o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Args i o -> o
forall i o. Args i o -> o
init Args i o
args) o -> o
forall a. a -> a
id Maybe o
mcurrent
in Args i o -> o -> i -> o
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 Int -> Int -> Bool
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 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1000000) (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
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 (Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d Integer -> Integer -> Rational
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
| Opts i o -> Bool
forall i o. Opts i o -> Bool
alwaysResetTimer Opts i o
opts = UTCTime
fullDelayed
| Bool
otherwise = UTCTime -> (UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UTCTime
fullDelayed UTCTime -> UTCTime
forall a. a -> a
id (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime
mlast_expiration
where
fullDelayed :: UTCTime
fullDelayed = (UTCTime -> Int -> UTCTime
`addTimeUsec` Opts i o -> Int
forall i o. Opts i o -> Int
delay Opts i o
opts) UTCTime
send_time