{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
-- Do no complain about the System.Timeout import.
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Control.Concurrent.Timeout (
    timeout,
    threadDelay
  ) where

import Data.Typeable
import Data.Timeout
import Data.Unique
import Control.Applicative
import Control.Monad.Base
import Control.Exception
import qualified Control.Concurrent as C
-- Imported for Haddock.
import qualified System.Timeout as C

data TimeoutException = TimeoutException Unique
  deriving (Typeable, TimeoutException -> TimeoutException -> Bool
(TimeoutException -> TimeoutException -> Bool)
-> (TimeoutException -> TimeoutException -> Bool)
-> Eq TimeoutException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
/= :: TimeoutException -> TimeoutException -> Bool
Eq)

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

instance Exception TimeoutException

-- | A version of 'C.timeout' that takes 'Timeout' instead of number of
--   microseconds.
timeout ∷ MonadBase IO μ ⇒ Timeout → IO α → μ (Maybe α)
timeout :: forall (μ :: * -> *) α.
MonadBase IO μ =>
Timeout -> IO α -> μ (Maybe α)
timeout Timeout
tt IO α
_ | Timeout
tt Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
instantly = Maybe α -> μ (Maybe α)
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe α
forall a. Maybe a
Nothing
timeout Timeout
tt IO α
io = IO (Maybe α) -> μ (Maybe α)
forall α. IO α -> μ α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Maybe α) -> μ (Maybe α)) -> IO (Maybe α) -> μ (Maybe α)
forall a b. (a -> b) -> a -> b
$ do
  ThreadId
pid <- IO ThreadId
C.myThreadId
  TimeoutException
ex  <- Unique -> TimeoutException
TimeoutException (Unique -> TimeoutException) -> IO Unique -> IO TimeoutException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique
  (TimeoutException -> Maybe ())
-> (() -> IO (Maybe α)) -> IO (Maybe α) -> IO (Maybe α)
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\TimeoutException
e -> if TimeoutException
e TimeoutException -> TimeoutException -> Bool
forall a. Eq a => a -> a -> Bool
== TimeoutException
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)
             (IO ThreadId
-> (ThreadId -> IO ())
-> (ThreadId -> IO (Maybe α))
-> IO (Maybe α)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO () -> IO ThreadId
C.forkIO (Timeout -> IO ()
forall (μ :: * -> *). MonadBase IO μ => Timeout -> μ ()
threadDelay Timeout
tt 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 -> TimeoutException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
C.throwTo ThreadId
pid TimeoutException
ex))
                      (ThreadId -> IO ()
C.killThread)
                      (\ThreadId
_ -> α -> Maybe α
forall a. a -> Maybe a
Just (α -> Maybe α) -> IO α -> IO (Maybe α)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO α
io))

-- | A version of 'C.threadDelay' that takes 'Timeout' instead of number of
--   microseconds.
threadDelay ∷ MonadBase IO μ ⇒ Timeout → μ ()
threadDelay :: forall (μ :: * -> *). MonadBase IO μ => Timeout -> μ ()
threadDelay Timeout
tt | Timeout
tt Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
instantly = () -> μ ()
forall a. a -> μ a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
threadDelay Timeout
tt = IO () -> μ ()
forall α. IO α -> μ α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> μ ()) -> IO () -> μ ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
C.threadDelay (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
us') IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> IO ()
go Word64
us'
  where us :: Word64
us = Timeout
tt Timeout -> TimeoutUnit -> Word64
#> TimeoutUnit
MicroSecond
        maxUs :: Word64
maxUs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound ∷ Int)
        us' :: Word64
us' = Word64
maxUs Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` Word64
us
        go :: Word64 -> IO ()
go Word64
passed = case Word64
us Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
passed of
          Word64
0    → () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Word64
left → Int -> IO ()
C.threadDelay (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
us'') IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> IO ()
go Word64
us''
            where us'' :: Word64
us'' = Word64
maxUs Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` Word64
left