From 617bd255ffbf156ce664bff3e860ea24e34c8946 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 23 Oct 2026 16:00:19 +0300
Subject: [PATCH] Diagrams

---
 home-assistant-controller.cabal            |  1 +
 src/AFRP.hs                                | 46 +++++++++++-----------
 src/AFRP/Diagram.hs                        | 44 +++++++++++++++++++++
 src/HomeAssistant/Controller/Bedroom.hs    | 30 +++++++-------
 src/HomeAssistant/Controller/Children.hs   | 16 ++++----
 src/HomeAssistant/Controller/Effect.hs     | 25 +++++++-----
 src/HomeAssistant/Controller/Entity.hs     |  5 ++-
 src/HomeAssistant/Controller/Hallway.hs    |  4 +-
 src/HomeAssistant/Controller/Kitchen.hs    | 16 ++++----
 src/HomeAssistant/Controller/Livingroom.hs |  8 ++--
 10 files changed, 124 insertions(+), 71 deletions(-)
 create mode 100644 src/AFRP/Diagram.hs

diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal
index c422e07..c986e26 100644
--- a/home-assistant-controller.cabal
+++ b/home-assistant-controller.cabal
@@ -60,6 +60,7 @@ library
 
     -- Modules exported by the library.
     exposed-modules:  AFRP
+                    , AFRP.Diagram
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
                     , HomeAssistant.Controller.Children
diff --git a/src/AFRP.hs b/src/AFRP.hs
index ff7a046..e1a038b 100644
--- a/src/AFRP.hs
+++ b/src/AFRP.hs
@@ -5,7 +5,7 @@ module AFRP
   , Auto(..)
   , DecodedAuto(..)
   , eff
-  , withEntities
+  , named
   , Event(..)
   , hold
   , holdKnown
@@ -67,6 +67,8 @@ import qualified Data.Conduit.Cereal as CC
 import qualified Conduit as C
 import Control.Monad.Catch (MonadCatch, handle)
 import Control.Exception.Annotated (throw)
+import AFRP.Diagram
+import Data.Text (Text)
 
 
 data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
@@ -257,54 +259,54 @@ load path a = handle defaultOnMissingFile (flip deserialize a <$> liftIO (B.read
       | isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
       | otherwise = throw e
 
+
 -- | 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
+  , runDiagramC :: forall x. (DiagramF x -> x) -> x
   , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b
   }
 
+-- Provide a name
+named :: Text -> Mealy eff a b -> Mealy eff a b
+named n f = f{runDiagramC = \run -> run (Step n (emptyDiagram run))}
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
-  Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt -> af nt <> bf nt
+  Mealy ast ad af <> Mealy bst bd bf = Mealy (ast <> bst) (combineDiagram Merge ad bd) $ \nt -> af nt <> bf nt
 
 
 instance Monoid b => Monoid (Mealy eff a b) where
-  mempty = Mealy mempty $ \_nt -> mempty
+  mempty = Mealy mempty emptyDiagram $ \_nt -> mempty
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = Mealy mempty $ \nt -> do
+eff f = Mealy mempty emptyDiagram $ \nt -> do
   Stateful (Codec get put) (State () False) $ \s req a -> do
     b <- nt (f req a)
     pure (b, s)
 
--- | Override the static entity set of an arrow. Use when a combinator
--- (e.g. 'switch') hides continuation entities from the runtime's
--- startup subscription scan.
-withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
-withEntities es (Mealy _ f) = Mealy es f
 
 instance Category (Mealy eff) where
   {- HLINT ignore "Use const" -}
-  id = Mealy mempty $ \_nt -> id
-  (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do
+  id = Mealy mempty emptyDiagram $ \_nt -> id
+  (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then ad bd) $ \nt -> do
     f nt . g nt
 
 instance Arrow (Mealy eff) where
-  arr f = Mealy mempty $ \_nt -> arr f
-  first (Mealy st f) = Mealy st $ \nt -> first (f nt)
+  arr f = Mealy mempty emptyDiagram $ \_nt -> arr f
+  first (Mealy st d f) = Mealy st d $ \nt -> first (f nt)
 
 instance ArrowChoice (Mealy eff) where
-  left (Mealy st f) = Mealy st $ \nt -> left (f nt)
+  left (Mealy st d f) = Mealy st d $ \nt -> left (f nt)
 
 
 instance Functor (Mealy eff a) where
-  fmap f (Mealy st g) = Mealy st $ \nt -> fmap f (g nt)
+  fmap f (Mealy st d g) = Mealy st d $ \nt -> fmap f (g nt)
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy mempty $ \_ -> pure b
-  Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt ->
+  pure b = Mealy mempty emptyDiagram $ \_ -> pure b
+  Mealy ast ad f <*> Mealy bst bd x = Mealy (ast <> bst) (combineDiagram Compose ad bd) $ \nt ->
     f nt <*> x nt
 
 data Event a
@@ -369,10 +371,10 @@ preMapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure
 
 
 mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccum step x extract = Mealy mempty $ \_nt -> mapAccum' step x extract
+mapAccum step x extract = Mealy mempty emptyDiagram $ \_nt -> mapAccum' step x extract
 
 preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccum step x extract = Mealy mempty $ \_nt -> preMapAccum' step x extract
+preMapAccum step x extract = Mealy mempty emptyDiagram $ \_nt -> preMapAccum' step x extract
 
 mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
 mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
@@ -381,7 +383,7 @@ mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ s
     step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
 
 preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccumRequest step x extract = Mealy mempty $ \_ -> preMapAccumRequest' step x extract
+preMapAccumRequest step x extract = Mealy mempty emptyDiagram $ \_ -> preMapAccumRequest' step x extract
 
 preMapAccumRequest' :: forall m x a b. (Serialize x, Eq x, Monad m) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
 preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
@@ -390,7 +392,7 @@ preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s r
     step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
 
 mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccumRequest step x extract = Mealy mempty $ \_ -> mapAccumRequest' step x extract
+mapAccumRequest step x extract = Mealy mempty emptyDiagram $ \_ -> mapAccumRequest' step x extract
 
 mapAccumRequest' :: forall m x a b. (Monad m, Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
 mapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
@@ -606,7 +608,7 @@ requestLocalTime :: Request -> LocalTime
 requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
 
 currentTime :: Mealy eff a LocalTime
-currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
+currentTime = Mealy mempty emptyDiagram $ \_nt -> Fun $ \req _ ->
   requestLocalTime req
 
 
diff --git a/src/AFRP/Diagram.hs b/src/AFRP/Diagram.hs
new file mode 100644
index 0000000..073f9b8
--- /dev/null
+++ b/src/AFRP/Diagram.hs
@@ -0,0 +1,44 @@
+module AFRP.Diagram where
+import Data.Text (Text)
+import qualified Text.Printf as Text
+import qualified Data.Text as T
+
+-- For rendering the arrows
+data DiagramF f
+  = Empty
+  | Step Text f -- Named step
+  | Then f f -- >>>
+  | Both f f -- &&&
+  | Branch f f -- |||
+  | Merge f f -- <>
+  | Compose f f -- <*>
+
+type DiagramAlgebra a = DiagramF a -> a
+type DiagramC= forall a. DiagramAlgebra a -> a
+
+combineDiagram :: (forall a. a -> a -> DiagramF a) -> DiagramC -> DiagramC -> DiagramC
+combineDiagram constructor a b r = r (constructor (a r) (b r))
+
+emptyDiagram :: DiagramC
+emptyDiagram r = r Empty
+
+
+renderF :: DiagramF (Maybe String) -> Maybe String
+renderF = \case
+  Empty -> Nothing
+  Step n x -> Just $ T.unpack n <> maybe "" (Text.printf "( %s )") x
+  Then (Just a) (Just b) -> Just $ a <> " -> " <> b
+  Then (Just a) _ -> Just a
+  Then _ b -> b
+  Both (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Both (Just a) _ -> Just a
+  Both _ b -> b
+  Branch (Just a) (Just b) -> Just $ Text.printf "(%s || %s)" a b
+  Branch (Just a) Nothing -> Just $ Text.printf "(%s || <skip>)" a
+  Branch _ b -> b
+  Merge (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Merge (Just a) _ -> Just a
+  Merge _ b -> b
+  Compose (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Compose (Just a) _ -> Just a
+  Compose _ b -> b
diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs
index 99bf234..c6ed2a6 100644
--- a/src/HomeAssistant/Controller/Bedroom.hs
+++ b/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
diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs
index 24e3b1e..02eaae6 100644
--- a/src/HomeAssistant/Controller/Children.hs
+++ b/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
diff --git a/src/HomeAssistant/Controller/Effect.hs b/src/HomeAssistant/Controller/Effect.hs
index 48ab98b..64250a0 100644
--- a/src/HomeAssistant/Controller/Effect.hs
+++ b/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
diff --git a/src/HomeAssistant/Controller/Entity.hs b/src/HomeAssistant/Controller/Entity.hs
index 4819ffe..70e6890 100644
--- a/src/HomeAssistant/Controller/Entity.hs
+++ b/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)
diff --git a/src/HomeAssistant/Controller/Hallway.hs b/src/HomeAssistant/Controller/Hallway.hs
index 248b3b7..c7c34ee 100644
--- a/src/HomeAssistant/Controller/Hallway.hs
+++ b/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)
diff --git a/src/HomeAssistant/Controller/Kitchen.hs b/src/HomeAssistant/Controller/Kitchen.hs
index 0fd49f9..728ff73 100644
--- a/src/HomeAssistant/Controller/Kitchen.hs
+++ b/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
diff --git a/src/HomeAssistant/Controller/Livingroom.hs b/src/HomeAssistant/Controller/Livingroom.hs
index 9d4c035..1c24258 100644
--- a/src/HomeAssistant/Controller/Livingroom.hs
+++ b/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 -< ()