diff --git a/fold-debounce.cabal b/fold-debounce.cabal index 3a1a650..c5b7833 100644 --- a/fold-debounce.cabal +++ b/fold-debounce.cabal @@ -9,7 +9,8 @@ description: Fold multiple events that happen in a given period of ti category: Control cabal-version: 2.0 build-type: Simple -extra-source-files: README.md, ChangeLog.md +extra-source-files: README.md +extra-doc-files: ChangeLog.md homepage: https://github.com/debug-ito/fold-debounce bug-reports: https://github.com/debug-ito/fold-debounce/issues diff --git a/src/Control/FoldDebounce.hs b/src/Control/FoldDebounce.hs index 4aa5fdd..eb5ea1d 100644 --- a/src/Control/FoldDebounce.hs +++ b/src/Control/FoldDebounce.hs @@ -86,6 +86,7 @@ import Control.Concurrent.STM (STM, TChan, TVar, atomically, new writeTVar) import Control.Concurrent.STM.Delay (cancelDelay, newDelay, waitDelay) import Data.Default (Default (def)) +import Data.Maybe (fromMaybe) import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) -- | Mandatory parameters for 'new'. @@ -95,9 +96,9 @@ data Args i o -- 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 + -- The callback should not throw any exception. If it does, the -- 'Trigger' is abnormally closed, causing - -- 'UnexpectedClosedException' when 'close'. + -- 'UnexpectedClosedException' when 'close' is called. cb :: o -> IO () -- | The binary operation of left-fold. The left-fold is evaluated strictly. , fold :: o -> i -> o @@ -139,7 +140,7 @@ instance Default (Opts i o) where -- 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 = []} +forStack mycb = Args { cb = mycb, fold = flip (:), init = []} -- | 'Args' for monoids. Input events are appended to the tail. forMonoid :: Monoid i @@ -151,7 +152,7 @@ forMonoid mycb = Args { cb = mycb, fold = mappend, init = mempty } -- folded, they still start the timer and activate the callback. forVoid :: IO () -- ^ 'cb' field. -> Args i () -forVoid mycb = Args { cb = const mycb, fold = (\_ _ -> ()), init = () } +forVoid mycb = Args { cb = const mycb, fold = \_ _ -> (), init = () } type SendTime = UTCTime type ExpirationTime = UTCTime @@ -211,7 +212,7 @@ send trig in_event = do close :: Trigger i o -> IO () close trig = do atomically $ whenOpen $ writeTChan (trigInput trig) TIFinish - atomically $ whenOpen $ retry -- wait for closing + atomically $ whenOpen retry -- wait for closing where whenOpen stm_action = do state <- getThreadState trig @@ -236,7 +237,7 @@ threadAction args opts in_chan = threadAction' Nothing Nothing where mgot <- waitInput in_chan mexpiration case mgot of Nothing -> fireCallback args mout_event >> threadAction' Nothing Nothing - Just (TIFinish) -> fireCallback args mout_event + Just TIFinish -> fireCallback args mout_event Just (TIEvent in_event send_time) -> let next_out = doFold args mout_event in_event next_expiration = nextExpiration opts mexpiration send_time @@ -252,7 +253,7 @@ waitInput in_chan mexpiration = do Just 0 -> return Nothing Nothing -> atomically readInputSTM Just dur -> bracket (newDelay dur) cancelDelay $ \timer -> do - atomically $ readInputSTM <|> (const Nothing <$> waitDelay timer) + atomically $ readInputSTM <|> (Nothing <$ waitDelay timer) where readInputSTM = Just <$> readTChan in_chan @@ -261,11 +262,11 @@ 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 +doFold args mcurrent in_event = let current = fromMaybe (init args) mcurrent in fold args current in_event noNegative :: Int -> Int -noNegative x = if x < 0 then 0 else x +noNegative x = max x 0 diffTimeUsec :: UTCTime -> UTCTime -> Int diffTimeUsec a b = noNegative $ round $ (* 1000000) $ toRational $ diffUTCTime a b @@ -276,7 +277,7 @@ 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 + | otherwise = fromMaybe fullDelayed mlast_expiration where fullDelayed = (`addTimeUsec` delay opts) send_time diff --git a/test/Control/FoldDebounceSpec.hs b/test/Control/FoldDebounceSpec.hs index 06e00d6..9443f1e 100644 --- a/test/Control/FoldDebounceSpec.hs +++ b/test/Control/FoldDebounceSpec.hs @@ -17,8 +17,10 @@ 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 = [] +forFIFO cb = F.Args + { F.cb = cb + , F.fold = \l v -> l ++ [v] + , F.init = [] } callbackToTChan :: TChan a -> a -> IO () @@ -26,12 +28,12 @@ callbackToTChan output = atomically . writeTChan output fifoTrigger :: F.Opts Int [Int] -> IO (F.Trigger Int [Int], TChan [Int]) fifoTrigger opts = do - output <- atomically $ newTChan + output <- atomically newTChan 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) +repeatFor duration_usec action = repeatUntil . addUTCTime (fromRational (duration_usec % 1000000)) =<< getCurrentTime where repeatUntil goal_time = do action @@ -122,7 +124,7 @@ spec = do F.UnexpectedClosedException _ -> True _ -> False) it "folds input events strictly" $ do - output <- atomically $ newTChan + 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 @@ -134,7 +136,7 @@ spec = do F.UnexpectedClosedException _ -> True _ -> False) it "emits output events even if input events are coming intensely" $ do - output <- atomically $ newTChan + 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" @@ -143,7 +145,7 @@ spec = do output_events `shouldSatisfy` ((> 2) . length) describe "forStack" $ do it "creates a stacked FoldDebounce" $ do - output <- atomically $ newTChan + output <- atomically newTChan trig <- F.new (F.forStack $ callbackToTChan output) F.def { F.delay = 50000 } F.send trig 10 @@ -153,7 +155,7 @@ spec = do F.close trig describe "forMonoid" $ do it "creates a FoldDebounce for Monoids" $ do - output <- atomically $ newTChan + output <- atomically newTChan trig <- F.new (F.forMonoid $ callbackToTChan output) F.def { F.delay = 50000 } F.send trig [10] @@ -163,7 +165,7 @@ spec = do F.close trig describe "forVoid" $ do it "discards input events, but starts the timer" $ do - output <- atomically $ newTChan + output <- atomically newTChan trig <- F.new (F.forVoid $ callbackToTChan output "hoge") F.def { F.delay = 50000 } F.send trig "foo1"