fold-debounce 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+104/−39 lines, 4 filesdep +stm-delaydep ~basedep ~stmdep ~timePVP ok
version bump matches the API change (PVP)
Dependencies added: stm-delay
Dependency ranges changed: base, stm, time
API changes (from Hackage documentation)
Files
- ChangeLog.md +13/−0
- fold-debounce.cabal +17/−3
- src/Control/FoldDebounce.hs +49/−35
- test/Control/FoldDebounceSpec.hs +25/−1
ChangeLog.md view
@@ -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.
fold-debounce.cabal view
@@ -1,5 +1,5 @@ name: fold-debounce-version: 0.1.0.0+version: 0.2.0.0 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> 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
src/Control/FoldDebounce.hs view
@@ -2,7 +2,7 @@ -- Module: Control.FoldDebounce -- Description: Fold multiple events that happen in a given period of time -- Maintainer: Toshio Ito <debug.ito@gmail.com>--- +-- -- 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 <https://metacpan.org/pod/AnyEvent::Debounce> --@@ -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+
test/Control/FoldDebounceSpec.hs view
@@ -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