-- 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/.

module Control.Effect.Interpreter.Heftia.Concurrent.Timer where

import Control.Concurrent.Thread.Delay qualified as Thread
import Control.Effect (sendIns, type (~>))
import Control.Effect.ExtensibleFinal (type (:!!))
import Control.Effect.Hefty (interposeRec, interpret, interpretRec, raise, raiseUnder)
import Control.Effect.Interpreter.Heftia.Coroutine (runCoroutine)
import Control.Effect.Interpreter.Heftia.State (evalState)
import Data.Effect.Concurrent.Timer (CyclicTimer (Wait), LCyclicTimer, LTimer, Timer (..), clock, cyclicTimer)
import Data.Effect.Coroutine (Status (Coroutine, Done))
import Data.Effect.State (get, put)
import Data.Function ((&))
import Data.Hefty.Extensible (ForallHFunctor, type (<|))
import Data.Time (DiffTime)
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Void (Void, absurd)
import GHC.Clock (getMonotonicTimeNSec)
import UnliftIO (liftIO)

runTimerIO ::
    forall eh ef.
    (IO <| ef, ForallHFunctor eh) =>
    eh :!! LTimer ': ef ~> eh :!! ef
runTimerIO :: forall (eh :: [(* -> *) -> * -> *]) (ef :: [(* -> *) -> * -> *]).
(IO <| ef, ForallHFunctor eh) =>
(eh :!! (LTimer : ef)) ~> (eh :!! ef)
runTimerIO =
    forall (e :: (* -> *) -> * -> *) (rs :: [(* -> *) -> * -> *])
       (ehs :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs), HeadIns e) =>
(UnliftIfSingle e ~> Eff u fr ehs rs)
-> Eff u fr ehs (e : rs) ~> Eff u fr ehs rs
interpretRec \case
        Timer x
UnliftIfSingle LTimer x
Clock -> do
            Word64
t <- IO Word64
getMonotonicTimeNSec forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
picosecondsToDiffTime forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
t forall a. Num a => a -> a -> a
* Integer
1000
        Sleep DiffTime
t ->
            Integer -> IO ()
Thread.delay (DiffTime -> Integer
diffTimeToPicoseconds DiffTime
t forall a. Integral a => a -> a -> a
`quot` Integer
1000_000) forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

runCyclicTimer :: forall ef. Timer <| ef => '[] :!! LCyclicTimer ': ef ~> '[] :!! ef
runCyclicTimer :: forall (ef :: [(* -> *) -> * -> *]).
(Timer <| ef) =>
('[] :!! (LCyclicTimer : ef)) ~> ('[] :!! ef)
runCyclicTimer (:!!) '[] (LCyclicTimer : ef) x
a = do
    Status
  (Hefty (FreerFinal Monad) (EffUnion ExtensibleUnion '[] ef))
  ()
  DiffTime
  Void
timer0 :: Status ('[] :!! ef) () DiffTime Void <- forall a b r (er :: [(* -> *) -> * -> *])
       (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(MonadFreer c fr, Union u, c (Eff u fr '[] er)) =>
Eff u fr '[] (LYield a b : er) r
-> Eff u fr '[] er (Status (Eff u fr '[] er) a b r)
runCoroutine forall (m :: * -> *) a.
(Timer <: m, Yield () DiffTime <: m, Monad m) =>
m a
cyclicTimer
    (:!!) '[] (LCyclicTimer : ef) x
a forall a b. a -> (a -> b) -> b
& forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) (ehs :: [(* -> *) -> * -> *])
       (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs)) =>
Eff u fr ehs (e2 : r) ~> Eff u fr ehs (e2 : e1 : r)
raiseUnder
        forall a b. a -> (a -> b) -> b
& forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (ehs :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HeadIns e) =>
(UnliftIfSingle e ~> Eff u fr ehs r)
-> Eff u fr '[] (e : r) ~> Eff u fr ehs r
interpret \case
            Wait DiffTime
delta ->
                forall s (f :: * -> *). SendIns (State s) f => f s
get @(Status ('[] :!! ef) () DiffTime Void) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Done Void
x -> forall a. Void -> a
absurd Void
x
                    Coroutine () DiffTime
-> (:!!)
     '[]
     ef
     (Status
        (Hefty (FreerFinal Monad) (EffUnion ExtensibleUnion '[] ef))
        ()
        DiffTime
        Void)
k -> forall s (f :: * -> *). SendIns (State s) f => s -> f ()
put forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (ehs :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs)) =>
Eff u fr ehs r ~> Eff u fr ehs (e : r)
raise (DiffTime
-> (:!!)
     '[]
     ef
     (Status
        (Hefty (FreerFinal Monad) (EffUnion ExtensibleUnion '[] ef))
        ()
        DiffTime
        Void)
k DiffTime
delta)
        forall a b. a -> (a -> b) -> b
& forall s (r :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, c (Eff u fr '[] r),
 c (StateT s (Eff u fr '[] r)), Applicative (Eff u fr '[] r)) =>
s -> Eff u fr '[] (LState s : r) ~> Eff u fr '[] r
evalState Status
  (Hefty (FreerFinal Monad) (EffUnion ExtensibleUnion '[] ef))
  ()
  DiffTime
  Void
timer0

restartClock :: (Timer <| ef, ForallHFunctor eh) => eh :!! ef ~> eh :!! ef
restartClock :: forall (ef :: [(* -> *) -> * -> *]) (eh :: [(* -> *) -> * -> *]).
(Timer <| ef, ForallHFunctor eh) =>
(eh :!! ef) ~> (eh :!! ef)
restartClock (:!!) eh ef x
a = do
    DiffTime
t0 <- forall (f :: * -> *). SendIns Timer f => f DiffTime
clock
    (:!!) eh ef x
a forall a b. a -> (a -> b) -> b
& forall (e :: * -> *) (ehs :: [(* -> *) -> * -> *])
       (efs :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs), Member u e efs) =>
(e ~> Eff u fr ehs efs) -> Eff u fr ehs efs ~> Eff u fr ehs efs
interposeRec \case
        Timer x
Clock -> do
            DiffTime
t <- forall (f :: * -> *). SendIns Timer f => f DiffTime
clock
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DiffTime
t forall a. Num a => a -> a -> a
- DiffTime
t0
        Timer x
other -> forall (ins :: * -> *) (f :: * -> *) a.
SendIns ins f =>
ins a -> f a
sendIns Timer x
other