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

import Polysemy (intercept)
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 :: Sem r t
dateCurrentRelative = do
  (t
startAt, t
startActual) <- forall (r :: [(* -> *) -> * -> *]).
Member (AtomicState (t, t)) r =>
Sem r (t, t)
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 (r :: [(* -> *) -> * -> *]). Member (Time t d) r => Sem r t
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 :: Sem r a -> Sem r a
interceptTimeAtWithStart =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Time t d (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
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 (r :: [(* -> *) -> * -> *]).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
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 (r :: [(* -> *) -> * -> *]).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
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 ->
      u -> Sem r ()
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 (r :: [(* -> *) -> * -> *]). Member (Time t d) r => Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
      (t, t) -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @(t, t) (t
startAt, t
startActual)
    Time.Adjust u1
diff -> do
      ((t, t) -> (t, t)) -> Sem r ()
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 (r :: [(* -> *) -> * -> *]). Member (Time t d) r => Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
      (t, t) -> Sem r ()
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 :: t -> Sem r a -> Sem r a
interceptTimeAt t
startAt Sem r a
sem = do
  t
startActual <- forall (r :: [(* -> *) -> * -> *]). Member (Time t d) r => Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
  TVar (t, t)
tv <- (t, t) -> Sem r (TVar (t, t))
forall (m :: * -> *) a. MonadIO m => a -> m (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 (r :: [(* -> *) -> * -> *]) a.
(Torsor t diff, TimeUnit diff, HasDate t d,
 Members '[Time t d, AtomicState (t, t)] r) =>
Sem r a -> Sem r a
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 :: Sem r a -> Sem r a
interceptTimeConstantState =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Time t d (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
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 ->
      (t -> x) -> Sem r x
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 ->
      u -> Sem r ()
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 ->
      (t -> t) -> Sem r ()
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 ->
      t -> Sem r ()
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 :: t -> Sem r a -> Sem r a
interceptTimeConstant t
startAt Sem r a
sem = do
  TVar t
tv <- t -> Sem r (TVar t)
forall (m :: * -> *) a. MonadIO m => a -> m (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 d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
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 :: Sem r a -> Sem r a
interceptTimeConstantNow Sem r a
sem = do
  t
now <- forall (r :: [(* -> *) -> * -> *]). Member (Time t d) r => Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
Member (Time t d) r =>
Sem r t
Time.now @t @d
  TVar t
tv <- t -> Sem r (TVar t)
forall (m :: * -> *) a. MonadIO m => a -> m (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 d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
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 #-}