module Lang.Crucible.Utils.Timeout
  ( Timeout(..)
  , TimedOut(..)
  , withTimeout
  ) where

import qualified Control.Concurrent as CC
import qualified Control.Concurrent.Async as CCA

import qualified Lang.Crucible.Utils.Seconds as Secs

-- | A timeout, in seconds.
newtype Timeout = Timeout { Timeout -> Seconds
getTimeout :: Secs.Seconds }
  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, Eq Timeout
Eq Timeout =>
(Timeout -> Timeout -> Ordering)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Bool)
-> (Timeout -> Timeout -> Timeout)
-> (Timeout -> Timeout -> Timeout)
-> Ord Timeout
Timeout -> Timeout -> Bool
Timeout -> Timeout -> Ordering
Timeout -> Timeout -> Timeout
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Timeout -> Timeout -> Ordering
compare :: Timeout -> Timeout -> Ordering
$c< :: Timeout -> Timeout -> Bool
< :: Timeout -> Timeout -> Bool
$c<= :: Timeout -> Timeout -> Bool
<= :: Timeout -> Timeout -> Bool
$c> :: Timeout -> Timeout -> Bool
> :: Timeout -> Timeout -> Bool
$c>= :: Timeout -> Timeout -> Bool
>= :: Timeout -> Timeout -> Bool
$cmax :: Timeout -> Timeout -> Timeout
max :: Timeout -> Timeout -> Timeout
$cmin :: Timeout -> Timeout -> Timeout
min :: Timeout -> Timeout -> Timeout
Ord, Int -> Timeout -> ShowS
[Timeout] -> ShowS
Timeout -> String
(Int -> Timeout -> ShowS)
-> (Timeout -> String) -> ([Timeout] -> ShowS) -> Show Timeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Timeout -> ShowS
showsPrec :: Int -> Timeout -> ShowS
$cshow :: Timeout -> String
show :: Timeout -> String
$cshowList :: [Timeout] -> ShowS
showList :: [Timeout] -> ShowS
Show)

-- Private, not exported
timeoutToMicros :: Timeout -> Int
timeoutToMicros :: Timeout -> Int
timeoutToMicros = Seconds -> Int
Secs.secondsToMicroseconds (Seconds -> Int) -> (Timeout -> Seconds) -> Timeout -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timeout -> Seconds
getTimeout

-- | A task timed out.
data TimedOut = TimedOut
  deriving Int -> TimedOut -> ShowS
[TimedOut] -> ShowS
TimedOut -> String
(Int -> TimedOut -> ShowS)
-> (TimedOut -> String) -> ([TimedOut] -> ShowS) -> Show TimedOut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimedOut -> ShowS
showsPrec :: Int -> TimedOut -> ShowS
$cshow :: TimedOut -> String
show :: TimedOut -> String
$cshowList :: [TimedOut] -> ShowS
showList :: [TimedOut] -> ShowS
Show

-- | Execute a task with a timeout.
--
-- Implemented via 'CCA.race', so re-throws exceptions that occur during the
-- task (if it completes before the timeout).
withTimeout ::
  -- | Timeout duration (seconds)
  Timeout ->
  -- | Task to attempt
  IO a ->
  IO (Either TimedOut a)
withTimeout :: forall a. Timeout -> IO a -> IO (Either TimedOut a)
withTimeout Timeout
to IO a
task = do
  let timeout :: IO TimedOut
timeout = do
        Int -> IO ()
CC.threadDelay (Timeout -> Int
timeoutToMicros Timeout
to)
        TimedOut -> IO TimedOut
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TimedOut
TimedOut
  IO TimedOut -> IO a -> IO (Either TimedOut a)
forall a b. IO a -> IO b -> IO (Either a b)
CCA.race IO TimedOut
timeout IO a
task