diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for fold-debounce + +## 0.1.0.0 -- 2015-05-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fold-debounce.cabal b/fold-debounce.cabal new file mode 100644 --- /dev/null +++ b/fold-debounce.cabal @@ -0,0 +1,41 @@ +name: fold-debounce +version: 0.1.0.0 +author: Toshio Ito +maintainer: Toshio Ito +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 diff --git a/src/Control/FoldDebounce.hs b/src/Control/FoldDebounce.hs new file mode 100644 --- /dev/null +++ b/src/Control/FoldDebounce.hs @@ -0,0 +1,266 @@ +-- | +-- Module: Control.FoldDebounce +-- Description: Fold multiple events that happen in a given period of time +-- Maintainer: Toshio Ito +-- +-- 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 +-- +-- +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 diff --git a/test/Control/FoldDebounceSpec.hs b/test/Control/FoldDebounceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/FoldDebounceSpec.hs @@ -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 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}