1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
{-# LANGUAGE OverloadedStrings #-}
module Debounce (
Debounce,
makeDebounce, debounceClick,
) where
import Control.Concurrent
import Control.Monad (when, void)
import Data.IORef
import Data.Text (Text)
-- import Data.Text qualified as T
-- import AtomicPrint
-- delay in microseconds; current waiter
data Debounce = Debounce Text Int (IO ()) (IORef State)
data State = Idle -- ^ no event recently
| Waiting -- ^ recent event, debouncing
| Running -- ^ delay expired, running action
| RunningRerun -- ^ still running action but another event appeared in the mean time
deriving (Show)
-- State transition diagram:
--
-- ,---------> IDLE
-- | |
-- | click |,-----. click
-- | V |
-- | WAITING >-'
-- | | ^.______________
-- | threadDelay | \ (completed)
-- | V |
-- '---------< RUNNING -------> RUNNINGRERUN >-,
-- (completed) click ^.___/ click
--
-- In Idle, no debounceWait thread is running.
-- In Waiting, debounceWait is in its threadDelay.
-- In Running & RunningRerun, debounceWait is in its 'action'.
-- There is always <=1 debounceWait thread at a time.
makeDebounce :: Text -> Double -> IO () -> IO Debounce
makeDebounce description secs action = Debounce description (round (secs * 1e6)) action <$> newIORef Idle
debounceClick :: Debounce -> IO ()
debounceClick deb@(Debounce _descr _ _ ref) = do
(gowait, _origstate) <- atomicModifyIORef' ref $ \st -> case st of
Idle -> (Waiting, (True, st))
Waiting -> (Waiting, (False, st))
Running -> (RunningRerun, (False, st))
RunningRerun -> (RunningRerun, (False, st))
-- atomicPrint $ "debounce[" <> _descr <> "] @ " <> T.show _origstate
when gowait $
debounceWait deb
-- Precondition: current state is Waiting
debounceWait :: Debounce -> IO ()
debounceWait deb@(Debounce _descr delay action ref) =
void . forkIO $ do
threadDelay delay
atomicModifyIORef' ref $ \case
Waiting -> (Running, ())
st -> error $ "debounce: unexpected " ++ show st ++ ", should be Waiting"
-- atomicPrint $ "debounce[" <> _descr <> "] running"
action
gowait <- atomicModifyIORef' ref $ \case
Running -> (Idle, False)
RunningRerun -> (Waiting, True)
st -> error $ "debounce: unexpected " ++ show st ++ ", should be Running(Rerun)"
-- atomicPrint $ "debounce[" <> _descr <> "] done, " <> (if gowait then "again" else "now idle")
when gowait $
debounceWait deb
|
