fold-debounce (empty) → 0.1.0.0
raw patch · 8 files changed
+507/−0 lines, 8 filesdep +basedep +data-defaultdep +fold-debouncesetup-changed
Dependencies added: base, data-default, fold-debounce, hspec, stm, time
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +13/−0
- Setup.hs +2/−0
- fold-debounce.cabal +41/−0
- src/Control/FoldDebounce.hs +266/−0
- test/Control/FoldDebounceSpec.hs +149/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for fold-debounce++## 0.1.0.0 -- 2015-05-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Toshio Ito++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Toshio Ito nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+# fold-debounce++Fold multiple events that happen in a given period of time.++## How to run tests++```+cabal configure --enable-tests && cabal build && cabal test+```++## Author++Toshio Ito <debug.ito [at] gmail.com>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fold-debounce.cabal view
@@ -0,0 +1,41 @@+name: fold-debounce+version: 0.1.0.0+author: Toshio Ito <debug.ito@gmail.com>+maintainer: Toshio Ito <debug.ito@gmail.com>+license: BSD3+license-file: LICENSE+synopsis: Fold multiple events that happen in a given period of time.+description: Fold multiple events that happen in a given period of time. See "Control.FoldDebounce".+category: Control+cabal-version: >= 1.10+build-type: Simple+extra-source-files: README.md, ChangeLog.md+homepage: https://github.com/debug-ito/fold-debounce+bug-reports: https://github.com/debug-ito/fold-debounce/issues++library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Control.FoldDebounce+ default-extensions: DeriveDataTypeable+ -- other-modules:+ 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++test-suite spec+ 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++source-repository head+ type: git+ location: https://github.com/debug-ito/fold-debounce.git
+ src/Control/FoldDebounce.hs view
@@ -0,0 +1,266 @@+-- |+-- 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+-- > +-- > import System.IO (putStrLn)+-- > import Control.Concurrent (threadDelay)+-- > +-- > import qualified Control.FoldDebounce as Fdeb+-- > +-- > printValue :: Int -> IO ()+-- > printValue v = putStrLn ("value = " ++ show v)+-- > +-- > main :: IO ()+-- > main = do+-- > trigger <- Fdeb.new Fdeb.Args { Fdeb.cb = printValue, Fdeb.fold = (+), Fdeb.init = 0 }+-- > Fdeb.def { Fdeb.delay = 500000 }+-- > let send' = Fdeb.send trigger+-- > send' 1+-- > send' 2+-- > send' 3+-- > threadDelay 1000000 -- During this period, "value = 6" is printed.+-- > send' 4+-- > threadDelay 1000 -- Nothing is printed.+-- > send' 5+-- > threadDelay 1000000 -- During this period, "value = 9" is printed.+-- > Fdeb.close trigger+-- +-- This module is similar to "Control.Debounce". It debouces input+-- events and regulates the frequency at which the action (callback)+-- is executed.+--+-- The difference from "Control.Debounce" is:+--+-- * With "Control.Debounce", you cannot pass values to the callback+-- action. This module folds (accumulates) the input events (type @i@)+-- and passes the folded output event (type @o@) to the callback.+-- +-- * "Control.Debounce" immediately runs the callback at the first+-- 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>+--+--+module Control.FoldDebounce (+ -- * Create the trigger+ new,+ Trigger,+ -- * Parameter types+ Args(..),+ Opts,+ def,+ -- ** Accessors for 'Opts'+ -- $opts_accessors+ delay,+ alwaysResetTimer,+ -- ** Preset parameters+ forStack,+ forMonoid,+ forVoid,+ -- * Use the trigger+ send,+ -- * Finish the trigger+ close,+ -- * Exception types+ OpException(..)+) where++import Prelude hiding (init)+import Data.Monoid (Monoid, mempty, mappend)+import Control.Monad (void)+import Control.Applicative ((<|>), (<$>))+import Control.Concurrent (forkFinally)+import Control.Exception (Exception, SomeException)+import Data.Typeable (Typeable)++import Data.Default (Default(def))+import Control.Concurrent.STM (TChan, readTChan, newTChanIO, writeTChan,+ TVar, registerDelay, readTVar, writeTVar, newTVarIO,+ STM, retry, atomically, throwSTM)+import Data.Time (getCurrentTime, diffUTCTime, UTCTime)++-- | Mandatory parameters for 'new'.+data Args i o = Args {+ -- | The callback to be called when the output event is+ -- emitted. Note that this action is run in a different thread than+ -- the one calling 'send'.+ -- + -- The callback should not throw any exception. In this case, the+ -- 'Trigger' is abnormally closed, causing+ -- 'UnexpectedClosedException' when 'close'.+ cb :: o -> IO (),++ -- | The binary operation of left-fold. The left-fold is evaluated strictly.+ fold :: o -> i -> o,++ -- | The initial value of the left-fold.+ init :: o+}++-- $opts_accessors+-- You can update fields in 'Opts' via these accessors.+--++++-- | Optional parameters for 'new'. You can get the default by 'def'+-- function.+data Opts i o = Opts { + -- | The time (in microsecond) to wait after receiving an event+ -- before sending it, in case more events happen in the interim.+ --+ -- Default: 1 second (1000000)+ delay :: Int,+ + -- | Normally, when an event is received and it's the first of a+ -- series, a timer is started, and when that timer expires, all+ -- events are sent. If you set this parameter to True, then+ -- the timer is reset after each event is received.+ --+ -- Default: False+ alwaysResetTimer :: Bool+}++instance Default (Opts i o) where+ def = Opts {+ delay = 1000000,+ alwaysResetTimer = False+ }++-- | 'Args' for stacks. Input events are accumulated in a stack, i.e.,+-- the last event is at the head of the list.+forStack :: ([i] -> IO ()) -- ^ 'cb' field.+ -> Args i [i]+forStack mycb = Args { cb = mycb, fold = (flip (:)), init = []}++-- | 'Args' for monoids. Input events are appended to the tail.+forMonoid :: Monoid i+ => (i -> IO ()) -- ^ 'cb' field.+ -> Args i i+forMonoid mycb = Args { cb = mycb, fold = mappend, init = mempty }++-- | 'Args' that discards input events. Although input events are not+-- folded, they still start the timer and activate the callback.+forVoid :: IO () -- ^ 'cb' field.+ -> Args i ()+forVoid mycb = Args { cb = const mycb, fold = (\_ _ -> ()), init = () }++-- | Internal input to the worker thread.+data ThreadInput i = TIEvent i -- ^ A new input event is made+ | TIFinish -- ^ the caller wants to finish the thread.++-- | Internal state of the worker thread.+data ThreadState = TSOpen -- ^ the thread is open and running+ | TSClosedNormally -- ^ the thread is successfully closed+ | TSClosedAbnormally SomeException -- ^ the thread is abnormally closed with the given exception.++-- | A trigger to send input events to FoldDebounce. You input data of+-- type @i@ to the trigger, and it outputs data of type @o@.+data Trigger i o = Trigger {+ trigInput :: TChan (ThreadInput i),+ trigState :: TVar ThreadState+}++-- | Create a FoldDebounce trigger.+new :: Args i o -- ^ mandatory parameters+ -> Opts i o -- ^ optional parameters+ -> IO (Trigger i o) -- ^ action to create the trigger. +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 an input event.+--+-- If the 'Trigger' is already closed, it throws+-- '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++-- | Close and release the 'Trigger'. If there is a pending output event, the event is fired immediately.+--+-- If the 'Trigger' has been abnormally closed, it throws 'UnexpectedClosedException'.+close :: Trigger i o -> IO ()+close trig = do+ atomically $ whenOpen $ writeTChan (trigInput trig) TIFinish+ atomically $ whenOpen $ retry -- wait for closing+ where+ whenOpen stm_action = do+ state <- getThreadState trig+ case state of+ TSOpen -> stm_action+ TSClosedNormally -> return ()+ TSClosedAbnormally e -> throwSTM $ UnexpectedClosedException e++-- | Exception type used by FoldDebounce operations+data OpException = AlreadyClosedException -- ^ You attempted to 'send' after the trigger is already 'close'd.+ | UnexpectedClosedException SomeException -- ^ The 'SomeException' is thrown in the background thread.+ 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' mtimeout mout_event = do+ start_time <- getCurrentTime+ mgot <- waitInput in_chan mtimeout+ case mgot of+ Nothing -> fireCallback args mout_event >> threadAction' Nothing Nothing+ Just (TIFinish) -> fireCallback args mout_event+ Just (TIEvent in_event) -> do+ 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)+ +waitInput :: TChan a -- ^ input channel+ -> Maybe Int -- ^ timeout in microseconds. 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)+ where+ checkTimeout timer = do+ timed_out <- readTVar timer+ if timed_out then return Nothing else retry++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++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+ where+ elapsed_usec = round $ (* 1000000) $ toRational $ diffUTCTime end_time start_time+ raw_result = maybe (delay opts) (subtract elapsed_usec) morig_timeout
+ test/Control/FoldDebounceSpec.hs view
@@ -0,0 +1,149 @@+module Control.FoldDebounceSpec (main, spec) where++import Control.Concurrent (threadDelay)++import Control.Monad.STM (atomically)+import Control.Concurrent.STM.TChan (TChan,newTChan,writeTChan,readTChan,tryPeekTChan,tryReadTChan)+import Test.Hspec+import qualified Control.FoldDebounce as F++main :: IO ()+main = hspec spec++forFIFO :: ([Int] -> IO ()) -> F.Args Int [Int]+forFIFO cb = F.Args {+ F.cb = cb, F.fold = (\l v -> l ++ [v]), F.init = []+ }++callbackToTChan :: TChan a -> a -> IO ()+callbackToTChan output = atomically . writeTChan output++fifoTrigger :: F.Opts Int [Int] -> IO (F.Trigger Int [Int], TChan [Int])+fifoTrigger opts = do+ output <- atomically $ newTChan+ trig <- F.new (forFIFO $ callbackToTChan output) opts+ return (trig, output)++spec :: Spec+spec = do+ describe "Trigger" $ do+ it "emits single output event for single input event" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 50000 }+ F.send trig 10+ atomically (readTChan output) `shouldReturn` [10]+ F.close trig+ it "emits single FIFO list for multiple input events" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 50000 }+ F.send trig 10+ F.send trig 20+ F.send trig 30+ atomically (readTChan output) `shouldReturn` [10,20,30]+ F.close trig+ it "waits for more events that follow the first event" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 500000 }+ F.send trig 10+ threadDelay 30000+ atomically (tryPeekTChan output) `shouldReturn` Nothing+ threadDelay 500000+ atomically (tryReadTChan output) `shouldReturn` Just [10]+ F.close trig+ it "emits the output event 'delay' interval after the first input event (alwaysResetTimer = False)" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 500000 }+ F.send trig 10+ threadDelay 100000+ F.send trig 20+ threadDelay 100000+ F.send trig 30+ threadDelay 100000+ F.send trig 40+ threadDelay 100000+ F.send trig 50+ threadDelay 200000+ atomically (tryReadTChan output) `shouldReturn` Just [10,20,30,40,50]+ F.close trig+ it "emits the output event 'delay' interval after the last input event (alwaysResetTimer = True)" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 500000, F.alwaysResetTimer = True }+ F.send trig 10+ threadDelay 100000+ F.send trig 20+ threadDelay 100000+ F.send trig 30+ threadDelay 100000+ F.send trig 40+ threadDelay 100000+ F.send trig 50+ threadDelay 200000+ atomically (tryReadTChan output) `shouldReturn` Nothing+ threadDelay 400000+ atomically (tryReadTChan output) `shouldReturn` Just [10,20,30,40,50]+ it "throws AlreadyClosedException after closed" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 10000 }+ F.send trig 10+ atomically (readTChan output) `shouldReturn` [10]+ F.close trig+ F.send trig 20 `shouldThrow` (\e -> case e of+ F.AlreadyClosedException -> True+ _ -> False)+ it "emits a pending output event when closed" $ do+ (trig, output) <- fifoTrigger F.def { F.delay = 100000 }+ F.send trig 10+ F.send trig 20+ F.send trig 30+ F.close trig+ atomically (tryReadTChan output) `shouldReturn` Just [10,20,30]+ it "is ok to close after close" $ do+ (trig, _) <- fifoTrigger F.def { F.delay = 20000 }+ F.close trig+ F.close trig+ it "throws UnexpectedClosedException when close after the thread abnormally dies" $ do+ trig <- F.new F.Args { F.cb = error "Boom!", F.fold = (++), F.init = ""} F.def { F.delay = 10000 }+ F.send trig "hogehoge"+ threadDelay 50000+ F.close trig `shouldThrow` (\e -> case e of+ F.UnexpectedClosedException _ -> True+ _ -> False)+ it "folds input events strictly" $ do+ output <- atomically $ newTChan+ trig <- F.new F.Args { F.cb = callbackToTChan output, F.fold = (+), F.init = 0 }+ F.def { F.delay = 100000 }+ F.send trig 10+ F.send trig 20+ F.send trig undefined+ threadDelay 200000+ atomically (tryReadTChan output) `shouldReturn` (Nothing :: Maybe Int)+ F.close trig `shouldThrow` (\e -> case e of+ F.UnexpectedClosedException _ -> True+ _ -> False)+ describe "forStack" $ do+ it "creates a stacked FoldDebounce" $ do+ output <- atomically $ newTChan+ trig <- F.new (F.forStack $ callbackToTChan output)+ F.def { F.delay = 50000 }+ F.send trig 10+ F.send trig 20+ F.send trig 30+ atomically (readTChan output) `shouldReturn` ([30,20,10] :: [Int])+ F.close trig+ describe "forMonoid" $ do+ it "creates a FoldDebounce for Monoids" $ do+ output <- atomically $ newTChan+ trig <- F.new (F.forMonoid $ callbackToTChan output)+ F.def { F.delay = 50000 }+ F.send trig [10]+ F.send trig [20]+ F.send trig [30]+ atomically (readTChan output) `shouldReturn` ([10,20,30] :: [Int])+ F.close trig+ describe "forVoid" $ do+ it "discards input events, but starts the timer" $ do+ output <- atomically $ newTChan+ trig <- F.new (F.forVoid $ callbackToTChan output "hoge")+ F.def { F.delay = 50000 }+ F.send trig "foo1"+ F.send trig "foo2"+ F.send trig "foo3"+ atomically (readTChan output) `shouldReturn` "hoge"+ threadDelay 100000+ atomically (tryReadTChan output) `shouldReturn` Nothing+ F.close trig+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}