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] 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