diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Revision history for fold-debounce +## 0.2.0.0 -- 2015-06-01 + +* The debounce period now starts from the time when the first input + event is sent. Previously it was the time when the first input event + is popped from the input queue. That lead to weird behavior when the + input traffic was too intense. + +* Now this module works without -threaded ghc option thanks to new + dependency on 'stm-delay' package. + +* Bumped the major version due to the new dependency. + + ## 0.1.0.0 -- 2015-05-22 * First version. Released on an unsuspecting world. diff --git a/fold-debounce.cabal b/fold-debounce.cabal --- a/fold-debounce.cabal +++ b/fold-debounce.cabal @@ -1,5 +1,5 @@ name: fold-debounce -version: 0.1.0.0 +version: 0.2.0.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -23,18 +23,32 @@ build-depends: base >= 4.6.0 && < 4.9, data-default >=0.5.3 && <0.6, stm >=2.4.2 && <2.5, - time >=1.4.0 && <1.6 + time >=1.4.0 && <1.6, + stm-delay >=0.1.1 && <0.2 test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test + ghc-options: -Wall + main-is: Spec.hs + other-modules: Control.FoldDebounceSpec + build-depends: base, fold-debounce, + hspec >=2.1.7 && <2.2, + stm, + time + +test-suite spec-threaded + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test ghc-options: -Wall -threaded main-is: Spec.hs other-modules: Control.FoldDebounceSpec build-depends: base, fold-debounce, hspec >=2.1.7 && <2.2, - stm + stm, + time source-repository head type: git diff --git a/src/Control/FoldDebounce.hs b/src/Control/FoldDebounce.hs --- a/src/Control/FoldDebounce.hs +++ b/src/Control/FoldDebounce.hs @@ -2,7 +2,7 @@ -- Module: Control.FoldDebounce -- Description: Fold multiple events that happen in a given period of time -- Maintainer: Toshio Ito --- +-- -- Synopsis: -- -- > module Main (main) where @@ -44,10 +44,6 @@ -- input event. This module just starts a timer at the first input, -- and runs the callback when the timer expires. -- --- __IMPORTANT NOTE__: currently you have to add @-threaded@ option to --- ghc linker to use this module. I'm not sure if you can use it with --- other compilers. --- -- The API and documentation is borrowed from a Perl module called -- AnyEvent::Debounce. See -- @@ -77,18 +73,20 @@ ) 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) +import Control.Exception (Exception, SomeException, bracket) import Data.Typeable (Typeable) import Data.Default (Default(def)) import Control.Concurrent.STM (TChan, readTChan, newTChanIO, writeTChan, - TVar, registerDelay, readTVar, writeTVar, newTVarIO, + TVar, readTVar, writeTVar, newTVarIO, STM, retry, atomically, throwSTM) -import Data.Time (getCurrentTime, diffUTCTime, UTCTime) +import Control.Concurrent.STM.Delay (newDelay, cancelDelay, waitDelay) +import Data.Time (getCurrentTime, diffUTCTime, UTCTime, addUTCTime) -- | Mandatory parameters for 'new'. data Args i o = Args { @@ -130,6 +128,7 @@ -- -- Default: False alwaysResetTimer :: Bool + } instance Default (Opts i o) where @@ -156,8 +155,11 @@ -> Args i () forVoid mycb = Args { cb = const mycb, fold = (\_ _ -> ()), init = () } +type SendTime = UTCTime +type ExpirationTime = UTCTime + -- | Internal input to the worker thread. -data ThreadInput i = TIEvent i -- ^ A new input event is made +data ThreadInput i = TIEvent i SendTime -- ^ A new input event is made | TIFinish -- ^ the caller wants to finish the thread. -- | Internal state of the worker thread. @@ -193,12 +195,14 @@ -- 'AlreadyClosedException'. If the 'Trigger' has been abnormally -- closed, it throws 'UnexpectedClosedException'. send :: Trigger i o -> i -> IO () -send trig in_event = atomically $ do - state <- getThreadState trig - case state of - TSOpen -> writeTChan (trigInput trig) (TIEvent in_event) - TSClosedNormally -> throwSTM AlreadyClosedException - TSClosedAbnormally e -> throwSTM $ UnexpectedClosedException e +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 and release the 'Trigger'. If there is a pending output event, the event is fired immediately. -- @@ -226,28 +230,29 @@ threadAction :: Args i o -> Opts i o -> TChan (ThreadInput i) -> IO () threadAction args opts in_chan = threadAction' Nothing Nothing where - threadAction' mtimeout mout_event = do - start_time <- getCurrentTime - mgot <- waitInput in_chan mtimeout + 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) -> do + Just (TIEvent in_event send_time) -> let next_out = doFold args mout_event in_event - evaled_next_out <- next_out `seq` return next_out - end_time <- getCurrentTime - threadAction' (Just $ nextTimeout opts mtimeout start_time end_time) (Just evaled_next_out) + next_expiration = nextExpiration opts mexpiration send_time + in next_out `seq` threadAction' (Just next_expiration) (Just next_out) waitInput :: TChan a -- ^ input channel - -> Maybe Int -- ^ timeout in microseconds. If 'Nothing', it never times out. + -> Maybe ExpirationTime -- ^ If 'Nothing', it never times out. -> IO (Maybe a) -- ^ 'Nothing' if timed out -waitInput in_chan mtimeout = do - timer <- maybe (newTVarIO False) registerDelay mtimeout - atomically $ (Just <$> readTChan in_chan) <|> (checkTimeout timer) +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 - checkTimeout timer = do - timed_out <- readTVar timer - if timed_out then return Nothing else retry + readInputSTM = Just <$> readTChan in_chan fireCallback :: Args i o -> Maybe o -> IO () fireCallback _ Nothing = return () @@ -257,10 +262,19 @@ doFold args mcurrent in_event = let current = maybe (init args) id mcurrent in fold args current in_event -nextTimeout :: Opts i o -> Maybe Int -> UTCTime -> UTCTime -> Int -nextTimeout opts morig_timeout start_time end_time - | alwaysResetTimer opts = delay opts - | otherwise = if raw_result < 0 then 0 else raw_result +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 - elapsed_usec = round $ (* 1000000) $ toRational $ diffUTCTime end_time start_time - raw_result = maybe (delay opts) (subtract elapsed_usec) morig_timeout + fullDelayed = (`addTimeUsec` delay opts) send_time + diff --git a/test/Control/FoldDebounceSpec.hs b/test/Control/FoldDebounceSpec.hs --- a/test/Control/FoldDebounceSpec.hs +++ b/test/Control/FoldDebounceSpec.hs @@ -1,8 +1,11 @@ module Control.FoldDebounceSpec (main, spec) where +import Data.Ratio ((%)) import Control.Concurrent (threadDelay) +import Control.Applicative ((<$>)) -import Control.Monad.STM (atomically) +import Data.Time (getCurrentTime, addUTCTime) +import Control.Monad.STM (atomically, STM) import Control.Concurrent.STM.TChan (TChan,newTChan,writeTChan,readTChan,tryPeekTChan,tryReadTChan) import Test.Hspec import qualified Control.FoldDebounce as F @@ -24,6 +27,19 @@ trig <- F.new (forFIFO $ callbackToTChan output) opts return (trig, output) +repeatFor :: Integer -> IO () -> IO () +repeatFor duration_usec action = repeatUntil =<< (addUTCTime (fromRational (duration_usec % 1000000)) <$> getCurrentTime) + where + repeatUntil goal_time = do + action + cur_time <- getCurrentTime + if cur_time > goal_time then return () else repeatUntil goal_time + +readAllTChan :: TChan a -> STM [a] +readAllTChan chan = reverse <$> readAllTChan' [] + where + readAllTChan' cur_ret = maybe (return cur_ret) (\val -> readAllTChan' (val : cur_ret)) =<< tryReadTChan chan + spec :: Spec spec = do describe "Trigger" $ do @@ -114,6 +130,14 @@ F.close trig `shouldThrow` (\e -> case e of F.UnexpectedClosedException _ -> True _ -> False) + it "emits output events even if input events are coming intensely" $ do + output <- atomically $ newTChan + trig <- F.new F.Args { F.cb = callbackToTChan output, F.fold = (\_ i -> i), F.init = "" } + F.def { F.delay = 500 } + repeatFor 2000 $ F.send trig "abc" + F.close trig + output_events <- atomically $ readAllTChan output + output_events `shouldSatisfy` ((> 2) . length) describe "forStack" $ do it "creates a stacked FoldDebounce" $ do output <- atomically $ newTChan