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 1/4] 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 -< ()
-- 
2.56.0


From 15e50322c46cdf1013bb61288d5b9010034f3674 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 23 Oct 2026 22:55:06 +0300
Subject: [PATCH 2/4] Making the controllers more linear

Basically, the idea of `(oneBranch <> secondBranch)` instead of

```
do
x <- foo
case x of
  ...
```
---
 src/AFRP.hs                             | 30 ++++++++++++++++++++++---
 src/AFRP/Diagram.hs                     | 19 ++++++++++------
 src/HomeAssistant/Controller/Bedroom.hs | 16 +++++++------
 src/HomeAssistant/Runtime.hs            |  3 +++
 4 files changed, 51 insertions(+), 17 deletions(-)

diff --git a/src/AFRP.hs b/src/AFRP.hs
index e1a038b..883f6bc 100644
--- a/src/AFRP.hs
+++ b/src/AFRP.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE TypeOperators #-}
 
 module AFRP
   ( Mealy(..)
@@ -18,8 +20,10 @@ module AFRP
   , changes
   , whenA
   , filterA
+  , filterEvent
   , thenA
   , (>>|)
+  , (>>||)
   , toEvent
   , lMerge
   , Pair(..)
@@ -271,7 +275,7 @@ data Mealy eff a b = Mealy
 
 -- Provide a name
 named :: Text -> Mealy eff a b -> Mealy eff a b
-named n f = f{runDiagramC = \run -> run (Step n (emptyDiagram run))}
+named n f = f{runDiagramC = \run -> run (Step n (runDiagramC f run))}
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
   Mealy ast ad af <> Mealy bst bd bf = Mealy (ast <> bst) (combineDiagram Merge ad bd) $ \nt -> af nt <> bf nt
@@ -290,15 +294,19 @@ eff f = Mealy mempty emptyDiagram $ \nt -> do
 instance Category (Mealy eff) where
   {- HLINT ignore "Use const" -}
   id = Mealy mempty emptyDiagram $ \_nt -> id
-  (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then ad bd) $ \nt -> do
+  (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then bd ad) $ \nt -> do
     f nt . g nt
 
 instance Arrow (Mealy eff) where
   arr f = Mealy mempty emptyDiagram $ \_nt -> arr f
   first (Mealy st d f) = Mealy st d $ \nt -> first (f nt)
+  (Mealy ast ad f) &&& (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Both ad bd) $ \nt -> do
+    f nt &&& g nt
 
 instance ArrowChoice (Mealy eff) where
   left (Mealy st d f) = Mealy st d $ \nt -> left (f nt)
+  (Mealy ast ad f) +++ (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Branch ad bd) $ \nt -> do
+    f nt +++ g nt
 
 
 instance Functor (Mealy eff a) where
@@ -486,13 +494,29 @@ whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>>
 filterA :: (a -> Bool) -> Mealy eff a (Either () a)
 filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
 
+-- filters events through if they match the predicate
+filterEvent :: (ArrowChoice cat, Arrow cat) => (a -> Bool) -> Event a `cat` Event a
+filterEvent predicate = proc ev -> do
+  case ev of
+       Event a | predicate a -> id -< ev
+       _ -> arr (const Tick) -< ()
+
 thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
 thenA f g = f >>> arr Left ||| g
 
 (>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
 (>>|) = thenA
 
-infixl 2 >>|
+infixl 2 >>||
+
+(>>||) :: (ArrowChoice cat, Arrow cat) => cat a (Event b) -> cat b c -> cat a (Event c)
+f >>|| g = proc x -> do
+  e <- f -< x
+  case e of
+       Event e' -> g >>> arr Event -< e'
+       Tick -> arr (const Tick) -< ()
+
+infixr 3 >>|
 
 toEvent :: Mealy eff (Either () a) (Event a)
 toEvent = arr (either (const Tick) Event)
diff --git a/src/AFRP/Diagram.hs b/src/AFRP/Diagram.hs
index 073f9b8..1e2b93b 100644
--- a/src/AFRP/Diagram.hs
+++ b/src/AFRP/Diagram.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module AFRP.Diagram where
 import Data.Text (Text)
 import qualified Text.Printf as Text
@@ -23,22 +24,26 @@ emptyDiagram :: DiagramC
 emptyDiagram r = r Empty
 
 
-renderF :: DiagramF (Maybe String) -> Maybe String
+renderF :: DiagramF (Maybe T.Text) -> Maybe T.Text
 renderF = \case
   Empty -> Nothing
-  Step n x -> Just $ T.unpack n <> maybe "" (Text.printf "( %s )") x
+  Step n x -> Just $ n <> T.pack (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 b) -> Just $ T.pack $ 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 (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s || %s)" a b
+  -- I'm leaving this here. This would be technically more correct (showing
+  -- the empty branch, ie. the full if-then-else, but often we care about a
+  -- more simplistic `when` style structure
+  -- Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "(%s || <skip>)" a
+  Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "%s" a
   Branch _ b -> b
-  Merge (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Merge (Just a) (Just b) -> Just $ T.pack $ 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 b) -> Just $ T.pack $ 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 c6ed2a6..c367c10 100644
--- a/src/HomeAssistant/Controller/Bedroom.hs
+++ b/src/HomeAssistant/Controller/Bedroom.hs
@@ -5,7 +5,7 @@ module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
 import qualified Data.Text as T
-import AFRP (Event (..), lMerge, duration, edge)
+import AFRP (Event (..), lMerge, duration, edge, filterEvent, named, (>>||))
 import Data.Aeson (Value, object, (.=))
 import Control.Arrow ((>>>), returnA, arr, Arrow (..))
 import Data.Bool (bool)
@@ -134,14 +134,16 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
   >>> arr (fmap (bool Closed Open))
 
 bedroomDrawerController :: HASS (Event Value) ()
-bedroomDrawerController = proc x -> do
-  st <- drawer >>> traceEvent -< x
-  case st of
-       Event Open -> callService "drawer light on" (switchService [entity] True) -< ()
-       Event Closed -> callService "drawer light off" (switchService [entity] False) -< ()
-       _ -> returnA -< ()
+bedroomDrawerController =
+  drawer >>>
+  (named "Drawer opened" lightOn <> named "Drawer closed" lightOff)
+  >>> arr (const ())
   where
     entity = EntityId "switch.bedroom_drawer_light_masse"
+    lightOff = filterEvent (== Closed)
+      >>|| callService "drawer light off" (switchService [entity] False)
+    lightOn = filterEvent (== Open)
+      >>|| callService "drawer light on" (switchService [entity] True)
 
 door :: HASS (Event Value) (Event DoorState)
 door = entityBool "binary_sensor.makuuhuone_ovi_contact"
diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs
index 3355dbb..e6fd680 100644
--- a/src/HomeAssistant/Runtime.hs
+++ b/src/HomeAssistant/Runtime.hs
@@ -48,6 +48,7 @@ import Text.Read (readMaybe)
 import UnliftIO.Async
 import Control.Monad.Catch (MonadCatch)
 import Control.Exception.Annotated (checkpoint, Annotation (..))
+import AFRP.Diagram (renderF)
 
 step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path name trace st a = do
@@ -122,6 +123,8 @@ defaultMain =
         rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
         metricsPort <- lookupPort
         writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
+        forM_ controllers $ \(Controller n m) ->
+          logLocM InfoS $ ls $ n <> ": " <> fromMaybe "" (runDiagramC m renderF)
         let ents = foldMap (\(Controller _ m) -> entities m) controllers
             workers =
               [ ("reader", readerAction host 8123 token ents bus),
-- 
2.56.0


From 078f24e4b9c3aa97752a46f86603558aa575b367 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Fri, 23 Oct 2026 23:57:05 +0300
Subject: [PATCH 3/4] Fix tests and add tests for kitchen lights

---
 test/AFRPSpec.hs    |  5 +++--
 test/KitchenSpec.hs | 11 +++++++++--
 2 files changed, 12 insertions(+), 4 deletions(-)

diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs
index c5074a5..1d59574 100644
--- a/test/AFRPSpec.hs
+++ b/test/AFRPSpec.hs
@@ -20,6 +20,7 @@ import qualified Hedgehog.Range as Range
 import Test.Hspec
 import Test.Hspec.Hedgehog
 import Data.Maybe (listToMaybe)
+import AFRP.Diagram (emptyDiagram)
 
 fakeRequest :: Request
 fakeRequest = Request (sec 0) utc nil "test"
@@ -536,11 +537,11 @@ sampleSpec = describe "sample" $ do
 
 -- | A stateless arrow carrying a fixed entity set, for testing propagation.
 subscribed :: S.Set T.Text -> Mealy Identity Int Int
-subscribed ents = Mealy ents $ \_ -> Fun $ \_ a -> a
+subscribed ents = Mealy ents emptyDiagram $ \_ -> Fun $ \_ a -> a
 
 -- | Same as 'subscribed' but yields a function, for testing '<*>'.
 subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
-subscribedF ents = Mealy ents $ \_ -> Fun $ \_ a -> (a +)
+subscribedF ents = Mealy ents emptyDiagram $ \_ -> Fun $ \_ a -> (a +)
 
 entitiesSpec :: Spec
 entitiesSpec = describe "entities" $ do
diff --git a/test/KitchenSpec.hs b/test/KitchenSpec.hs
index ab615c1..695b1cb 100644
--- a/test/KitchenSpec.hs
+++ b/test/KitchenSpec.hs
@@ -11,6 +11,7 @@ import HomeAssistant.Controller.Kitchen
 import Support
 import Test.Hspec
 import Data.Default (def)
+import Data.Time (getCurrentTime, addUTCTime)
 
 -- Helper functions for creating test events
 testDinnerLightLevel :: Int -> Event Value
@@ -37,9 +38,15 @@ dinnerTableSpec = describe "dinnerTableController" $ do
     services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "on"])
       `shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On def)]]
 
-  it "turns lights off when presence is unoccupied" $ do
-    services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "off"])
+  it "turns lights to sleep when presence is unoccupied" $ do
+    now <- getCurrentTime
+    services (runHASSTimed dinnerTableController [(now, testDinnerLightLevel 10), (now, testDinnerPresence "off")])
       `shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], []]
+  it "turns lights off when no presence for 300 seconds" $ do
+    now <- getCurrentTime
+    let later = 305 `addUTCTime` now
+    services (runHASSTimed dinnerTableController [(now, testDinnerLightLevel 10), (now, testDinnerPresence "off"), (later, Tick)])
+      `shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [], [switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] Off]]
 
   it "does nothing on Tick" $ do
     services (runHASS dinnerTableController [Tick])
-- 
2.56.0


From 5f8b3cbe002b7678ce7e5c003bdb614c69c17cff Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Sat, 24 Oct 2026 00:18:04 +0300
Subject: [PATCH 4/4] Refactor to a more arrows style syntax

---
 src/AFRP.hs                             |  4 +--
 src/HomeAssistant/Controller/Kitchen.hs | 47 +++++++++++--------------
 2 files changed, 23 insertions(+), 28 deletions(-)

diff --git a/src/AFRP.hs b/src/AFRP.hs
index 883f6bc..66c105d 100644
--- a/src/AFRP.hs
+++ b/src/AFRP.hs
@@ -507,7 +507,7 @@ thenA f g = f >>> arr Left ||| g
 (>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
 (>>|) = thenA
 
-infixl 2 >>||
+infixl 2 >>|
 
 (>>||) :: (ArrowChoice cat, Arrow cat) => cat a (Event b) -> cat b c -> cat a (Event c)
 f >>|| g = proc x -> do
@@ -516,7 +516,7 @@ f >>|| g = proc x -> do
        Event e' -> g >>> arr Event -< e'
        Tick -> arr (const Tick) -< ()
 
-infixr 3 >>|
+infixr 1 >>||
 
 toEvent :: Mealy eff (Either () a) (Event a)
 toEvent = arr (either (const Tick) Event)
diff --git a/src/HomeAssistant/Controller/Kitchen.hs b/src/HomeAssistant/Controller/Kitchen.hs
index 728ff73..7552ee9 100644
--- a/src/HomeAssistant/Controller/Kitchen.hs
+++ b/src/HomeAssistant/Controller/Kitchen.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE Arrows #-}
 module HomeAssistant.Controller.Kitchen where
 import HomeAssistant.Controller
-import AFRP (Event (..))
+import AFRP (Event (..), (>>||))
 import qualified AFRP
 import Data.Aeson (Value)
 import Control.Arrow ((>>>), Arrow (..), returnA)
@@ -36,44 +36,39 @@ dinnerLightLevel = entityRead "sensor.sijainti_keittio_light_level" >>> AFRP.hol
 dinnerPresence :: HASS (Event Value) Presence
 dinnerPresence = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied
 
-dinnerLightEvents :: HASS (Event Value) (Event LightingMode)
-dinnerLightEvents =
+
+dinnerTableController :: HASS (Event Value) ()
+dinnerTableController =
   ((,) <$> dinnerLightLevel <*> dinnerPresence)
   >>> arr lightWanted
-  >>> (sleepEvent &&& offEvent &&& onEvent)
-  >>> arr (\(s, (o, n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n)
+  -- These are done "in parallel", there is a chance that two services are called in one go
+  >>> mconcat
+    [ AFRP.named "Lights on" lightsOn
+    , AFRP.named "Lights sleep" lightsSleep
+    , AFRP.named "Lights off" lightsOff ]
+  >>> arr (const ()) -- I don't like this extra arr here
   where
     lightWanted (lightLevel, occ) = occ == Occupied && lightLevel < 13
 
-    onEvent =
+    lightsOn =
       AFRP.edge
-      >>> arr (fmap (const LightingOn))
+      >>|| sleep "sleep off" False
+      >>> callService "Dining light on" (light [EntityId "light.kitchen_dining_large"] $ On def)
 
-    sleepEvent =
+    lightsSleep =
       arr not
       >>> AFRP.edge
-      >>> arr (fmap (const LightingSleep))
+      >>|| sleep "sleep on" True
 
-    offEvent =
+    lightsOff =
       arr not
       >>> AFRP.waitFor 300
-      >>> arr (fmap (const LightingOff))
+      >>|| sleep "sleep off" False
+      >>> callService "Dining light on" (light [EntityId "light.kitchen_dining_large"] Off)
+
+
+    sleep lbl b = callService lbl (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] b)
 
-dinnerTableController :: HASS (Event Value) ()
-dinnerTableController = proc x -> do
-  ev <- dinnerLightEvents -< x
-  case ev of
-       Event LightingOn -> do
-         sleep "sleep off"-< False
-         callServiceDyn "Dining light on" (light [EntityId "light.kitchen_dining_large"]) -< On def
-       Event LightingOff -> do
-         sleep "sleep off" -< False
-         callServiceDyn "Dining light off" (light [EntityId "light.kitchen_dining_large"]) -< Off
-       Event LightingSleep -> do
-         sleep "sleep on" -< True
-       _ -> returnA -< ()
-  where
-    sleep lbl = callServiceDyn lbl (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
 
 kitchenMotionController :: HASS (Event Value) ()
 kitchenMotionController = kitchenCeilingController <> dinnerTableController
-- 
2.56.0