{-# LANGUAGE DeriveGeneric #-}

module Control.Monad.Class.MonadTime
  ( MonadTime (..)
  , MonadMonotonicTime (..)
    -- * 'DiffTime' and its action on 'Time'
  , Time (..)
  , diffTime
  , addTime
  , DiffTime
    -- * 'NominalTime' and its action on 'UTCTime'
  , UTCTime
  , diffUTCTime
  , addUTCTime
  , NominalDiffTime
  ) where

import           Control.Monad.Reader
import           Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime,
                     addUTCTime, diffUTCTime)
import qualified Data.Time.Clock as Time
import           Data.Word (Word64)
import           GHC.Clock (getMonotonicTimeNSec)
import           GHC.Generics (Generic (..))

-- | A point in time in a monotonic clock.
--
-- The epoch for this clock is arbitrary and does not correspond to any wall
-- clock or calendar, and is /not guaranteed/ to be the same epoch across
-- program runs. It is represented as the 'DiffTime' from this arbitrary epoch.
--
newtype Time = Time DiffTime
  deriving (Time -> Time -> Bool
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: 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
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$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
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
$cp1Ord :: Eq Time
Ord, Int -> Time -> ShowS
[Time] -> ShowS
Time -> String
(Int -> Time -> ShowS)
-> (Time -> String) -> ([Time] -> ShowS) -> Show Time
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Time] -> ShowS
$cshowList :: [Time] -> ShowS
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> ShowS
$cshowsPrec :: Int -> Time -> ShowS
Show, (forall x. Time -> Rep Time x)
-> (forall x. Rep Time x -> Time) -> Generic Time
forall x. Rep Time x -> Time
forall x. Time -> Rep Time x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Time x -> Time
$cfrom :: forall x. Time -> Rep Time x
Generic)

-- | The time duration between two points in time (positive or negative).
diffTime :: Time -> Time -> DiffTime
diffTime :: Time -> Time -> DiffTime
diffTime (Time DiffTime
t) (Time DiffTime
t') = DiffTime
t DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
t'

-- | Add a duration to a point in time, giving another time.
addTime :: DiffTime -> Time -> Time
addTime :: DiffTime -> Time -> Time
addTime DiffTime
d (Time DiffTime
t) = DiffTime -> Time
Time (DiffTime
d DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
t)

infixr 9 `addTime`


class Monad m => MonadMonotonicTime m where
  -- | Time in a monotonic clock, with high precision. The epoch for this
  -- clock is arbitrary and does not correspond to any wall clock or calendar.
  --
  getMonotonicTime :: m Time

class MonadMonotonicTime m => MonadTime m where
  -- | Wall clock time.
  --
  getCurrentTime   :: m UTCTime

--
-- Instances for IO
--

instance MonadMonotonicTime IO where
  getMonotonicTime :: IO Time
getMonotonicTime =
      (Word64 -> Time) -> IO Word64 -> IO Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Time
conv IO Word64
getMonotonicTimeNSec
    where
      conv :: Word64 -> Time
      conv :: Word64 -> Time
conv = DiffTime -> Time
Time (DiffTime -> Time) -> (Word64 -> DiffTime) -> Word64 -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DiffTime
Time.picosecondsToDiffTime (Integer -> DiffTime) -> (Word64 -> Integer) -> Word64 -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000) (Integer -> Integer) -> (Word64 -> Integer) -> Word64 -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger

instance MonadTime IO where
  getCurrentTime :: IO UTCTime
getCurrentTime = IO UTCTime
Time.getCurrentTime

--
-- Instance for ReaderT
--

instance MonadMonotonicTime m => MonadMonotonicTime (ReaderT r m) where
  getMonotonicTime :: ReaderT r m Time
getMonotonicTime = m Time -> ReaderT r m Time
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime

instance MonadTime m => MonadTime (ReaderT r m) where
  getCurrentTime :: ReaderT r m UTCTime
getCurrentTime   = m UTCTime -> ReaderT r m UTCTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime