    {-# 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 = (Seconds -> IO (Either Seconds ())) -> Seconds -> IO ()
    forall (m :: * -> *) a b.
    Monad m =>
    (a -> m (Either a b)) -> a -> m b
    loopM ((Seconds -> IO (Either Seconds ())) -> Seconds -> IO ())
    -> (Seconds -> IO (Either Seconds ())) -> Seconds -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Seconds
    s ->
        -- important to handle both overflow and underflow vs Int
        if Seconds
    s Seconds -> Seconds -> Bool
    forall a. Ord a => a -> a -> Bool
    < Seconds
    0 then
            Either Seconds () -> IO (Either Seconds ())
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either Seconds () -> IO (Either Seconds ()))
    -> Either Seconds () -> IO (Either Seconds ())
    forall a b. (a -> b) -> a -> b
    $ () -> Either Seconds ()
    forall a b. b -> Either a b
    Right ()
        else if Seconds
    s Seconds -> Seconds -> Bool
    forall a. Ord a => a -> a -> Bool
    > Seconds
    2000 then do
            Int -> IO ()
    threadDelay Int
    2000000000 -- 2000 * 1e6
            Either Seconds () -> IO (Either Seconds ())
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either Seconds () -> IO (Either Seconds ()))
    -> Either Seconds () -> IO (Either Seconds ())
    forall a b. (a -> b) -> a -> b
    $ Seconds -> Either Seconds ()
    forall a b. a -> Either a b
    Left (Seconds -> Either Seconds ()) -> Seconds -> Either Seconds ()
    forall a b. (a -> b) -> a -> b
    $ Seconds
    s Seconds -> Seconds -> Seconds
    forall a. Num a => a -> a -> a
    - Seconds
    2000
        else do
            Int -> IO ()
    threadDelay (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Seconds -> Int
    forall b. Integral b => Seconds -> b
    forall a b. (RealFrac a, Integral b) => a -> b
    ceiling (Seconds -> Int) -> Seconds -> Int
    forall a b. (a -> b) -> a -> b
    $ Seconds
    s Seconds -> Seconds -> Seconds
    forall a. Num a => a -> a -> a
    * Seconds
    1000000
            Either Seconds () -> IO (Either Seconds ())
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either Seconds () -> IO (Either Seconds ()))
    -> Either Seconds () -> IO (Either Seconds ())
    forall a b. (a -> b) -> a -> b
    $ () -> Either Seconds ()
    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
    (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

    -- | 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 Seconds -> Seconds -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Seconds
    0 = Maybe a -> IO (Maybe a)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe a
    forall a. Maybe a
    Nothing
        | 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 -> Bool)
    -> (Timeout -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
    forall e a.
    Exception e =>
    (e -> Bool) -> (e -> IO a) -> IO a -> IO a
    handleBool (Timeout -> Timeout -> Bool
    forall a. Eq a => a -> a -> Bool
    == Timeout
    ex)
                       (IO (Maybe a) -> Timeout -> IO (Maybe a)
    forall a b. a -> b -> a
    const (IO (Maybe a) -> Timeout -> IO (Maybe a))
    -> IO (Maybe a) -> Timeout -> IO (Maybe a)
    forall a b. (a -> b) -> a -> b
    $ Maybe a -> IO (Maybe a)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure 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
    $ Seconds -> IO ()
    sleep Seconds
    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)
                                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))

    -- | 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 Seconds -> Seconds -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Seconds
    3600 = Seconds -> String -> ShowS
    forall {p}. RealFrac p => p -> String -> ShowS
    f (Seconds
    x Seconds -> Seconds -> Seconds
    forall a. Fractional a => a -> a -> a
    / Seconds
    60) String
    "h" String
    "m"
        | Seconds
    x Seconds -> Seconds -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Seconds
    60 = Seconds -> String -> ShowS
    forall {p}. RealFrac p => p -> String -> ShowS
    f Seconds
    x String
    "m" String
    "s"
        | Bool
    otherwise = Int -> Seconds -> String
    forall a. RealFloat a => Int -> a -> String
    showDP Int
    2 Seconds
    x String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "s"
        where
            f :: p -> String -> ShowS
    f p
    x String
    m String
    s = Integer -> String
    forall a. Show a => a -> String
    show Integer
    ms String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    m String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char
    '0' | Integer
    ss Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    < Integer
    10] String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Integer -> String
    forall a. Show a => a -> String
    show Integer
    ss String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s
                where (Integer
    ms,Integer
    ss) = p -> Integer
    forall b. Integral b => p -> b
    forall a b. (RealFrac a, Integral b) => a -> b
    round p
    x Integer -> Integer -> (Integer, Integer)
    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
        IO Seconds -> IO (IO Seconds)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (IO Seconds -> IO (IO Seconds)) -> IO Seconds -> IO (IO Seconds)
    forall a b. (a -> b) -> a -> b
    $ do
            TimeSpec
    end <- IO TimeSpec
    time
            Seconds -> IO Seconds
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Seconds -> IO Seconds) -> Seconds -> IO Seconds
    forall a b. (a -> b) -> a -> b
    $ Seconds
    1e-9 Seconds -> Seconds -> Seconds
    forall a. Num a => a -> a -> a
    * Integer -> Seconds
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (TimeSpec -> Integer
    toNanoSecs (TimeSpec -> Integer) -> TimeSpec -> Integer
    forall a b. (a -> b) -> a -> b
    $ TimeSpec
    end TimeSpec -> TimeSpec -> TimeSpec
    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 <- IO (IO Seconds) -> m (IO Seconds)
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO (IO Seconds)
    offsetTime
        a
    res <- m a
    act
        Seconds
    time <- IO Seconds -> m Seconds
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Seconds
    time
        (Seconds, a) -> m (Seconds, a)
    forall a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Seconds
    time, a
    res)