{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

{- | Basic missing time utilities. -}
module OM.Time (
  MonadTimeSpec(..),
  Time(..),
  timed,
  diffTimeSpec,
  addTime,
) where


import Control.Monad.Trans.Class (MonadTrans(lift))
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import Data.Binary (Binary, get, put)
import Data.Int (Int64)
import Data.Time (Day(ModifiedJulianDay), UTCTime(UTCTime), DiffTime)
import System.Clock (TimeSpec)
import qualified System.Clock as Clock


{- | Wrapper around 'UTCTime', used mainly to provide a 'Binary' instance. -}
newtype Time = Time {
    Time -> UTCTime
unTime :: UTCTime
  }
  deriving newtype (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
/= :: Time -> Time -> Bool
Eq, Eq Time
Eq Time =>
(Time -> Time -> Ordering)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> Ord Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
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
$ccompare :: Time -> Time -> Ordering
compare :: Time -> Time -> Ordering
$c< :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
>= :: Time -> Time -> Bool
$cmax :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
min :: Time -> Time -> Time
Ord, [Time] -> Value
[Time] -> Encoding
Time -> Bool
Time -> Value
Time -> Encoding
(Time -> Value)
-> (Time -> Encoding)
-> ([Time] -> Value)
-> ([Time] -> Encoding)
-> (Time -> Bool)
-> ToJSON Time
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Time -> Value
toJSON :: Time -> Value
$ctoEncoding :: Time -> Encoding
toEncoding :: Time -> Encoding
$ctoJSONList :: [Time] -> Value
toJSONList :: [Time] -> Value
$ctoEncodingList :: [Time] -> Encoding
toEncodingList :: [Time] -> Encoding
$comitField :: Time -> Bool
omitField :: Time -> Bool
ToJSON, Maybe Time
Value -> Parser [Time]
Value -> Parser Time
(Value -> Parser Time)
-> (Value -> Parser [Time]) -> Maybe Time -> FromJSON Time
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Time
parseJSON :: Value -> Parser Time
$cparseJSONList :: Value -> Parser [Time]
parseJSONList :: Value -> Parser [Time]
$comittedField :: Maybe Time
omittedField :: Maybe Time
FromJSON, ToJSONKeyFunction [Time]
ToJSONKeyFunction Time
ToJSONKeyFunction Time
-> ToJSONKeyFunction [Time] -> ToJSONKey Time
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction Time
toJSONKey :: ToJSONKeyFunction Time
$ctoJSONKeyList :: ToJSONKeyFunction [Time]
toJSONKeyList :: ToJSONKeyFunction [Time]
ToJSONKey, FromJSONKeyFunction [Time]
FromJSONKeyFunction Time
FromJSONKeyFunction Time
-> FromJSONKeyFunction [Time] -> FromJSONKey Time
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: FromJSONKeyFunction Time
fromJSONKey :: FromJSONKeyFunction Time
$cfromJSONKeyList :: FromJSONKeyFunction [Time]
fromJSONKeyList :: FromJSONKeyFunction [Time]
FromJSONKey)
instance Show Time where
  showsPrec :: Int -> Time -> ShowS
showsPrec Int
n = Int -> UTCTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
n (UTCTime -> ShowS) -> (Time -> UTCTime) -> Time -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> UTCTime
unTime
instance Binary Time where
  put :: Time -> Put
put (Time (UTCTime (ModifiedJulianDay Integer
day) DiffTime
tod)) = 
    (Integer, Rational) -> Put
forall t. Binary t => t -> Put
put (Integer
day, DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
tod)
  get :: Get Time
get = do
    (Integer
day, Rational
tod) <- Get (Integer, Rational)
forall t. Binary t => Get t
get
    Time -> Get Time
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> Time
Time (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
day) (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational Rational
tod)))


{- | A monad that can produce the current time as a TimeSpec. -}
class (Monad m) => MonadTimeSpec m where
  getTime :: m TimeSpec

{- | The IO instances uses 'Clock.getTime' 'Clock.MonotonicCoarse'. -}
instance MonadTimeSpec IO where
  getTime :: IO TimeSpec
getTime = Clock -> IO TimeSpec
Clock.getTime Clock
Clock.MonotonicCoarse

instance {-# OVERLAPPABLE #-}
    ( Monad (t m)
    , MonadTimeSpec m
    , MonadTrans t
    )
  =>
    MonadTimeSpec (t m)
  where
    getTime :: t m TimeSpec
getTime = m TimeSpec -> t m TimeSpec
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m TimeSpec
forall (m :: * -> *). MonadTimeSpec m => m TimeSpec
getTime


{- | Perform an action and measure how long it takes. -}
timed
  :: MonadTimeSpec m
  => m a
  -> m (a, DiffTime)
timed :: forall (m :: * -> *) a. MonadTimeSpec m => m a -> m (a, DiffTime)
timed m a
action = do
  TimeSpec
start <- m TimeSpec
forall (m :: * -> *). MonadTimeSpec m => m TimeSpec
getTime
  a
result <- m a
action
  TimeSpec
end <- m TimeSpec
forall (m :: * -> *). MonadTimeSpec m => m TimeSpec
getTime
  (a, DiffTime) -> m (a, DiffTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
result, TimeSpec -> TimeSpec -> DiffTime
diffTimeSpec TimeSpec
end TimeSpec
start)


{- | Take the difference of two time specs, as a 'DiffTime'. -}
diffTimeSpec :: TimeSpec -> TimeSpec -> DiffTime
diffTimeSpec :: TimeSpec -> TimeSpec -> DiffTime
diffTimeSpec TimeSpec
a TimeSpec
b =
  Integer -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (TimeSpec -> Integer
Clock.toNanoSecs (TimeSpec -> TimeSpec -> TimeSpec
Clock.diffTimeSpec TimeSpec
a TimeSpec
b)) DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1_000_000_000


{- | Add a 'DiffTime' to a 'TimeSpec'. -}
addTime :: DiffTime -> TimeSpec -> TimeSpec
addTime :: DiffTime -> TimeSpec -> TimeSpec
addTime DiffTime
diff TimeSpec
time =
  let
    rat :: Rational
rat = DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
diff

    secDiff :: Int64
    secDiff :: Int64
secDiff = Rational -> Int64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Rational
rat

    nsecDiff :: Int64
    nsecDiff :: Int64
nsecDiff = Rational -> Int64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate ((DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
diff Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Int64 -> Rational
forall a. Real a => a -> Rational
toRational Int64
secDiff) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1_000_000_000)
  in
    Clock.TimeSpec {
      sec :: Int64
Clock.sec = TimeSpec -> Int64
Clock.sec TimeSpec
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
secDiff,
      nsec :: Int64
Clock.nsec = TimeSpec -> Int64
Clock.nsec TimeSpec
time Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
nsecDiff
    }