timer-wheel-0.3.0: test/Main.hs

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

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

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)))