{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Test.Hspec.Core.Clock (
  Seconds(..)
, toMilliseconds
, toMicroseconds
, getMonotonicTime
, measure
, sleep
, timeout
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Text.Printf
import           System.Clock
import           Control.Concurrent
import qualified System.Timeout as System

newtype Seconds = Seconds Double
  deriving (Seconds -> Seconds -> Bool
(Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Bool) -> Eq Seconds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seconds -> Seconds -> Bool
$c/= :: Seconds -> Seconds -> Bool
== :: Seconds -> Seconds -> Bool
$c== :: Seconds -> Seconds -> Bool
Eq, Int -> Seconds -> ShowS
[Seconds] -> ShowS
Seconds -> String
(Int -> Seconds -> ShowS)
-> (Seconds -> String) -> ([Seconds] -> ShowS) -> Show Seconds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Seconds] -> ShowS
$cshowList :: [Seconds] -> ShowS
show :: Seconds -> String
$cshow :: Seconds -> String
showsPrec :: Int -> Seconds -> ShowS
$cshowsPrec :: Int -> Seconds -> ShowS
Show, Eq Seconds
Eq Seconds
-> (Seconds -> Seconds -> Ordering)
-> (Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Bool)
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds -> Seconds)
-> Ord Seconds
Seconds -> Seconds -> Bool
Seconds -> Seconds -> Ordering
Seconds -> Seconds -> Seconds
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
min :: Seconds -> Seconds -> Seconds
$cmin :: Seconds -> Seconds -> Seconds
max :: Seconds -> Seconds -> Seconds
$cmax :: Seconds -> Seconds -> Seconds
>= :: Seconds -> Seconds -> Bool
$c>= :: Seconds -> Seconds -> Bool
> :: Seconds -> Seconds -> Bool
$c> :: Seconds -> Seconds -> Bool
<= :: Seconds -> Seconds -> Bool
$c<= :: Seconds -> Seconds -> Bool
< :: Seconds -> Seconds -> Bool
$c< :: Seconds -> Seconds -> Bool
compare :: Seconds -> Seconds -> Ordering
$ccompare :: Seconds -> Seconds -> Ordering
$cp1Ord :: Eq Seconds
Ord, Integer -> Seconds
Seconds -> Seconds
Seconds -> Seconds -> Seconds
(Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Integer -> Seconds)
-> Num Seconds
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Seconds
$cfromInteger :: Integer -> Seconds
signum :: Seconds -> Seconds
$csignum :: Seconds -> Seconds
abs :: Seconds -> Seconds
$cabs :: Seconds -> Seconds
negate :: Seconds -> Seconds
$cnegate :: Seconds -> Seconds
* :: Seconds -> Seconds -> Seconds
$c* :: Seconds -> Seconds -> Seconds
- :: Seconds -> Seconds -> Seconds
$c- :: Seconds -> Seconds -> Seconds
+ :: Seconds -> Seconds -> Seconds
$c+ :: Seconds -> Seconds -> Seconds
Num, Num Seconds
Num Seconds
-> (Seconds -> Seconds -> Seconds)
-> (Seconds -> Seconds)
-> (Rational -> Seconds)
-> Fractional Seconds
Rational -> Seconds
Seconds -> Seconds
Seconds -> Seconds -> Seconds
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Seconds
$cfromRational :: Rational -> Seconds
recip :: Seconds -> Seconds
$crecip :: Seconds -> Seconds
/ :: Seconds -> Seconds -> Seconds
$c/ :: Seconds -> Seconds -> Seconds
$cp1Fractional :: Num Seconds
Fractional, Seconds -> ModifierParser
Seconds -> FieldFormatter
(Seconds -> FieldFormatter)
-> (Seconds -> ModifierParser) -> PrintfArg Seconds
forall a.
(a -> FieldFormatter) -> (a -> ModifierParser) -> PrintfArg a
parseFormat :: Seconds -> ModifierParser
$cparseFormat :: Seconds -> ModifierParser
formatArg :: Seconds -> FieldFormatter
$cformatArg :: Seconds -> FieldFormatter
PrintfArg)

toMilliseconds :: Seconds -> Int
toMilliseconds :: Seconds -> Int
toMilliseconds (Seconds Double
s) = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000)

toMicroseconds :: Seconds -> Int
toMicroseconds :: Seconds -> Int
toMicroseconds (Seconds Double
s) = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)

getMonotonicTime :: IO Seconds
getMonotonicTime :: IO Seconds
getMonotonicTime = do
  TimeSpec
t <- Clock -> IO TimeSpec
getTime Clock
Monotonic
  Seconds -> IO Seconds
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds -> IO Seconds) -> Seconds -> IO Seconds
forall a b. (a -> b) -> a -> b
$ Double -> Seconds
Seconds ((Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> (TimeSpec -> Integer) -> TimeSpec -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Integer
toNanoSecs (TimeSpec -> Double) -> TimeSpec -> Double
forall a b. (a -> b) -> a -> b
$ TimeSpec
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000000000)

measure :: IO a -> IO (Seconds, a)
measure :: IO a -> IO (Seconds, a)
measure IO a
action = do
  Seconds
t0 <- IO Seconds
getMonotonicTime
  a
a <- IO a
action
  Seconds
t1 <- IO Seconds
getMonotonicTime
  (Seconds, a) -> IO (Seconds, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t1 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
t0, a
a)

sleep :: Seconds -> IO ()
sleep :: Seconds -> IO ()
sleep = Int -> IO ()
threadDelay (Int -> IO ()) -> (Seconds -> Int) -> Seconds -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> Int
toMicroseconds

timeout :: Seconds -> IO a -> IO (Maybe a)
timeout :: Seconds -> IO a -> IO (Maybe a)
timeout = Int -> IO a -> IO (Maybe a)
forall a. Int -> IO a -> IO (Maybe a)
System.timeout (Int -> IO a -> IO (Maybe a))
-> (Seconds -> Int) -> Seconds -> IO a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> Int
toMicroseconds