module Ema.Dynamic (
  Dynamic (Dynamic),
) where

import Control.Monad.Logger (MonadLogger, logDebugNS)
import UnliftIO (MonadUnliftIO, race_)
import UnliftIO.Concurrent (threadDelay)

{- | A time-varying value of type `a`, changing under monad `m`.

  To create a `Dynamic`, supply the initial value along with a function that
  forever updates it using the given monadic update function.

 `Dynamic`'s can be composed using `Applicative`.
-}
newtype Dynamic m a
  = Dynamic
      ( -- Initial value
        a
      , -- Set a new value
        (a -> m ()) -> m ()
      )

instance Functor (Dynamic m) where
  fmap :: forall a b. (a -> b) -> Dynamic m a -> Dynamic m b
fmap a -> b
f (Dynamic (a
x0, (a -> m ()) -> m ()
xf)) =
    forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic
      ( a -> b
f a
x0
      , \b -> m ()
send -> (a -> m ()) -> m ()
xf forall a b. (a -> b) -> a -> b
$ b -> m ()
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
      )

instance (MonadUnliftIO m, MonadLogger m) => Applicative (Dynamic m) where
  pure :: forall a. a -> Dynamic m a
pure a
x = forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic (a
x, forall a b. a -> b -> a
const forall (f :: Type -> Type). Applicative f => f ()
pass)
  liftA2 :: forall a b c.
(a -> b -> c) -> Dynamic m a -> Dynamic m b -> Dynamic m c
liftA2 a -> b -> c
f (Dynamic (a
x0, (a -> m ()) -> m ()
xf)) (Dynamic (b
y0, (b -> m ()) -> m ()
yf)) =
    forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic
      ( a -> b -> c
f a
x0 b
y0
      , \c -> m ()
send -> do
          TVar (a, b)
var <- forall (m :: Type -> Type) a. MonadIO m => a -> m (TVar a)
newTVarIO (a
x0, b
y0)
          TMVar ()
sendLock :: TMVar () <- forall (m :: Type -> Type) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
          forall (m :: Type -> Type) a b.
MonadUnliftIO m =>
m a -> m b -> m ()
race_
            ( do
                (a -> m ()) -> m ()
xf forall a b. (a -> b) -> a -> b
$ \a
x -> do
                  forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
sendLock ()
                  forall (m :: Type -> Type).
MonadLogger m =>
LogSource -> LogSource -> m ()
logDebugNS LogSource
"ema.dyn.app" LogSource
"left update"
                  c -> m ()
send forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
                    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (a, b)
var forall a b. (a -> b) -> a -> b
$ forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const a
x)
                    a -> b -> c
f a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (a, b)
var
                  forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar ()
sendLock
                forall (m :: Type -> Type).
MonadLogger m =>
LogSource -> LogSource -> m ()
logDebugNS LogSource
"ema.dyn.app" LogSource
"updater exited; keeping thread alive"
                forall (m :: Type -> Type). MonadIO m => Int -> m ()
threadDelay forall a. Bounded a => a
maxBound
            )
            ( do
                (b -> m ()) -> m ()
yf forall a b. (a -> b) -> a -> b
$ \b
y -> do
                  forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
sendLock ()
                  forall (m :: Type -> Type).
MonadLogger m =>
LogSource -> LogSource -> m ()
logDebugNS LogSource
"ema.dyn.app" LogSource
"right update"
                  c -> m ()
send forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
                    forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (a, b)
var forall a b. (a -> b) -> a -> b
$ forall (p :: Type -> Type -> Type) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. a -> b -> a
const b
y)
                    (a -> b -> c
`f` b
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (a, b)
var
                  forall (m :: Type -> Type) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar ()
sendLock
                forall (m :: Type -> Type).
MonadLogger m =>
LogSource -> LogSource -> m ()
logDebugNS LogSource
"ema.dyn.app" LogSource
"updater exited; keeping thread alive"
                forall (m :: Type -> Type). MonadIO m => Int -> m ()
threadDelay forall a. Bounded a => a
maxBound
            )
      )