Still requires more thought (exceptions, laziness) https://www.reddit.com/r/haskell/comments/ky1llf/concurrent_programming_puzzle_debouncing_events/

Debouncy.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumDecimals #-}

module Main where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Monad
import Data.Foldable
import Data.Monoid
import Data.Semigroup qualified as S
import System.IO

data State a
  = -- | Nothing's happening
    Waiting
  | -- | The Async is for the wait timer.
    Debouncing (Async ()) (S.Last a)
  | -- | The Async is for the executing job.
    Running (Async ()) (Last a)
  | -- | We are wrapping up, but before exiting we might have to process a.
    WrappingUp (Maybe a)

debounce :: (a -> IO ()) -> IO (a -> IO (), IO ())
debounce doSomething = do
  ref <- newMVar Waiting
  let critical before middle after =
        before *> modifyMVar ref middle >>= traverse_ after
      critical_ before middle =
        before *> modifyMVar_ ref middle
      newVal x =
        critical_
          (pure ())
          ( \case
              Waiting ->
                do
                  a <- async timer
                  pure (Debouncing a (S.Last x))
              Debouncing a previous ->
                pure (Debouncing a (previous <> S.Last x))
              Running a previous ->
                pure (Running a (previous <> Last (Just x)))
              WrappingUp {} -> fail "no newVal after starting wrap up!"
          )
      timer =
        critical_
          (threadDelay 10e6)
          ( \case
              Waiting ->
                fail "how can we be waiting!?"
              Debouncing _ (S.Last y) -> do
                a' <- async $ doSomethingAndPerhapsOneFinalThing y
                pure (Running a' mempty)
              Running {} ->
                fail "it's me who should start running things!"
              WrappingUp {} ->
                fail "I should already be cancelled I think."
          )
      doSomethingAndPerhapsOneFinalThing v =
        critical
          (doSomething v)
          ( \case
              Waiting ->
                fail "how can we be waiting!?"
              Debouncing {} ->
                fail "how can we be debouncing!?"
              Running _ (Last mpending) -> case mpending of
                Nothing ->
                  pure (Waiting, Nothing)
                Just pending ->
                  do
                    a <- async timer
                    pure (Debouncing a (S.Last pending), Nothing)
              WrappingUp mpending ->
                pure (WrappingUp Nothing, mpending)
          )
          doSomething
      wrapUp =
        critical
          (pure ())
          ( \case
              Waiting ->
                pure (WrappingUp Nothing, Nothing)
              Debouncing a (S.Last v) ->
                do
                  cancel a
                  a' <- async (doSomethingAndPerhapsOneFinalThing v)
                  pure (WrappingUp Nothing, Just a')
              Running a (Last v) ->
                pure (WrappingUp v, Just a)
              WrappingUp {} ->
                fail "only one wrapUp permitted!"
          )
          wait
  pure (newVal, wrapUp)

main :: IO ()
main = do
  putStrLn "starting..."
  (newVal, wrapUp) <- debounce (\msg -> threadDelay 2e6 *> putStrLn msg)
  threadDelay 2e6
  newVal "foo"
  threadDelay 2e6
  newVal "bar"
  threadDelay 2e6
  newVal "baz"
  threadDelay 15e6
  newVal "boo"
  newVal "boo2"
  newVal "boo3"
  wrapUp