module Polysemy.Time.Ghc where

import Control.Concurrent (threadDelay)
import Data.Time (Day, NominalDiffTime, UTCTime, utctDay)
import Data.Time.Clock.System (getSystemTime, systemToUTCTime)

import Polysemy.Time.At (interceptTimeAt, interceptTimeConstant, interceptTimeConstantNow)
import qualified Polysemy.Time.Data.Time as Time
import Polysemy.Time.Data.Time (Time)
import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), convert)
import Polysemy.Time.Orphans ()

-- |Convenience alias for 'Data.Time'.
type GhcTime =
  Time UTCTime Day

now ::
  Member (Embed IO) r =>
  Sem r UTCTime
now :: Sem r UTCTime
now =
  SystemTime -> UTCTime
systemToUTCTime (SystemTime -> UTCTime) -> Sem r SystemTime -> Sem r UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SystemTime -> Sem r SystemTime
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO SystemTime
getSystemTime

-- |Interpret 'Time' with the types from 'Data.Time'.
interpretTimeGhc ::
  Member (Embed IO) r =>
  InterpreterFor GhcTime r
interpretTimeGhc :: InterpreterFor GhcTime r
interpretTimeGhc =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 GhcTime (Sem rInitial) x -> Sem r x)
-> Sem (GhcTime : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    GhcTime (Sem rInitial) x
Time.Now ->
      Sem r x
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Sem r UTCTime
now
    GhcTime (Sem rInitial) x
Time.Today ->
      UTCTime -> Day
utctDay (UTCTime -> Day) -> Sem r UTCTime -> Sem r Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r UTCTime
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Sem r UTCTime
now
    Time.Sleep (convert -> MicroSeconds us) ->
      IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (Int -> IO ()
threadDelay (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
us))
    Time.SetTime _ ->
      Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    Time.Adjust _ ->
      Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
    Time.SetDate _ ->
      Sem r x
forall (f :: * -> *). Applicative f => f ()
unit

-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time at the start of interpretation.
interpretTimeGhcAt ::
  Member (Embed IO) r =>
  UTCTime ->
  InterpreterFor GhcTime r
interpretTimeGhcAt :: UTCTime -> InterpreterFor GhcTime r
interpretTimeGhcAt UTCTime
t =
  Sem (GhcTime : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor GhcTime r
interpretTimeGhc (Sem (GhcTime : r) a -> Sem r a)
-> (Sem (GhcTime : r) a -> Sem (GhcTime : r) a)
-> Sem (GhcTime : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Sem (GhcTime : r) a -> Sem (GhcTime : r) a
forall 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
interceptTimeAt @NominalDiffTime UTCTime
t

-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constant.
interpretTimeGhcConstant ::
  Member (Embed IO) r =>
  UTCTime ->
  InterpreterFor GhcTime r
interpretTimeGhcConstant :: UTCTime -> InterpreterFor GhcTime r
interpretTimeGhcConstant UTCTime
t =
  Sem (GhcTime : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor GhcTime r
interpretTimeGhc (Sem (GhcTime : r) a -> Sem r a)
-> (Sem (GhcTime : r) a -> Sem (GhcTime : r) a)
-> Sem (GhcTime : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Sem (GhcTime : r) a -> Sem (GhcTime : r) a
forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, Embed IO] r) =>
t -> Sem r a -> Sem r a
interceptTimeConstant UTCTime
t

-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constantly the time at the
-- start of interpretation.
interpretTimeGhcConstantNow ::
  Member (Embed IO) r =>
  InterpreterFor GhcTime r
interpretTimeGhcConstantNow :: InterpreterFor GhcTime r
interpretTimeGhcConstantNow =
  Sem (GhcTime : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor GhcTime r
interpretTimeGhc (Sem (GhcTime : r) a -> Sem r a)
-> (Sem (GhcTime : r) a -> Sem (GhcTime : r) a)
-> Sem (GhcTime : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d (r :: [(* -> *) -> * -> *]) a.
(HasDate UTCTime d, Members '[Time UTCTime d, Embed IO] r) =>
Sem r a -> Sem r a
forall t d (r :: [(* -> *) -> * -> *]) a.
(HasDate t d, Members '[Time t d, Embed IO] r) =>
Sem r a -> Sem r a
interceptTimeConstantNow @UTCTime