MasseR/home-assistant-controller
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Unify per-room Lights enums into shared LightingMode

Browse Source
This commit is contained in:
MasseR
2026-09-29 23:38:43 +03:00
parent ad023a1ba2
commit c2426dec3d
6 changed files with 49 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files
home-assistant-controller.cabal
+1
View File
@@ -64,6 +64,7 @@ library
, HomeAssistant.Controller.Bedroom
, HomeAssistant.Controller.Hallway
, HomeAssistant.Controller.Kitchen
, HomeAssistant.Controller.Light.Mode
, HomeAssistant.Controller.Children
, HomeAssistant.Controller.Livingroom
, HomeAssistant.Controller.Ruuvi
src/HomeAssistant/Controller/Bedroom.hs
+9 -14
View File
@@ -3,6 +3,7 @@
module HomeAssistant.Controller.Bedroom where
import HomeAssistant.Controller
import HomeAssistant.Controller.Light.Mode (LightingMode (..))
import qualified Data.Text as T
import AFRP (Event (..), lMerge, duration, edge)
import Data.Aeson (Value, object, (.=))
@@ -32,17 +33,11 @@ createBedroomScene = Service
, serviceTarget= []
}
data PresenceLights
= LightsOn -- Restore lights
| LightsOff -- Timer expired, darkness
| LightsSleep -- No presence detected, sleep mode
deriving (Eq, Show)
-- Bedroom presence
bedroomPresence :: HASS (Event Value) (Event Presence)
bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy"
presenceLightEvents :: HASS (Event Value) (Event PresenceLights)
presenceLightEvents :: HASS (Event Value) (Event LightingMode)
presenceLightEvents =
bedroomPresence >>> AFRP.hold Unoccupied
>>> arr lightWanted
@@ -50,9 +45,9 @@ presenceLightEvents =
>>> arr (\(s,(o,n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n)
where
lightWanted o = o == Occupied
sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightsSleep)
onEvent = AFRP.edge >>> arr (AFRP.tag LightsOn)
offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff)
sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightingSleep)
onEvent = AFRP.edge >>> arr (AFRP.tag LightingOn)
offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightingOff)
bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightSnapshot)
@@ -63,13 +58,13 @@ bedroomPresenceController = proc x -> do
p <- presenceLightEvents >>> traceEvent -< x
snap <- (doSnapshot &&& bedroomLightsSignal) >>> AFRP.snapshot M.empty >>> traceValue -< x
case p of
Event LightsOff -> do
Event LightingOff -> do
callService (light bedroomLights Off) -< ()
Event LightsOn -> do
Event LightingOn -> do
-- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap
returnA -< ()
Event LightsSleep -> do
Event LightingSleep -> do
callService createBedroomScene -< ()
callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
_ -> returnA -< ()
@@ -83,7 +78,7 @@ bedroomPresenceController = proc x -> do
, light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
]
doSnapshot = presenceLightEvents
>>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick)
>>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick)
transition = Just $ object ["transition" .= (1:: Int)]
src/HomeAssistant/Controller/Hallway.hs
+5 -13
View File
@@ -2,7 +2,8 @@
{-# LANGUAGE Arrows #-}
module HomeAssistant.Controller.Hallway where
import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..))
import HomeAssistant.Controller (Presence, HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..))
import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
import AFRP (Event (..))
import qualified AFRP
import Data.Aeson (Value)
@@ -15,25 +16,16 @@ import Data.Default (def)
hallwayPresence :: HASS (Event Value) Presence
hallwayPresence = motion "binary_sensor.hallway_movement_occupancy" >>> motionToPresence 500
data Lights = LightsOn | LightsOff
deriving (Show)
eventLights :: HASS Presence (Event Lights)
eventLights = AFRP.changes >>> arr (fmap presenceLights)
where
presenceLights Occupied = LightsOn
presenceLights Unoccupied = LightsOff
hallwayLightsController :: HASS (Event Value) ()
hallwayLightsController = proc x -> do
now <- AFRP.currentTime -< ()
p <- hallwayPresence -< x
ev <- eventLights -< p
ev <- lightingModeEvents -< p
traceEvent -< ev
case ev of
-- The lights entity is a "group of lights" in hass
Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
Event LightsOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
Event LightingOff -> callServiceDyn (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
+11 -19
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE Arrows #-}
module HomeAssistant.Controller.Kitchen where
import HomeAssistant.Controller
import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
import AFRP (Event (..))
import qualified AFRP
import Data.Aeson (Value)
@@ -13,27 +14,18 @@ import Data.Default (def)
-- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
data Lights = LightsOn | LightsOff | LightsSleep
deriving (Show)
kitchenPresence :: HASS (Event Value) Presence
kitchenPresence = motion "binary_sensor.kitchen_movement_occupancy" >>> motionToPresence 500
eventLights :: HASS Presence (Event Lights)
eventLights = AFRP.changes >>> arr (fmap presenceLights)
where
presenceLights Occupied = LightsOn
presenceLights Unoccupied = LightsOff
kitchenCeilingController :: HASS (Event Value) ()
kitchenCeilingController = proc x -> do
now <- AFRP.currentTime -< ()
p <- kitchenPresence -< x
ev <- eventLights -< p
ev <- lightingModeEvents -< p
traceEvent -< ev
case ev of
Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
_ -> returnA -< ()
where
lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
@@ -45,7 +37,7 @@ 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 Lights)
dinnerLightEvents :: HASS (Event Value) (Event LightingMode)
dinnerLightEvents =
((,) <$> dinnerLightLevel <*> dinnerPresence)
>>> arr lightWanted
@@ -56,29 +48,29 @@ dinnerLightEvents =
onEvent =
AFRP.edge
>>> arr (fmap (const LightsOn))
>>> arr (fmap (const LightingOn))
sleepEvent =
arr not
>>> AFRP.edge
>>> arr (fmap (const LightsSleep))
>>> arr (fmap (const LightingSleep))
offEvent =
arr not
>>> AFRP.waitFor 300
>>> arr (fmap (const LightsOff))
>>> arr (fmap (const LightingOff))
dinnerTableController :: HASS (Event Value) ()
dinnerTableController = proc x -> do
ev <- dinnerLightEvents -< x
case ev of
Event LightsOn -> do
Event LightingOn -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
Event LightsOff -> do
Event LightingOff -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off
Event LightsSleep -> do
Event LightingSleep -> do
sleep -< True
_ -> returnA -< ()
where
src/HomeAssistant/Controller/Light/Mode.hs
+19
View File
@@ -0,0 +1,19 @@
module HomeAssistant.Controller.Light.Mode
( LightingMode(..)
, toLightingMode
, lightingModeEvents
) where
import HomeAssistant.Controller (Presence(..), HASS)
import qualified AFRP
import Control.Arrow (Arrow(..), (>>>))
data LightingMode = LightingOn | LightingOff | LightingSleep
deriving (Eq, Show)
toLightingMode :: Presence -> LightingMode
toLightingMode Occupied = LightingOn
toLightingMode Unoccupied = LightingOff
lightingModeEvents :: HASS Presence (AFRP.Event LightingMode)
lightingModeEvents = AFRP.changes >>> arr (fmap toLightingMode)
src/HomeAssistant/Controller/Livingroom.hs
+4 -12
View File
@@ -3,6 +3,7 @@
module HomeAssistant.Controller.Livingroom where
import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, LightCommand (..), traceEvent, callService, activateScene)
import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
import qualified AFRP
import Control.Arrow ((>>>), Arrow (..), returnA)
import Data.Aeson (Value)
@@ -11,18 +12,9 @@ import Control.Category ((.))
import Data.Time (LocalTime(..), toGregorian, TimeOfDay (..))
import Data.Default (def)
data Lights = LightsOn | LightsOff
deriving (Show)
livingroomPresence :: HASS (AFRP.Event Value) Presence
livingroomPresence = presence "binary_sensor.occupancy_olohuone_derived" >>> AFRP.hold Unoccupied
eventLights :: HASS Presence (AFRP.Event Lights)
eventLights = AFRP.changes >>> arr (fmap presenceLights)
where
presenceLights Occupied = LightsOn
presenceLights Unoccupied = LightsOff
-- There's a small race condition / corner case bug in the og implementation
-- I have a couple of lights in the Livingroom
@@ -44,11 +36,11 @@ lights = [EntityId "light.livingroom_ceiling", EntityId "light.livingroom_sofa"]
livingroomPresenceController :: HASS (AFRP.Event Value) ()
livingroomPresenceController = proc x -> do
ev <- eventLights . livingroomPresence -< x
ev <- lightingModeEvents . livingroomPresence -< x
traceEvent -< ev
case ev of
AFRP.Event LightsOn -> callServiceDyn (light lights) -< On def
AFRP.Event LightsOff -> callServiceDyn (light lights) -< Off
AFRP.Event LightingOn -> callServiceDyn (light lights) -< On def
AFRP.Event LightingOff -> callServiceDyn (light lights) -< Off
_ -> returnA -< ()
returnA -< ()