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, Embed IO, State (t, t)] r =>
  Sem r t
dateCurrentRelative :: Sem r t
dateCurrentRelative = do
  (startAt :: t
startAt, startActual :: t
startActual) <- forall (r :: [Effect]).
MemberWithError (State (t, t)) r =>
Sem r (t, t)
forall s (r :: [Effect]). MemberWithError (State s) r => Sem r s
get @(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 :: [Effect]). MemberWithError (Time t d) r => Sem r t
forall t d (r :: [Effect]). 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.
interpretTimeAtWithStart ::
  ∀ diff t d r a .
  Torsor t diff =>
  TimeUnit diff =>
  HasDate t d =>
  Members [Time t d, Embed IO, State (t, t)] r =>
  Sem r a ->
  Sem r a
interpretTimeAtWithStart :: Sem r a -> Sem r a
interpretTimeAtWithStart =
  (forall x (rInitial :: [Effect]).
 Time t d (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: [Effect]). e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept @(Time t d) \case
    Time.Now ->
      forall (r :: [Effect]).
(Torsor t diff, Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r t
forall diff t d (r :: [Effect]).
(Torsor t diff, Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r t
dateCurrentRelative @diff @t @d
    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 :: [Effect]).
(Torsor t diff, Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r t
forall diff t d (r :: [Effect]).
(Torsor t diff, Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r t
dateCurrentRelative @diff @t @d
    Time.Sleep t :: u
t ->
      u -> Sem r ()
forall t d (r :: [Effect]) u.
(MemberWithError (Time t d) r, TimeUnit u) =>
u -> Sem r ()
Time.sleep @t @d u
t
    Time.SetTime startAt :: t
startAt -> do
      t
startActual <- forall (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
forall t d (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
Time.now @t @d
      (t, t) -> Sem r ()
forall s (r :: [Effect]).
MemberWithError (State s) r =>
s -> Sem r ()
put @(t, t) (t
startAt, t
startActual)
    Time.Adjust diff :: u1
diff -> do
      ((t, t) -> (t, t)) -> Sem r ()
forall s (r :: [Effect]).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' @(t, t) \ (old :: t
old, actual :: 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 startAt :: d
startAt -> do
      t
startActual <- forall (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
forall t d (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
Time.now @t @d
      (t, t) -> Sem r ()
forall s (r :: [Effect]).
MemberWithError (State s) r =>
s -> Sem r ()
put @(t, t) (d -> t
forall t d. HasDate t d => d -> t
dateToTime d
startAt, t
startActual)
{-# INLINE interpretTimeAtWithStart #-}

-- |Interpret 'Time' so that the time when the program starts is @startAt@.
interpretTimeAt ::
  ∀ (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
interpretTimeAt :: t -> Sem r a -> Sem r a
interpretTimeAt startAt :: t
startAt sem :: Sem r a
sem = do
  t
startActual <- forall (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
forall t d (r :: [Effect]). MemberWithError (Time t d) r => Sem r t
Time.now @t @d
  (t, t) -> Sem (State (t, t) : r) a -> Sem r a
forall s (r :: [Effect]) a. s -> Sem (State s : r) a -> Sem r a
evalState (t
startAt, t
startActual) (Sem (State (t, t) : r) a -> Sem r a)
-> (Sem r a -> Sem (State (t, t) : r) a) -> Sem r a -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: [Effect]) a.
(Torsor t diff, TimeUnit diff, HasDate t d,
 Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r a -> Sem r a
forall diff t d (r :: [Effect]) a.
(Torsor t diff, TimeUnit diff, HasDate t d,
 Members '[Time t d, Embed IO, State (t, t)] r) =>
Sem r a -> Sem r a
interpretTimeAtWithStart @diff @t @d (Sem (State (t, t) : r) a -> Sem (State (t, t) : r) a)
-> (Sem r a -> Sem (State (t, t) : r) a)
-> Sem r a
-> Sem (State (t, t) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r a -> Sem (State (t, t) : r) a
forall (e :: Effect) (r :: [Effect]) 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 interpretTimeAt #-}