Rename light observation layer (LightStatus, lightSignal, brightness, temperature)

This commit is contained in:
2026-09-29 23:19:34 +03:00
parent 7ce994e814
commit ad023a1ba2
2 changed files with 28 additions and 29 deletions
+23 -24
View File
@@ -3,7 +3,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE DuplicateRecordFields #-}
module HomeAssistant.Controller
( Service(..)
@@ -30,10 +29,11 @@ module HomeAssistant.Controller
, traceValue
, switch
, Target(..)
, brightness
, lightBrightnessEvent
, lightTemperatureEvent
, LightCommand(..)
, lightSignal
, LightStatus(..)
, observedLight
, LightSnapshot(..)
, ikeaQuickButton
, IkeaButton(..)
, IkeaGesture(..)
@@ -169,11 +169,11 @@ instance Default LightAttributes where
formatLightAttributes :: LightAttributes -> Maybe Value
formatLightAttributes LightAttributes{lightBrightness, lightColorTemperature, lightTransition} = toObject $ catMaybes
[ ["transition" .= x | x <- lightTransition]
, ["color_temp_kelvin" .= k | k <- lightColorTemperature]
, ["brightness" .= b | BrightnessAbsolute b <- lightBrightness]
, ["brightness_pct" .= b | BrightnessPercent b <- lightBrightness]
formatLightAttributes s = toObject $ catMaybes
[ ["transition" .= x | x <- lightTransition s]
, ["color_temp_kelvin" .= k | k <- lightColorTemperature s]
, ["brightness" .= b | BrightnessAbsolute b <- lightBrightness s]
, ["brightness_pct" .= b | BrightnessPercent b <- lightBrightness s]
]
where
toObject :: [Pair] -> Maybe Value
@@ -238,37 +238,36 @@ entityRead entityId = entityRead' entityId >>> toEvent
entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
entityBool entityId = entityBool' entityId >>> toEvent
brightness :: T.Text -> HASS (Event Value) (Event Int)
brightness entityId =
lightBrightnessEvent :: T.Text -> HASS (Event Value) (Event Int)
lightBrightnessEvent entityId =
entityChangeEvent' entityId
>>| arr (maybe (Left ()) Right . eventBrightness)
>>> AFRP.toEvent
where
eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral
temperature :: T.Text -> HASS (Event Value) (Event Int)
temperature entityId =
lightTemperatureEvent :: T.Text -> HASS (Event Value) (Event Int)
lightTemperatureEvent entityId =
entityChangeEvent' entityId
>>| arr (maybe (Left ()) Right . eventTemperature)
>>> AFRP.toEvent
where
eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral
-- XXX: Needs better name
data LightStatus = LightStatus
{ lightEnabled :: Bool
, lightBrightness :: Int
, lightTemperature :: Int
data LightSnapshot = LightSnapshot
{ observedOn :: Bool
, observedBrightness :: Int
, observedTemperature :: Int
}
deriving (Show, Generic, Eq)
instance Serialize LightStatus
instance Serialize LightSnapshot
lightSignal :: T.Text -> HASS (Event Value) LightStatus
lightSignal entityId = proc ev -> do
observedLight :: T.Text -> HASS (Event Value) LightSnapshot
observedLight entityId = proc ev -> do
e <- hold False . entityBool entityId -< ev
b <- hold 0 . brightness entityId -< ev
t <- hold 0 . temperature entityId -< ev
returnA -< LightStatus e b t
b <- hold 0 . lightBrightnessEvent entityId -< ev
t <- hold 0 . lightTemperatureEvent entityId -< ev
returnA -< LightSnapshot e b t
data IkeaGesture
= ShortClick
+5 -5
View File
@@ -55,8 +55,8 @@ presenceLightEvents =
offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff)
bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightStatus)
bedroomLightsSignal = M.fromList <$> traverse (\e -> (e,) <$> lightSignal e) [e | EntityId e <- bedroomLights]
bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightSnapshot)
bedroomLightsSignal = M.fromList <$> traverse (\e -> (e,) <$> observedLight e) [e | EntityId e <- bedroomLights]
bedroomPresenceController :: HASS (Event Value) ()
bedroomPresenceController = proc x -> do
@@ -76,9 +76,9 @@ bedroomPresenceController = proc x -> do
where
-- This is the meat of this change. To support transitioning the brightness, exactly,
-- we need to do the brightness call separately and last
toLight :: T.Text -> LightStatus -> [Service]
toLight entityId LightStatus{lightEnabled=False} = [light [EntityId entityId] Off]
toLight entityId LightStatus{lightEnabled=True, lightTemperature=t, lightBrightness=b} =
toLight :: T.Text -> LightSnapshot -> [Service]
toLight entityId LightSnapshot{observedOn=False} = [light [EntityId entityId] Off]
toLight entityId LightSnapshot{observedOn=True, observedTemperature=t, observedBrightness=b} =
[ light [EntityId entityId] (On def{lightColorTemperature=Just t})
, light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
]