module UnliftIO.AutoUpdate.Thread
  ( -- * Creation
    mkAutoUpdate
  , mkAutoUpdateWithModify
  )
where

import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Maybe (fromMaybe)
import GHC.Conc.Sync (labelThread)
import UnliftIO (MonadUnliftIO)
import UnliftIO.AutoUpdate.Types
import UnliftIO.Concurrent (forkIO, threadDelay)
import UnliftIO.Exception
  ( SomeException
  , catch
  , mask_
  , try
  )
import UnliftIO.IORef (newIORef, readIORef, writeIORef)
import UnliftIO.MVar
  ( newEmptyMVar
  , putMVar
  , readMVar
  , takeMVar
  , tryPutMVar
  )

{- | 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 UpdateSettings m a
us = forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> Maybe (a -> m a) -> m (m a)
mkAutoUpdateHelper UpdateSettings m a
us forall a. Maybe a
Nothing

{- | 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 UpdateSettings m a
us a -> m a
f = forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> Maybe (a -> m a) -> m (m a)
mkAutoUpdateHelper UpdateSettings m a
us (forall a. a -> Maybe a
Just a -> m a
f)

mkAutoUpdateHelper :: MonadUnliftIO m => UpdateSettings m a -> Maybe (a -> m a) -> m (m a)
mkAutoUpdateHelper :: forall (m :: * -> *) a.
MonadUnliftIO m =>
UpdateSettings m a -> Maybe (a -> m a) -> m (m a)
mkAutoUpdateHelper UpdateSettings m a
us Maybe (a -> m a)
updateActionModify = do
  -- A baton to tell the worker thread to generate a new value.
  MVar ()
needsRunning <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar

  -- The initial response variable. Response variables allow the requesting
  -- thread to block until a value is generated by the worker thread.
  MVar a
responseVar0 <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar

  -- The current value, if available. We start off with a Left value
  -- indicating no value is available, and the above-created responseVar0 to
  -- give a variable to block on.
  IORef (Either (MVar a) a)
currRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MVar a
responseVar0

  -- This is used to set a value in the currRef variable when the worker
  -- thread exits. In reality, that value should never be used, since the
  -- worker thread exiting only occurs if an async exception is thrown, which
  -- should only occur if there are no references to needsRunning left.
  -- However, this handler will make error messages much clearer if there's a
  -- bug in the implementation.
  let fillRefOnExit :: m () -> m ()
fillRefOnExit m ()
f = do
        Either SomeException ()
eres <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try m ()
f
        case Either SomeException ()
eres of
          Left SomeException
e ->
            forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$
              forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                [Char]
"Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
                  forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (SomeException
e :: SomeException)
          Right () ->
            forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$
              forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                [Char]
"Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
                  forall a. [a] -> [a] -> [a]
++ [Char]
"which should be impossible due to usage of infinite loop"

  -- fork the worker thread immediately. Note that we mask async exceptions,
  -- but *not* in an uninterruptible manner. This will allow a
  -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
  -- down this thread when all references to the returned function are
  -- garbage collected, and therefore there is no thread that can fill the
  -- needsRunning MVar.
  --
  -- Note that since we throw away the ThreadId of this new thread and never
  -- calls myThreadId, normal async exceptions can never be thrown to it,
  -- only RTS exceptions.
  ThreadId
tid <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadUnliftIO m => m () -> m ()
fillRefOnExit forall a b. (a -> b) -> a -> b
$ do
    -- This infinite loop makes up out worker thread. It takes an a
    -- responseVar value where the next value should be putMVar'ed to for
    -- the benefit of any requesters currently blocked on it.
    let loop :: MVar a -> Maybe a -> m b
loop MVar a
responseVar Maybe a
maybea = do
          -- block until a value is actually needed
          forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar ()
needsRunning

          -- new value requested, so run the updateAction
          a
a <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
catchSome forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) a. UpdateSettings m a -> m a
updateAction UpdateSettings m a
us) (Maybe (a -> m a)
updateActionModify forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
maybea)

          -- we got a new value, update currRef and lastValue
          forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
a
          forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar a
responseVar a
a

          -- delay until we're needed again
          forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. UpdateSettings m a -> Int
updateFreq UpdateSettings m a
us

          -- delay's over. create a new response variable and set currRef
          -- to use it, so that the next requester will block on that
          -- variable. Then loop again with the updated response
          -- variable.
          MVar a
responseVar' <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
          forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Either (MVar a) a)
currRef forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left MVar a
responseVar'
          MVar a -> Maybe a -> m b
loop MVar a
responseVar' (forall a. a -> Maybe a
Just a
a)

    -- Kick off the loop, with the initial responseVar0 variable.
    forall {b}. MVar a -> Maybe a -> m b
loop MVar a
responseVar0 forall a. Maybe a
Nothing
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> [Char] -> IO ()
labelThread ThreadId
tid forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. UpdateSettings m a -> [Char]
updateThreadName UpdateSettings m a
us
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    Either (MVar a) a
mval <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Either (MVar a) a)
currRef
    case Either (MVar a) a
mval of
      Left MVar a
responseVar -> do
        -- no current value, force the worker thread to run...
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
needsRunning ()

        -- and block for the result from the worker
        forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar a
responseVar
      -- we have a current value, use it
      Right a
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

{- | Turn a runtime exception into an impure exception, so that all 'IO'
 actions will complete successfully. This simply defers the exception until
 the value is forced.
-}
catchSome :: MonadUnliftIO m => m a -> m a
catchSome :: forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
catchSome m a
act = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
UnliftIO.Exception.catch m a
act forall a b. (a -> b) -> a -> b
$ \SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw (SomeException
e :: SomeException)