Triggers instead of full state events

test/AFRPSpec.hs

@@ -1,12 +1,16 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module AFRPSpec (spec) where
 
-import Control.Arrow (arr)
+import Control.Arrow (arr, (&&&), first, left)
 import Control.Category ((>>>))
 import Control.Monad.Fix (MonadFix (..))
 import Data.Foldable (for_)
 import AFRP
 import Data.Functor.Identity (Identity (..))
 import Data.List (sort)
+import qualified Data.Set as S
+import qualified Data.Text as T
 import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime)
 import Data.UUID (nil)
 import Hedgehog
@@ -59,6 +63,7 @@ runStEff m s0 as = go m s0 as
 
 spec :: Spec
 spec = describe "AFRP" $ do
+  entitiesSpec
   holdSpec
   eventsSpec
   isEventSpec
@@ -529,3 +534,56 @@ sampleSpec = describe "sample" $ do
           out = runPure sample ps
       for_ (zip ps out) $ \((v, ev), o) ->
         o === tag v ev
+
+-- | A stateless arrow carrying a fixed entity set, for testing propagation.
+subscribed :: S.Set T.Text -> Mealy Identity Int Int
+subscribed ents = Mealy ents $ \_ _ a -> pure (a, subscribed ents)
+
+-- | Same as 'subscribed' but yields a function, for testing '<*>'.
+subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
+subscribedF ents = Mealy ents $ \_ _ a -> pure ((a +), subscribedF ents)
+
+entitiesSpec :: Spec
+entitiesSpec = describe "entities" $ do
+  it "id carries no entities" $
+    entities (arr id :: Mealy Identity Int Int) `shouldBe` S.empty
+
+  it "arr carries no entities" $
+    entities (arr (+ 1) :: Mealy Identity Int Int) `shouldBe` S.empty
+
+  it "eff carries no entities" $
+    entities (eff (\_ x -> Identity (x + 1))) `shouldBe` S.empty
+
+  it "primitive combinators carry no entities" $ do
+    entities (hold 'a') `shouldBe` S.empty
+    entities (changes @Int) `shouldBe` S.empty
+    entities edge `shouldBe` S.empty
+    entities (sliding (3 :: Int)) `shouldBe` S.empty
+
+  it "Category (.) unions entity sets" $
+    entities (subscribed (S.singleton "a") >>> subscribed (S.singleton "b"))
+      `shouldBe` S.fromList ["a", "b"]
+
+  it "Applicative (<*>) unions entity sets" $
+    entities (subscribedF (S.singleton "a") <*> subscribed (S.singleton "b"))
+      `shouldBe` S.fromList ["a", "b"]
+
+  it "Arrow (&&&) unions entity sets" $
+    entities (subscribed (S.singleton "a") &&& subscribed (S.singleton "b"))
+      `shouldBe` S.fromList ["a", "b"]
+
+  it "(>>>) unions entity sets" $
+    entities (subscribed (S.singleton "a") >>> arr id >>> subscribed (S.singleton "b"))
+      `shouldBe` S.fromList ["a", "b"]
+
+  it "left preserves the entity set" $
+    entities (left (subscribed (S.singleton "a")) :: Mealy Identity (Either Int Int) (Either Int Int))
+      `shouldBe` S.singleton "a"
+
+  it "first preserves the entity set" $
+    entities (first (subscribed (S.singleton "a")) :: Mealy Identity (Int, Int) (Int, Int))
+      `shouldBe` S.singleton "a"
+
+  it "fmap preserves the entity set" $
+    entities (fmap (+ 1) (subscribed (S.singleton "a")))
+      `shouldBe` S.singleton "a"