timer-wheel-0.4.0: test/Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.IORef
import Data.Maybe (isJust)
import System.Mem (performGC)
import System.Mem.Weak (deRefWeak)
import TimerWheel

main :: IO ()
main = do
  do
    putStrLn "Timer wheel runs scheduled actions"
    with Config {spokes = 4, resolution = 0.05} \wheel -> do
      var <- newEmptyMVar
      let n = 1000
      replicateM_ n (register_ wheel 0 (putMVar var ()))
      replicateM_ n (takeMVar var)

  do
    putStrLn "Timers can be canceled"
    var <- newEmptyMVar
    with Config {spokes = 4, resolution = 0.05} \wheel -> do
      let n = 1000
      cancels <- replicateM n (register wheel 0 (putMVar var ()))
      successes <- sequence (take (n `div` 2) cancels)
      replicateM_ (n - length (filter id successes)) (takeMVar var)

  do
    putStrLn "Successful `cancel` returns True (then False)"
    with Config {spokes = 4, resolution = 0.05} \wheel -> do
      cancel <- register wheel 1 (pure ())
      cancel `is` True
      cancel `is` False

  do
    putStrLn "Unsuccessful `cancel` returns False"
    with Config {spokes = 4, resolution = 0.05} \wheel -> do
      var <- newEmptyMVar
      cancel <- register wheel 0 (putMVar var ())
      takeMVar var
      cancel `is` False

  do
    putStrLn "Recurring timers work"
    with Config {spokes = 4, resolution = 0.05} \wheel -> do
      canary <- newIORef () -- kept alive only by timer
      weakCanary <- mkWeakIORef canary (pure ())
      var <- newEmptyMVar
      cancel <- recurring wheel 0 (readIORef canary >> putMVar var ())
      replicateM_ 2 (takeMVar var)
      cancel -- should drop reference canary after a GC
      performGC
      (isJust <$> deRefWeak weakCanary) `is` False

  do
    putStrLn "`with` re-throws exception from background thread"
    catch
      ( with Config {spokes = 4, resolution = 0.05} \wheel -> do
          var <- newEmptyMVar
          register_ wheel 0 (throwIO Bye >> putMVar var ())
          takeMVar var
          throwIO (userError "fail")
      )
      ( \ex ->
          case fromException ex of
            Just Bye -> pure ()
            _ -> throwIO ex
      )

data Bye = Bye
  deriving stock (Show)
  deriving anyclass (Exception)

class Assert a b where
  is :: a -> b -> IO ()

instance (Eq a, Show a) => Assert (IO a) a where
  is mx y = do
    x <- mx
    unless (x == y) (throwIO (userError (show x ++ " /= " ++ show y)))