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 {
cb :: o -> IO (),
fold :: o -> i -> o,
init :: o
}
data Opts i o = Opts {
delay :: Int,
alwaysResetTimer :: Bool
}
instance Default (Opts i o) where
def = Opts {
delay = 1000000,
alwaysResetTimer = False
}
forStack :: ([i] -> IO ())
-> Args i [i]
forStack mycb = Args { cb = mycb, fold = (flip (:)), init = []}
forMonoid :: Monoid i
=> (i -> IO ())
-> Args i i
forMonoid mycb = Args { cb = mycb, fold = mappend, init = mempty }
forVoid :: IO ()
-> Args i ()
forVoid mycb = Args { cb = const mycb, fold = (\_ _ -> ()), 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 {
trigInput :: TChan (ThreadInput i),
trigState :: TVar ThreadState
}
new :: Args i o
-> Opts i o
-> IO (Trigger i o)
new args opts = do
chan <- newTChanIO
state_tvar <- newTVarIO TSOpen
let putState = atomically . writeTVar state_tvar
void $ forkFinally (threadAction args opts chan)
(either (putState . TSClosedAbnormally) (const $ putState TSClosedNormally))
return $ Trigger chan state_tvar
getThreadState :: Trigger i o -> STM ThreadState
getThreadState trig = readTVar (trigState trig)
send :: Trigger i o -> i -> IO ()
send trig in_event = do
send_time <- getCurrentTime
atomically $ do
state <- getThreadState trig
case state of
TSOpen -> writeTChan (trigInput trig) (TIEvent in_event send_time)
TSClosedNormally -> throwSTM AlreadyClosedException
TSClosedAbnormally e -> throwSTM $ UnexpectedClosedException e
close :: Trigger i o -> IO ()
close trig = do
atomically $ whenOpen $ writeTChan (trigInput trig) TIFinish
atomically $ whenOpen $ retry
where
whenOpen stm_action = do
state <- getThreadState trig
case state of
TSOpen -> stm_action
TSClosedNormally -> return ()
TSClosedAbnormally e -> throwSTM $ UnexpectedClosedException e
data OpException = AlreadyClosedException
| UnexpectedClosedException SomeException
deriving (Show, Typeable)
instance Exception OpException
threadAction :: Args i o -> Opts i o -> TChan (ThreadInput i) -> IO ()
threadAction args opts in_chan = threadAction' Nothing Nothing where
threadAction' mexpiration mout_event = do
mgot <- waitInput in_chan mexpiration
case mgot of
Nothing -> fireCallback args mout_event >> threadAction' Nothing Nothing
Just (TIFinish) -> fireCallback args mout_event
Just (TIEvent in_event send_time) ->
let next_out = doFold args mout_event in_event
next_expiration = nextExpiration opts mexpiration send_time
in next_out `seq` threadAction' (Just next_expiration) (Just next_out)
waitInput :: TChan a
-> Maybe ExpirationTime
-> IO (Maybe a)
waitInput in_chan mexpiration = do
cur_time <- getCurrentTime
let mwait_duration = (`diffTimeUsec` cur_time) <$> mexpiration
case mwait_duration of
Just 0 -> return Nothing
Nothing -> atomically readInputSTM
Just dur -> bracket (newDelay dur) cancelDelay $ \timer -> do
atomically $ readInputSTM <|> (const Nothing <$> waitDelay timer)
where
readInputSTM = Just <$> readTChan in_chan
fireCallback :: Args i o -> Maybe o -> IO ()
fireCallback _ Nothing = return ()
fireCallback args (Just out_event) = cb args out_event
doFold :: Args i o -> Maybe o -> i -> o
doFold args mcurrent in_event = let current = maybe (init args) id mcurrent
in fold args current in_event
noNegative :: Int -> Int
noNegative x = if x < 0 then 0 else x
diffTimeUsec :: UTCTime -> UTCTime -> Int
diffTimeUsec a b = noNegative $ round $ (* 1000000) $ toRational $ diffUTCTime a b
addTimeUsec :: UTCTime -> Int -> UTCTime
addTimeUsec t d = addUTCTime (fromRational (fromIntegral d % 1000000)) t
nextExpiration :: Opts i o -> Maybe ExpirationTime -> SendTime -> ExpirationTime
nextExpiration opts mlast_expiration send_time
| alwaysResetTimer opts = fullDelayed
| otherwise = maybe fullDelayed id $ mlast_expiration
where
fullDelayed = (`addTimeUsec` delay opts) send_time