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