{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Effectful.Time
(
Time (..)
, MonadTime (..)
, 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)
data Time :: Effect where
CurrentTime :: Time m UTCTime
MonotonicTime :: Time m Double
type instance DispatchOf Time = Dynamic
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
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
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