{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeOperators    #-}

module Control.Monad.Freer.Extras.Delay where

import Control.Concurrent (threadDelay)
import Control.Monad.Freer (Eff, LastMember, interpret, type (~>))
import Control.Monad.Freer.TH (makeEffect)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Time.Units (TimeUnit, toMicroseconds)

data DelayEffect r where
    DelayThread :: TimeUnit a => a -> DelayEffect ()

makeEffect ''DelayEffect

handleDelayEffect ::
       forall effs m. (LastMember m effs, MonadIO m)
    => Eff (DelayEffect ': effs) ~> Eff effs
handleDelayEffect :: Eff (DelayEffect : effs) ~> Eff effs
handleDelayEffect =
    (DelayEffect ~> Eff effs) -> Eff (DelayEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((DelayEffect ~> Eff effs) -> Eff (DelayEffect : effs) ~> Eff effs)
-> (DelayEffect ~> Eff effs)
-> Eff (DelayEffect : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
        DelayThread t ->
            IO () -> Eff effs ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff effs ()) -> (a -> IO ()) -> a -> Eff effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> IO ()) -> (a -> Int) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> (a -> Integer) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds (a -> Eff effs ()) -> a -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ a
t