fold-debounce 0.2.0.9 → 0.2.0.10
raw patch · 4 files changed
+122/−111 lines, 4 filesdep ~timePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: time
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- fold-debounce.cabal +4/−2
- src/Control/FoldDebounce.hs +98/−96
- test/Control/FoldDebounceSpec.hs +16/−13
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for fold-debounce +## 0.2.0.10 -- 2022-11-24++* Confirmed test with `ghc-9.2.5` and `time-1.11`.+ ## 0.2.0.9 -- 2019-10-04 * Confirmed test with `time-1.9.3`.
fold-debounce.cabal view
@@ -1,5 +1,5 @@ name: fold-debounce-version: 0.2.0.9+version: 0.2.0.10 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -23,7 +23,7 @@ build-depends: base >= 4.6.0 && <5.0, data-default-class >=0.0.1 && <0.2, stm >=2.4.2 && <2.6,- time >=1.4.0 && <1.10,+ time >=1.4.0 && <1.12, stm-delay >=0.1.1 && <0.2 test-suite spec@@ -33,6 +33,7 @@ ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" main-is: Spec.hs other-modules: Control.FoldDebounceSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base, fold-debounce, hspec >=2.1.7, stm,@@ -45,6 +46,7 @@ ghc-options: -Wall -threaded -fno-warn-unused-imports "-with-rtsopts=-M512m" main-is: Spec.hs other-modules: Control.FoldDebounceSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base, fold-debounce, hspec, stm,
src/Control/FoldDebounce.hs view
@@ -4,17 +4,17 @@ -- 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 }@@ -29,7 +29,7 @@ -- > 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.@@ -39,7 +39,7 @@ -- * 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.@@ -48,63 +48,62 @@ -- 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+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.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 Control.Applicative ((<$>), (<|>))+import Control.Concurrent (forkFinally)+import Control.Exception (Exception, SomeException, bracket)+import Control.Monad (void)+import Data.Monoid (Monoid, mappend, mempty)+import Data.Ratio ((%))+import Data.Typeable (Typeable)+import Prelude hiding (init) -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)+import Control.Concurrent.STM (STM, TChan, TVar, atomically, newTChanIO, newTVarIO,+ readTChan, readTVar, retry, throwSTM, writeTChan,+ writeTVar)+import Control.Concurrent.STM.Delay (cancelDelay, newDelay, waitDelay)+import Data.Default.Class (Default (def))+import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) -- | 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-}+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.@@ -114,22 +113,21 @@ -- | 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--}+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 {@@ -159,25 +157,28 @@ type ExpirationTime = UTCTime -- | Internal input to the worker thread.-data ThreadInput i = TIEvent i SendTime -- ^ A new input event is made- | TIFinish -- ^ the caller wants to finish the thread.+data ThreadInput i+ = TIEvent i SendTime -- ^ A new input event is made+ | TIFinish -- | 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.+data ThreadState+ = TSOpen -- ^ the thread is open and running+ | TSClosedNormally -- ^ the thread is successfully closed+ | TSClosedAbnormally SomeException -- | 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-}+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. + -> IO (Trigger i o) -- ^ action to create the trigger. new args opts = do chan <- newTChanIO state_tvar <- newTVarIO TSOpen@@ -200,8 +201,8 @@ atomically $ do state <- getThreadState trig case state of- TSOpen -> writeTChan (trigInput trig) (TIEvent in_event send_time)- TSClosedNormally -> throwSTM AlreadyClosedException+ 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.@@ -215,21 +216,22 @@ whenOpen stm_action = do state <- getThreadState trig case state of- TSOpen -> stm_action- TSClosedNormally -> return ()+ 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)+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 args opts in_chan = threadAction' Nothing Nothing where threadAction' mexpiration mout_event = do mgot <- waitInput in_chan mexpiration case mgot of@@ -239,7 +241,7 @@ 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 -- ^ input channel -> Maybe ExpirationTime -- ^ If 'Nothing', it never times out. -> IO (Maybe a) -- ^ 'Nothing' if timed out@@ -255,7 +257,7 @@ readInputSTM = Just <$> readTChan in_chan fireCallback :: Args i o -> Maybe o -> IO ()-fireCallback _ Nothing = return ()+fireCallback _ Nothing = return () fireCallback args (Just out_event) = cb args out_event doFold :: Args i o -> Maybe o -> i -> o
test/Control/FoldDebounceSpec.hs view
@@ -1,14 +1,17 @@-module Control.FoldDebounceSpec (main, spec) where+module Control.FoldDebounceSpec+ ( main+ , spec+ ) where -import Data.Ratio ((%))-import Control.Concurrent (threadDelay)-import Control.Applicative ((<$>))+import Control.Applicative ((<$>))+import Control.Concurrent (threadDelay)+import Data.Ratio ((%)) -import Data.Time (getCurrentTime, addUTCTime)-import Control.Monad.STM (atomically, STM)-import Control.Concurrent.STM.TChan (TChan,newTChan,writeTChan,readTChan,tryReadTChan)-import Test.Hspec-import qualified Control.FoldDebounce as F+import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, tryReadTChan, writeTChan)+import qualified Control.FoldDebounce as F+import Control.Monad.STM (STM, atomically)+import Data.Time (addUTCTime, getCurrentTime)+import Test.Hspec main :: IO () main = hspec spec@@ -99,7 +102,7 @@ F.close trig F.send trig 20 `shouldThrow` (\e -> case e of F.AlreadyClosedException -> True- _ -> False)+ _ -> False) it "emits a pending output event when closed" $ do (trig, output) <- fifoTrigger F.def { F.delay = 100000 } F.send trig 10@@ -117,7 +120,7 @@ threadDelay 50000 F.close trig `shouldThrow` (\e -> case e of F.UnexpectedClosedException _ -> True- _ -> False)+ _ -> False) it "folds input events strictly" $ do output <- atomically $ newTChan trig <- F.new F.Args { F.cb = callbackToTChan output, F.fold = (+), F.init = 0 }@@ -129,7 +132,7 @@ atomically (tryReadTChan output) `shouldReturn` (Nothing :: Maybe Int) F.close trig `shouldThrow` (\e -> case e of F.UnexpectedClosedException _ -> True- _ -> False)+ _ -> 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 = "" }@@ -170,4 +173,4 @@ threadDelay 100000 atomically (tryReadTChan output) `shouldReturn` Nothing F.close trig- +