At.hs

-- |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 = do
  (startAt, startActual) <- atomicGet @(t, t)
  (`add` startAt) . (`difference` startActual) <$> 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 =
  intercept @(Time t d) \case
    Time.Now ->
      dateCurrentRelative @diff @t @d
    Time.Today ->
      date <$> dateCurrentRelative @diff @t @d
    Time.Sleep t ->
      Time.sleep @t @d t
    Time.SetTime startAt -> do
      startActual <- Time.now @t @d
      atomicPut @(t, t) (startAt, startActual)
    Time.Adjust diff -> do
      atomicModify' @(t, t) \ (old, actual) -> (addTimeUnit diff old, actual)
    Time.SetDate startAt -> do
      startActual <- Time.now @t @d
      atomicPut @(t, t) (dateToTime startAt, 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 startAt sem = do
  startActual <- Time.now @t @d
  tv <- newTVarIO (startAt, startActual)
  runAtomicStateTVar tv . interceptTimeAtWithStart @diff @t @d . raise $ 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 =
  intercept @(Time t d) \case
    Time.Now ->
      atomicGet
    Time.Today ->
      atomicGets @t date
    Time.Sleep t ->
      Time.sleep @t @d t
    Time.SetTime now ->
      atomicPut now
    Time.Adjust diff ->
      atomicModify' @t (addTimeUnit diff)
    Time.SetDate startAt ->
      atomicPut @t (dateToTime 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 startAt sem = do
  tv <- newTVarIO startAt
  runAtomicStateTVar tv . interceptTimeConstantState @t . raise $ 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 = do
  now <- Time.now @t @d
  tv <- newTVarIO now
  runAtomicStateTVar tv . interceptTimeConstantState @t . raise $ sem
{-# inline interceptTimeConstantNow #-}