-- SPDX-License-Identifier: MPL-2.0

module Control.Monad.Hefty.Concurrent.Timer where

import Control.Concurrent.Thread.Delay qualified as Thread
import Control.Monad.Hefty.Coroutine (runCoroutine)
import Control.Monad.Hefty.State (evalState)
import Control.Monad.Hefty (
    interpose,
    interpret,
    liftIO,
    raise,
    raiseUnder,
    send,
    (&),
    type (:!!),
    type (<|),
    type (~>),
 )
import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), Timer (..), clock, cyclicTimer)
import Data.Effect.Coroutine (Status (Continue, Done))
import Data.Effect.State (get, put)
import Data.Time (DiffTime)
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Void (Void, absurd)
import GHC.Clock (getMonotonicTimeNSec)

runTimerIO
    :: forall eh ef
     . (IO <| ef)
    => eh :!! Timer ': ef ~> eh :!! ef
runTimerIO :: forall (eh :: [EffectH]) (ef :: [EffectF]).
(IO <| ef) =>
(eh :!! (Timer : ef)) ~> (eh :!! ef)
runTimerIO =
    (Timer ~> Eff eh ef) -> Eff eh (Timer : ef) ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \case
        Timer x
Clock -> do
            Word64
t <- IO Word64
getMonotonicTimeNSec IO Word64 -> (IO Word64 -> Eff eh ef Word64) -> Eff eh ef Word64
forall a b. a -> (a -> b) -> b
& IO Word64 -> Eff eh ef Word64
forall a. IO a -> Eff eh ef a
forall (m :: EffectF) a. MonadIO m => IO a -> m a
liftIO
            x -> Eff eh ef x
forall a. a -> Eff eh ef a
forall (f :: EffectF) a. Applicative f => a -> f a
pure (x -> Eff eh ef x) -> x -> Eff eh ef 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 eh ef x) -> Eff eh ef x
forall a b. a -> (a -> b) -> b
& IO () -> Eff eh ef x
IO () -> Eff eh ef ()
forall a. IO a -> Eff eh ef a
forall (m :: EffectF) a. MonadIO m => IO a -> m a
liftIO

runCyclicTimer
    :: forall ef
     . (Timer <| ef)
    => '[] :!! CyclicTimer ': ef ~> '[] :!! ef
runCyclicTimer :: forall (ef :: [EffectF]).
(Timer <| ef) =>
('[] :!! (CyclicTimer : ef)) ~> ('[] :!! ef)
runCyclicTimer (:!!) '[] (CyclicTimer : ef) x
a = do
    Status (Eff '[] ef) () DiffTime Void
timer0 :: Status ('[] :!! ef) () DiffTime Void <- Eff '[] (Yield () DiffTime : ef) Void
-> Eff '[] ef (Status (Eff '[] ef) () DiffTime Void)
forall a b ans (r :: [EffectF]).
Eff '[] (Yield a b : r) ans
-> Eff '[] r (Status (Eff '[] r) a b ans)
runCoroutine Eff '[] (Yield () DiffTime : ef) Void
forall (m :: EffectF) a.
(Timer <: m, Yield () DiffTime <: m, Monad m) =>
m a
cyclicTimer
    (:!!) '[] (CyclicTimer : ef) x
a
        (:!!) '[] (CyclicTimer : ef) x
-> ((:!!) '[] (CyclicTimer : ef) x
    -> Eff
         '[]
         (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
         x)
-> Eff
     '[]
     (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
     x
forall a b. a -> (a -> b) -> b
& (:!!) '[] (CyclicTimer : ef) x
-> Eff
     '[]
     (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
     x
forall (e1 :: EffectF) (e2 :: EffectF) (ef :: [EffectF])
       (eh :: [EffectH]) x.
Eff eh (e1 : ef) x -> Eff eh (e1 : e2 : ef) x
raiseUnder
        Eff
  '[]
  (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
  x
-> (Eff
      '[]
      (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
      x
    -> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x)
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
forall a b. a -> (a -> b) -> b
& (CyclicTimer
 ~> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef))
-> Eff
     '[]
     (CyclicTimer : State (Status (Eff '[] ef) () DiffTime Void) : ef)
   ~> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef)
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \case
            Wait DiffTime
delta ->
                forall s (f :: EffectF). SendFOE (State s) f => f s
get @(Status ('[] :!! ef) () DiffTime Void) Eff
  '[]
  (State (Status (Eff '[] ef) () DiffTime Void) : ef)
  (Status (Eff '[] ef) () DiffTime Void)
-> (Status (Eff '[] ef) () DiffTime Void
    -> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x)
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
forall a b.
Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) a
-> (a
    -> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) b)
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) b
forall (m :: EffectF) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Done Void
x -> Void
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
forall a. Void -> a
absurd Void
x
                    Continue () DiffTime -> Eff '[] ef (Status (Eff '[] ef) () DiffTime Void)
k -> Status (Eff '[] ef) () DiffTime Void
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
Status (Eff '[] ef) () DiffTime Void
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) ()
forall s (f :: EffectF). SendFOE (State s) f => s -> f ()
put (Status (Eff '[] ef) () DiffTime Void
 -> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x)
-> Eff
     '[]
     (State (Status (Eff '[] ef) () DiffTime Void) : ef)
     (Status (Eff '[] ef) () DiffTime Void)
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
forall (m :: EffectF) a b. Monad m => (a -> m b) -> m a -> m b
=<< Eff '[] ef (Status (Eff '[] ef) () DiffTime Void)
-> Eff
     '[]
     (State (Status (Eff '[] ef) () DiffTime Void) : ef)
     (Status (Eff '[] ef) () DiffTime Void)
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]) x.
Eff eh ef x -> Eff eh (e : ef) x
raise (DiffTime -> Eff '[] ef (Status (Eff '[] ef) () DiffTime Void)
k DiffTime
delta)
        Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
-> (Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
    -> (:!!) '[] ef x)
-> (:!!) '[] ef x
forall a b. a -> (a -> b) -> b
& Status (Eff '[] ef) () DiffTime Void
-> Eff '[] (State (Status (Eff '[] ef) () DiffTime Void) : ef) x
-> (:!!) '[] ef x
forall s (ef :: [EffectF]) a.
s -> Eff '[] (State s : ef) a -> Eff '[] ef a
evalState Status (Eff '[] ef) () DiffTime Void
timer0

restartClock :: (Timer <| ef) => eh :!! ef ~> eh :!! ef
restartClock :: forall (ef :: [EffectF]) (eh :: [EffectH]).
(Timer <| ef) =>
(eh :!! ef) ~> (eh :!! ef)
restartClock (:!!) eh ef x
a = do
    DiffTime
t0 <- Eff eh ef DiffTime
forall (f :: EffectF). SendFOE Timer f => f DiffTime
clock
    (:!!) eh ef x
a (:!!) eh ef x -> ((:!!) eh ef x -> (:!!) eh ef x) -> (:!!) eh ef x
forall a b. a -> (a -> b) -> b
& (Timer ~> Eff eh ef) -> Eff eh ef ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e <| ef) =>
(e ~> Eff eh ef) -> Eff eh ef ~> Eff eh ef
interpose \case
        Timer x
Clock -> do
            DiffTime
t <- Eff eh ef DiffTime
forall (f :: EffectF). SendFOE Timer f => f DiffTime
clock
            x -> Eff eh ef x
forall a. a -> Eff eh ef a
forall (f :: EffectF) a. Applicative f => a -> f a
pure (x -> Eff eh ef x) -> x -> Eff eh ef 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 x
other -> Timer x -> Eff eh ef x
Timer ~> Eff eh ef
forall (e :: EffectF) (ef :: [EffectF]) (eh :: [EffectH]).
(e <| ef) =>
e ~> Eff eh ef
send Timer x
other