module Halogen.Subscription where

import Control.Arrow ((&&&))
import Control.Monad.UUID
import Data.Coerce
import Data.Functor.Contravariant
import Data.NT
import HPrelude

-- | A paired `Listener` and `Emitter` produced with the `create` function.
data Subscribe m a = Subscribe
  { forall (m :: * -> *) a. Subscribe m a -> Listener m a
listener :: Listener m a
  , forall (m :: * -> *) a. Subscribe m a -> Emitter m a
emitter :: Emitter m a
  }

create :: (MonadIO m, MonadUUID m) => m (Subscribe m a)
create :: forall (m :: * -> *) a.
(MonadIO m, MonadUUID m) =>
m (Subscribe m a)
create = do
  subscribers <- [(a -> m (), UUID)] -> m (IORef [(a -> m (), UUID)])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
  pure
    $ Subscribe
      { emitter = Emitter $ \a -> m ()
handler -> do
          uuid <- m UUID
forall (m :: * -> *). MonadUUID m => m UUID
generateV4
          atomicModifyIORef'_ subscribers (<> [(handler, uuid)])
          pure
            $ Subscription
              { unsubscribe = atomicModifyIORef'_ subscribers (HPrelude.filter (\(a -> m ()
_, UUID
uuid') -> UUID
uuid UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
uuid'))
              }
      , listener = Listener {notify = \a
a -> IORef [(a -> m (), UUID)] -> m [(a -> m (), UUID)]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [(a -> m (), UUID)]
subscribers m [(a -> m (), UUID)] -> ([(a -> m (), UUID)] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((a -> m (), UUID) -> m ()) -> [(a -> m (), UUID)] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(a -> m ()
k, UUID
_) -> a -> m ()
k a
a)}
      }

newtype Emitter m a = Emitter {forall (m :: * -> *) a.
Emitter m a -> (a -> m ()) -> m (Subscription m)
registerHandler :: (a -> m ()) -> m (Subscription m)}
  deriving ((forall a b. (a -> b) -> Emitter m a -> Emitter m b)
-> (forall a b. a -> Emitter m b -> Emitter m a)
-> Functor (Emitter m)
forall a b. a -> Emitter m b -> Emitter m a
forall a b. (a -> b) -> Emitter m a -> Emitter m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> Emitter m b -> Emitter m a
forall (m :: * -> *) a b. (a -> b) -> Emitter m a -> Emitter m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> Emitter m a -> Emitter m b
fmap :: forall a b. (a -> b) -> Emitter m a -> Emitter m b
$c<$ :: forall (m :: * -> *) a b. a -> Emitter m b -> Emitter m a
<$ :: forall a b. a -> Emitter m b -> Emitter m a
Functor)

hoistEmitter :: (MonadUnliftIO m) => Emitter IO a -> Emitter m a
hoistEmitter :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Emitter IO a -> Emitter m a
hoistEmitter (Emitter (a -> IO ()) -> IO (Subscription IO)
g) = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((a -> m ()) -> m (Subscription m)) -> Emitter m a)
-> ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ \a -> m ()
k -> ((forall a. m a -> IO a) -> IO (Subscription m))
-> m (Subscription m)
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Subscription m))
 -> m (Subscription m))
-> ((forall a. m a -> IO a) -> IO (Subscription m))
-> m (Subscription m)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
  (Subscription IO -> Subscription m)
-> IO (Subscription IO) -> IO (Subscription m)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO ~> m) -> Subscription IO -> Subscription m
forall (m :: * -> *) (n :: * -> *).
(m ~> n) -> Subscription m -> Subscription n
hoistSubscription ((IO ~> m) -> Subscription IO -> Subscription m)
-> (IO ~> m) -> Subscription IO -> Subscription m
forall a b. (a -> b) -> a -> b
$ (forall a. IO a -> m a) -> IO ~> m
forall {k} (m :: k -> *) (n :: k -> *).
(forall (a :: k). m a -> n a) -> m ~> n
NT IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO) (IO (Subscription IO) -> IO (Subscription m))
-> IO (Subscription IO) -> IO (Subscription m)
forall a b. (a -> b) -> a -> b
$ (a -> IO ()) -> IO (Subscription IO)
g ((a -> IO ()) -> IO (Subscription IO))
-> (a -> IO ()) -> IO (Subscription IO)
forall a b. (a -> b) -> a -> b
$ m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> (a -> m ()) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ()
k

instance (MonadIO m) => Applicative (Emitter m) where
  pure :: forall a. a -> Emitter m a
pure a
a = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((a -> m ()) -> m (Subscription m)) -> Emitter m a)
-> ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ \a -> m ()
k -> do
    a -> m ()
k a
a
    Subscription m -> m (Subscription m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> Subscription m
forall (m :: * -> *). m () -> Subscription m
Subscription (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

  (Emitter ((a -> b) -> m ()) -> m (Subscription m)
e1) <*> :: forall a b. Emitter m (a -> b) -> Emitter m a -> Emitter m b
<*> (Emitter (a -> m ()) -> m (Subscription m)
e2) = ((b -> m ()) -> m (Subscription m)) -> Emitter m b
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((b -> m ()) -> m (Subscription m)) -> Emitter m b)
-> ((b -> m ()) -> m (Subscription m)) -> Emitter m b
forall a b. (a -> b) -> a -> b
$ \b -> m ()
k -> do
    latestA <- Maybe (a -> b) -> m (IORef (Maybe (a -> b)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe (a -> b)
forall a. Maybe a
Nothing
    latestB <- newIORef Nothing
    Subscription c1 <- e1 $ \a -> b
a -> do
      IORef (Maybe (a -> b)) -> Maybe (a -> b) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (Maybe (a -> b))
latestA ((a -> b) -> Maybe (a -> b)
forall a. a -> Maybe a
Just a -> b
a)
      IORef (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe a)
latestB m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> m ()) -> Maybe a -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (b -> m ()
k (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
a)
    Subscription c2 <- e2 $ \a
b -> do
      IORef (Maybe a) -> Maybe a -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
atomicWriteIORef IORef (Maybe a)
latestB (a -> Maybe a
forall a. a -> Maybe a
Just a
b)
      IORef (Maybe (a -> b)) -> m (Maybe (a -> b))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe (a -> b))
latestA m (Maybe (a -> b)) -> (Maybe (a -> b) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((a -> b) -> m ()) -> Maybe (a -> b) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (b -> m ()
k (b -> m ()) -> ((a -> b) -> b) -> (a -> b) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
b))
    pure (Subscription (c1 *> c2))

instance (MonadIO m) => Alternative (Emitter m) where
  empty :: forall a. Emitter m a
empty = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((a -> m ()) -> m (Subscription m)) -> Emitter m a)
-> ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ \a -> m ()
_ -> Subscription m -> m (Subscription m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> Subscription m
forall (m :: * -> *). m () -> Subscription m
Subscription (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
  (Emitter (a -> m ()) -> m (Subscription m)
f) <|> :: forall a. Emitter m a -> Emitter m a -> Emitter m a
<|> (Emitter (a -> m ()) -> m (Subscription m)
g) = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((a -> m ()) -> m (Subscription m)) -> Emitter m a)
-> ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ \a -> m ()
k -> do
    Subscription c1 <- (a -> m ()) -> m (Subscription m)
f a -> m ()
k
    Subscription c2 <- g k
    pure (Subscription (c1 *> c2))

makeEmitter
  :: (Functor m)
  => ((a -> m ()) -> m (m ()))
  -> Emitter m a
makeEmitter :: forall (m :: * -> *) a.
Functor m =>
((a -> m ()) -> m (m ())) -> Emitter m a
makeEmitter (a -> m ()) -> m (m ())
f = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter ((m () -> Subscription m) -> m (m ()) -> m (Subscription m)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m () -> Subscription m
forall (m :: * -> *). m () -> Subscription m
Subscription (m (m ()) -> m (Subscription m))
-> ((a -> m ()) -> m (m ())) -> (a -> m ()) -> m (Subscription m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m ()) -> m (m ())
f)

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

newtype Listener m a = Listener {forall (m :: * -> *) a. Listener m a -> a -> m ()
notify :: a -> m ()}

notify :: Listener m a -> a -> m ()
notify :: forall (m :: * -> *) a. Listener m a -> a -> m ()
notify (Listener a -> m ()
f) = a -> m ()
f

instance Contravariant (Listener m) where
  contramap :: forall a' a. (a' -> a) -> Listener m a -> Listener m a'
contramap a' -> a
f (Listener a -> m ()
g) = (a' -> m ()) -> Listener m a'
forall a b. Coercible a b => a -> b
coerce (a -> m ()
g (a -> m ()) -> (a' -> a) -> a' -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

newtype Subscription m = Subscription {forall (m :: * -> *). Subscription m -> m ()
unsubscribe :: m ()}

hoistSubscription :: (m ~> n) -> Subscription m -> Subscription n
hoistSubscription :: forall (m :: * -> *) (n :: * -> *).
(m ~> n) -> Subscription m -> Subscription n
hoistSubscription (NT forall a. m a -> n a
f) (Subscription m ()
unsub) = n () -> Subscription n
forall (m :: * -> *). m () -> Subscription m
Subscription (m () -> n ()
forall a. m a -> n a
f m ()
unsub)

subscribe
  :: (Functor m)
  => Emitter m a
  -> (a -> m r)
  -> m (Subscription m)
subscribe :: forall (m :: * -> *) a r.
Functor m =>
Emitter m a -> (a -> m r) -> m (Subscription m)
subscribe Emitter m a
em a -> m r
k = Emitter m a
em.registerHandler (m r -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m r -> m ()) -> (a -> m r) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m r
k)

unsubscribe :: Subscription m -> m ()
unsubscribe :: forall (m :: * -> *). Subscription m -> m ()
unsubscribe (Subscription m ()
unsub) = m ()
unsub

fold :: (MonadIO m) => (a -> b -> b) -> Emitter m a -> b -> Emitter m b
fold :: forall (m :: * -> *) a b.
MonadIO m =>
(a -> b -> b) -> Emitter m a -> b -> Emitter m b
fold a -> b -> b
f (Emitter (a -> m ()) -> m (Subscription m)
e) b
b = ((b -> m ()) -> m (Subscription m)) -> Emitter m b
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((b -> m ()) -> m (Subscription m)) -> Emitter m b)
-> ((b -> m ()) -> m (Subscription m)) -> Emitter m b
forall a b. (a -> b) -> a -> b
$ \b -> m ()
k -> do
  result <- b -> m (IORef b)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef b
b
  e $ \a
a -> IORef b -> (b -> (b, b)) -> m b
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef b
result (a -> b -> b
f a
a (b -> b) -> (b -> b) -> b -> (b, b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> b -> b
f a
a) m b -> (b -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m ()
k

filter :: (Applicative m) => (a -> Bool) -> Emitter m a -> Emitter m a
filter :: forall (m :: * -> *) a.
Applicative m =>
(a -> Bool) -> Emitter m a -> Emitter m a
filter a -> Bool
p (Emitter (a -> m ()) -> m (Subscription m)
e) = ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall (m :: * -> *) a.
((a -> m ()) -> m (Subscription m)) -> Emitter m a
Emitter (((a -> m ()) -> m (Subscription m)) -> Emitter m a)
-> ((a -> m ()) -> m (Subscription m)) -> Emitter m a
forall a b. (a -> b) -> a -> b
$ \a -> m ()
k -> (a -> m ()) -> m (Subscription m)
e ((a -> m ()) -> m (Subscription m))
-> (a -> m ()) -> m (Subscription m)
forall a b. (a -> b) -> a -> b
$ \a
a -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
p a
a) (a -> m ()
k a
a)

{-
-- | Compute a fixed point.
fix :: forall i o. (Emitter i -> (Emitter i, Emitter o)) -> Emitter o
fix f = Emitter $ \k -> do
  Subscription c1 <- subscribe input (notify listener)
  Subscription c2 <- subscribe output k
  pure (Subscription (c1 *> c2))
  where
  SubscribeIO { emitter, listener } = unsafePerformIO create
  (input, output) = f emitter
  -}