{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.Timeout ( timeout, Timeout, timeoutWithPred ) where
import Control.Concurrent ( forkIOWithUnmask, myThreadId, throwTo, killThread )
import Control.Exception ( Exception, bracket, handleJust )
import Control.Monad ( return, (>>), fmap )
import Data.Bool ( Bool(False), otherwise )
import Data.Eq ( Eq, (==) )
import Data.Function ( (.), const)
import Data.Maybe ( Maybe(Nothing, Just) )
import Data.Ord ( (<) )
import Data.Typeable ( Typeable )
import Data.Unique ( Unique, newUnique )
import Prelude ( Integer )
import System.IO ( IO )
import Text.Show ( Show, show )
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger )
import Control.Monad ( (>>=), fail )
#endif
#ifdef __HADDOCK_VERSION__
import Data.Int ( Int )
import System.IO ( hGetBuf, hPutBuf, hWaitForInput )
import qualified System.Timeout ( timeout )
#endif
import Control.Concurrent.Thread.Delay ( delay )
newtype Timeout = Timeout Unique deriving (Timeout -> Timeout -> Bool
(Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool) -> Eq Timeout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
/= :: Timeout -> Timeout -> Bool
Eq, Typeable)
instance Show Timeout where
show :: Timeout -> String
show Timeout
_ = String
"<<timeout>>"
instance Exception Timeout
timeoutWithPred :: Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
timeoutWithPred :: forall α. Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
timeoutWithPred Integer
n (Timeout -> Bool) -> IO α
f
| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 = (α -> Maybe α) -> IO α -> IO (Maybe α)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap α -> Maybe α
forall a. a -> Maybe a
Just ((Timeout -> Bool) -> IO α
f (Bool -> Timeout -> Bool
forall a b. a -> b -> a
const Bool
False))
| Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Maybe α -> IO (Maybe α)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe α
forall a. Maybe a
Nothing
| Bool
otherwise = do
pid <- IO ThreadId
myThreadId
ex <- fmap Timeout newUnique
handleJust (\Timeout
e -> if Timeout
e Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
ex then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
(\()
_ -> Maybe α -> IO (Maybe α)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe α
forall a. Maybe a
Nothing)
(bracket (forkIOWithUnmask (\forall a. IO a -> IO a
unmask -> IO () -> IO ()
forall a. IO a -> IO a
unmask (Integer -> IO ()
delay Integer
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> Timeout -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex)))
(killThread)
(\ThreadId
_ -> (α -> Maybe α) -> IO α -> IO (Maybe α)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap α -> Maybe α
forall a. a -> Maybe a
Just ((Timeout -> Bool) -> IO α
f (Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
==Timeout
ex)))
)
timeout :: Integer -> IO α -> IO (Maybe α)
timeout :: forall α. Integer -> IO α -> IO (Maybe α)
timeout Integer
n = Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
forall α. Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
timeoutWithPred Integer
n (((Timeout -> Bool) -> IO α) -> IO (Maybe α))
-> (IO α -> (Timeout -> Bool) -> IO α) -> IO α -> IO (Maybe α)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO α -> (Timeout -> Bool) -> IO α
forall a b. a -> b -> a
const