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 = (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 = forall a. Monoid a => a -> a -> a
mappend, init :: i
init = forall a. Monoid a => a
mempty }
forVoid :: IO ()
-> 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
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 <- 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 :: 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 :: 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
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
data OpException
= AlreadyClosedException
| UnexpectedClosedException SomeException
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
-> 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) 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