{-# LANGUAGE RecursiveDo #-}
module TimerWheel
(
TimerWheel,
create,
with,
Config (..),
register,
register_,
recurring,
recurring_,
)
where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.Bool (bool)
import Data.Fixed (E6, Fixed)
import Data.Function (fix)
import Data.IORef (newIORef, readIORef, writeIORef)
import GHC.Exception (errorCallException)
import qualified Ki
import TimerWheel.Internal.Config (Config)
import qualified TimerWheel.Internal.Config as Config
import TimerWheel.Internal.Micros (Micros (Micros))
import qualified TimerWheel.Internal.Micros as Micros
import TimerWheel.Internal.Supply (Supply)
import qualified TimerWheel.Internal.Supply as Supply
import TimerWheel.Internal.Wheel (Wheel)
import qualified TimerWheel.Internal.Wheel as Wheel
data TimerWheel = TimerWheel
{
TimerWheel -> Supply
supply :: {-# UNPACK #-} !Supply,
TimerWheel -> Wheel
wheel :: {-# UNPACK #-} !Wheel
}
create :: Ki.Scope -> Config -> IO TimerWheel
create :: Scope -> Config -> IO TimerWheel
create Scope
scope Config
config = do
Config -> IO ()
validateConfig Config
config
Wheel
wheel <- Int -> Micros -> IO Wheel
Wheel.create (Config -> Int
Config.spokes Config
config) (Fixed E6 -> Micros
Micros.fromFixed (Config -> Fixed E6
Config.resolution Config
config))
Supply
supply <- IO Supply
Supply.new
Scope -> IO Void -> IO ()
Ki.fork_ Scope
scope (forall a. Wheel -> IO a
Wheel.reap Wheel
wheel)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimerWheel {Supply
supply :: Supply
supply :: Supply
supply, Wheel
wheel :: Wheel
wheel :: Wheel
wheel}
with :: Config -> (TimerWheel -> IO a) -> IO a
with :: forall a. Config -> (TimerWheel -> IO a) -> IO a
with Config
config TimerWheel -> IO a
action =
forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
TimerWheel
wheel <- Scope -> Config -> IO TimerWheel
create Scope
scope Config
config
TimerWheel -> IO a
action TimerWheel
wheel
validateConfig :: Config -> IO ()
validateConfig :: Config -> IO ()
validateConfig Config
config =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Int
Config.spokes Config
config forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Config -> Fixed E6
Config.resolution Config
config forall a. Ord a => a -> a -> Bool
<= Fixed E6
0) do
forall e a. Exception e => e -> IO a
throwIO (String -> SomeException
errorCallException (String
"timer-wheel: invalid config: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Config
config))
register ::
TimerWheel ->
Fixed E6 ->
IO () ->
IO (IO Bool)
register :: TimerWheel -> Fixed E6 -> IO () -> IO (IO Bool)
register TimerWheel
wheel Fixed E6
delay =
TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl TimerWheel
wheel (Fixed E6 -> Micros
Micros.fromSeconds (forall a. Ord a => a -> a -> a
max Fixed E6
0 Fixed E6
delay))
register_ ::
TimerWheel ->
Fixed E6 ->
IO () ->
IO ()
register_ :: TimerWheel -> Fixed E6 -> IO () -> IO ()
register_ TimerWheel
wheel Fixed E6
delay IO ()
action = do
IO Bool
_ <- TimerWheel -> Fixed E6 -> IO () -> IO (IO Bool)
register TimerWheel
wheel Fixed E6
delay IO ()
action
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
registerImpl :: TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl :: TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl TimerWheel {Supply
supply :: Supply
supply :: TimerWheel -> Supply
supply, Wheel
wheel :: Wheel
wheel :: TimerWheel -> Wheel
wheel} Micros
delay IO ()
action = do
Int
key <- Supply -> IO Int
Supply.next Supply
supply
Wheel -> Int -> Micros -> IO () -> IO (IO Bool)
Wheel.insert Wheel
wheel Int
key Micros
delay IO ()
action
recurring ::
TimerWheel ->
Fixed E6 ->
IO () ->
IO (IO ())
recurring :: TimerWheel -> Fixed E6 -> IO () -> IO (IO ())
recurring TimerWheel
wheel (Fixed E6 -> Micros
Micros.fromSeconds -> Micros
delay) IO ()
action = mdo
let doAction :: IO ()
doAction :: IO ()
doAction = do
IO Bool
cancel <- TimerWheel -> Micros -> IO () -> IO (IO Bool)
reregister TimerWheel
wheel Micros
delay IO ()
doAction
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO Bool)
cancelRef IO Bool
cancel
IO ()
action
IO Bool
cancel0 <- TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl TimerWheel
wheel Micros
delay IO ()
doAction
IORef (IO Bool)
cancelRef <- forall a. a -> IO (IORef a)
newIORef IO Bool
cancel0
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
IO Bool -> IO ()
untilTrue do
IO Bool
cancel <- forall a. IORef a -> IO a
readIORef IORef (IO Bool)
cancelRef
IO Bool
cancel
recurring_ ::
TimerWheel ->
Fixed E6 ->
IO () ->
IO ()
recurring_ :: TimerWheel -> Fixed E6 -> IO () -> IO ()
recurring_ TimerWheel
wheel (Fixed E6 -> Micros
Micros.fromSeconds -> Micros
delay) IO ()
action = do
IO Bool
_ <- TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl TimerWheel
wheel Micros
delay IO ()
doAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
doAction :: IO ()
doAction :: IO ()
doAction = do
IO Bool
_ <- TimerWheel -> Micros -> IO () -> IO (IO Bool)
reregister TimerWheel
wheel Micros
delay IO ()
doAction
IO ()
action
reregister :: TimerWheel -> Micros -> IO () -> IO (IO Bool)
reregister :: TimerWheel -> Micros -> IO () -> IO (IO Bool)
reregister TimerWheel
wheel Micros
delay =
TimerWheel -> Micros -> IO () -> IO (IO Bool)
registerImpl TimerWheel
wheel (if Micros
reso forall a. Ord a => a -> a -> Bool
> Micros
delay then Word64 -> Micros
Micros Word64
0 else Micros
delay Micros -> Micros -> Micros
`Micros.minus` Micros
reso)
where
reso :: Micros
reso :: Micros
reso =
TimerWheel -> Micros
resolution TimerWheel
wheel
resolution :: TimerWheel -> Micros
resolution :: TimerWheel -> Micros
resolution =
Wheel -> Micros
Wheel.resolution forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimerWheel -> Wheel
wheel
untilTrue :: IO Bool -> IO ()
untilTrue :: IO Bool -> IO ()
untilTrue IO Bool
m =
forall a. (a -> a) -> a
fix \IO ()
again ->
IO Bool
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> a -> Bool -> a
bool IO ()
again (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())