Capped based on light level

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)]
 
 
 

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

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