Extra.hs

{-# 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.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 = loopM $ \s ->
    -- important to handle both overflow and underflow vs Int
    if s < 0 then
        pure $ Right ()
    else if s > 2000 then do
        threadDelay 2000000000 -- 2000 * 1e6
        pure $ Left $ s - 2000
    else do
        threadDelay $ ceiling $ s * 1000000
        pure $ 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 (Eq,Typeable)
instance Show Timeout where show _ = "<<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 n f
    | n <= 0 = pure Nothing
    | otherwise = do
        pid <- myThreadId
        ex  <- fmap Timeout newUnique
        handleBool (== ex)
                   (const $ pure Nothing)
                   (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex)
                            killThread
                            (\_ -> fmap Just 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 x
    | x >= 3600 = f (x / 60) "h" "m"
    | x >= 60 = f x "m" "s"
    | otherwise = showDP 2 x ++ "s"
    where
        f x m s = show ms ++ m ++ ['0' | ss < 10] ++ show ss ++ s
            where (ms,ss) = round x `divMod` 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 = do
    start <- time
    pure $ do
        end <- time
        pure $ 1e-9 * fromIntegral (toNanoSecs $ end - start)
    where time = getTime Monotonic

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

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

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