{-# LANGUAGE LambdaCase #-}
module Control.Concurrent.Async.Timer.Internal where
import qualified Control.Concurrent.Async as Async
import Control.Exception.Safe
import Control.Monad (void)
import Control.Monad.IO.Unlift
import UnliftIO.Async
import UnliftIO.Concurrent
import UnliftIO.STM
data Timer = Timer { Timer -> MVar ()
timerMVar :: MVar ()
, Timer -> TBQueue TimerCommand
timerControl :: TBQueue TimerCommand }
data TimerCommand = TimerReset deriving (Int -> TimerCommand -> ShowS
[TimerCommand] -> ShowS
TimerCommand -> String
(Int -> TimerCommand -> ShowS)
-> (TimerCommand -> String)
-> ([TimerCommand] -> ShowS)
-> Show TimerCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimerCommand] -> ShowS
$cshowList :: [TimerCommand] -> ShowS
show :: TimerCommand -> String
$cshow :: TimerCommand -> String
showsPrec :: Int -> TimerCommand -> ShowS
$cshowsPrec :: Int -> TimerCommand -> ShowS
Show, TimerCommand -> TimerCommand -> Bool
(TimerCommand -> TimerCommand -> Bool)
-> (TimerCommand -> TimerCommand -> Bool) -> Eq TimerCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimerCommand -> TimerCommand -> Bool
$c/= :: TimerCommand -> TimerCommand -> Bool
== :: TimerCommand -> TimerCommand -> Bool
$c== :: TimerCommand -> TimerCommand -> Bool
Eq)
data TimerConf = TimerConf { TimerConf -> Int
_timerConfInitDelay :: Int
, TimerConf -> Int
_timerConfInterval :: Int }
millisleep :: MonadIO m => Int -> m ()
millisleep :: Int -> m ()
millisleep Int
dt = Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dt Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
3)
defaultConf :: TimerConf
defaultConf :: TimerConf
defaultConf = TimerConf :: Int -> Int -> TimerConf
TimerConf { _timerConfInitDelay :: Int
_timerConfInitDelay = Int
0
, _timerConfInterval :: Int
_timerConfInterval = Int
1000 }
setInitDelay :: Int -> TimerConf -> TimerConf
setInitDelay :: Int -> TimerConf -> TimerConf
setInitDelay Int
n TimerConf
conf = TimerConf
conf { _timerConfInitDelay :: Int
_timerConfInitDelay = Int
n }
setInterval :: Int -> TimerConf -> TimerConf
setInterval :: Int -> TimerConf -> TimerConf
setInterval Int
n TimerConf
conf = TimerConf
conf { _timerConfInterval :: Int
_timerConfInterval = Int
n }
timerLoop
:: MonadUnliftIO m
=> Int
-> Int
-> Timer
-> m ()
timerLoop :: Int -> Int -> Timer -> m ()
timerLoop Int
initDelay Int
intervalDelay Timer
timer = Int -> m ()
forall b. Int -> m b
go Int
initDelay
where go :: Int -> m b
go Int
delay = do
m () -> m TimerCommand -> m (Either () TimerCommand)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
millisleep Int
delay) m TimerCommand
readCmd m (Either () TimerCommand)
-> (Either () TimerCommand -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
Left () -> do
m ()
wakeUp
Int -> m b
go Int
intervalDelay
Right TimerCommand
cmd ->
case TimerCommand
cmd of
TimerCommand
TimerReset ->
Int -> m b
go Int
intervalDelay
wakeUp :: m ()
wakeUp = MVar () -> () -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar (Timer -> MVar ()
timerMVar Timer
timer) ()
readCmd :: m TimerCommand
readCmd = STM TimerCommand -> m TimerCommand
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM TimerCommand -> m TimerCommand)
-> STM TimerCommand -> m TimerCommand
forall a b. (a -> b) -> a -> b
$ TBQueue TimerCommand -> STM TimerCommand
forall a. TBQueue a -> STM a
readTBQueue (Timer -> TBQueue TimerCommand
timerControl Timer
timer)
wait
:: MonadUnliftIO m
=> Timer
-> m ()
wait :: Timer -> m ()
wait = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (Timer -> m ()) -> Timer -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar (MVar () -> m ()) -> (Timer -> MVar ()) -> Timer -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timer -> MVar ()
timerMVar
reset
:: MonadUnliftIO m
=> Timer
-> m ()
reset :: Timer -> m ()
reset Timer
timer =
STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue TimerCommand -> TimerCommand -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Timer -> TBQueue TimerCommand
timerControl Timer
timer) TimerCommand
TimerReset
withAsyncTimer
:: (MonadUnliftIO m, MonadMask m)
=> TimerConf
-> (Timer -> m b)
-> m b
withAsyncTimer :: TimerConf -> (Timer -> m b) -> m b
withAsyncTimer TimerConf
conf Timer -> m b
io = do
MVar ()
mVar <- m (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
TBQueue TimerCommand
controlChannel <- STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand))
-> STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand)
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue TimerCommand)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
1
let timer :: Timer
timer = Timer :: MVar () -> TBQueue TimerCommand -> Timer
Timer { timerMVar :: MVar ()
timerMVar = MVar ()
mVar
, timerControl :: TBQueue TimerCommand
timerControl = TBQueue TimerCommand
controlChannel }
initDelay :: Int
initDelay = TimerConf -> Int
_timerConfInitDelay TimerConf
conf
intervalDelay :: Int
intervalDelay = TimerConf -> Int
_timerConfInterval TimerConf
conf
m () -> (Async () -> m b) -> m b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Int -> Int -> Timer -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
Int -> Int -> Timer -> m ()
timerLoop Int
initDelay Int
intervalDelay Timer
timer) ((Async () -> m b) -> m b) -> (Async () -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ Async ()
asyncTimer -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
asyncTimer
Timer -> m b
io Timer
timer