Triggers instead of full state events

src/AFRP.hs

@@ -40,53 +40,59 @@ import Data.Either (fromLeft)
 import Data.Bool (bool)
 import Data.Monoid (Endo(..))
 import Data.UUID (UUID)
+import qualified Data.Set as S
+import qualified Data.Text as T
 
 data Request = Request
   { requestTime :: !UTCTime
   , requestTraceId :: !UUID
-  }
-  deriving Show
+  } deriving Show
 
-newtype Mealy eff a b = Mealy
-  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) }
+-- | The set of entity ids an arrow subscribes to. Static: it does not
+-- change as the machine steps, so the runtime can read it once to build
+-- trigger subscriptions.
+data Mealy eff a b = Mealy
+  { entities :: S.Set T.Text
+  , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b)
+  }
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = Mealy $ \nt req x ->
+eff f = Mealy mempty $ \nt req x ->
   nt (f req x) >>= \b -> pure (b, eff f)
 
 instance Category (Mealy eff) where
-  id = Mealy (\_ _ x -> pure (x, id))
-  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
+  id = Mealy mempty (\_ _ x -> pure (x, id))
+  (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
     (b, g') <- g nt t a
     (c, f') <- f nt t b
     pure (c, f' . g')
 
 instance Arrow (Mealy eff) where
-  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
-  first (Mealy f) = Mealy $ \nt t (b,d) -> do
+  arr f = Mealy mempty $ \_ _ b -> pure (f b, arr f)
+  first (Mealy st f) = Mealy st $ \nt t (b,d) -> do
     (c, f') <- f nt t b
     pure ((c, d), first f')
 
 instance ArrowChoice (Mealy eff) where
-  left (Mealy f) = Mealy $ \nt t -> \case
+  left m@(Mealy st f) = Mealy st $ \nt t -> \case
     Left b -> do
       (c, f') <- f nt t b
       pure (Left c, left f')
-    Right d -> pure (Right d, left (Mealy f))
+    Right d -> pure (Right d, left m)
 
 instance ArrowLoop (Mealy eff) where
-  loop (Mealy f) = Mealy $ \nt t b -> do
+  loop (Mealy st f) = Mealy st $ \nt t b -> do
     ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
     pure (c, loop f')
 
 instance Functor (Mealy eff a) where
-  fmap f (Mealy g) = Mealy $ \nt t a -> do
+  fmap f (Mealy st g) = Mealy st $ \nt t a -> do
     (b, g') <- g nt t a
     pure (f b, fmap f g')
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
-  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
+  pure b = Mealy mempty $ \_ _ _ -> pure (b, pure b)
+  Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do
     (f', fNext) <- f nt t a
     (x', xNext) <- x nt t a
     pure (f' x', fNext <*> xNext)
@@ -97,7 +103,7 @@ data Event a
   deriving (Show, Eq, Functor, Foldable, Traversable)
 
 hold :: a -> Mealy eff (Event a) a
-hold a = Mealy $ \_ _ -> \case
+hold a = Mealy mempty $ \_ _ -> \case
   Tick -> pure (a, hold a)
   Event a' -> pure (a', hold a')
 
@@ -114,7 +120,7 @@ tag :: b -> Event a -> Event b
 tag b ev = b <$ ev
 
 switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
-switch (Mealy f) s = Mealy $ \nt t a -> do
+switch (Mealy st f) s = Mealy st $ \nt t a -> do
   ((b, ev), f') <- f nt t a
   case ev of
           Tick -> pure (b, switch f' s)
@@ -126,28 +132,28 @@ sample = arr (uncurry tag)
 preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 preMapAccum f x extract = go x
   where
-    go b = Mealy $ \_ _ a ->
+    go b = Mealy mempty $ \_ _ a ->
       let next = f b a
       in pure (extract b, go next)
 
 preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 preMapAccumRequest f x extract = go x
   where
-    go b = Mealy $ \_ t a ->
+    go b = Mealy mempty $ \_ t a ->
       let next = f t b a
       in pure (extract b, go next)
 
 mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 mapAccum f x extract = go x
   where
-    go b = Mealy $ \_ _ a ->
+    go b = Mealy mempty $ \_ _ a ->
       let next = f b a
       in pure (extract next, go next)
 
 mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
 mapAccumRequest f x extract = go x
   where
-    go b = Mealy $ \_ t a ->
+    go b = Mealy mempty $ \_ t a ->
       let next = f t b a
       in pure (extract next, go next)
 
@@ -229,10 +235,10 @@ lMerge Tick (Event a) = Event a
 edge :: Mealy eff Bool (Event ())
 edge = go False
   where
-    go True = Mealy $ \_ _ -> \case
+    go True = Mealy mempty $ \_ _ -> \case
       True -> pure (Tick, go True)
       False -> pure (Tick, go False)
-    go False = Mealy $ \_ _ -> \case
+    go False = Mealy mempty $ \_ _ -> \case
       True -> pure (Event (), go True)
       False -> pure (Tick, go False)