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 :: (a -> b) -> Dynamic m a -> Dynamic m b
fmap a -> b
f (Dynamic (a
x0, (a -> m ()) -> m ()
xf)) =
    (b, (b -> m ()) -> m ()) -> Dynamic m b
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 ((a -> m ()) -> m ()) -> (a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ b -> m ()
send (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
      )

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