diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index 225f405..822c5fc 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -57,11 +57,17 @@ newtype Snapshot = Snapshot { getSnapshot :: Map T.Text LightObservation } deriving (Show, Eq) deriving Serialize via (Map T.Text LightObservation) +lightLevel :: HASS (Event Value) Int +lightLevel = entityRead "sensor.presence_sensor_bedroom_light_level" >>> AFRP.hold 15 + bedroomPresenceController :: HASS (Event Value) () bedroomPresenceController = proc x -> do p <- presenceLightEvents >>> traceEvent -< x + capped <- lightLevel >>> arr (< 4) -< x + -- mode <- AFRP.hold LightingOff -< p -- This line is just for debugging purposes _ <- bedroomLightStatus >>> AFRP.changes >>> traceEvent -< x + _ <- lightLevel >>> AFRP.changes >>> traceEvent -< x snap <- (doSnapshot &&& bedroomLightStatus) >>> AFRP.snapshot M.empty >>> arr Snapshot -< x -- This line is just for debugging _ <- AFRP.changes >>> traceEvent -< snap @@ -69,23 +75,22 @@ bedroomPresenceController = proc x -> do Event LightingOff -> do callService (light bedroomLightTargets Off) -< () Event LightingOn -> do - callServicesDyn (concatMap (uncurry toLight)) -< M.toList (getSnapshot snap) + callServicesDyn (\(c,xs) -> concatMap (uncurry (toLight c)) xs) -< (capped, M.toList (getSnapshot snap)) returnA -< () Event LightingSleep -> do - callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< () + callService (activateScene "scene.makuuhuone_lepotila") -< () _ -> returnA -< () 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 -> LightObservation -> [Service] - toLight entityId LightObservation{observedOn=False} = [light [EntityId entityId] Off] - toLight entityId LightObservation{observedOn=True, observedTemperature=t, observedBrightness=b} = - [ light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness = Just (BrightnessAbsolute b), lightColorTemperature=Just t}) - -- , light [EntityId entityId] (On def{lightTransition = Just 2, lightBrightness=Just (BrightnessAbsolute b)}) + toLight :: Bool -> T.Text -> LightObservation -> [Service] + toLight _ entityId LightObservation{observedOn=False} = [light [EntityId entityId] Off] + toLight capped entityId LightObservation{observedOn=True, observedTemperature=t, observedBrightness=b} = + [ light [EntityId entityId] (On def + {lightBrightness = fmap (\b' -> BrightnessAbsolute $ if capped then 140 `min` b' else b') b + , lightColorTemperature = t + }) ] doSnapshot = presenceLightEvents >>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick) - transition = Just $ object ["transition" .= (1:: Int)] data BedroomControls @@ -109,24 +114,22 @@ bedroomButtonController = proc x -> do -- Any event will cause the sleep mode to be turned off case ev of Event (Masse (OnButton ShortRelease)) -> do - callService (activateSceneWith "scene.makuuhuone_masse" transition) -< () + callService (activateScene "scene.makuuhuone_masse") -< () Event (Masse (OnButton DoubleClick)) -> do - callService (activateSceneWith "scene.makuuhuone_keski" transition) -< () + callService (activateScene "scene.makuuhuone_keski") -< () Event (Masse (OnButton LongClick)) -> do - callService (activateSceneWith "scene.makuuhuone_kirkas" transition) -< () + callService (activateScene "scene.makuuhuone_kirkas") -< () Event (Masse (OffButton _)) -> do callService (light [AreaId "makuuhuone"] Off) -< () Event (Enishen (OnButton ShortRelease)) -> do - callService (activateSceneWith "scene.makuuhuone_jemina" transition) -< () + callService (activateScene "scene.makuuhuone_jemina") -< () Event (Enishen (OnButton DoubleClick)) -> do - callService (activateSceneWith "scene.makuuhuone_keski" transition) -< () + callService (activateScene "scene.makuuhuone_keski") -< () Event (Enishen (OnButton LongClick)) -> do - callService (activateSceneWith "scene.makuuhuone_kirkas" transition) -< () + callService (activateScene "scene.makuuhuone_kirkas") -< () Event (Enishen (OffButton _)) -> do callService (light [AreaId "makuuhuone"] Off) -< () _ -> returnA -< () - where - transition = Just $ object ["transition" .= (1 :: Int)] diff --git a/src/HomeAssistant/Controller/Light/Mode.hs b/src/HomeAssistant/Controller/Light/Mode.hs index f0c5442..245290a 100644 --- a/src/HomeAssistant/Controller/Light/Mode.hs +++ b/src/HomeAssistant/Controller/Light/Mode.hs @@ -8,9 +8,12 @@ import HomeAssistant.Controller.Effect (HASS) import HomeAssistant.Controller.Presence (Presence (..)) import qualified AFRP import Control.Arrow (Arrow(..), (>>>)) +import GHC.Generics (Generic) +import Data.Serialize (Serialize) data LightingMode = LightingOn | LightingOff | LightingSleep - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance Serialize LightingMode toLightingMode :: Presence -> LightingMode toLightingMode Occupied = LightingOn diff --git a/src/HomeAssistant/Controller/Light/Observation.hs b/src/HomeAssistant/Controller/Light/Observation.hs index b426c15..462a013 100644 --- a/src/HomeAssistant/Controller/Light/Observation.hs +++ b/src/HomeAssistant/Controller/Light/Observation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} module HomeAssistant.Controller.Light.Observation ( LightObservation(..) @@ -8,7 +9,7 @@ module HomeAssistant.Controller.Light.Observation , lightTemperatureEvent ) where -import AFRP (Event, hold, toEvent, (>>|)) +import AFRP (Event, hold) import Control.Arrow (arr, returnA) import Control.Category ((>>>), (.)) import Control.Lens ((^?)) @@ -17,30 +18,28 @@ import Data.Aeson.Lens (key, _Integral) import qualified Data.Text as T import GHC.Generics (Generic) import Data.Serialize (Serialize) -import HomeAssistant.Controller.Entity (entityChangeEvent', entityBool) +import HomeAssistant.Controller.Entity (entityBool, entityChangeEvent) import HomeAssistant.Controller.Effect (HASS) import Prelude hiding ((.)) -lightBrightnessEvent :: T.Text -> HASS (Event Value) (Event Int) +lightBrightnessEvent :: T.Text -> HASS (Event Value) (Event (Maybe Int)) lightBrightnessEvent entityId = - entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventBrightness) - >>> AFRP.toEvent + entityChangeEvent entityId + >>> arr (fmap eventBrightness) where eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral -lightTemperatureEvent :: T.Text -> HASS (Event Value) (Event Int) +lightTemperatureEvent :: T.Text -> HASS (Event Value) (Event (Maybe Int)) lightTemperatureEvent entityId = - entityChangeEvent' entityId - >>| arr (maybe (Left ()) Right . eventTemperature) - >>> AFRP.toEvent + entityChangeEvent entityId + >>> arr (fmap eventTemperature) where eventTemperature v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "color_temp_kelvin" . _Integral data LightObservation = LightObservation { observedOn :: Bool - , observedBrightness :: Int - , observedTemperature :: Int + , observedBrightness :: Maybe Int + , observedTemperature :: Maybe Int } deriving (Show, Generic, Eq) instance Serialize LightObservation @@ -48,6 +47,6 @@ instance Serialize LightObservation observedLight :: T.Text -> HASS (Event Value) LightObservation observedLight entityId = proc ev -> do e <- hold False . entityBool entityId -< ev - b <- hold 0 . lightBrightnessEvent entityId -< ev - t <- hold 0 . lightTemperatureEvent entityId -< ev + b <- hold Nothing . lightBrightnessEvent entityId -< ev + t <- hold Nothing . lightTemperatureEvent entityId -< ev returnA -< LightObservation e b t