{-# 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 Yamada Ryo
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 <- forall (f :: * -> *). SendIns Timer f => f DiffTime
clock
    m DiffTime -> m a
f forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). SendIns Timer f => f DiffTime
clock forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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 = 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 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 <- forall (f :: * -> *). SendIns Timer f => f DiffTime
clock
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
t forall a. Ord a => a -> a -> Bool
> DiffTime
now) do
        forall (f :: * -> *). SendIns Timer f => DiffTime -> f ()
sleep forall a b. (a -> b) -> a -> b
$ DiffTime
t forall a. Num a => a -> a -> a
- DiffTime
now
    forall (f :: * -> *) a. Applicative f => a -> f a
pure if DiffTime
t forall a. Ord a => a -> a -> Bool
< DiffTime
now then forall a. a -> Maybe a
Just (DiffTime
now forall a. Num a => a -> a -> a
- DiffTime
t) else 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 <- forall (f :: * -> *). SendIns Timer f => f DiffTime
clock
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix DiffTime
t0 \DiffTime -> m a
next DiffTime
t -> do
        DiffTime
t' <- (DiffTime
t +) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DiffTime
deltaTime
        m ()
a
        Maybe DiffTime
delay <- forall (m :: * -> *).
(Timer <: m, Monad m) =>
DiffTime -> m (Maybe DiffTime)
sleepUntil DiffTime
t'
        DiffTime -> m a
next forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m DiffTime -> m () -> m a
runCyclic (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 = forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
DiffTime -> m () -> m a
runPeriodic DiffTime
interval forall a b. (a -> b) -> a -> b
$ forall a b (f :: * -> *). SendIns (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 = forall (m :: * -> *) a.
(Timer <: m, Monad m) =>
m DiffTime -> m () -> m a
runCyclic (forall a b (f :: * -> *). SendIns (Yield a b) f => a -> f b
yield ()) (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
{-# INLINE cyclicTimer #-}

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