diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index fbd82e4..aeb06bb 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -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 diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index d337206..6dc0f68 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -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)}) ]