Diagrams

src/HomeAssistant/Controller/Bedroom.hs

@@ -69,12 +69,12 @@ bedroomPresenceController = proc x -> do
   _ <- AFRP.changes >>> traceEvent -< snap
   case p of
        Event LightingOff -> do
-         callService (light bedroomLightTargets Off) -< ()
+         callService "Turn off lights" (light bedroomLightTargets Off) -< ()
        Event LightingOn -> do
-         callServicesDyn (\(c,xs) -> concatMap (uncurry (toLight c)) xs) -< (capped, M.toList (getSnapshot snap))
+         callServicesDyn "Turn on lights (capped)" (\(c,xs) -> concatMap (uncurry (toLight c)) xs) -< (capped, M.toList (getSnapshot snap))
          returnA -< ()
        Event LightingSleep -> do
-         callService (activateScene "scene.makuuhuone_lepotila") -< ()
+         callService "Turn on sleep" (activateScene "scene.makuuhuone_lepotila") -< ()
        _ -> returnA -< ()
   where
     toLight :: Bool -> T.Text -> LightObservation -> [Service]
@@ -110,21 +110,21 @@ bedroomButtonController = proc x -> do
   -- Any event will cause the sleep mode to be turned off
   case ev of
        Event (Masse (OnButton ShortRelease)) -> do
-         callService (activateScene "scene.makuuhuone_masse") -< ()
+         callService  "scene.makuuhuone_masse" (activateScene "scene.makuuhuone_masse") -< ()
        Event (Masse (OnButton DoubleClick)) -> do
-         callService (activateScene "scene.makuuhuone_keski") -< ()
+         callService  "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
        Event (Masse (OnButton LongClick)) -> do
-         callService (activateScene "scene.makuuhuone_kirkas") -< ()
+         callService  "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
        Event (Masse (OffButton _)) -> do
-         callService (light [AreaId "makuuhuone"] Off) -< ()
+         callService  "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
        Event (Enishen (OnButton ShortRelease)) -> do
-         callService (activateScene "scene.makuuhuone_jemina") -< ()
+         callService  "scene.makuuhuone_jemina" (activateScene "scene.makuuhuone_jemina") -< ()
        Event (Enishen (OnButton DoubleClick)) -> do
-         callService (activateScene "scene.makuuhuone_keski") -< ()
+         callService  "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
        Event (Enishen (OnButton LongClick)) -> do
-         callService (activateScene "scene.makuuhuone_kirkas") -< ()
+         callService  "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
        Event (Enishen (OffButton _)) -> do
-         callService (light [AreaId "makuuhuone"] Off) -< ()
+         callService  "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
        _ -> returnA -< ()
 
 
@@ -137,8 +137,8 @@ bedroomDrawerController :: HASS (Event Value) ()
 bedroomDrawerController = proc x -> do
   st <- drawer >>> traceEvent -< x
   case st of
-       Event Open -> callService (switchService [entity] True) -< ()
-       Event Closed -> callService (switchService [entity] False) -< ()
+       Event Open -> callService "drawer light on" (switchService [entity] True) -< ()
+       Event Closed -> callService "drawer light off" (switchService [entity] False) -< ()
        _ -> returnA -< ()
   where
     entity = EntityId "switch.bedroom_drawer_light_masse"
@@ -163,8 +163,8 @@ humidifierController = proc x -> do
   case st of
        -- Turn the humidifier on when the door is closed
        -- the humidifier is low-powered, no point in losing all the humidity
-       Event Open -> callService (humidifier False) -< ()
-       Event Closed -> callService (humidifier True) -< ()
+       Event Open -> callService "Humidifier off" (humidifier False) -< ()
+       Event Closed -> callService "Humidifier on" (humidifier True) -< ()
        _ -> returnA -< ()
   where
     humidifier state = Service

src/HomeAssistant/Controller/Children.hs

@@ -85,11 +85,11 @@ schoolLightController = lightsOn <> lightsOff
 
 lightsOn :: HASS a ()
 lightsOn = foldMap atTime timersOn
-  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] (On def{lightBrightness=Just $ BrightnessPercent 100} )))
+  >>> AFRP.onEvent (callService "Lights on" (light [AreaId "lasten_makuuhuone"] (On def{lightBrightness=Just $ BrightnessPercent 100} )))
 
 lightsOff :: HASS a ()
 lightsOff = foldMap atTime timersOff
-  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off))
+  >>> AFRP.onEvent (callService "Lights off" (light [AreaId "lasten_makuuhuone"] Off))
 
 
 childrenBedroomButton :: HASS   (Event Value) (Event (IkeaButton IkeaGesture))
@@ -99,10 +99,10 @@ childrenBedroomButtonController :: HASS (Event Value) ()
 childrenBedroomButtonController = proc x -> do
   ev <- childrenBedroomButton >>> traceEvent -< x
   case ev of
-       Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< ()
-       Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< ()
-       Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< ()
-       Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< ()
+       Event (OnButton ShortRelease) -> callService  "scene.lasten_nukkuvalmistelu" (activateScene "scene.lasten_nukkuvalmistelu") -< ()
+       Event (OnButton DoubleClick) -> callService  "scene.lasten_luku" (activateScene "scene.lasten_luku") -< ()
+       Event (OnButton LongClick) -> callService  "scene.lasten_kirkas" (activateScene "scene.lasten_kirkas") -< ()
+       Event (OffButton _) -> callService  "Lights off" (light [AreaId "lasten_makuuhuone"] Off) -< ()
        _ -> returnA -< ()
 
 newtype PM25 = PM25 Float
@@ -153,8 +153,8 @@ childrenAirFilterController = proc ev -> do
   humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev
   case level of
        Event PM25High ->
-         AFRP.whenA (== Just Idle) (callService (fanOnTo (Percentage 80))) -< humidifier
-       Event PM25Low -> callService (fanOnTo (Percentage 20)) -< ()
+         AFRP.whenA (== Just Idle) (callService "Fan strong" (fanOnTo (Percentage 80))) -< humidifier
+       Event PM25Low -> callService "Fan low" (fanOnTo (Percentage 20)) -< ()
        _ -> returnA -< ()
   where
     fanOnTo percentage = Service

src/HomeAssistant/Controller/Effect.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module HomeAssistant.Controller.Effect
   ( HASSEff(..)
@@ -13,9 +14,10 @@ module HomeAssistant.Controller.Effect
   , traceValue
   ) where
 
-import AFRP (Mealy, eff, Event (..), Request)
+import AFRP (Mealy, eff, Event (..), Request, named)
 import Control.Arrow (returnA)
-import HomeAssistant.Controller.Service (Service)
+import HomeAssistant.Controller.Service (Service (..))
+import qualified Data.Text as T
 
 data HASSEff a where
   CallService :: Request -> Service -> HASSEff ()
@@ -25,17 +27,20 @@ data HASSEff a where
 
 type HASS a b = Mealy HASSEff a b
 
-callService :: Service -> HASS a ()
-callService service = eff (\req _ -> CallService req service)
+serviceLabel :: T.Text -> HASS a b -> HASS a b
+serviceLabel lbl = named ("Service: " <> lbl)
 
-callServices :: [Service] -> HASS a ()
-callServices service = eff (\req _ -> CallServices req service)
+callService :: T.Text -> Service -> HASS a ()
+callService lbl service = serviceLabel lbl $ eff (\req _ -> CallService req service)
 
-callServiceDyn :: (a -> Service) -> HASS a ()
-callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
+callServices :: T.Text -> [Service] -> HASS a ()
+callServices lbl service = serviceLabel lbl $ eff (\req _ -> CallServices req service)
 
-callServicesDyn :: (a -> [Service]) -> HASS a ()
-callServicesDyn mkService = eff (\req a -> CallServices req (mkService a))
+callServiceDyn :: T.Text -> (a -> Service) -> HASS a ()
+callServiceDyn lbl mkService = serviceLabel lbl $ eff (\req a -> CallService req (mkService a))
+
+callServicesDyn :: T.Text -> (a -> [Service]) -> HASS a ()
+callServicesDyn lbl mkService = serviceLabel lbl $ eff (\req a -> CallServices req (mkService a))
 
 debug :: Show a => HASS a a
 debug = proc x -> do

src/HomeAssistant/Controller/Entity.hs

@@ -10,7 +10,7 @@ module HomeAssistant.Controller.Entity
   , entityBool'
   ) where
 
-import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent)
+import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent, named)
 import Control.Arrow (arr)
 import Control.Category ((>>>))
 import Data.Aeson (Value)
@@ -19,12 +19,13 @@ import qualified Data.Text as T
 import qualified Data.Set as S
 import Control.Lens (has, only, (^?), to)
 import qualified Data.Text.Lens as TL
+import AFRP.Diagram (emptyDiagram)
 
 entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
 entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
 
 entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
-entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity)
+entityChangeEvent' entityId = named entityId $ Mealy (S.singleton entityId) emptyDiagram $ runMealy (events >>| filterA isEntity)
   where
     isEntity :: Value -> Bool
     isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId)

src/HomeAssistant/Controller/Hallway.hs

@@ -24,8 +24,8 @@ hallwayLightsController = proc x -> do
   traceEvent -< ev
   case ev of
        -- The lights entity is a "group of lights" in hass
-       Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
-       Event LightingOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
+       Event LightingOn | lightsAllowed now -> callServiceDyn "Lights on" (light [EntityId "light.hallway_lights"]) -< On def
+       Event LightingOff -> callServiceDyn "Lights off" (light [EntityId "light.hallway_lights"]) -< Off
        _ -> returnA -< ()
   where
     lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Controller/Kitchen.hs

@@ -23,8 +23,8 @@ kitchenCeilingController = proc x -> do
   ev <- lightingModeEvents -< p
   traceEvent -< ev
   case ev of
-       Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
-       Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
+       Event LightingOn | lightsAllowed now -> callServiceDyn  "light.kitchen_ceiling on" (light [EntityId "light.kitchen_ceiling"]) -< On def
+       Event LightingOff -> callServiceDyn  "light.kitchen_ceiling off" (light [EntityId "light.kitchen_ceiling"]) -< Off
        _ -> returnA -< ()
   where
     lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
@@ -64,16 +64,16 @@ dinnerTableController = proc x -> do
   ev <- dinnerLightEvents -< x
   case ev of
        Event LightingOn -> do
-         sleep -< False
-         callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
+         sleep "sleep off"-< False
+         callServiceDyn "Dining light on" (light [EntityId "light.kitchen_dining_large"]) -< On def
        Event LightingOff -> do
-         sleep -< False
-         callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off
+         sleep "sleep off" -< False
+         callServiceDyn "Dining light off" (light [EntityId "light.kitchen_dining_large"]) -< Off
        Event LightingSleep -> do
-         sleep -< True
+         sleep "sleep on" -< True
        _ -> returnA -< ()
   where
-    sleep = callServiceDyn (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
+    sleep lbl = callServiceDyn lbl (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
 
 kitchenMotionController :: HASS (Event Value) ()
 kitchenMotionController = kitchenCeilingController <> dinnerTableController

src/HomeAssistant/Controller/Livingroom.hs

@@ -39,8 +39,8 @@ livingroomPresenceController = proc x -> do
   ev <- lightingModeEvents . livingroomPresence -< x
   traceEvent -< ev
   case ev of
-       AFRP.Event LightingOn -> callServiceDyn (light livingroomLightTargets) -< On def
-       AFRP.Event LightingOff -> callServiceDyn (light livingroomLightTargets) -< Off
+       AFRP.Event LightingOn -> callServiceDyn "Lights on" (light livingroomLightTargets) -< On def
+       AFRP.Event LightingOff -> callServiceDyn "Lights off" (light livingroomLightTargets) -< Off
        _ -> returnA -< ()
   returnA -< ()
 
@@ -88,6 +88,6 @@ livingroomPlantLights = (season &&& tod)
   where
     setLights = proc mode -> do
       case mode of
-           AFRP.Event Growth -> callService (activateScene "scene.olohuoneen_kasvivalo") -< ()
-           AFRP.Event Ambience -> callService (activateScene "scene.kasvivalo_iltatila") -< ()
+           AFRP.Event Growth -> callService  "scene.olohuoneen_kasvivalo" (activateScene "scene.olohuoneen_kasvivalo") -< ()
+           AFRP.Event Ambience -> callService  "scene.kasvivalo_iltatila" (activateScene "scene.kasvivalo_iltatila") -< ()
            _ -> returnA -< ()