{-# LANGUAGE RecordWildCards #-}

module UnliftIO.AutoUpdate.Event
  ( -- * Creation
    mkAutoUpdate
  , mkAutoUpdateWithModify

    -- * Internal
  , UpdateState (..)
  , mkClosableAutoUpdate
  , mkClosableAutoUpdate'
  )
where

import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout)
import UnliftIO (MonadUnliftIO)
import UnliftIO.AutoUpdate.Types
import UnliftIO.IORef
import UnliftIO.STM

--------------------------------------------------------------------------------

{- | Generate an action which will either read from an automatically
 updated value, or run the update action in the current thread.

 @since 0.1.0
-}
mkAutoUpdate :: MonadUnliftIO m => UpdateSettings m a -> m (m a)
mkAutoUpdate :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> m (m a)
mkAutoUpdate = forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b) -> UpdateSettings m a -> m b
mkAutoUpdateThings forall a b. (a -> b) -> a -> b
$ \m a
g m ()
_ UpdateState m a
_ -> m a
g

{- | Generate an action which will either read from an automatically
 updated value, or run the update action in the current thread if
 the first time or the provided modify action after that.

 @since 0.1.0
-}
mkAutoUpdateWithModify :: MonadUnliftIO m => UpdateSettings m a -> (a -> m a) -> m (m a)
mkAutoUpdateWithModify :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> (a -> m a) -> m (m a)
mkAutoUpdateWithModify = forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b)
-> UpdateSettings m a -> (a -> m a) -> m b
mkAutoUpdateThingsWithModify (\m a
g m ()
_ UpdateState m a
_ -> m a
g)

--------------------------------------------------------------------------------

data UpdateState m a = UpdateState
  { forall (m :: * -> *) a. UpdateState m a -> a -> m a
usUpdateAction_ :: a -> m a
  , forall (m :: * -> *) a. UpdateState m a -> IORef a
usLastResult_ :: IORef a
  , forall (m :: * -> *) a. UpdateState m a -> Int
usIntervalMicro_ :: Int
  , forall (m :: * -> *) a. UpdateState m a -> TVar Bool
usTimeHasCome_ :: TVar Bool
  , forall (m :: * -> *) a. UpdateState m a -> IORef (m ())
usDeleteTimeout_ :: IORef (m ())
  }

--------------------------------------------------------------------------------

mkAutoUpdateThings ::
  MonadUnliftIO m =>
  (m a -> m () -> UpdateState m a -> b) ->
  UpdateSettings m a ->
  m b
mkAutoUpdateThings :: forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b) -> UpdateSettings m a -> m b
mkAutoUpdateThings m a -> m () -> UpdateState m a -> b
mk settings :: UpdateSettings m a
settings@UpdateSettings {m a
Int
String
updateThreadName :: forall (m :: * -> *) a. UpdateSettings m a -> String
updateAction :: forall (m :: * -> *) a. UpdateSettings m a -> m a
updateSpawnThreshold :: forall (m :: * -> *) a. UpdateSettings m a -> Int
updateFreq :: forall (m :: * -> *) a. UpdateSettings m a -> Int
updateThreadName :: String
updateAction :: m a
updateSpawnThreshold :: Int
updateFreq :: Int
..} =
  forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b)
-> UpdateSettings m a -> (a -> m a) -> m b
mkAutoUpdateThingsWithModify m a -> m () -> UpdateState m a -> b
mk UpdateSettings m a
settings (forall a b. a -> b -> a
const m a
updateAction)

mkAutoUpdateThingsWithModify ::
  MonadUnliftIO m =>
  (m a -> m () -> UpdateState m a -> b) ->
  UpdateSettings m a ->
  (a -> m a) ->
  m b
mkAutoUpdateThingsWithModify :: forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b)
-> UpdateSettings m a -> (a -> m a) -> m b
mkAutoUpdateThingsWithModify m a -> m () -> UpdateState m a -> b
mk UpdateSettings m a
settings a -> m a
update1 = do
  UpdateState m a
us <- forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> (a -> m a) -> m (UpdateState m a)
openUpdateState UpdateSettings m a
settings a -> m a
update1
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ m a -> m () -> UpdateState m a -> b
mk (forall (m :: * -> *) a. MonadUnliftIO m => UpdateState m a -> m a
getUpdateResult UpdateState m a
us) (forall (m :: * -> *) a. MonadUnliftIO m => UpdateState m a -> m ()
closeUpdateState UpdateState m a
us) UpdateState m a
us

--------------------------------------------------------------------------------

{- $setup
 >>> :seti -XNumericUnderscores
 >>> import Control.Concurrent
-}

{- |
 >>> iref <- newIORef (0 :: Int)
 >>> action = modifyIORef iref (+ 1) >> readIORef iref
 >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action }
 >>> getValue
 1
 >>> threadDelay 100_000 >> getValue
 1
 >>> threadDelay 200_000 >> getValue
 2
 >>> closeState
-}
mkClosableAutoUpdate :: MonadUnliftIO m => UpdateSettings m a -> m (m a, m ())
mkClosableAutoUpdate :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> m (m a, m ())
mkClosableAutoUpdate = forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b) -> UpdateSettings m a -> m b
mkAutoUpdateThings forall a b. (a -> b) -> a -> b
$ \m a
g m ()
c UpdateState m a
_ -> (m a
g, m ()
c)

-- | provide `UpdateState` for debugging
mkClosableAutoUpdate' :: MonadUnliftIO m => UpdateSettings m a -> m (m a, m (), UpdateState m a)
mkClosableAutoUpdate' :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> m (m a, m (), UpdateState m a)
mkClosableAutoUpdate' = forall (m :: * -> *) a b.
MonadUnliftIO m =>
(m a -> m () -> UpdateState m a -> b) -> UpdateSettings m a -> m b
mkAutoUpdateThings (,,)

--------------------------------------------------------------------------------

mkDeleteTimeout :: MonadUnliftIO m => TVar Bool -> Int -> m (m ())
mkDeleteTimeout :: forall (m :: * -> *).
MonadUnliftIO m =>
TVar Bool -> Int -> m (m ())
mkDeleteTimeout TVar Bool
thc Int
micro = do
  TimerManager
mgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TimerManager
getSystemTimerManager
  TimeoutKey
key <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout TimerManager
mgr Int
micro (forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
thc Bool
True)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TimerManager -> TimeoutKey -> TimeoutCallback
unregisterTimeout TimerManager
mgr TimeoutKey
key

openUpdateState :: MonadUnliftIO m => UpdateSettings m a -> (a -> m a) -> m (UpdateState m a)
openUpdateState :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> (a -> m a) -> m (UpdateState m a)
openUpdateState UpdateSettings {m a
Int
String
updateThreadName :: String
updateAction :: m a
updateSpawnThreshold :: Int
updateFreq :: Int
updateThreadName :: forall (m :: * -> *) a. UpdateSettings m a -> String
updateAction :: forall (m :: * -> *) a. UpdateSettings m a -> m a
updateSpawnThreshold :: forall (m :: * -> *) a. UpdateSettings m a -> Int
updateFreq :: forall (m :: * -> *) a. UpdateSettings m a -> Int
..} a -> m a
update1 = do
  TVar Bool
thc <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
  forall (m :: * -> *) a.
(a -> m a)
-> IORef a -> Int -> TVar Bool -> IORef (m ()) -> UpdateState m a
UpdateState a -> m a
update1
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
updateAction)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
updateFreq
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure TVar Bool
thc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadUnliftIO m =>
TVar Bool -> Int -> m (m ())
mkDeleteTimeout TVar Bool
thc Int
updateFreq)

closeUpdateState :: MonadUnliftIO m => UpdateState m a -> m ()
closeUpdateState :: forall (m :: * -> *) a. MonadUnliftIO m => UpdateState m a -> m ()
closeUpdateState UpdateState {Int
TVar Bool
IORef a
IORef (m ())
a -> m a
usDeleteTimeout_ :: IORef (m ())
usTimeHasCome_ :: TVar Bool
usIntervalMicro_ :: Int
usLastResult_ :: IORef a
usUpdateAction_ :: a -> m a
usDeleteTimeout_ :: forall (m :: * -> *) a. UpdateState m a -> IORef (m ())
usTimeHasCome_ :: forall (m :: * -> *) a. UpdateState m a -> TVar Bool
usIntervalMicro_ :: forall (m :: * -> *) a. UpdateState m a -> Int
usLastResult_ :: forall (m :: * -> *) a. UpdateState m a -> IORef a
usUpdateAction_ :: forall (m :: * -> *) a. UpdateState m a -> a -> m a
..} = do
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (m ())
usDeleteTimeout_

onceOnTimeHasCome :: MonadUnliftIO m => UpdateState m a -> m () -> m ()
onceOnTimeHasCome :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateState m a -> m () -> m ()
onceOnTimeHasCome UpdateState {Int
TVar Bool
IORef a
IORef (m ())
a -> m a
usDeleteTimeout_ :: IORef (m ())
usTimeHasCome_ :: TVar Bool
usIntervalMicro_ :: Int
usLastResult_ :: IORef a
usUpdateAction_ :: a -> m a
usDeleteTimeout_ :: forall (m :: * -> *) a. UpdateState m a -> IORef (m ())
usTimeHasCome_ :: forall (m :: * -> *) a. UpdateState m a -> TVar Bool
usIntervalMicro_ :: forall (m :: * -> *) a. UpdateState m a -> Int
usLastResult_ :: forall (m :: * -> *) a. UpdateState m a -> IORef a
usUpdateAction_ :: forall (m :: * -> *) a. UpdateState m a -> a -> m a
..} m ()
action = do
  forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    Bool
timeHasCome <- forall a. TVar a -> STM a
readTVar TVar Bool
usTimeHasCome_
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
timeHasCome forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
usTimeHasCome_ Bool
False
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
timeHasCome m ()
action

getUpdateResult :: MonadUnliftIO m => UpdateState m a -> m a
getUpdateResult :: forall (m :: * -> *) a. MonadUnliftIO m => UpdateState m a -> m a
getUpdateResult us :: UpdateState m a
us@UpdateState {Int
TVar Bool
IORef a
IORef (m ())
a -> m a
usDeleteTimeout_ :: IORef (m ())
usTimeHasCome_ :: TVar Bool
usIntervalMicro_ :: Int
usLastResult_ :: IORef a
usUpdateAction_ :: a -> m a
usDeleteTimeout_ :: forall (m :: * -> *) a. UpdateState m a -> IORef (m ())
usTimeHasCome_ :: forall (m :: * -> *) a. UpdateState m a -> TVar Bool
usIntervalMicro_ :: forall (m :: * -> *) a. UpdateState m a -> Int
usLastResult_ :: forall (m :: * -> *) a. UpdateState m a -> IORef a
usUpdateAction_ :: forall (m :: * -> *) a. UpdateState m a -> a -> m a
..} = do
  forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateState m a -> m () -> m ()
onceOnTimeHasCome UpdateState m a
us forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
usLastResult_ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m a
usUpdateAction_ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
usLastResult_
    forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (m ())
usDeleteTimeout_ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadUnliftIO m =>
TVar Bool -> Int -> m (m ())
mkDeleteTimeout TVar Bool
usTimeHasCome_ Int
usIntervalMicro_
  forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
usLastResult_