DebounceSpec.hs

module Unit.Atelier.Effects.DebounceSpec (test_Debounce) where

import Data.Dynamic (fromDynamic, toDyn)
import Effectful (runEff)
import Effectful.Concurrent (runConcurrent)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase, (@?=))

import Data.IORef qualified as IORef
import Effectful.Concurrent.STM qualified as STM
import StmContainers.Map qualified as Map

import Atelier.Effects.Debounce (Entry (..), ensureCallback, ensureEntry)
import Atelier.Time (Millisecond)

import Atelier.Effects.Conc qualified as Conc
import Atelier.Effects.Console qualified as Console
import Atelier.Effects.Debounce qualified as Debounce
import Atelier.Effects.Delay qualified as Delay


test_Debounce :: TestTree
test_Debounce =
    testGroup
        "Atelier.Effects.Debounce"
        [ testGroup "run" testRun
        , testGroup "ensureEntry" testEnsureEntry
        , testGroup "ensureCallback" testEnsureCallback
        ]


testEnsureEntry :: [TestTree]
testEnsureEntry =
    [ testGroup
        "new key"
        [ testCase "gets generation 0" do
            state <- runSTM Map.new
            entry <- runSTM $ mkEntry 1 42 state (+)
            entry.generation @?= 0
        , testCase "stores value as arg" do
            state <- runSTM Map.new
            entry <- runSTM $ mkEntry 1 42 state (+)
            (entry.arg >>= fromDynamic) @?= Just @Int 42
        ]
    , testGroup
        "existing key"
        [ testCase "increments generation" do
            state <- runSTM Map.new
            _ <- runSTM $ mkEntry 1 2 state (+)
            entry <- runSTM $ mkEntry 1 3 state (+)
            entry.generation @?= 1
        , testCase "applies merge function to old and new value" do
            state <- runSTM Map.new
            _ <- runSTM $ mkEntry 1 5 state (+)
            entry <- runSTM $ mkEntry 1 10 state (+)
            (entry.arg >>= fromDynamic) @?= Just @Int 15
        ]
    , testGroup
        "multiple updates"
        [ testCase "accumulates generation" do
            state <- runSTM Map.new
            _ <- runSTM $ mkEntry 1 1 state (+)
            _ <- runSTM $ mkEntry 1 2 state (+)
            entry <- runSTM $ mkEntry 1 3 state (+)
            entry.generation @?= 2
        , testCase "applies merge cumulatively" do
            state <- runSTM Map.new
            _ <- runSTM $ mkEntry 1 1 state (+)
            _ <- runSTM $ mkEntry 1 2 state (+)
            entry <- runSTM $ mkEntry 1 3 state (+)
            (entry.arg >>= fromDynamic) @?= Just @Int 6
        ]
    , testGroup
        "independent keys"
        [ testCase "do not interfere with each other" do
            state <- runSTM Map.new
            entryA <- runSTM $ mkEntry 1 10 state (+)
            entryB <- runSTM $ mkEntry 2 20 state (+)
            (entryA.arg >>= fromDynamic) @?= Just @Int 10
            (entryB.arg >>= fromDynamic) @?= Just @Int 20
            entryA.generation @?= 0
            entryB.generation @?= 0
        ]
    ]
  where
    mkEntry = ensureEntry @Int @Int
    runSTM action = runEff . runConcurrent $ STM.atomically action


testEnsureCallback :: [TestTree]
testEnsureCallback =
    [ testCase "fires callback when entry's generation still matches" do
        actual <- runCallbackTest do
            state <- STM.atomically Map.new
            STM.atomically $ Map.insert (entry 0) (1 :: Int) state
            ref <- liftIO $ IORef.newIORef @Int 0
            t <-
                Conc.fork
                    $ ensureCallback @Int @Int 1 state 1 0
                    $ liftIO . IORef.writeIORef ref
            Conc.await t
            liftIO $ IORef.readIORef ref
        actual @?= 10
    , testCase "skips callback when generation has been bumped" do
        runCallbackTest do
            state <- STM.atomically Map.new
            -- A newer event has already bumped generation to 1
            STM.atomically $ Map.insert (entry 1) (1 :: Int) state
            -- This fork was scheduled for generation 0; it should skip
            ensureCallback @Int @Int 1 state 1 0 \_ ->
                liftIO $ False @?= True
    , testCase "skips callback when entry has been removed" do
        runCallbackTest do
            state <- STM.atomically Map.new
            ensureCallback @Int @Int 1 state 1 0 \_ ->
                liftIO $ False @?= True
    ]
  where
    runCallbackTest =
        runEff
            . runConcurrent
            . Console.runIO
            . Delay.runIO
            . Conc.runIO
    entry generation =
        Entry
            { generation
            , arg = Just $ toDyn @Int 10
            }


-- These specs exercise real-timer debouncing across forked threads. Rather than
-- sleeping a fixed duration and hoping the settle fired (which races scheduling
-- under load), each callback signals a 'TMVar' and the test blocks until it
-- fires. Multi-burst tests sequence by waiting for each burst's fire, so bursts
-- cannot merge regardless of timing. A short grace after the fire guards against
-- a spurious second fire.
testRun :: [TestTree]
testRun =
    [ testGroup
        "Debounce.with"
        [ testGroup
            "when invoked once"
            [ testCase "fires once" do
                n <- runTest do
                    (count, fired) <- newCounter
                    Debounce.with 50 () (bump count fired)
                    awaitFire fired
                    Delay.wait @Millisecond 80
                    readCount count
                n @?= 1
            ]
        , testGroup
            "when invoked multiple times"
            [ testCase "fires once" do
                n <- runTest do
                    (count, fired) <- newCounter
                    Debounce.with 50 () (bump count fired)
                    Debounce.with 50 () (bump count fired)
                    Debounce.with 50 () (bump count fired)
                    awaitFire fired
                    Delay.wait @Millisecond 80
                    readCount count
                n @?= 1
            ]
        , testGroup
            "when invoked multiple times with a delay between"
            [ testCase "fires once per burst" do
                n <- runTest do
                    (count, fired) <- newCounter
                    Debounce.with 50 () (bump count fired)
                    Debounce.with 50 () (bump count fired)
                    awaitFire fired -- burst 1 settled and cleared the entry
                    Debounce.with 50 () (bump count fired)
                    Debounce.with 50 () (bump count fired)
                    awaitFire fired -- burst 2 is therefore independent
                    readCount count
                n @?= 2
            ]
        , testGroup
            "when invoked many times"
            [ testCase "should not crash" do
                n <- runTest do
                    (count, fired) <- newCounter
                    replicateM_ 10_000 $ Debounce.with 50 () (bump count fired)
                    awaitFire fired
                    Delay.wait @Millisecond 80
                    readCount count
                n @?= 1
            ]
        ]
    , testGroup
        "Debounce.withArg"
        [ testGroup
            "when invoked once"
            [ testCase "fires callback with the provided arg" do
                got <- runTest do
                    result <- STM.atomically STM.newEmptyTMVar
                    Debounce.withArg 50 (+) () (42 :: Int) (signal result)
                    awaitValue result
                got @?= Just 42
            ]
        , testGroup
            "when invoked multiple times rapidly"
            [ testCase "fires once" do
                n <- runTest do
                    (count, fired) <- newCounter
                    let cb _ = bump count fired
                    Debounce.withArg 50 (+) () (1 :: Int) cb
                    Debounce.withArg 50 (+) () (2 :: Int) cb
                    Debounce.withArg 50 (+) () (3 :: Int) cb
                    awaitFire fired
                    Delay.wait @Millisecond 80
                    readCount count
                n @?= 1
            , testCase "fires callback with merged arg" do
                got <- runTest do
                    result <- STM.atomically STM.newEmptyTMVar
                    let cb = signal result
                    Debounce.withArg 50 (+) () (1 :: Int) cb
                    Debounce.withArg 50 (+) () (2 :: Int) cb
                    Debounce.withArg 50 (+) () (3 :: Int) cb
                    awaitValue result
                got @?= Just 6
            ]
        , testGroup
            "when invoked multiple times with a delay between"
            [ testCase "fires once per burst with merged arg" do
                xs <- runTest do
                    fired <- STM.atomically STM.newEmptyTMVar
                    ref <- STM.atomically (STM.newTVar @[Int] [])
                    let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ()))
                    Debounce.withArg 50 (+) () (1 :: Int) cb
                    Debounce.withArg 50 (+) () (2 :: Int) cb
                    awaitFire fired -- burst 1 fired (1+2=3); entry cleared
                    Debounce.withArg 50 (+) () (10 :: Int) cb
                    Debounce.withArg 50 (+) () (20 :: Int) cb
                    awaitFire fired -- burst 2 fired (10+20=30)
                    STM.atomically (STM.readTVar ref)
                xs @?= [3, 30]
            ]
        ]
    ]
  where
    runTest =
        runEff
            . runConcurrent
            . Conc.runIO
            . Delay.runIO
            . Debounce.run

    -- A fire counter paired with a TMVar signalling that a fire happened.
    newCounter = do
        count <- STM.atomically (STM.newTVar @Int 0)
        fired <- STM.atomically STM.newEmptyTMVar
        pure (count, fired)
    bump count fired = STM.atomically do
        STM.modifyTVar' count (+ 1)
        void $ STM.tryPutTMVar fired ()
    readCount count = STM.atomically (STM.readTVar count)
    signal result v = STM.atomically (STM.putTMVar result v)

    -- Block until a callback signals, bounded by a generous timeout so a real
    -- regression fails loudly instead of hanging forever.
    awaitFire fired =
        awaitValue fired >>= \case
            Just () -> pure ()
            Nothing -> liftIO $ assertFailure "debounce callback did not fire within 5s"
    awaitValue tmv =
        either (const Nothing) Just
            <$> Conc.race (Delay.wait @Millisecond 5000) (STM.atomically (STM.takeTMVar tmv))