{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
-- |
-- 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 && !ghcjs_HOST_OS
import qualified GHC.Event as Ev
#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 TVar Bool -> TVar Bool -> Bool
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 Int -> Int -> Bool
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
        var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
        return Delay
            { delayVar    = var
            , delayUpdate = \Int
_t -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            , delayCancel = 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
    expired <- Delay -> STM Bool
tryWaitDelay Delay
delay
    if expired then return ()
               else retry

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

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

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

getDelayImpl :: Int -> IO Delay
#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
getDelayImpl :: Int -> IO Delay
getDelayImpl Int
t0 = do
    m <- IO (Maybe EventManager)
Ev.getSystemEventManager
    case m of
        Maybe EventManager
Nothing -> Int -> IO Delay
implThread Int
t0
        Just EventManager
_ -> do
            mgr <- IO TimerManager
Ev.getSystemTimerManager
            implEvent mgr t0
#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_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 && !ghcjs_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
    var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True
    return Delay
        { delayVar    = var
        , delayUpdate = Ev.updateTimeout mgr k
        , delayCancel = Ev.unregisterTimeout mgr k
        }
#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_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
    var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    let 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
    mv <- new t0 >>= newMVar . Just
    return Delay
        { delayVar    = var
        , delayUpdate = replaceThread mv . fmap Just . new
        , delayCancel = replaceThread mv $ return 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
    m <- MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread)
forall a. MVar a -> IO a
takeMVar MVar (Maybe TimeoutThread)
mv
    case 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.
            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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Just TimeoutThread
tt -> do
            m' <- TimeoutThread -> IO (Maybe (IO ()))
stopTimeoutThread TimeoutThread
tt
            case 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.
                    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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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
    mv <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    tid <- compat_forkIOUnmasked $ do
        threadDelay t
        m <- tryTakeMVar mv
        -- If m is Just, this thread will not be interrupted,
        -- so no need for a 'mask' between the tryTakeMVar and the action.
        case m of
            Maybe ()
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just ()
_  -> IO ()
io
    return (TimeoutThread tid 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) =
    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 a b. (a -> b) -> IO a -> IO b
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

------------------------------------------------------------------------
-- 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.
-}