{-# LANGUAGE CPP #-}
-- |
-- Module:      Control.Concurrent.STM.Delay
-- Copyright:   (c) Joseph Adams 2012
-- License:     BSD3
-- Maintainer:  joeyadams3.14159@gmail.com
-- Portability: Requires GHC 7+
--
-- One-shot timer whose duration can be updated.  Think of it as an enhanced
-- version of 'registerDelay'.
--
-- This uses "GHC.Event" when available (GHC 7.2+, @-threaded@, non-Windows OS).
-- Otherwise, it falls back to forked threads and 'threadDelay'.
module Control.Concurrent.STM.Delay (
    -- * Managing delays
    Delay,
    newDelay,
    updateDelay,
    cancelDelay,

    -- * Waiting for expiration
    waitDelay,
    tryWaitDelay,
    tryWaitDelayIO,

    -- * Example
    -- $example
) 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

-- | A 'Delay' is an updatable timer that rings only once.
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

-- | Create a new 'Delay' that will ring in the given number of microseconds.
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

  -- Special case zero timeout, so user can create an
  -- already-rung 'Delay' efficiently.
  | 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 ()
            }

-- | Set an existing 'Delay' to ring in the given number of microseconds
-- (from the time 'updateDelay' is called), rather than when it was going to
-- ring.  If the 'Delay' has already rung, do nothing.
updateDelay :: Delay -> Int -> IO ()
updateDelay :: Delay -> Int -> IO ()
updateDelay = Delay -> Int -> IO ()
delayUpdate

-- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later.
-- If the 'Delay' has already rung, do nothing.
cancelDelay :: Delay -> IO ()
cancelDelay :: Delay -> IO ()
cancelDelay = Delay -> IO ()
delayCancel

-- | Block until the 'Delay' rings.  If the 'Delay' has already rung,
-- return immediately.
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

-- | Non-blocking version of 'waitDelay'.
-- Return 'True' if the 'Delay' has rung.
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

-- | Faster version of @'atomically' . 'tryWaitDelay'@.  See 'readTVarIO'.
--
-- Since 0.1.1
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

------------------------------------------------------------------------
-- Drivers

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
-- | Use the timeout API in "GHC.Event" via TimerManager
--implEvent :: Ev.TimerManager -> Int -> IO Delay
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
-- | Use the timeout API in "GHC.Event"
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

-- | Use threads and threadDelay:
--
--  [init]
--      Fork a thread to wait the given length of time, then set the TVar.
--
--  [delayUpdate]
--      Stop the existing thread and (unless the delay has been canceled)
--      fork a new thread.
--
--  [delayCancel]
--      Stop the existing thread, if any.
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
            -- Don't create a new timer thread after the 'Delay' has
            -- been canceled.  Otherwise, the behavior is inconsistent
            -- with GHC.Event.
            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
                    -- Timer already rang (or will ring very soon).
                    -- Don't start a new timer thread, as it would
                    -- waste resources and have no externally
                    -- observable effect.
                    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

------------------------------------------------------------------------
-- TimeoutThread

data TimeoutThread = TimeoutThread !ThreadId !(MVar ())

-- | Fork a thread to perform an action after the given number of
-- microseconds.
--
-- 'forkTimeoutThread' is non-interruptible.
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
        -- If m is Just, this thread will not be interrupted,
        -- so no need for a 'mask' between the tryTakeMVar and the action.
        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)

-- | Prevent the 'TimeoutThread' from performing its action.  If it's too late,
-- return 'Nothing'.  Otherwise, return an action (namely, 'killThread') for
-- cleaning up the underlying thread.
--
-- 'stopTimeoutThread' has a nice property: it is /non-interruptible/.
-- This means that, in an exception 'mask', it will not poll for exceptions.
-- See "Control.Exception" for more info.
--
-- However, the action returned by 'stopTimeoutThread' /does/ poll for
-- exceptions.  That's why 'stopTimeoutThread' returns this action rather than
-- simply doing it.  This lets the caller do it outside of a critical section.
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

------------------------------------------------------------------------
-- Compatibility

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

------------------------------------------------------------------------

{- $example
Suppose we are managing a network connection, and want to time it out if no
messages are received in over five minutes.  We'll create a 'Delay', and an
action to \"bump\" it:

@
  let timeoutInterval = 5 * 60 * 1000000 :: 'Int'
  delay <- 'newDelay' timeoutInterval
  let bump = 'updateDelay' delay timeoutInterval
@

This way, the 'Delay' will ring if it is not bumped for longer than
five minutes.

Now we fork the receiver thread:

@
  dead <- 'newEmptyTMVarIO'
  _ <- 'forkIO' $
    ('forever' $ do
         msg <- recvMessage
         bump
         handleMessage msg
     ) \`finally\` 'atomically' ('putTMVar' dead ())
@

Finally, we wait for the delay to ring, or for the receiver thread to fail due
to an exception:

@
  'atomically' $ 'waitDelay' delay \`orElse\` 'readTMVar' dead
@

Warning:

 * If /handleMessage/ blocks, the 'Delay' may ring due to @handleMessage@
   taking too long, rather than just @recvMessage@ taking too long.

 * The loop will continue to run until you do something to stop it.

It might be simpler to use "System.Timeout" instead:

@
  m <- 'System.Timeout.timeout' timeoutInterval recvMessage
  case m of
      Nothing  -> 'fail' \"timed out\"
      Just msg -> handleMessage msg
@

However, using a 'Delay' has the following advantages:

 * If @recvMessage@ makes a blocking FFI call (e.g. network I/O on Windows),
   'System.Timeout.timeout' won't work, since it uses an asynchronous
   exception, and FFI calls can't be interrupted with async exceptions.
   The 'Delay' approach lets you handle the timeout in another thread,
   while the FFI call is still blocked.

 * 'updateDelay' is more efficient than 'System.Timeout.timeout' when
   "GHC.Event" is available.
-}