{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}

-- NOTE: [Equality Constraints]
--
-- Evidently, GHC 9.2 requires GADTs or TypeFamilies to use equality
-- constraints e.g. @k ~ A_Lens@.
#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904
{-# LANGUAGE TypeFamilies #-}
#endif

-- | Provides the 'MonadTime' class.
--
-- @since 0.1
module Effects.Time
  ( -- * Effect
    MonadTime (..),
    getSystemTime,

    -- * Timing
    withTiming,
    withTiming_,

    -- ** TimeSpec
    TimeSpec (..),

    -- *** Creation
    fromSeconds,
    fromNanoSeconds,

    -- *** Elimination
    toSeconds,
    toNanoSeconds,

    -- *** Operations
    diffTimeSpec,
    normalizeTimeSpec,

    -- * Formatting
    formatLocalTime,
    formatZonedTime,

    -- * Parsing
    parseLocalTime,
    parseZonedTime,

    -- * Misc
    getSystemTimeString,
    getSystemZonedTimeString,

    -- * Reexports

    -- ** Time
    LocalTime (..),
    ZonedTime (..),

    -- ** Algebra
    ASemigroup (..),
    AMonoid (..),
    MSemiSpace (..),
    MSpace (..),
    Semimodule,
    SemivectorSpace,
    Normed,
    LowerBounded (..),
    UpperBoundless,
  )
where

import Control.DeepSeq (NFData)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT)
import Data.Bounds (LowerBounded (lowerBound), UpperBoundless)
import Data.Time.Format qualified as Format
import Data.Time.LocalTime
  ( LocalTime (LocalTime, localDay, localTimeOfDay),
    ZonedTime (ZonedTime, zonedTimeToLocalTime, zonedTimeZone),
  )
import Data.Time.LocalTime qualified as Local
import GHC.Clock qualified as C
#if MIN_VERSION_base(4,17,0)
import GHC.Float (properFractionDouble)
#endif
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import GHC.Stack (HasCallStack)
import Numeric.Algebra
  ( AMonoid (zero),
    ASemigroup ((.+.)),
    MSemiSpace ((.*)),
    MSpace ((.%)),
    Normed (norm),
    Semimodule,
    SemivectorSpace,
  )
import Optics.Core (A_Lens, LabelOptic (labelOptic), lensVL)

-- | Structure for holding time data. 'Eq' and 'Ord' are defined in terms of
-- an equivalence class e.g.
--
-- @
-- MkTimeSpec s n === MkTimeSpec 0 (s * 1_000_000_000 + n)
-- @
--
-- @since 0.1
data TimeSpec = MkTimeSpec
  { -- | Seconds.
    --
    -- @since 0.1
    TimeSpec -> Natural
sec :: !Natural,
    -- | Nanoseconds.
    --
    -- @since 0.1
    TimeSpec -> Natural
nsec :: !Natural
  }
  deriving stock
    ( -- | @since 0.1
      (forall x. TimeSpec -> Rep TimeSpec x)
-> (forall x. Rep TimeSpec x -> TimeSpec) -> Generic TimeSpec
forall x. Rep TimeSpec x -> TimeSpec
forall x. TimeSpec -> Rep TimeSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TimeSpec -> Rep TimeSpec x
from :: forall x. TimeSpec -> Rep TimeSpec x
$cto :: forall x. Rep TimeSpec x -> TimeSpec
to :: forall x. Rep TimeSpec x -> TimeSpec
Generic,
      -- | @since 0.1
      Int -> TimeSpec -> ShowS
[TimeSpec] -> ShowS
TimeSpec -> String
(Int -> TimeSpec -> ShowS)
-> (TimeSpec -> String) -> ([TimeSpec] -> ShowS) -> Show TimeSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeSpec -> ShowS
showsPrec :: Int -> TimeSpec -> ShowS
$cshow :: TimeSpec -> String
show :: TimeSpec -> String
$cshowList :: [TimeSpec] -> ShowS
showList :: [TimeSpec] -> ShowS
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      TimeSpec -> ()
(TimeSpec -> ()) -> NFData TimeSpec
forall a. (a -> ()) -> NFData a
$crnf :: TimeSpec -> ()
rnf :: TimeSpec -> ()
NFData
    )

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Natural, b ~ Natural) =>
  LabelOptic "sec" k TimeSpec TimeSpec a b
  where
  labelOptic :: Optic k NoIx TimeSpec TimeSpec a b
labelOptic = LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b)
-> LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkTimeSpec Natural
a1 Natural
a2) ->
    (Natural -> TimeSpec) -> f Natural -> f TimeSpec
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Natural
b -> Natural -> Natural -> TimeSpec
MkTimeSpec Natural
b Natural
a2) (a -> f b
f a
Natural
a1)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance
  (k ~ A_Lens, a ~ Natural, b ~ Natural) =>
  LabelOptic "nsec" k TimeSpec TimeSpec a b
  where
  labelOptic :: Optic k NoIx TimeSpec TimeSpec a b
labelOptic = LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b)
-> LensVL TimeSpec TimeSpec a b -> Lens TimeSpec TimeSpec a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkTimeSpec Natural
a1 Natural
a2) ->
    (Natural -> TimeSpec) -> f Natural -> f TimeSpec
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Natural
b -> Natural -> Natural -> TimeSpec
MkTimeSpec Natural
a1 Natural
b) (a -> f b
f a
Natural
a2)
  {-# INLINE labelOptic #-}

-- | @since 0.1
instance Eq TimeSpec where
  TimeSpec
l == :: TimeSpec -> TimeSpec -> Bool
== TimeSpec
r = TimeSpec -> Natural
toNanoSeconds TimeSpec
l Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== TimeSpec -> Natural
toNanoSeconds TimeSpec
r
  {-# INLINEABLE (==) #-}

-- | @since 0.1
instance Ord TimeSpec where
  TimeSpec
l <= :: TimeSpec -> TimeSpec -> Bool
<= TimeSpec
r = TimeSpec -> Natural
toNanoSeconds TimeSpec
l Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= TimeSpec -> Natural
toNanoSeconds TimeSpec
r
  {-# INLINEABLE (<=) #-}

-- | @since 0.1
instance LowerBounded TimeSpec where
  lowerBound :: TimeSpec
lowerBound = Natural -> Natural -> TimeSpec
MkTimeSpec Natural
0 Natural
0
  {-# INLINEABLE lowerBound #-}

-- | @since 0.1
instance UpperBoundless TimeSpec

-- | @since 0.1
instance ASemigroup TimeSpec where
  MkTimeSpec Natural
ls Natural
ln .+. :: TimeSpec -> TimeSpec -> TimeSpec
.+. MkTimeSpec Natural
rs Natural
rn = Natural -> Natural -> TimeSpec
MkTimeSpec (Natural
ls Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
rs) (Natural
ln Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
rn)
  {-# INLINEABLE (.+.) #-}

-- | @since 0.1
instance AMonoid TimeSpec where
  zero :: TimeSpec
zero = Natural -> Natural -> TimeSpec
MkTimeSpec Natural
0 Natural
0
  {-# INLINEABLE zero #-}

-- | @since 0.1
instance MSemiSpace TimeSpec Natural where
  MkTimeSpec Natural
s Natural
n .* :: TimeSpec -> Natural -> TimeSpec
.* Natural
k = Natural -> Natural -> TimeSpec
MkTimeSpec (Natural
s Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
k) (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
k)
  {-# INLINEABLE (.*) #-}

-- | @since 0.1
instance MSpace TimeSpec Natural where
  TimeSpec
ts .% :: TimeSpec -> Natural -> TimeSpec
.% Natural
k = Double -> TimeSpec
fromSeconds (TimeSpec -> Double
toSeconds TimeSpec
ts Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
k)
  {-# INLINEABLE (.%) #-}

-- | @since 0.1
instance Semimodule TimeSpec Natural

-- | @since 0.1
instance SemivectorSpace TimeSpec Natural

-- | @since 0.1
instance Normed TimeSpec where
  norm :: TimeSpec -> TimeSpec
norm = TimeSpec -> TimeSpec
forall a. a -> a
id
  {-# INLINEABLE norm #-}

-- | Converts 'Double' seconds to a 'TimeSpec'.
--
-- @since 0.1
fromSeconds :: Double -> TimeSpec
fromSeconds :: Double -> TimeSpec
fromSeconds Double
d =
  MkTimeSpec
    { sec :: Natural
sec = Natural
seconds,
      nsec :: Natural
nsec = Natural
nanoseconds
    }
  where
    (Natural
seconds, Double
remainder) = Double -> (Natural, Double)
forall b. Integral b => Double -> (b, Double)
properFractionDouble Double
d
    nanoseconds :: Natural
nanoseconds = Double -> Natural
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Natural) -> Double -> Natural
forall a b. (a -> b) -> a -> b
$ Double
remainder Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1_000_000_000

-- | Converts 'Natural' nanoseconds to a 'TimeSpec'.
--
-- @since 0.1
fromNanoSeconds :: Natural -> TimeSpec
fromNanoSeconds :: Natural -> TimeSpec
fromNanoSeconds Natural
nanoseconds = Natural -> Natural -> TimeSpec
MkTimeSpec Natural
s Natural
ns
  where
    (Natural
s, Natural
ns) = Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
quotRem Natural
nanoseconds Natural
1_000_000_000

-- | Converts a 'TimeSpec' to 'Double' seconds.
--
-- @since 0.1
toSeconds :: TimeSpec -> Double
toSeconds :: TimeSpec -> Double
toSeconds (MkTimeSpec Natural
s Natural
n) =
  Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000_000_000)

-- | Converts a 'TimeSpec' into 'Natural' nanoseconds.
--
-- @since 0.1
toNanoSeconds :: TimeSpec -> Natural
toNanoSeconds :: TimeSpec -> Natural
toNanoSeconds (MkTimeSpec Natural
s Natural
n) = (Natural
s Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
1_000_000_000) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
n

-- | Returns the absolute difference of two 'TimeSpec's.
--
-- @since 0.1
diffTimeSpec :: TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec :: TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec TimeSpec
t1 TimeSpec
t2
  | Natural
t1' Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
t2' = Natural -> TimeSpec
fromNanoSeconds (Natural
t1' Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
t2')
  | Bool
otherwise = Natural -> TimeSpec
fromNanoSeconds (Natural
t2' Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
t1')
  where
    t1' :: Natural
t1' = TimeSpec -> Natural
toNanoSeconds TimeSpec
t1
    t2' :: Natural
t2' = TimeSpec -> Natural
toNanoSeconds TimeSpec
t2

-- | Normalizes nanoseconds < 1 second.
--
-- @since 0.1
normalizeTimeSpec :: TimeSpec -> TimeSpec
normalizeTimeSpec :: TimeSpec -> TimeSpec
normalizeTimeSpec = Natural -> TimeSpec
fromNanoSeconds (Natural -> TimeSpec)
-> (TimeSpec -> Natural) -> TimeSpec -> TimeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeSpec -> Natural
toNanoSeconds

-- | Time effect.
--
-- @since 0.1
class (Monad m) => MonadTime m where
  -- | Returns the zoned system time.
  --
  -- @since 0.1
  getSystemZonedTime :: (HasCallStack) => m ZonedTime

  -- | Return monotonic time in seconds, since some unspecified starting
  -- point.
  --
  -- @since 0.1
  getMonotonicTime :: (HasCallStack) => m Double

-- | @since 0.1
instance MonadTime IO where
  getSystemZonedTime :: HasCallStack => IO ZonedTime
getSystemZonedTime = IO ZonedTime
Local.getZonedTime
  {-# INLINEABLE getSystemZonedTime #-}
  getMonotonicTime :: HasCallStack => IO Double
getMonotonicTime = IO Double
C.getMonotonicTime
  {-# INLINEABLE getMonotonicTime #-}

-- | @since 0.1
instance (MonadTime m) => MonadTime (ReaderT e m) where
  getSystemZonedTime :: HasCallStack => ReaderT e m ZonedTime
getSystemZonedTime = m ZonedTime -> ReaderT e m ZonedTime
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m ZonedTime
forall (m :: * -> *). (MonadTime m, HasCallStack) => m ZonedTime
getSystemZonedTime
  {-# INLINEABLE getSystemZonedTime #-}
  getMonotonicTime :: HasCallStack => ReaderT e m Double
getMonotonicTime = m Double -> ReaderT e m Double
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Double
forall (m :: * -> *). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  {-# INLINEABLE getMonotonicTime #-}

-- | Returns the local system time.
--
-- @since 0.1
getSystemTime :: (HasCallStack, MonadTime m) => m LocalTime
getSystemTime :: forall (m :: * -> *). (HasCallStack, MonadTime m) => m LocalTime
getSystemTime = ZonedTime -> LocalTime
Local.zonedTimeToLocalTime (ZonedTime -> LocalTime) -> m ZonedTime -> m LocalTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ZonedTime
forall (m :: * -> *). (MonadTime m, HasCallStack) => m ZonedTime
getSystemZonedTime
{-# INLINEABLE getSystemTime #-}

-- | Runs an action, returning the elapsed time.
--
-- @since 0.1
withTiming ::
  ( HasCallStack,
    MonadTime m
  ) =>
  m a ->
  m (TimeSpec, a)
withTiming :: forall (m :: * -> *) a.
(HasCallStack, MonadTime m) =>
m a -> m (TimeSpec, a)
withTiming m a
m = do
  Double
start <- m Double
forall (m :: * -> *). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  a
res <- m a
m
  Double
end <- m Double
forall (m :: * -> *). (MonadTime m, HasCallStack) => m Double
getMonotonicTime
  (TimeSpec, a) -> m (TimeSpec, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> TimeSpec
fromSeconds (Double
end Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
start), a
res)
{-# INLINEABLE withTiming #-}

-- | 'withTiming' but ignores the result value.
--
-- @since 0.1
withTiming_ ::
  ( HasCallStack,
    MonadTime m
  ) =>
  m a ->
  m TimeSpec
withTiming_ :: forall (m :: * -> *) a.
(HasCallStack, MonadTime m) =>
m a -> m TimeSpec
withTiming_ = ((TimeSpec, a) -> TimeSpec) -> m (TimeSpec, a) -> m TimeSpec
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TimeSpec, a) -> TimeSpec
forall a b. (a, b) -> a
fst (m (TimeSpec, a) -> m TimeSpec)
-> (m a -> m (TimeSpec, a)) -> m a -> m TimeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (TimeSpec, a)
forall (m :: * -> *) a.
(HasCallStack, MonadTime m) =>
m a -> m (TimeSpec, a)
withTiming
{-# INLINEABLE withTiming_ #-}

-- TODO: handle more time zones?

-- | Formats the 'ZonedTime' to @YYYY-MM-DD HH:MM:SS Z@.
--
-- @since 0.1
formatZonedTime :: ZonedTime -> String
formatZonedTime :: ZonedTime -> String
formatZonedTime = TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Format.formatTime TimeLocale
Format.defaultTimeLocale String
zonedTimeFormat

-- | Retrieves the formatted 'LocalTime'.
--
-- @since 0.1
getSystemTimeString :: (HasCallStack, MonadTime m) => m String
getSystemTimeString :: forall (m :: * -> *). (HasCallStack, MonadTime m) => m String
getSystemTimeString = (LocalTime -> String) -> m LocalTime -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTime -> String
formatLocalTime m LocalTime
forall (m :: * -> *). (HasCallStack, MonadTime m) => m LocalTime
getSystemTime
{-# INLINEABLE getSystemTimeString #-}

-- | Formats the 'LocalTime' to @YYYY-MM-DD HH:MM:SS@.
--
-- @since 0.1
formatLocalTime :: LocalTime -> String
formatLocalTime :: LocalTime -> String
formatLocalTime = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Format.formatTime TimeLocale
Format.defaultTimeLocale String
localTimeFormat

-- | Retrieves the formatted 'ZonedTime'.
--
-- @since 0.1
getSystemZonedTimeString :: (HasCallStack, MonadTime m) => m String
getSystemZonedTimeString :: forall (m :: * -> *). (HasCallStack, MonadTime m) => m String
getSystemZonedTimeString = (ZonedTime -> String) -> m ZonedTime -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ZonedTime -> String
formatZonedTime m ZonedTime
forall (m :: * -> *). (MonadTime m, HasCallStack) => m ZonedTime
getSystemZonedTime
{-# INLINEABLE getSystemZonedTimeString #-}

-- TODO: It would be nice if parse(Local|Zoned)Time included a callstack
-- when f is IO. Alas, IO's MonadFail instance uses failIO, which does NOT
-- add backtrace information.
--
-- Keeping this note in case this changes.
--
-- Update: There is now an issue for this:
--
--     https://github.com/haskell/core-libraries-committee/issues/301
--
-- If this is merged, add HasCallStack to most (all?) functions in this
-- repo w/ MonadFail.

-- | Parses the 'LocalTime' from @YYYY-MM-DD HH:MM:SS@.
--
-- @since 0.1
parseLocalTime :: (MonadFail f) => String -> f LocalTime
parseLocalTime :: forall (f :: * -> *). MonadFail f => String -> f LocalTime
parseLocalTime =
  Bool -> TimeLocale -> String -> String -> f LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
Format.parseTimeM
    Bool
True
    TimeLocale
Format.defaultTimeLocale
    String
localTimeFormat
{-# INLINEABLE parseLocalTime #-}

-- | Parses the 'ZonedTime' from @YYYY-MM-DD HH:MM:SS Z@.
--
-- ==== __Known Timezones__
--
-- * UTC
-- * UT
-- * GMT
-- * EST
-- * EDT
-- * CST
-- * CDT
-- * MST
-- * MDT
-- * PST
-- * PDT
-- * +HHMM (e.g. +1300)
--
-- @since 0.1
parseZonedTime :: (MonadFail f) => String -> f ZonedTime
parseZonedTime :: forall (f :: * -> *). MonadFail f => String -> f ZonedTime
parseZonedTime =
  Bool -> TimeLocale -> String -> String -> f ZonedTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
Format.parseTimeM
    Bool
True
    TimeLocale
Format.defaultTimeLocale
    String
zonedTimeFormat
{-# INLINEABLE parseZonedTime #-}

localTimeFormat :: String
localTimeFormat :: String
localTimeFormat = String
"%0Y-%m-%d %H:%M:%S"

zonedTimeFormat :: String
zonedTimeFormat :: String
zonedTimeFormat = String
"%0Y-%m-%d %H:%M:%S %Z"

#if !MIN_VERSION_base(4,17,0)
properFractionDouble :: Integral b => Double -> (b, Double)
{-# NOINLINE [1] properFractionDouble #-}
properFractionDouble x =
  case decodeFloat x of
    (m, n) ->
      if n >= 0
        then (fromInteger m * 2 ^ n, 0.0)
        else case quotRem m (2 ^ negate n) of
          (w, r) ->
            (fromInteger w, encodeFloat r n)
#endif