-- |Interceptors for fixing a specific time, Internal
module Polysemy.Time.At where

import Control.Concurrent.STM (newTVarIO)
import Torsor (Torsor (add), difference)

import Polysemy.Time.Calendar (HasDate, date, dateToTime)
import qualified Polysemy.Time.Data.Time as Time
import Polysemy.Time.Data.Time (Time)
import Polysemy.Time.Data.TimeUnit (TimeUnit, addTimeUnit)

-- |Determine the current time adjusted for the difference between a custom instant and the time at which the program
-- was started.
dateCurrentRelative ::
  ∀ diff t d r .
  Torsor t diff =>
  Members [Time t d, AtomicState (t, t)] r =>
  Sem r t
dateCurrentRelative :: forall diff t d (r :: [(* -> *) -> * -> *]).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
dateCurrentRelative = do
  (t
startAt, t
startActual) <- forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
Sem r s
atomicGet @(t, t)
  (diff -> t -> t
forall p v. Torsor p v => v -> p -> p
`add` t
startAt) (diff -> t) -> (t -> diff) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> t -> diff
forall p v. Torsor p v => p -> p -> v
`difference` t
startActual) (t -> t) -> Sem r t -> Sem r t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d

-- |Given real and adjusted start time, change all calls to 'Time.Now' and 'Time.Today' to be relative to that start
-- time.
-- This needs to be interpreted with a vanilla interpreter for 'Time' once more.
interceptTimeAtWithStart ::
  ∀ diff t d r a .
  Torsor t diff =>
  TimeUnit diff =>
  HasDate t d =>
  Members [Time t d, AtomicState (t, t)] r =>
  Sem r a ->
  Sem r a
interceptTimeAtWithStart :: forall diff t d (r :: [(* -> *) -> * -> *]) a.
(Torsor t diff, TimeUnit diff, HasDate t d,
 Members '[Time t d, AtomicState (t, t)] r) =>
Sem r a -> Sem r a
interceptTimeAtWithStart =
  forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept @(Time t d) \case
    Time t d (Sem rInitial) x
Time.Now ->
      forall diff t d (r :: [(* -> *) -> * -> *]).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
dateCurrentRelative @diff @t @d
    Time t d (Sem rInitial) x
Time.Today ->
      t -> x
forall t d. HasDate t d => t -> d
date (t -> x) -> Sem r t -> Sem r x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall diff t d (r :: [(* -> *) -> * -> *]).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
dateCurrentRelative @diff @t @d
    Time.Sleep u
t ->
      forall t d u (r :: [(* -> *) -> * -> *]).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep @t @d u
t
    Time.SetTime t
startAt -> do
      t
startActual <- forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
      forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @(t, t) (t
startAt, t
startActual)
    Time.Adjust u1
diff -> do
      forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' @(t, t) \ (t
old, t
actual) -> (u1 -> t -> t
forall t u1 u2. AddTimeUnit t u1 u2 => u1 -> t -> t
addTimeUnit u1
diff t
old, t
actual)
    Time.SetDate d
startAt -> do
      t
startActual <- forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
      forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @(t, t) (d -> t
forall t d. HasDate t d => d -> t
dateToTime d
startAt, t
startActual)
{-# inline interceptTimeAtWithStart #-}

-- |Interpret 'Time' so that the time when the program starts is @startAt@.
interceptTimeAt ::
  ∀ (diff :: Type) t d r a .
  TimeUnit diff =>
  Torsor t diff =>
  HasDate t d =>
  Members [Time t d, Embed IO] r =>
  t ->
  Sem r a ->
  Sem r a
interceptTimeAt :: forall diff t d (r :: [(* -> *) -> * -> *]) a.
(TimeUnit diff, Torsor t diff, HasDate t d,
 Members '[Time t d, Embed IO] r) =>
t -> Sem r a -> Sem r a
interceptTimeAt t
startAt Sem r a
sem = do
  t
startActual <- forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
  TVar (t, t)
tv <- IO (TVar (t, t)) -> Sem r (TVar (t, t))
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed ((t, t) -> IO (TVar (t, t))
forall a. a -> IO (TVar a)
newTVarIO (t
startAt, t
startActual))
  TVar (t, t) -> Sem (AtomicState (t, t) : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar (t, t)
tv (Sem (AtomicState (t, t) : r) a -> Sem r a)
-> (Sem r a -> Sem (AtomicState (t, t) : r) a)
-> Sem r a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall diff t d (r :: [(* -> *) -> * -> *]) a.
(Torsor t diff, TimeUnit diff, HasDate t d,
 Members '[Time t d, AtomicState (t, t)] r) =>
Sem r a -> Sem r a
interceptTimeAtWithStart @diff @t @d (Sem (AtomicState (t, t) : r) a -> Sem (AtomicState (t, t) : r) a)
-> (Sem r a -> Sem (AtomicState (t, t) : r) a)
-> Sem r a
-> Sem (AtomicState (t, t) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (AtomicState (t, t) : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r a -> Sem r a) -> Sem r a -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r a
sem
{-# inline interceptTimeAt #-}

-- |Change all calls to 'Time.Now' and 'Time.Today' to return the given start time.
-- This needs to be interpreted with a vanilla interpreter for 'Time' once more.
interceptTimeConstantState ::
  ∀ t d r a .
  HasDate t d =>
  Members [Time t d, AtomicState t] r =>
  Sem r a ->
  Sem r a
interceptTimeConstantState :: forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
interceptTimeConstantState =
  forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept @(Time t d) \case
    Time t d (Sem rInitial) x
Time.Now ->
      Sem r x
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
Sem r s
atomicGet
    Time t d (Sem rInitial) x
Time.Today ->
      forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets @t t -> x
forall t d. HasDate t d => t -> d
date
    Time.Sleep u
t ->
      forall t d u (r :: [(* -> *) -> * -> *]).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep @t @d u
t
    Time.SetTime t
now ->
      t -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut t
now
    Time.Adjust u1
diff ->
      forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' @t (u1 -> t -> t
forall t u1 u2. AddTimeUnit t u1 u2 => u1 -> t -> t
addTimeUnit u1
diff)
    Time.SetDate d
startAt ->
      forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @t (d -> t
forall t d. HasDate t d => d -> t
dateToTime d
startAt)
{-# inline interceptTimeConstantState #-}

-- |Interpret 'Time' so that the time is always @startAt@.
--
-- The time can still be changed with 'Time.setTime', 'Time.adjust' and 'Time.setDate'.
interceptTimeConstant ::
  ∀ t d r a .
  HasDate t d =>
  Members [Time t d, Embed IO] r =>
  t ->
  Sem r a ->
  Sem r a
interceptTimeConstant :: forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, Embed IO] r) =>
t -> Sem r a -> Sem r a
interceptTimeConstant t
startAt Sem r a
sem = do
  TVar t
tv <- IO (TVar t) -> Sem r (TVar t)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (t -> IO (TVar t)
forall a. a -> IO (TVar a)
newTVarIO t
startAt)
  TVar t -> Sem (AtomicState t : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar t
tv (Sem (AtomicState t : r) a -> Sem r a)
-> (Sem r a -> Sem (AtomicState t : r) a) -> Sem r a -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
interceptTimeConstantState @t (Sem (AtomicState t : r) a -> Sem (AtomicState t : r) a)
-> (Sem r a -> Sem (AtomicState t : r) a)
-> Sem r a
-> Sem (AtomicState t : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (AtomicState t : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r a -> Sem r a) -> Sem r a -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r a
sem
{-# inline interceptTimeConstant #-}

-- |Interpret 'Time' so that the time is always the time at the start of interpretation.
--
-- The time can still be changed with 'Time.setTime', 'Time.adjust' and 'Time.setDate'.
interceptTimeConstantNow ::
  ∀ t d r a .
  HasDate t d =>
  Members [Time t d, Embed IO] r =>
  Sem r a ->
  Sem r a
interceptTimeConstantNow :: forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, Embed IO] r) =>
Sem r a -> Sem r a
interceptTimeConstantNow Sem r a
sem = do
  t
now <- forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
  TVar t
tv <- IO (TVar t) -> Sem r (TVar t)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (t -> IO (TVar t)
forall a. a -> IO (TVar a)
newTVarIO t
now)
  TVar t -> Sem (AtomicState t : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar t
tv (Sem (AtomicState t : r) a -> Sem r a)
-> (Sem r a -> Sem (AtomicState t : r) a) -> Sem r a -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
interceptTimeConstantState @t (Sem (AtomicState t : r) a -> Sem (AtomicState t : r) a)
-> (Sem r a -> Sem (AtomicState t : r) a)
-> Sem r a
-> Sem (AtomicState t : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (AtomicState t : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r a -> Sem r a) -> Sem r a -> Sem r a
forall a b. (a -> b) -> a -> b
$ Sem r a
sem
{-# inline interceptTimeConstantNow #-}