{-# LANGUAGE AllowAmbiguousTypes #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2024 Sayo Koyoneda
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable
-}
module Data.Effect.Concurrent.Timer where

import Control.Monad (when)
import Data.Effect.Coroutine (Yield, yield)
import Data.Function (fix)
import Data.Functor ((<&>))
import Data.Time (DiffTime)

data Timer a where
    Clock :: Timer DiffTime
    Sleep :: DiffTime -> Timer ()
makeEffectF [''Timer]

withElapsedTime :: (Timer <: m, Monad m) => (m DiffTime -> m a) -> m a
withElapsedTime :: forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
(m DiffTime -> m a) -> m a
withElapsedTime m DiffTime -> m a
f = do
    DiffTime
start <- m DiffTime
forall (f :: * -> *). SendFOE Timer f => f DiffTime
clock
    m DiffTime -> m a
f (m DiffTime -> m a) -> m DiffTime -> m a
forall a b. (a -> b) -> a -> b
$ m DiffTime
forall (f :: * -> *). SendFOE Timer f => f DiffTime
clock m DiffTime -> (DiffTime -> DiffTime) -> m 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)

measureTime :: (Timer <: m, Monad m) => m a -> m (DiffTime, a)
measureTime :: forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m a -> m (DiffTime, a)
measureTime m a
m = (m DiffTime -> m (DiffTime, a)) -> m (DiffTime, a)
forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
(m DiffTime -> m a) -> m a
withElapsedTime \m DiffTime
elapsedTime -> do
    a
r <- m a
m
    m DiffTime
elapsedTime m DiffTime -> (DiffTime -> (DiffTime, a)) -> m (DiffTime, a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,a
r)

sleepUntil :: (Timer <: m, Monad m) => DiffTime -> m (Maybe DiffTime)
sleepUntil :: forall (m :: * -> *).
(Timer <: m, Monad m) =>
DiffTime -> m (Maybe DiffTime)
sleepUntil DiffTime
t = do
    DiffTime
now <- m DiffTime
forall (f :: * -> *). SendFOE Timer f => f DiffTime
clock
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
now) do
        DiffTime -> m ()
forall (f :: * -> *). SendFOE Timer f => DiffTime -> f ()
sleep (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime
t DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
now
    Maybe DiffTime -> m (Maybe DiffTime)
forall a. a -> m 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

runCyclic :: (Timer <: m, Monad m) => m DiffTime -> m () -> m a
runCyclic :: forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m DiffTime -> m () -> m a
runCyclic m DiffTime
deltaTime m ()
a = do
    DiffTime
t0 <- m DiffTime
forall (f :: * -> *). SendFOE Timer f => f DiffTime
clock
    (((DiffTime -> m a) -> DiffTime -> m a) -> DiffTime -> m a)
-> DiffTime -> ((DiffTime -> m a) -> DiffTime -> m a) -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((DiffTime -> m a) -> DiffTime -> m a) -> DiffTime -> m a
forall a. (a -> a) -> a
fix DiffTime
t0 \DiffTime -> m a
next DiffTime
t -> do
        DiffTime
t' <- (DiffTime
t +) (DiffTime -> DiffTime) -> m DiffTime -> m DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DiffTime
deltaTime
        m ()
a
        Maybe DiffTime
delay <- DiffTime -> m (Maybe DiffTime)
forall (m :: * -> *).
(Timer <: m, Monad m) =>
DiffTime -> m (Maybe DiffTime)
sleepUntil DiffTime
t'
        DiffTime -> m a
next (DiffTime -> m a) -> DiffTime -> m 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

runPeriodic :: (Timer <: m, Monad m) => DiffTime -> m () -> m a
runPeriodic :: forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
DiffTime -> m () -> m a
runPeriodic DiffTime
interval = m DiffTime -> m () -> m a
forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m DiffTime -> m () -> m a
runCyclic (DiffTime -> m DiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DiffTime
interval)
{-# INLINE runPeriodic #-}

periodicTimer :: forall m a. (Timer <: m, Yield () () <: m, Monad m) => DiffTime -> m a
periodicTimer :: forall (m :: * -> *) a.
(Timer <: m, Yield () () <: m, Monad m) =>
DiffTime -> m a
periodicTimer DiffTime
interval = DiffTime -> m () -> m a
forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
DiffTime -> m () -> m a
runPeriodic DiffTime
interval (m () -> m a) -> m () -> m a
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a b (f :: * -> *). SendFOE (Yield a b) f => a -> f b
yield ()
{-# INLINE periodicTimer #-}

cyclicTimer :: forall m a. (Timer <: m, Yield () DiffTime <: m, Monad m) => m a
cyclicTimer :: forall (m :: * -> *) a.
(Timer <: m, Yield () DiffTime <: m, Monad m) =>
m a
cyclicTimer = m DiffTime -> m () -> m a
forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m DiffTime -> m () -> m a
runCyclic (() -> m DiffTime
forall a b (f :: * -> *). SendFOE (Yield a b) f => a -> f b
yield ()) (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINE cyclicTimer #-}

data CyclicTimer a where
    Wait :: DiffTime -> CyclicTimer ()
makeEffectF [''CyclicTimer]