1 files changed, 75 insertions, 0 deletions
diff --git a/src/Debounce.hs b/src/Debounce.hs
new file mode 100644
index 0000000..7e9ccab
--- /dev/null
+++ b/src/Debounce.hs
@@ -0,0 +1,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