{-# options_haddock prune #-}

-- |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 Polysemy.Time.Data.TimeUnit (MilliSeconds (MilliSeconds), TimeUnit, addTimeUnit, convert)
import qualified Polysemy.Time.Effect.Time as Time
import Polysemy.Time.Effect.Time (Time)

-- |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 :: EffectRow).
(Torsor t diff, Members '[Time t d, AtomicState (t, t)] r) =>
Sem r t
dateCurrentRelative = do
  (t
startAt, t
startActual) <- forall s (r :: EffectRow). 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 :: EffectRow). 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 :: EffectRow) 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 :: EffectRow) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: EffectRow). 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 :: EffectRow).
(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 :: EffectRow).
(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 :: EffectRow).
(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 :: EffectRow). Member (Time t d) r => Sem r t
Time.now @t @d
      forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @(t, t) (t
startAt, t
startActual)
    Time.Adjust u1
diff -> do
      forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' @(t, t) ((t -> t) -> (t, t) -> (t, t)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (u1 -> t -> t
forall t u1 u2. AddTimeUnit t u1 u2 => u1 -> t -> t
addTimeUnit u1
diff))
    Time.SetDate d
startAt -> do
      t
startActual <- forall t d (r :: EffectRow). Member (Time t d) r => Sem r t
Time.now @t @d
      forall s (r :: EffectRow).
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 :: EffectRow) 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 :: EffectRow). 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 :: EffectRow) 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 :: EffectRow) 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 :: EffectRow) 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 :: EffectRow) 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 #-}

sleepPoll ::
  ∀ t d diff u r .
  Ord diff =>
  TimeUnit u =>
  TimeUnit diff =>
  Torsor t diff =>
  Members [Time t d, AtomicState t] r =>
  u ->
  t ->
  Sem r ()
sleepPoll :: forall t d diff u (r :: EffectRow).
(Ord diff, TimeUnit u, TimeUnit diff, Torsor t diff,
 Members '[Time t d, AtomicState t] r) =>
u -> t -> Sem r ()
sleepPoll u
duration t
start =
  Sem r ()
spin
  where
    spin :: Sem r ()
spin = do
      forall t d u (r :: EffectRow).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep @t @d (Int64 -> MilliSeconds
MilliSeconds Int64
10)
      Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (t -> Bool
later (t -> Bool) -> Sem r t -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet @t) Sem r ()
spin
    later :: t -> Bool
later t
now =
      t -> t -> diff
forall p v. Torsor p v => p -> p -> v
difference t
now t
start diff -> diff -> Bool
forall a. Ord a => a -> a -> Bool
>= diff
diff
    diff :: diff
diff =
      forall a b. (TimeUnit a, TimeUnit b) => a -> b
convert @u @diff u
duration

-- |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 diff r a .
  Ord diff =>
  HasDate t d =>
  TimeUnit diff =>
  Torsor t diff =>
  Members [Time t d, AtomicState t] r =>
  Sem r a ->
  Sem r a
interceptTimeConstantState :: forall t d diff (r :: EffectRow) a.
(Ord diff, HasDate t d, TimeUnit diff, Torsor t diff,
 Members '[Time t d, AtomicState t] r) =>
Sem r a -> Sem r a
interceptTimeConstantState =
  forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: EffectRow). 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 :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet
    Time t d (Sem rInitial) x
Time.Today ->
      forall s s' (r :: EffectRow).
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 diff u (r :: EffectRow).
(Ord diff, TimeUnit u, TimeUnit diff, Torsor t diff,
 Members '[Time t d, AtomicState t] r) =>
u -> t -> Sem r ()
sleepPoll @t @d u
t (t -> Sem r x) -> Sem r t -> Sem r x
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r t
forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet
    Time.SetTime t
now ->
      t -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut t
now
    Time.Adjust u1
diff ->
      forall s (r :: EffectRow).
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 :: EffectRow).
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'.
-- Sleeping will only terminate after the time has been advanced by `Time.adjust`.
interceptTimeConstant ::
  ∀ t d diff r a .
  Ord diff =>
  HasDate t d =>
  TimeUnit diff =>
  Torsor t diff =>
  Members [Time t d, Embed IO] r =>
  t ->
  Sem r a ->
  Sem r a
interceptTimeConstant :: forall t d diff (r :: EffectRow) a.
(Ord diff, HasDate t d, TimeUnit diff, Torsor t diff,
 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 :: EffectRow) 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 :: EffectRow) 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 diff (r :: EffectRow) a.
(Ord diff, HasDate t d, TimeUnit diff, Torsor t diff,
 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 :: EffectRow) 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'.
-- Sleeping will only terminate after the time has been advanced by `Time.adjust`.
interceptTimeConstantNow ::
  ∀ t d diff r a .
  Ord diff =>
  HasDate t d =>
  TimeUnit diff =>
  Torsor t diff =>
  Members [Time t d, Embed IO] r =>
  Sem r a ->
  Sem r a
interceptTimeConstantNow :: forall t d diff (r :: EffectRow) a.
(Ord diff, HasDate t d, TimeUnit diff, Torsor t diff,
 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 :: EffectRow). 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 :: EffectRow) 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 :: EffectRow) 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 diff (r :: EffectRow) a.
(Ord diff, HasDate t d, TimeUnit diff, Torsor t diff,
 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 :: EffectRow) 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 #-}