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

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


import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Reader (ReaderT(ReaderT, runReaderT), ask)
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 Prelude
  ( Applicative(pure), Fractional((/), fromRational), Monad(return)
  , Num((*), (+), (-)), Real(toRational), RealFrac(truncate), Show(showsPrec)
  , (.), Eq, Functor, IO, Ord, flip, realToFrac
  )
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
    (day, tod) <- Get (Integer, Rational)
forall t. Binary t => Get t
get
    return (Time (UTCTime (ModifiedJulianDay day) (fromRational 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
  start <- m TimeSpec
forall (m :: * -> *). MonadTimeSpec m => m TimeSpec
getTime
  result <- action
  end <- getTime
  pure (result, diffTimeSpec end 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
    }


{-| An instance of MonadTimeSpec where the time is always a constant value.  -}
newtype NowT m a = NowT
  { forall (m :: * -> *) a. NowT m a -> ReaderT TimeSpec m a
_unNowT :: ReaderT TimeSpec m a
  }
  deriving newtype
    ( Functor (NowT m)
Functor (NowT m) =>
(forall a. a -> NowT m a)
-> (forall a b. NowT m (a -> b) -> NowT m a -> NowT m b)
-> (forall a b c.
    (a -> b -> c) -> NowT m a -> NowT m b -> NowT m c)
-> (forall a b. NowT m a -> NowT m b -> NowT m b)
-> (forall a b. NowT m a -> NowT m b -> NowT m a)
-> Applicative (NowT m)
forall a. a -> NowT m a
forall a b. NowT m a -> NowT m b -> NowT m a
forall a b. NowT m a -> NowT m b -> NowT m b
forall a b. NowT m (a -> b) -> NowT m a -> NowT m b
forall a b c. (a -> b -> c) -> NowT m a -> NowT m b -> NowT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (NowT m)
forall (m :: * -> *) a. Applicative m => a -> NowT m a
forall (m :: * -> *) a b.
Applicative m =>
NowT m a -> NowT m b -> NowT m a
forall (m :: * -> *) a b.
Applicative m =>
NowT m a -> NowT m b -> NowT m b
forall (m :: * -> *) a b.
Applicative m =>
NowT m (a -> b) -> NowT m a -> NowT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> NowT m a -> NowT m b -> NowT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> NowT m a
pure :: forall a. a -> NowT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
NowT m (a -> b) -> NowT m a -> NowT m b
<*> :: forall a b. NowT m (a -> b) -> NowT m a -> NowT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> NowT m a -> NowT m b -> NowT m c
liftA2 :: forall a b c. (a -> b -> c) -> NowT m a -> NowT m b -> NowT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
NowT m a -> NowT m b -> NowT m b
*> :: forall a b. NowT m a -> NowT m b -> NowT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
NowT m a -> NowT m b -> NowT m a
<* :: forall a b. NowT m a -> NowT m b -> NowT m a
Applicative
    , (forall a b. (a -> b) -> NowT m a -> NowT m b)
-> (forall a b. a -> NowT m b -> NowT m a) -> Functor (NowT m)
forall a b. a -> NowT m b -> NowT m a
forall a b. (a -> b) -> NowT m a -> NowT m b
forall (m :: * -> *) a b. Functor m => a -> NowT m b -> NowT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NowT m a -> NowT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NowT m a -> NowT m b
fmap :: forall a b. (a -> b) -> NowT m a -> NowT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> NowT m b -> NowT m a
<$ :: forall a b. a -> NowT m b -> NowT m a
Functor
    , Applicative (NowT m)
Applicative (NowT m) =>
(forall a b. NowT m a -> (a -> NowT m b) -> NowT m b)
-> (forall a b. NowT m a -> NowT m b -> NowT m b)
-> (forall a. a -> NowT m a)
-> Monad (NowT m)
forall a. a -> NowT m a
forall a b. NowT m a -> NowT m b -> NowT m b
forall a b. NowT m a -> (a -> NowT m b) -> NowT m b
forall (m :: * -> *). Monad m => Applicative (NowT m)
forall (m :: * -> *) a. Monad m => a -> NowT m a
forall (m :: * -> *) a b.
Monad m =>
NowT m a -> NowT m b -> NowT m b
forall (m :: * -> *) a b.
Monad m =>
NowT m a -> (a -> NowT m b) -> NowT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
NowT m a -> (a -> NowT m b) -> NowT m b
>>= :: forall a b. NowT m a -> (a -> NowT m b) -> NowT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
NowT m a -> NowT m b -> NowT m b
>> :: forall a b. NowT m a -> NowT m b -> NowT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> NowT m a
return :: forall a. a -> NowT m a
Monad
    , (forall (m :: * -> *). Monad m => Monad (NowT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> NowT m a)
-> MonadTrans NowT
forall (m :: * -> *). Monad m => Monad (NowT m)
forall (m :: * -> *) a. Monad m => m a -> NowT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> NowT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> NowT m a
MonadTrans
    )
instance (Monad m) => MonadTimeSpec (NowT m) where
  getTime :: NowT m TimeSpec
getTime = ReaderT TimeSpec m TimeSpec -> NowT m TimeSpec
forall (m :: * -> *) a. ReaderT TimeSpec m a -> NowT m a
NowT ReaderT TimeSpec m TimeSpec
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask


runNowT :: TimeSpec -> NowT m a -> m a
runNowT :: forall (m :: * -> *) a. TimeSpec -> NowT m a -> m a
runNowT TimeSpec
now (NowT ReaderT TimeSpec m a
action) =
  (ReaderT TimeSpec m a -> TimeSpec -> m a)
-> TimeSpec -> ReaderT TimeSpec m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT TimeSpec m a -> TimeSpec -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TimeSpec
now ReaderT TimeSpec m a
action