{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}

module Control.Monad.State.Delayed.Delayer where

import Data.Time
import HPrelude

data TimeoutKilled = TimeoutKilled
  deriving stock (Int -> TimeoutKilled -> ShowS
[TimeoutKilled] -> ShowS
TimeoutKilled -> String
(Int -> TimeoutKilled -> ShowS)
-> (TimeoutKilled -> String)
-> ([TimeoutKilled] -> ShowS)
-> Show TimeoutKilled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeoutKilled -> ShowS
showsPrec :: Int -> TimeoutKilled -> ShowS
$cshow :: TimeoutKilled -> String
show :: TimeoutKilled -> String
$cshowList :: [TimeoutKilled] -> ShowS
showList :: [TimeoutKilled] -> ShowS
Show)
  deriving anyclass (Show TimeoutKilled
Typeable TimeoutKilled
(Typeable TimeoutKilled, Show TimeoutKilled) =>
(TimeoutKilled -> SomeException)
-> (SomeException -> Maybe TimeoutKilled)
-> (TimeoutKilled -> String)
-> (TimeoutKilled -> Bool)
-> Exception TimeoutKilled
SomeException -> Maybe TimeoutKilled
TimeoutKilled -> Bool
TimeoutKilled -> String
TimeoutKilled -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: TimeoutKilled -> SomeException
toException :: TimeoutKilled -> SomeException
$cfromException :: SomeException -> Maybe TimeoutKilled
fromException :: SomeException -> Maybe TimeoutKilled
$cdisplayException :: TimeoutKilled -> String
displayException :: TimeoutKilled -> String
$cbacktraceDesired :: TimeoutKilled -> Bool
backtraceDesired :: TimeoutKilled -> Bool
Exception)

data Delayer s = Delayer NominalDiffTime (MVar (Maybe (DelayerState s)))

data DelayerState s = DelayerState
  { forall s. DelayerState s -> s
delayedState :: s
  , forall s. DelayerState s -> Async ()
commitFiber :: Async ()
  }

mkEmptyDelayer :: (MonadIO m) => NominalDiffTime -> m (Delayer s)
mkEmptyDelayer :: forall (m :: * -> *) s.
MonadIO m =>
NominalDiffTime -> m (Delayer s)
mkEmptyDelayer NominalDiffTime
delay = do
  s <- IO (MVar (Maybe (DelayerState s)))
-> m (MVar (Maybe (DelayerState s)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Maybe (DelayerState s)))
 -> m (MVar (Maybe (DelayerState s))))
-> IO (MVar (Maybe (DelayerState s)))
-> m (MVar (Maybe (DelayerState s)))
forall a b. (a -> b) -> a -> b
$ Maybe (DelayerState s) -> IO (MVar (Maybe (DelayerState s)))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe (DelayerState s)
forall a. Maybe a
Nothing
  pure $ Delayer delay s

mkTimedOutDelayerState :: NominalDiffTime -> s -> (s -> IO ()) -> IO (DelayerState s)
mkTimedOutDelayerState :: forall s.
NominalDiffTime -> s -> (s -> IO ()) -> IO (DelayerState s)
mkTimedOutDelayerState NominalDiffTime
delay s
s s -> IO ()
commit = do
  fiber <- IO (Async ()) -> IO (Async ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> IO (Async ())) -> IO (Async ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
delay Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
10 Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
6) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> s -> IO ()
commit s
s
  pure $ DelayerState s fiber