module Control.FoldDebounce (
new,
Trigger,
Args(..),
Opts,
def,
delay,
alwaysResetTimer,
forStack,
forMonoid,
forVoid,
send,
close,
OpException(..)
) where
import Prelude hiding (init)
import Data.Ratio ((%))
import Data.Monoid (Monoid, mempty, mappend)
import Control.Monad (void)
import Control.Applicative ((<|>), (<$>))
import Control.Concurrent (forkFinally)
import Control.Exception (Exception, SomeException, bracket)
import Data.Typeable (Typeable)
import Data.Default.Class (Default(def))
import Control.Concurrent.STM (TChan, readTChan, newTChanIO, writeTChan,
TVar, readTVar, writeTVar, newTVarIO,
STM, retry, atomically, throwSTM)
import Control.Concurrent.STM.Delay (newDelay, cancelDelay, waitDelay)
import Data.Time (getCurrentTime, diffUTCTime, UTCTime, addUTCTime)
data Args i o = Args {
Args i o -> o -> IO ()
cb :: o -> IO (),
Args i o -> o -> i -> o
fold :: o -> i -> o,
Args i o -> o
init :: o
}
data Opts i o = Opts {
Opts i o -> Int
delay :: Int,
Opts i o -> Bool
alwaysResetTimer :: Bool
}
instance Default (Opts i o) where
def :: Opts i o
def = Opts :: forall i o. Int -> Bool -> Opts i o
Opts {
delay :: Int
delay = 1000000,
alwaysResetTimer :: Bool
alwaysResetTimer = Bool
False
}
forStack :: ([i] -> IO ())
-> Args i [i]
forStack :: ([i] -> IO ()) -> Args i [i]
forStack mycb :: [i] -> IO ()
mycb = Args :: forall i o. (o -> IO ()) -> (o -> i -> o) -> o -> Args i o
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 :: (i -> IO ()) -> Args i i
forMonoid mycb :: i -> IO ()
mycb = Args :: forall i o. (o -> IO ()) -> (o -> i -> o) -> o -> Args i o
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 :: IO () -> Args i ()
forVoid mycb :: IO ()
mycb = Args :: forall i o. (o -> IO ()) -> (o -> i -> o) -> o -> Args i o
Args { cb :: () -> IO ()
cb = IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
mycb, fold :: () -> i -> ()
fold = (\_ _ -> ()), 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 {
Trigger i o -> TChan (ThreadInput i)
trigInput :: TChan (ThreadInput i),
Trigger i o -> TVar ThreadState
trigState :: TVar ThreadState
}
new :: Args i o
-> Opts i o
-> IO (Trigger i o)
new :: Args i o -> Opts i o -> IO (Trigger i o)
new args :: Args i o
args opts :: 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 (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 :: Trigger i o -> STM ThreadState
getThreadState trig :: 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 :: Trigger i o -> i -> IO ()
send trig :: Trigger i o
trig in_event :: 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
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)
TSClosedNormally -> OpException -> STM ()
forall e a. Exception e => e -> STM a
throwSTM OpException
AlreadyClosedException
TSClosedAbnormally e :: 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 :: Trigger i o -> IO ()
close trig :: 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_action :: 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
TSOpen -> STM ()
stm_action
TSClosedNormally -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TSClosedAbnormally e :: 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
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 :: Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
threadAction args :: Args i o
args opts :: Opts i o
opts in_chan :: 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' mexpiration :: Maybe UTCTime
mexpiration mout_event :: 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
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 (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 in_event :: i
in_event send_time :: 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 :: TChan a -> Maybe UTCTime -> IO (Maybe a)
waitInput in_chan :: TChan a
in_chan mexpiration :: 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 0 -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Nothing -> STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically STM (Maybe a)
readInputSTM
Just dur :: 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
$ \timer :: 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 (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 :: Args i o -> Maybe o -> IO ()
fireCallback _ Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fireCallback args :: Args i o
args (Just out_event :: 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 :: Args i o -> Maybe o -> i -> o
doFold args :: Args i o
args mcurrent :: Maybe o
mcurrent in_event :: 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 x :: Int
x = if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then 0 else Int
x
diffTimeUsec :: UTCTime -> UTCTime -> Int
diffTimeUsec :: UTCTime -> UTCTime -> Int
diffTimeUsec a :: UTCTime
a b :: UTCTime
b = Int -> Int
noNegative (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rational -> Int
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
* 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 t :: UTCTime
t d :: 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
% 1000000)) UTCTime
t
nextExpiration :: Opts i o -> Maybe ExpirationTime -> SendTime -> ExpirationTime
nextExpiration :: Opts i o -> Maybe UTCTime -> UTCTime -> UTCTime
nextExpiration opts :: Opts i o
opts mlast_expiration :: Maybe UTCTime
mlast_expiration send_time :: 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