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 :: [(* -> *) -> * -> *]).
MemberWithError (Time t d) r =>
Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
MemberWithError (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 (r :: [(* -> *) -> * -> *]) u.
(MemberWithError (Time t d) r, TimeUnit u) =>
u -> Sem r ()
Time.sleep @t @d u
t
    Time.SetTime t
startAt -> do
      t
startActual <- forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Time t d) r =>
Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
MemberWithError (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 :: [(* -> *) -> * -> *]).
MemberWithError (Time t d) r =>
Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
MemberWithError (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 :: [(* -> *) -> * -> *]).
MemberWithError (Time t d) r =>
Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
MemberWithError (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 (r :: [(* -> *) -> * -> *]) u.
(MemberWithError (Time t d) r, TimeUnit u) =>
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 :: [(* -> *) -> * -> *]).
MemberWithError (Time t d) r =>
Sem r t
forall t d (r :: [(* -> *) -> * -> *]).
MemberWithError (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 #-}