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"

test/BedroomSpec.hs

@@ -2,7 +2,8 @@
 
 module BedroomSpec (spec) where
 
-import AFRP (Event (..))
+import AFRP (Event (..), entities)
+import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Aeson (Value)
 import HomeAssistant.Controller
@@ -21,9 +22,39 @@ drawerState = Event . stateEvent "binary_sensor.bedroom_nightstand_drawer_sensor
 
 spec :: Spec
 spec = describe "Bedroom" $ do
+  entitySpec
   drawerSpec
   buttonSpec
 
+entitySpec :: Spec
+entitySpec = describe "entities" $ do
+  it "entityChangeEvent' registers its entity id" $
+    entities (entityChangeEvent' "sensor.foo")
+      `shouldBe` S.singleton "sensor.foo"
+
+  it "entityRead / entityBool inherit the entity id" $ do
+    entities (entityRead @Double "sensor.bar") `shouldBe` S.singleton "sensor.bar"
+    entities (entityBool "binary_sensor.baz") `shouldBe` S.singleton "binary_sensor.baz"
+
+  it "bedroomDrawerController subscribes to the drawer sensor" $
+    entities bedroomDrawerController
+      `shouldBe` S.singleton "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contact"
+
+  it "bedroomButtonController subscribes to both remote event entities" $
+    entities bedroomButtonController
+      `shouldBe` S.fromList
+        [ "event.bedroom_quick_remote_masse_action"
+        , "event.bedroom_quick_jemina_action"
+        ]
+
+  it "bedroomPresenceController subscribes to the presence sensor" $
+    entities bedroomPresenceController
+      `shouldBe` S.singleton "binary_sensor.presence_sensor_bedroom_occupancy"
+
+  it "humidifierController subscribes to the door sensor" $
+    entities humidifierController
+      `shouldBe` S.singleton "binary_sensor.makuuhuone_ovi_contact"
+
 drawerSpec :: Spec
 drawerSpec = describe "bedroomDrawerController" $ do
   let entity = EntityId "switch.bedroom_drawer_light_masse"

test/RuntimeSpec.hs

@@ -32,9 +32,11 @@ spec = pure ()
 -- doorEvent :: Text -> Value
 -- doorEvent state = object
 --   [ "event" .= object
---     [ "data" .= object
---       [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text)
---       , "new_state" .= object ["state" .= state]
+--     [ "variables" .= object
+--       [ "trigger" .= object
+--         [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text)
+--         , "to_state" .= object ["state" .= state]
+--         ]
 --       ]
 --     ]
 --   ]

test/Support.hs

@@ -57,25 +57,31 @@ runHASS m (a : as) =
 services :: [(b, [Service])] -> [[Service]]
 services = map snd
 
--- | Build a state-change event payload matching `entityChangeEvent'` / `entityBool'` lenses.
+-- | Build a state-trigger payload matching `entityChangeEvent'` / `entityBool'`
+-- lenses. The subscribe_trigger websocket event wraps the trigger datum under
+-- `event.variables.trigger`, with `entity_id` and `to_state.state` fields.
 stateEvent :: T.Text -> T.Text -> Value
 stateEvent entityId state = object
   [ "event" .= object
-    [ "data" .= object
-      [ "entity_id" .= entityId
-      , "new_state" .= object [ "state" .= state ]
+    [ "variables" .= object
+      [ "trigger" .= object
+        [ "entity_id" .= entityId
+        , "to_state" .= object [ "state" .= state ]
+        ]
       ]
     ]
   ]
 
--- | Build an Ikea button event payload matching `ikeaQuickButton` lenses.
+-- | Build an Ikea button trigger payload matching `ikeaQuickButton` lenses.
 buttonEvent :: T.Text -> T.Text -> Value
 buttonEvent entityId eventType = object
   [ "event" .= object
-    [ "data" .= object
-      [ "entity_id" .= entityId
-      , "new_state" .= object
-        [ "attributes" .= object [ "event_type" .= eventType ] ]
+    [ "variables" .= object
+      [ "trigger" .= object
+        [ "entity_id" .= entityId
+        , "to_state" .= object
+          [ "attributes" .= object [ "event_type" .= eventType ] ]
+        ]
       ]
     ]
   ]