@@ -0,0 +1,44 @@
1+{-# LANGUAGE ExplicitForAll #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE TypeApplications #-}
9+
10+module Reflex.PubSub where
11+
12+import Prelude hiding (lookup)
13+
14+import Control.Monad.Reader
15+import Data.Constraint.Extras
16+import Data.Dependent.Map
17+import Data.Dependent.Sum
18+import Data.Functor.Identity
19+
20+import Reflex
21+
22+type PubSubT t tag m = EventWriterT t [DSum tag Identity] (ReaderT (Event t (DMap tag Identity)) m)
23+
24+-- | 'PubSub' enables you to broadcast events from anywhere in your reflex network to
25+-- any location that is subscribed to the topic they are published to. Topics are best
26+-- representated as constructors of some custom GADT which carries a phantom type to
27+-- constrain the messages that can be published to it.
28+class (Reflex t, Monad m, Semigroup a) => PubSub t tag m a where
29+ publish :: tag a -> Event t a -> m ()
30+ subscribe :: tag a -> m (Event t a)
31+
32+runPubSubT :: (MonadFix m, Has Semigroup tag, GCompare tag, Reflex t) => PubSubT t tag m a -> m a
33+runPubSubT pubSub = mdo
34+ (result, publishE) <- runReaderT (runEventWriterT pubSub) $
35+ fromListWithKey (\k v1 v2 -> has @Semigroup k (v1 <> v2)) <$> publishE
36+ pure result
37+
38+instance (Reflex t, Monad m, GCompare tag, Semigroup a) => PubSub t tag (PubSubT t tag m) a where
39+ publish topic payloadE =
40+ tellEvent $ (\pl -> [topic ==> pl]) <$> payloadE
41+
42+ subscribe topic = do
43+ topicPublishE <- asks $ fmap (lookup topic)
44+ pure $ fmapMaybe (fmap runIdentity) topicPublishE