{-# LANGUAGE CPP #-}
module Control.Concurrent.STM.Delay (
Delay,
newDelay,
updateDelay,
cancelDelay,
waitDelay,
tryWaitDelay,
tryWaitDelayIO,
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (mask_)
import Control.Monad
#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS
import qualified GHC.Event as Ev
#endif
#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS
import qualified GHC.Conc as Conc
#endif
data Delay = Delay
{ Delay -> TVar Bool
delayVar :: !(TVar Bool)
, Delay -> Int -> IO ()
delayUpdate :: !(Int -> IO ())
, Delay -> IO ()
delayCancel :: !(IO ())
}
instance Eq Delay where
== :: Delay -> Delay -> Bool
(==) Delay
a Delay
b = Delay -> TVar Bool
delayVar Delay
a TVar Bool -> TVar Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Delay -> TVar Bool
delayVar Delay
b
newDelay :: Int -> IO Delay
newDelay :: Int -> IO Delay
newDelay Int
t
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> IO Delay
getDelayImpl Int
t
| Bool
otherwise = do
TVar Bool
var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
Delay -> IO Delay
forall (m :: * -> *) a. Monad m => a -> m a
return Delay :: TVar Bool -> (Int -> IO ()) -> IO () -> Delay
Delay
{ delayVar :: TVar Bool
delayVar = TVar Bool
var
, delayUpdate :: Int -> IO ()
delayUpdate = \Int
_t -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, delayCancel :: IO ()
delayCancel = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
updateDelay :: Delay -> Int -> IO ()
updateDelay :: Delay -> Int -> IO ()
updateDelay = Delay -> Int -> IO ()
delayUpdate
cancelDelay :: Delay -> IO ()
cancelDelay :: Delay -> IO ()
cancelDelay = Delay -> IO ()
delayCancel
waitDelay :: Delay -> STM ()
waitDelay :: Delay -> STM ()
waitDelay Delay
delay = do
Bool
expired <- Delay -> STM Bool
tryWaitDelay Delay
delay
if Bool
expired then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else STM ()
forall a. STM a
retry
tryWaitDelay :: Delay -> STM Bool
tryWaitDelay :: Delay -> STM Bool
tryWaitDelay = TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (TVar Bool -> STM Bool)
-> (Delay -> TVar Bool) -> Delay -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> TVar Bool
delayVar
tryWaitDelayIO :: Delay -> IO Bool
tryWaitDelayIO :: Delay -> IO Bool
tryWaitDelayIO = TVar Bool -> IO Bool
forall a. TVar a -> IO a
readTVarIO (TVar Bool -> IO Bool) -> (Delay -> TVar Bool) -> Delay -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> TVar Bool
delayVar
getDelayImpl :: Int -> IO Delay
#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS
getDelayImpl :: Int -> IO Delay
getDelayImpl Int
t0 = do
IO ()
Conc.ensureIOManagerIsRunning
Maybe EventManager
m <- IO (Maybe EventManager)
Ev.getSystemEventManager
case Maybe EventManager
m of
Maybe EventManager
Nothing -> Int -> IO Delay
implThread Int
t0
Just EventManager
_ -> do
TimerManager
mgr <- IO TimerManager
Ev.getSystemTimerManager
TimerManager -> Int -> IO Delay
implEvent TimerManager
mgr Int
t0
#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS
getDelayImpl t0 = do
m <- Ev.getSystemEventManager
case m of
Nothing -> implThread t0
Just mgr -> implEvent mgr t0
#else
getDelayImpl = implThread
#endif
#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS
implEvent :: TimerManager -> Int -> IO Delay
implEvent TimerManager
mgr Int
t0 = do
TVar Bool
var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
TimeoutKey
k <- TimerManager -> Int -> IO () -> IO TimeoutKey
Ev.registerTimeout TimerManager
mgr Int
t0 (IO () -> IO TimeoutKey) -> IO () -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
var Bool
True
Delay -> IO Delay
forall (m :: * -> *) a. Monad m => a -> m a
return Delay :: TVar Bool -> (Int -> IO ()) -> IO () -> Delay
Delay
{ delayVar :: TVar Bool
delayVar = TVar Bool
var
, delayUpdate :: Int -> IO ()
delayUpdate = TimerManager -> TimeoutKey -> Int -> IO ()
Ev.updateTimeout TimerManager
mgr TimeoutKey
k
, delayCancel :: IO ()
delayCancel = TimerManager -> TimeoutKey -> IO ()
Ev.unregisterTimeout TimerManager
mgr TimeoutKey
k
}
#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS
implEvent :: Ev.EventManager -> Int -> IO Delay
implEvent mgr t0 = do
var <- newTVarIO False
k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True
return Delay
{ delayVar = var
, delayUpdate = Ev.updateTimeout mgr k
, delayCancel = Ev.unregisterTimeout mgr k
}
#endif
implThread :: Int -> IO Delay
implThread :: Int -> IO Delay
implThread Int
t0 = do
TVar Bool
var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
let new :: Int -> IO TimeoutThread
new Int
t = Int -> IO () -> IO TimeoutThread
forkTimeoutThread Int
t (IO () -> IO TimeoutThread) -> IO () -> IO TimeoutThread
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
var Bool
True
MVar (Maybe TimeoutThread)
mv <- Int -> IO TimeoutThread
new Int
t0 IO TimeoutThread
-> (TimeoutThread -> IO (MVar (Maybe TimeoutThread)))
-> IO (MVar (Maybe TimeoutThread))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TimeoutThread -> IO (MVar (Maybe TimeoutThread))
forall a. a -> IO (MVar a)
newMVar (Maybe TimeoutThread -> IO (MVar (Maybe TimeoutThread)))
-> (TimeoutThread -> Maybe TimeoutThread)
-> TimeoutThread
-> IO (MVar (Maybe TimeoutThread))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeoutThread -> Maybe TimeoutThread
forall a. a -> Maybe a
Just
Delay -> IO Delay
forall (m :: * -> *) a. Monad m => a -> m a
return Delay :: TVar Bool -> (Int -> IO ()) -> IO () -> Delay
Delay
{ delayVar :: TVar Bool
delayVar = TVar Bool
var
, delayUpdate :: Int -> IO ()
delayUpdate = MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO ()
replaceThread MVar (Maybe TimeoutThread)
mv (IO (Maybe TimeoutThread) -> IO ())
-> (Int -> IO (Maybe TimeoutThread)) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeoutThread -> Maybe TimeoutThread)
-> IO TimeoutThread -> IO (Maybe TimeoutThread)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TimeoutThread -> Maybe TimeoutThread
forall a. a -> Maybe a
Just (IO TimeoutThread -> IO (Maybe TimeoutThread))
-> (Int -> IO TimeoutThread) -> Int -> IO (Maybe TimeoutThread)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO TimeoutThread
new
, delayCancel :: IO ()
delayCancel = MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO ()
replaceThread MVar (Maybe TimeoutThread)
mv (IO (Maybe TimeoutThread) -> IO ())
-> IO (Maybe TimeoutThread) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe TimeoutThread -> IO (Maybe TimeoutThread)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TimeoutThread
forall a. Maybe a
Nothing
}
replaceThread :: MVar (Maybe TimeoutThread)
-> IO (Maybe TimeoutThread)
-> IO ()
replaceThread :: MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO ()
replaceThread MVar (Maybe TimeoutThread)
mv IO (Maybe TimeoutThread)
new =
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO (IO ())
forall a. IO a -> IO a
mask_ (IO (IO ()) -> IO (IO ())) -> IO (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
Maybe TimeoutThread
m <- MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread)
forall a. MVar a -> IO a
takeMVar MVar (Maybe TimeoutThread)
mv
case Maybe TimeoutThread
m of
Maybe TimeoutThread
Nothing -> do
MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv Maybe TimeoutThread
forall a. Maybe a
Nothing
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Just TimeoutThread
tt -> do
Maybe (IO ())
m' <- TimeoutThread -> IO (Maybe (IO ()))
stopTimeoutThread TimeoutThread
tt
case Maybe (IO ())
m' of
Maybe (IO ())
Nothing -> do
MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv Maybe TimeoutThread
forall a. Maybe a
Nothing
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just IO ()
kill -> do
IO (Maybe TimeoutThread)
new IO (Maybe TimeoutThread) -> (Maybe TimeoutThread -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
kill
data TimeoutThread = TimeoutThread !ThreadId !(MVar ())
forkTimeoutThread :: Int -> IO () -> IO TimeoutThread
forkTimeoutThread :: Int -> IO () -> IO TimeoutThread
forkTimeoutThread Int
t IO ()
io = do
MVar ()
mv <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
ThreadId
tid <- IO () -> IO ThreadId
compat_forkIOUnmasked (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay Int
t
Maybe ()
m <- MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
mv
case Maybe ()
m of
Maybe ()
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ()
_ -> IO ()
io
TimeoutThread -> IO TimeoutThread
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> MVar () -> TimeoutThread
TimeoutThread ThreadId
tid MVar ()
mv)
stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))
stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))
stopTimeoutThread (TimeoutThread ThreadId
tid MVar ()
mv) =
Maybe (IO ()) -> (() -> Maybe (IO ())) -> Maybe () -> Maybe (IO ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (IO ())
forall a. Maybe a
Nothing (\()
_ -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (ThreadId -> IO ()
killThread ThreadId
tid)) (Maybe () -> Maybe (IO ())) -> IO (Maybe ()) -> IO (Maybe (IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
mv
compat_forkIOUnmasked :: IO () -> IO ThreadId
#if MIN_VERSION_base(4,4,0)
compat_forkIOUnmasked :: IO () -> IO ThreadId
compat_forkIOUnmasked IO ()
io = ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (\forall a. IO a -> IO a
_ -> IO ()
io)
#else
compat_forkIOUnmasked = forkIOUnmasked
#endif