{-# 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 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 forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> IO Delay
getDelayImpl Int
t
| Bool
otherwise = do
TVar Bool
var <- forall a. a -> IO (TVar a)
newTVarIO Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return Delay
{ delayVar :: TVar Bool
delayVar = TVar Bool
var
, delayUpdate :: Int -> IO ()
delayUpdate = \Int
_t -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
, delayCancel :: IO ()
delayCancel = 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 forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall a. STM a
retry
tryWaitDelay :: Delay -> STM Bool
tryWaitDelay :: Delay -> STM Bool
tryWaitDelay = forall a. TVar a -> STM a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> TVar Bool
delayVar
tryWaitDelayIO :: Delay -> IO Bool
tryWaitDelayIO :: Delay -> IO Bool
tryWaitDelayIO = forall a. TVar a -> IO a
readTVarIO 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 <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
TimeoutKey
k <- TimerManager -> Int -> IO () -> IO TimeoutKey
Ev.registerTimeout TimerManager
mgr Int
t0 forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
var Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
let new :: Int -> IO TimeoutThread
new Int
t = Int -> IO () -> IO TimeoutThread
forkTimeoutThread Int
t forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
var Bool
True
MVar (Maybe TimeoutThread)
mv <- Int -> IO TimeoutThread
new Int
t0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (MVar a)
newMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
forall (m :: * -> *) a. Monad m => a -> m a
return Delay
{ delayVar :: TVar Bool
delayVar = TVar Bool
var
, delayUpdate :: Int -> IO ()
delayUpdate = MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO ()
replaceThread MVar (Maybe TimeoutThread)
mv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just 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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return 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 =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
Maybe TimeoutThread
m <- forall a. MVar a -> IO a
takeMVar MVar (Maybe TimeoutThread)
mv
case Maybe TimeoutThread
m of
Maybe TimeoutThread
Nothing -> do
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return (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
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just IO ()
kill -> do
IO (Maybe TimeoutThread)
new forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe TimeoutThread)
mv
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 <- forall a. a -> IO (MVar a)
newMVar ()
ThreadId
tid <- IO () -> IO ThreadId
compat_forkIOUnmasked forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay Int
t
Maybe ()
m <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar ()
mv
case Maybe ()
m of
Maybe ()
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ()
_ -> IO ()
io
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) =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (\()
_ -> forall a. a -> Maybe a
Just (ThreadId -> IO ()
killThread ThreadId
tid)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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