Rename light observation layer (LightStatus, lightSignal, brightness, temperature)
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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)})
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user