{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
-- Description: Time effects
module Swarm.Effect.Time where

import Control.Algebra
import Control.Monad.Trans (MonadIO (liftIO))
import Data.Kind (Type)
import System.Clock (Clock (Monotonic), TimeSpec, getTime)

-- | Effect for things related to time
data Time (m :: Type -> Type) k where
  GetNow :: Time m TimeSpec

getNow :: Has Time sig m => m TimeSpec
getNow :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has Time sig m =>
m TimeSpec
getNow = Time m TimeSpec -> m TimeSpec
forall (eff :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member eff sig, Algebra sig m) =>
eff m a -> m a
send Time m TimeSpec
forall (m :: * -> *). Time m TimeSpec
GetNow

newtype TimeIOC m a = TimeIOC {forall (m :: * -> *) a. TimeIOC m a -> m a
runTimeIO :: m a}
  deriving newtype (Functor (TimeIOC m)
Functor (TimeIOC m) =>
(forall a. a -> TimeIOC m a)
-> (forall a b. TimeIOC m (a -> b) -> TimeIOC m a -> TimeIOC m b)
-> (forall a b c.
    (a -> b -> c) -> TimeIOC m a -> TimeIOC m b -> TimeIOC m c)
-> (forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b)
-> (forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m a)
-> Applicative (TimeIOC m)
forall a. a -> TimeIOC m a
forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m a
forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b
forall a b. TimeIOC m (a -> b) -> TimeIOC m a -> TimeIOC m b
forall a b c.
(a -> b -> c) -> TimeIOC m a -> TimeIOC m b -> TimeIOC 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 (TimeIOC m)
forall (m :: * -> *) a. Applicative m => a -> TimeIOC m a
forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m a
forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m b
forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m (a -> b) -> TimeIOC m a -> TimeIOC m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TimeIOC m a -> TimeIOC m b -> TimeIOC m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TimeIOC m a
pure :: forall a. a -> TimeIOC m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m (a -> b) -> TimeIOC m a -> TimeIOC m b
<*> :: forall a b. TimeIOC m (a -> b) -> TimeIOC m a -> TimeIOC m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TimeIOC m a -> TimeIOC m b -> TimeIOC m c
liftA2 :: forall a b c.
(a -> b -> c) -> TimeIOC m a -> TimeIOC m b -> TimeIOC m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m b
*> :: forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m a
<* :: forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m a
Applicative, (forall a b. (a -> b) -> TimeIOC m a -> TimeIOC m b)
-> (forall a b. a -> TimeIOC m b -> TimeIOC m a)
-> Functor (TimeIOC m)
forall a b. a -> TimeIOC m b -> TimeIOC m a
forall a b. (a -> b) -> TimeIOC m a -> TimeIOC m b
forall (m :: * -> *) a b.
Functor m =>
a -> TimeIOC m b -> TimeIOC m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TimeIOC m a -> TimeIOC 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) -> TimeIOC m a -> TimeIOC m b
fmap :: forall a b. (a -> b) -> TimeIOC m a -> TimeIOC m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TimeIOC m b -> TimeIOC m a
<$ :: forall a b. a -> TimeIOC m b -> TimeIOC m a
Functor, Applicative (TimeIOC m)
Applicative (TimeIOC m) =>
(forall a b. TimeIOC m a -> (a -> TimeIOC m b) -> TimeIOC m b)
-> (forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b)
-> (forall a. a -> TimeIOC m a)
-> Monad (TimeIOC m)
forall a. a -> TimeIOC m a
forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b
forall a b. TimeIOC m a -> (a -> TimeIOC m b) -> TimeIOC m b
forall (m :: * -> *). Monad m => Applicative (TimeIOC m)
forall (m :: * -> *) a. Monad m => a -> TimeIOC m a
forall (m :: * -> *) a b.
Monad m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m b
forall (m :: * -> *) a b.
Monad m =>
TimeIOC m a -> (a -> TimeIOC m b) -> TimeIOC 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 =>
TimeIOC m a -> (a -> TimeIOC m b) -> TimeIOC m b
>>= :: forall a b. TimeIOC m a -> (a -> TimeIOC m b) -> TimeIOC m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TimeIOC m a -> TimeIOC m b -> TimeIOC m b
>> :: forall a b. TimeIOC m a -> TimeIOC m b -> TimeIOC m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> TimeIOC m a
return :: forall a. a -> TimeIOC m a
Monad, Monad (TimeIOC m)
Monad (TimeIOC m) =>
(forall a. IO a -> TimeIOC m a) -> MonadIO (TimeIOC m)
forall a. IO a -> TimeIOC m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TimeIOC m)
forall (m :: * -> *) a. MonadIO m => IO a -> TimeIOC m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TimeIOC m a
liftIO :: forall a. IO a -> TimeIOC m a
MonadIO)

instance (MonadIO m, Algebra sig m) => Algebra (Time :+: sig) (TimeIOC m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (TimeIOC m)
-> (:+:) Time sig n a -> ctx () -> TimeIOC m (ctx a)
alg Handler ctx n (TimeIOC m)
hdl (:+:) Time sig n a
sig ctx ()
ctx = case (:+:) Time sig n a
sig of
    L Time n a
GetNow -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> TimeIOC m a -> TimeIOC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> TimeIOC m a
forall a. IO a -> TimeIOC m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Clock -> IO TimeSpec
System.Clock.getTime Clock
System.Clock.Monotonic)
    R sig n a
other -> m (ctx a) -> TimeIOC m (ctx a)
forall (m :: * -> *) a. m a -> TimeIOC m a
TimeIOC (Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (TimeIOC m (ctx x) -> m (ctx x)
forall (m :: * -> *) a. TimeIOC m a -> m a
runTimeIO (TimeIOC m (ctx x) -> m (ctx x))
-> (ctx (n x) -> TimeIOC m (ctx x)) -> ctx (n x) -> m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n x) -> TimeIOC m (ctx x)
Handler ctx n (TimeIOC m)
hdl) sig n a
other ctx ()
ctx)