fold-debounce 0.2.0.15 → 0.2.0.16
raw patch · 4 files changed
+29/−21 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- fold-debounce.cabal +3/−2
- src/Control/FoldDebounce.hs +11/−10
- test/Control/FoldDebounceSpec.hs +11/−9
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for fold-debounce +## 0.2.0.16 -- 2025-03-28++* Improve the code, haddock and .cabal file based on hlint and cabal check ( https://github.com/debug-ito/fold-debounce/pull/4 )+ ## 0.2.0.15 -- 2025-03-19 * Confirm test with `ghc-9.12.1`.
fold-debounce.cabal view
@@ -1,5 +1,5 @@ name: fold-debounce-version: 0.2.0.15+version: 0.2.0.16 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -9,7 +9,8 @@ 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
src/Control/FoldDebounce.hs view
@@ -86,6 +86,7 @@ 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ 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 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 @@ 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
test/Control/FoldDebounceSpec.hs view
@@ -17,8 +17,10 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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"