{-# LANGUAGE DeriveDataTypeable #-}
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
type Seconds = Double
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 ->
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
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 ()
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
timeout :: Seconds -> IO a -> IO (Maybe a)
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
pid <- IO ThreadId
myThreadId
ex <- fmap Timeout newUnique
handleBool (== ex)
(const $ pure Nothing)
(bracket (forkIOWithUnmask $ \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)
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))
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
offsetTime :: IO (IO Seconds)
offsetTime :: IO (IO Seconds)
offsetTime = do
start <- IO TimeSpec
time
pure $ do
end <- time
pure $ 1e-9 * fromIntegral (toNanoSecs $ end - start)
where time :: IO TimeSpec
time = Clock -> IO TimeSpec
getTime Clock
Monotonic
{-# DEPRECATED offsetTimeIncrease "Use 'offsetTime' instead, which is guaranteed to always increase." #-}
offsetTimeIncrease :: IO (IO Seconds)
offsetTimeIncrease :: IO (IO Seconds)
offsetTimeIncrease = IO (IO Seconds)
offsetTime
duration :: MonadIO m => m a -> m (Seconds, a)
duration :: forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration m a
act = do
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
res <- act
time <- liftIO time
pure (time, res)