{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Time measurement via 'MonadTime'.
module Effectful.Time
  ( -- * Effect
    Time (..)
  , MonadTime (..)

    -- ** Handlers
  , runTime
  , runFrozenTime
  ) where

import Control.Monad.IO.Class
import Control.Monad.Time
import Data.Time
import Effectful
import Effectful.Dispatch.Dynamic
import GHC.Clock (getMonotonicTime)

-- | Provide the ability to use the 'MonadTime' instance of 'Eff'.
data Time :: Effect where
  CurrentTime :: Time m UTCTime
  MonotonicTime :: Time m Double

type instance DispatchOf Time = Dynamic

-- | Run a 'Time' effect via 'IO'.
runTime :: IOE :> es => Eff (Time : es) a -> Eff es a
runTime :: forall (es :: [Effect]) a.
(IOE :> es) =>
Eff (Time : es) a -> Eff es a
runTime = forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs es
_ -> \case
  Time (Eff localEs) a
CurrentTime -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  Time (Eff localEs) a
MonotonicTime -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Double
getMonotonicTime

-- | Run a 'Time' effect with a frozen value of the 'CurrentTime' operation.
--
-- /Note:/ the 'MonotonicTime' operation works the same way as in 'runTime'.
runFrozenTime :: IOE :> es => UTCTime -> Eff (Time : es) a -> Eff es a
runFrozenTime :: forall (es :: [Effect]) a.
(IOE :> es) =>
UTCTime -> Eff (Time : es) a -> Eff es a
runFrozenTime UTCTime
time = forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs es
_ -> \case
  Time (Eff localEs) a
CurrentTime -> forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
time
  Time (Eff localEs) a
MonotonicTime -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Double
getMonotonicTime

----------------------------------------
-- Orphan instance

instance Time :> es => MonadTime (Eff es) where
  currentTime :: Eff es UTCTime
currentTime = forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send forall (m :: * -> *). Time m UTCTime
CurrentTime
  monotonicTime :: Eff es Double
monotonicTime = forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) =>
e (Eff es) a -> Eff es a
send forall (m :: * -> *). Time m Double
MonotonicTime