{-# LANGUAGE DeriveDataTypeable #-}

-- | Extra functions for working with times. Unlike the other modules in this package, there is no
--   corresponding @System.Time@ module. This module enhances the functionality
--   from "Data.Time.Clock", but in quite different ways.
--
--   Throughout, time is measured in 'Seconds', which is a type alias for 'Double'.
module System.Time.Extra(
    Seconds,
    sleep, timeout,
    showDuration,
    offsetTime, offsetTimeIncrease, duration
    ) where

import Control.Concurrent
import System.Clock
import Numeric.Extra
import Control.Monad.IO.Class
import Control.Monad.Extra
import Control.Exception.Extra
import Data.Typeable
import Data.Unique


-- | A type alias for seconds, which are stored as 'Double'.
type Seconds = Double

-- | Sleep for a number of seconds.
--
-- > fmap (round . fst) (duration $ sleep 1) == pure 1
sleep :: Seconds -> IO ()
sleep :: Seconds -> IO ()
sleep = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Either a b)) -> a -> m b
loopM forall a b. (a -> b) -> a -> b
$ \Seconds
s ->
    -- important to handle both overflow and underflow vs Int
    if Seconds
s forall a. Ord a => a -> a -> Bool
< Seconds
0 then
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
    else if Seconds
s forall a. Ord a => a -> a -> Bool
> Seconds
2000 then do
        Int -> IO ()
threadDelay Int
2000000000 -- 2000 * 1e6
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Seconds
s forall a. Num a => a -> a -> a
- Seconds
2000
    else do
        Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ Seconds
s forall a. Num a => a -> a -> a
* Seconds
1000000
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()


-- An internal type that is thrown as a dynamic exception to
-- interrupt the running IO computation when the timeout has
-- expired.
newtype Timeout = Timeout Unique deriving (Timeout -> Timeout -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Timeout -> Timeout -> Bool
$c/= :: Timeout -> Timeout -> Bool
== :: Timeout -> Timeout -> Bool
$c== :: Timeout -> Timeout -> Bool
Eq,Typeable)
instance Show Timeout where show :: Timeout -> String
show Timeout
_ = String
"<<timeout>>"
instance Exception Timeout


-- | A version of 'System.Timeout.timeout' that takes 'Seconds' and never
--   overflows the bounds of an 'Int'. In addition, the bug that negative
--   timeouts run for ever has been fixed.
--
-- > timeout (-3) (print 1) == pure Nothing
-- > timeout 0.1  (print 1) == fmap Just (print 1)
-- > do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1
-- > timeout 0.1  (sleep 2 >> print 1) == pure Nothing
timeout :: Seconds -> IO a -> IO (Maybe a)
-- Copied from GHC with a few tweaks.
timeout :: forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
n IO a
f
    | Seconds
n forall a. Ord a => a -> a -> Bool
<= Seconds
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    | Bool
otherwise = do
        ThreadId
pid <- IO ThreadId
myThreadId
        Timeout
ex  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique
        forall e a.
Exception e =>
(e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool (forall a. Eq a => a -> a -> Bool
== Timeout
ex)
                   (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
                   (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 b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex)
                            ThreadId -> IO ()
killThread
                            (\ThreadId
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO a
f))


-- | Show a number of seconds, typically a duration, in a suitable manner with
--   reasonable precision for a human.
--
-- > showDuration 3.435   == "3.44s"
-- > showDuration 623.8   == "10m24s"
-- > showDuration 62003.8 == "17h13m"
-- > showDuration 1e8     == "27777h47m"
showDuration :: Seconds -> String
showDuration :: Seconds -> String
showDuration Seconds
x
    | Seconds
x forall a. Ord a => a -> a -> Bool
>= Seconds
3600 = forall {p}. RealFrac p => p -> String -> ShowS
f (Seconds
x forall a. Fractional a => a -> a -> a
/ Seconds
60) String
"h" String
"m"
    | Seconds
x forall a. Ord a => a -> a -> Bool
>= Seconds
60 = forall {p}. RealFrac p => p -> String -> ShowS
f Seconds
x String
"m" String
"s"
    | Bool
otherwise = forall a. RealFloat a => Int -> a -> String
showDP Int
2 Seconds
x forall a. [a] -> [a] -> [a]
++ String
"s"
    where
        f :: p -> String -> ShowS
f p
x String
m String
s = forall a. Show a => a -> String
show Integer
ms forall a. [a] -> [a] -> [a]
++ String
m forall a. [a] -> [a] -> [a]
++ [Char
'0' | Integer
ss forall a. Ord a => a -> a -> Bool
< Integer
10] forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
ss forall a. [a] -> [a] -> [a]
++ String
s
            where (Integer
ms,Integer
ss) = forall a b. (RealFrac a, Integral b) => a -> b
round p
x forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
60


-- | Call once to start, then call repeatedly to get the elapsed time since the first call.
--   The time is guaranteed to be monotonic. This function is robust to system time changes.
--
-- > do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs
offsetTime :: IO (IO Seconds)
offsetTime :: IO (IO Seconds)
offsetTime = do
    TimeSpec
start <- IO TimeSpec
time
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
        TimeSpec
end <- IO TimeSpec
time
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Seconds
1e-9 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
toNanoSecs forall a b. (a -> b) -> a -> b
$ TimeSpec
end forall a. Num a => a -> a -> a
- TimeSpec
start)
    where time :: IO TimeSpec
time = Clock -> IO TimeSpec
getTime Clock
Monotonic

{-# DEPRECATED offsetTimeIncrease "Use 'offsetTime' instead, which is guaranteed to always increase." #-}

-- | A synonym for 'offsetTime'.
offsetTimeIncrease :: IO (IO Seconds)
offsetTimeIncrease :: IO (IO Seconds)
offsetTimeIncrease = IO (IO Seconds)
offsetTime

-- | Record how long a computation takes in 'Seconds'.
--
-- > do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5
duration :: MonadIO m => m a -> m (Seconds, a)
duration :: forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration m a
act = do
    IO Seconds
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (IO Seconds)
offsetTime
    a
res <- m a
act
    Seconds
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Seconds
time
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seconds
time, a
res)