{-# LANGUAGE TemplateHaskell #-}

module Time where

import qualified Data.Text as T
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)
import OurPrelude

data Time m a where
  Now :: Time m UTCTime

makeSem ''Time

runIO :: Member (Embed IO) r => Sem (Time ': r) a -> Sem r a
runIO :: Sem (Time : r) a -> Sem r a
runIO =
  (forall (rInitial :: EffectRow) x.
 Time (Sem rInitial) x -> Sem r x)
-> Sem (Time : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Time (Sem rInitial) x -> Sem r x)
 -> Sem (Time : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Time (Sem rInitial) x -> Sem r x)
-> Sem (Time : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    Time (Sem rInitial) x
Now -> IO UTCTime -> Sem r UTCTime
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO UTCTime
getCurrentTime

runPure :: UTCTime -> Sem (Time ': r) a -> Sem r a
runPure :: UTCTime -> Sem (Time : r) a -> Sem r a
runPure UTCTime
t =
  (forall (rInitial :: EffectRow) x.
 Time (Sem rInitial) x -> Sem r x)
-> Sem (Time : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Time (Sem rInitial) x -> Sem r x)
 -> Sem (Time : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Time (Sem rInitial) x -> Sem r x)
-> Sem (Time : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    Time (Sem rInitial) x
Now -> UTCTime -> Sem r UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure UTCTime
t

-- | Return the UTC time 1 hour ago

-- $setup
-- >>> import Data.Time.Format (parseTimeOrError)
-- >>> let exampleCurrentTime = parseTimeOrError False defaultTimeLocale "%Y-%-m-%-d" "2019-06-06" :: UTCTime
--
-- Examples:
--
-- >>> run $ runPure exampleCurrentTime oneHourAgo
-- 2019-06-05 23:00:00 UTC

oneHourAgo :: Member Time r => Sem r UTCTime
oneHourAgo :: Sem r UTCTime
oneHourAgo = Sem r UTCTime
forall (r :: EffectRow). MemberWithError Time r => Sem r UTCTime
now Sem r UTCTime -> (UTCTime -> UTCTime) -> Sem r UTCTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Integer -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ -Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60)

-- | Return the UTC time 2 hours ago
--
-- Examples:
--
-- >>> run $ runPure exampleCurrentTime twoHoursAgo
-- 2019-06-05 22:00:00 UTC
twoHoursAgo :: Member Time r => Sem r UTCTime
twoHoursAgo :: Sem r UTCTime
twoHoursAgo = Sem r UTCTime
forall (r :: EffectRow). MemberWithError Time r => Sem r UTCTime
now Sem r UTCTime -> (UTCTime -> UTCTime) -> Sem r UTCTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> NominalDiffTime) -> Integer -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ -Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2)

-- | Return the current ISO8601 date and time without timezone
--
-- TODO: switch to Data.Time.Format.ISO8601 once time-1.9.0 is available
-- unix depends on an earlier version currently https://github.com/haskell/unix/issues/131
--
-- Examples:
--
-- >>> run $ runPure exampleCurrentTime runDate
-- "2019-06-06T00:00:00"
runDate :: Member Time r => Sem r Text
runDate :: Sem r Text
runDate =
  Sem r UTCTime
forall (r :: EffectRow). MemberWithError Time r => Sem r UTCTime
now Sem r UTCTime -> (UTCTime -> String) -> Sem r String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%H:%M:%S"))
    Sem r String -> (String -> Text) -> Sem r Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Text
T.pack