(original) (raw)

{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-}

module System.Timeout ( Timeout, timeout ) where

#if !defined(mingw32_HOST_OS) import Control.Monad import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) #endif

import Control.Concurrent import Control.Exception (Exception(..), handleJust, bracket, uninterruptibleMask_, asyncExceptionToException, asyncExceptionFromException) import Data.Unique (Unique, newUnique)

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

instance Show Timeout where show :: Timeout -> String show Timeout _ = String "<>"

instance Exception Timeout where toException :: Timeout -> SomeException toException = Timeout -> SomeException forall e. Exception e => e -> SomeException asyncExceptionToException fromException :: SomeException -> Maybe Timeout fromException = SomeException -> Maybe Timeout forall e. Exception e => SomeException -> Maybe e asyncExceptionFromException

timeout :: Int -> IO a -> IO (Maybe a) timeout :: forall a. Int -> IO a -> IO (Maybe a) timeout Int n IO a f | Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = (a -> Maybe a) -> IO a -> IO (Maybe a) forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Maybe a forall a. a -> Maybe a Just IO a f | Int n Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0 = Maybe a -> IO (Maybe a) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing #if !defined(mingw32_HOST_OS) | Bool rtsSupportsBoundThreads = do

    ThreadId

pid <- IO ThreadId myThreadId Timeout ex <- (Unique -> Timeout) -> IO Unique -> IO Timeout forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Unique -> Timeout Timeout IO Unique newUnique TimerManager tm <- IO TimerManager getSystemTimerManager

    MVar ThreadId

lock <- IO (MVar ThreadId) forall a. IO (MVar a) newEmptyMVar let handleTimeout :: IO () handleTimeout = do Bool v <- MVar ThreadId -> IO Bool forall a. MVar a -> IO Bool isEmptyMVar MVar ThreadId lock Bool -> IO () -> IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool v (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ IO ThreadId -> IO () forall (f :: * -> *) a. Functor f => f a -> f () void (IO ThreadId -> IO ()) -> IO ThreadId -> IO () forall a b. (a -> b) -> a -> b $ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId) -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forall a b. (a -> b) -> a -> b $ \forall a. IO a -> IO a unmask -> IO () -> IO () forall a. IO a -> IO a unmask (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do Bool v2 <- MVar ThreadId -> ThreadId -> IO Bool forall a. MVar a -> a -> IO Bool tryPutMVar MVar ThreadId lock (ThreadId -> IO Bool) -> IO ThreadId -> IO Bool forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO ThreadId myThreadId Bool -> IO () -> IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool v2 (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ ThreadId -> Timeout -> IO () forall e. Exception e => ThreadId -> e -> IO () throwTo ThreadId pid Timeout ex cleanupTimeout :: TimeoutKey -> IO () cleanupTimeout TimeoutKey key = IO () -> IO () forall a. IO a -> IO a uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do Bool v <- MVar ThreadId -> ThreadId -> IO Bool forall a. MVar a -> a -> IO Bool tryPutMVar MVar ThreadId lock ThreadId forall a. HasCallStack => a undefined if Bool v then TimerManager -> TimeoutKey -> IO () unregisterTimeout TimerManager tm TimeoutKey key else MVar ThreadId -> IO ThreadId forall a. MVar a -> IO a takeMVar MVar ThreadId lock IO ThreadId -> (ThreadId -> 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 >>= ThreadId -> IO () killThread (Timeout -> Maybe ()) -> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a) forall e b a. Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a 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 a -> IO (Maybe a) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing) (IO TimeoutKey -> (TimeoutKey -> IO ()) -> (TimeoutKey -> IO (Maybe a)) -> IO (Maybe a) forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket (TimerManager -> Int -> IO () -> IO TimeoutKey registerTimeout TimerManager tm Int n IO () handleTimeout) TimeoutKey -> IO () cleanupTimeout (\TimeoutKey _ -> (a -> Maybe a) -> IO a -> IO (Maybe a) forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Maybe a forall a. a -> Maybe a Just IO a f)) #endif | Bool otherwise = do ThreadId pid <- IO ThreadId myThreadId Timeout ex <- (Unique -> Timeout) -> IO Unique -> IO Timeout forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Unique -> Timeout Timeout IO Unique newUnique (Timeout -> Maybe ()) -> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a) forall e b a. Exception e => (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a 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 a -> IO (Maybe a) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing) (IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO (Maybe a)) -> IO (Maybe a) forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId) -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId forall a b. (a -> b) -> a -> b $ \forall a. IO a -> IO a unmask -> IO () -> IO () forall a. IO a -> IO a unmask (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ Int -> IO () threadDelay Int 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) (IO () -> IO () forall a. IO a -> IO a uninterruptibleMask_ (IO () -> IO ()) -> (ThreadId -> IO ()) -> ThreadId -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . ThreadId -> IO () killThread) (\ThreadId _ -> (a -> Maybe a) -> IO a -> IO (Maybe a) forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Maybe a forall a. a -> Maybe a Just IO a f))