{-# LANGUAGE RecordWildCards #-}

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

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

import Control.Concurrent.STM
import Control.Monad
import Data.IORef
import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout)

import Control.AutoUpdate.Types

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

-- | 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 :: UpdateSettings a -> IO (IO a)
mkAutoUpdate :: forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate = (IO a -> IO () -> UpdateState a -> IO a)
-> UpdateSettings a -> IO (IO a)
forall a b.
(IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b
mkAutoUpdateThings ((IO a -> IO () -> UpdateState a -> IO a)
 -> UpdateSettings a -> IO (IO a))
-> (IO a -> IO () -> UpdateState a -> IO a)
-> UpdateSettings a
-> IO (IO a)
forall a b. (a -> b) -> a -> b
$ \IO a
g IO ()
_ UpdateState a
_ -> IO 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.4
mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify :: forall a. UpdateSettings a -> (a -> IO a) -> IO (IO a)
mkAutoUpdateWithModify UpdateSettings a
us a -> IO a
f = (IO a -> IO () -> UpdateState a -> IO a)
-> UpdateSettings a -> (a -> IO a) -> IO (IO a)
forall a b.
(IO a -> IO () -> UpdateState a -> b)
-> UpdateSettings a -> (a -> IO a) -> IO b
mkAutoUpdateThingsWithModify (\IO a
g IO ()
_ UpdateState a
_ -> IO a
g) UpdateSettings a
us a -> IO a
f

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

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

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

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

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

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

-- $setup
-- >>> :set -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 :: UpdateSettings a -> IO (IO a, IO ())
mkClosableAutoUpdate :: forall a. UpdateSettings a -> IO (IO a, IO ())
mkClosableAutoUpdate = (IO a -> IO () -> UpdateState a -> (IO a, IO ()))
-> UpdateSettings a -> IO (IO a, IO ())
forall a b.
(IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b
mkAutoUpdateThings ((IO a -> IO () -> UpdateState a -> (IO a, IO ()))
 -> UpdateSettings a -> IO (IO a, IO ()))
-> (IO a -> IO () -> UpdateState a -> (IO a, IO ()))
-> UpdateSettings a
-> IO (IO a, IO ())
forall a b. (a -> b) -> a -> b
$ \IO a
g IO ()
c UpdateState a
_ -> (IO a
g, IO ()
c)

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

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

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

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

closeUpdateState :: UpdateState a -> IO ()
closeUpdateState :: forall a. UpdateState a -> IO ()
closeUpdateState UpdateState{Int
TVar Bool
IORef a
IORef (IO ())
a -> IO a
usUpdateAction_ :: forall a. UpdateState a -> a -> IO a
usLastResult_ :: forall a. UpdateState a -> IORef a
usIntervalMicro_ :: forall a. UpdateState a -> Int
usTimeHasCome_ :: forall a. UpdateState a -> TVar Bool
usDeleteTimeout_ :: forall a. UpdateState a -> IORef (IO ())
usUpdateAction_ :: a -> IO a
usLastResult_ :: IORef a
usIntervalMicro_ :: Int
usTimeHasCome_ :: TVar Bool
usDeleteTimeout_ :: IORef (IO ())
..} = do
    IO ()
delete <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
usDeleteTimeout_
    IO ()
delete

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

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