{-# LANGUAGE AllowAmbiguousTypes #-}

-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2024-2025 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

Effects for controlling time-related operations.
-}
module Data.Effect.Concurrent.Timer where

import Control.Concurrent.Thread.Delay qualified as Thread
import Control.Effect (perform)
import Control.Effect.Interpret (interpose)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Effect (Emb)
import Data.Effect.Coroutine (Yield, yield)
import Data.Function (fix)
import Data.Functor ((<&>))
import Data.Time (DiffTime)
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import GHC.Clock (getMonotonicTimeNSec)

-- | An effect for time-related operations.
data Timer :: Effect where
    -- | Retrieves the current relative time from an arbitrary fixed reference point.
    --   The reference point does not change within the context of that scope.
    Clock :: Timer f DiffTime
    -- | Temporarily suspends computation for the specified duration.
    Sleep :: DiffTime -> Timer f ()

makeEffectF ''Timer

{- |
Creates a scope where elapsed time can be obtained.
An action to retrieve the elapsed time, re-zeroed at the start of the scope, is passed to the scope.
-}
withElapsedTime
    :: forall a es ff c
     . (Timer :> es, Monad (Eff ff es), Free c ff)
    => (Eff ff es DiffTime -> Eff ff es a)
    -- ^ A scope where the elapsed time can be obtained.
    -- An action to retrieve the elapsed time is passed as an argument.
    -> Eff ff es a
withElapsedTime :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
(Eff ff es DiffTime -> Eff ff es a) -> Eff ff es a
withElapsedTime Eff ff es DiffTime -> Eff ff es a
f = do
    DiffTime
start <- Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock
    Eff ff es DiffTime -> Eff ff es a
f (Eff ff es DiffTime -> Eff ff es a)
-> Eff ff es DiffTime -> Eff ff es a
forall a b. (a -> b) -> a -> b
$ Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock Eff ff es DiffTime -> (DiffTime -> DiffTime) -> Eff ff es DiffTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
`subtract` DiffTime
start)
{-# INLINE withElapsedTime #-}

-- | Returns the time taken for a computation along with the result as a pair.
measureTime
    :: forall a es ff c
     . (Timer :> es, Monad (Eff ff es), Free c ff)
    => Eff ff es a
    -> Eff ff es (DiffTime, a)
measureTime :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es a -> Eff ff es (DiffTime, a)
measureTime Eff ff es a
m = (Eff ff es DiffTime -> Eff ff es (DiffTime, a))
-> Eff ff es (DiffTime, a)
forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
(Eff ff es DiffTime -> Eff ff es a) -> Eff ff es a
withElapsedTime \Eff ff es DiffTime
elapsedTime -> do
    a
r <- Eff ff es a
m
    Eff ff es DiffTime
elapsedTime Eff ff es DiffTime
-> (DiffTime -> (DiffTime, a)) -> Eff ff es (DiffTime, a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,a
r)
{-# INLINE measureTime #-}

{- |
Temporarily suspends computation until the relative time from the fixed reference point in the current scope's context, as given by the argument.
If the specified resume time has already passed, returns the elapsed time (positive value) in `Just`.
-}
sleepUntil :: forall es ff c. (Timer :> es, Monad (Eff ff es), Free c ff) => DiffTime -> Eff ff es (Maybe DiffTime)
sleepUntil :: forall (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
DiffTime -> Eff ff es (Maybe DiffTime)
sleepUntil DiffTime
t = do
    DiffTime
now <- Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock
    Bool -> Eff ff es () -> Eff ff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
now) do
        DiffTime -> Eff ff es ()
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
DiffTime -> f ()
sleep (DiffTime -> Eff ff es ()) -> DiffTime -> Eff ff es ()
forall a b. (a -> b) -> a -> b
$ DiffTime
t DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
now
    Maybe DiffTime -> Eff ff es (Maybe DiffTime)
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure if DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
now then DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime
now DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
t) else Maybe DiffTime
forall a. Maybe a
Nothing
{-# INLINE sleepUntil #-}

{- |
Repeats a computation indefinitely. Controls so that each loop occurs at a specific time interval.
If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled.
-}
runCyclic
    :: forall a es ff c
     . (Timer :> es, Monad (Eff ff es), Free c ff)
    => Eff ff es DiffTime
    -- ^ An action called at the start of each loop to determine the time interval until the next loop.
    --   For example, @pure 1@ would control the loop to have a 1-second interval.
    -> Eff ff es ()
    -- ^ The computation to repeat.
    -> Eff ff es a
runCyclic :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es DiffTime -> Eff ff es () -> Eff ff es a
runCyclic Eff ff es DiffTime
deltaTime Eff ff es ()
a = do
    DiffTime
t0 <- Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock
    (((DiffTime -> Eff ff es a) -> DiffTime -> Eff ff es a)
 -> DiffTime -> Eff ff es a)
-> DiffTime
-> ((DiffTime -> Eff ff es a) -> DiffTime -> Eff ff es a)
-> Eff ff es a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((DiffTime -> Eff ff es a) -> DiffTime -> Eff ff es a)
-> DiffTime -> Eff ff es a
forall a. (a -> a) -> a
fix DiffTime
t0 \DiffTime -> Eff ff es a
next DiffTime
t -> do
        DiffTime
t' <- (DiffTime
t +) (DiffTime -> DiffTime) -> Eff ff es DiffTime -> Eff ff es DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff ff es DiffTime
deltaTime
        Eff ff es ()
a
        Maybe DiffTime
delay <- DiffTime -> Eff ff es (Maybe DiffTime)
forall (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
DiffTime -> Eff ff es (Maybe DiffTime)
sleepUntil DiffTime
t'
        DiffTime -> Eff ff es a
next (DiffTime -> Eff ff es a) -> DiffTime -> Eff ff es a
forall a b. (a -> b) -> a -> b
$ DiffTime -> (DiffTime -> DiffTime) -> Maybe DiffTime -> DiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DiffTime
t' (DiffTime
t' +) Maybe DiffTime
delay
{-# INLINE runCyclic #-}

{- |
Controls to repeat a specified computation at fixed time intervals. A specialized version of `runCyclic`.
If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled.
-}
runPeriodic
    :: forall a es ff c
     . (Timer :> es, Monad (Eff ff es), Free c ff)
    => DiffTime
    -- ^ Loop interval
    -> Eff ff es ()
    -- ^ The computation to repeat.
    -> Eff ff es a
runPeriodic :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
DiffTime -> Eff ff es () -> Eff ff es a
runPeriodic DiffTime
interval = Eff ff es DiffTime -> Eff ff es () -> Eff ff es a
forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es DiffTime -> Eff ff es () -> Eff ff es a
runCyclic (DiffTime -> Eff ff es DiffTime
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DiffTime
interval)
{-# INLINE runPeriodic #-}

{- |
Calls `yield` of a coroutine at fixed intervals.
If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled.
-}
periodicTimer
    :: forall a es ff c
     . (Timer :> es, Yield () () :> es, Monad (Eff ff es), Free c ff)
    => DiffTime
    -> Eff ff es a
periodicTimer :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Yield () () :> es, Monad (Eff ff es), Free c ff) =>
DiffTime -> Eff ff es a
periodicTimer DiffTime
interval = DiffTime -> Eff ff es () -> Eff ff es a
forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
DiffTime -> Eff ff es () -> Eff ff es a
runPeriodic DiffTime
interval (Eff ff es () -> Eff ff es a) -> Eff ff es () -> Eff ff es a
forall a b. (a -> b) -> a -> b
$ () -> Eff ff es ()
forall a b (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Yield a b :> es) =>
a -> f b
yield ()
{-# INLINE periodicTimer #-}

{- |
Calls `yield` of a coroutine at specific intervals.
Controls so that the time returned by `yield` becomes the time interval until the next loop.
If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled.
-}
cyclicTimer
    :: forall a es ff c
     . (Timer :> es, Yield () DiffTime :> es, Monad (Eff ff es), Free c ff)
    => Eff ff es a
cyclicTimer :: forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Yield () DiffTime :> es, Monad (Eff ff es),
 Free c ff) =>
Eff ff es a
cyclicTimer = Eff ff es DiffTime -> Eff ff es () -> Eff ff es a
forall a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es DiffTime -> Eff ff es () -> Eff ff es a
runCyclic (() -> Eff ff es DiffTime
forall a b (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Yield a b :> es) =>
a -> f b
yield ()) (() -> Eff ff es ()
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINE cyclicTimer #-}

-- | An effect that realizes control of wait times such that the specified time becomes the interval until the next @wait@ when @wait@ is executed repeatedly.
data CyclicTimer :: Effect where
    -- | Controls the wait time so that when @wait@ is executed repeatedly, the specified time becomes the interval until the next @wait@.
    Wait :: DiffTime -> CyclicTimer f ()

makeEffectF ''CyclicTimer

runTimerIO
    :: forall a ff es c
     . (Emb IO :> es, Monad (Eff ff es), Free c ff)
    => Eff ff (Timer ': es) a
    -> Eff ff es a
runTimerIO :: forall a (ff :: Effect) (es :: [Effect])
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (Timer : es) a -> Eff ff es a
runTimerIO =
    (Timer ~~> Eff ff es) -> Eff ff (Timer : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
        Timer (Eff ff es) x
Clock -> do
            Word64
t <- IO Word64
getMonotonicTimeNSec IO Word64 -> (IO Word64 -> Eff ff es Word64) -> Eff ff es Word64
forall a b. a -> (a -> b) -> b
& IO Word64 -> Eff ff es Word64
forall a. IO a -> Eff ff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            x -> Eff ff es x
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Eff ff es x) -> x -> Eff ff es x
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000
        Sleep DiffTime
t ->
            Integer -> IO ()
Thread.delay (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
t Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
1000_000) IO () -> (IO () -> Eff ff es x) -> Eff ff es x
forall a b. a -> (a -> b) -> b
& IO () -> Eff ff es x
IO () -> Eff ff es ()
forall a. IO a -> Eff ff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE runTimerIO #-}

-- | Re-zeros the clock time in the local scope.
restartClock :: forall a ff es c. (Timer :> es, Monad (Eff ff es), Free c ff) => Eff ff es a -> Eff ff es a
restartClock :: forall a (ff :: Effect) (es :: [Effect])
       (c :: (* -> *) -> Constraint).
(Timer :> es, Monad (Eff ff es), Free c ff) =>
Eff ff es a -> Eff ff es a
restartClock Eff ff es a
a = do
    DiffTime
t0 <- Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock
    Eff ff es a
a Eff ff es a -> (Eff ff es a -> Eff ff es a) -> Eff ff es a
forall a b. a -> (a -> b) -> b
& (Timer ~~> Eff ff es) -> Eff ff es a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(e :> es, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff es a -> Eff ff es a
interpose \case
        Timer (Eff ff es) x
Clock -> do
            DiffTime
t <- Eff ff es DiffTime
forall (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, Timer :> es) =>
f DiffTime
clock
            x -> Eff ff es x
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Eff ff es x) -> x -> Eff ff es x
forall a b. (a -> b) -> a -> b
$ x
DiffTime
t x -> x -> x
forall a. Num a => a -> a -> a
- x
DiffTime
t0
        Timer (Eff ff es) x
other -> Timer (Eff ff es) x -> Eff ff es x
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(e :> es, Free c ff) =>
e (Eff ff es) a -> Eff ff es a
perform Timer (Eff ff es) x
other
{-# INLINE restartClock #-}