Unify per-room Lights enums into shared LightingMode

home-assistant-controller.cabal

@@ -64,6 +64,7 @@ library
                     , HomeAssistant.Controller.Bedroom
                     , HomeAssistant.Controller.Hallway
                     , HomeAssistant.Controller.Kitchen
+                    , HomeAssistant.Controller.Light.Mode
                     , HomeAssistant.Controller.Children
                     , HomeAssistant.Controller.Livingroom
                     , HomeAssistant.Controller.Ruuvi

src/HomeAssistant/Controller/Bedroom.hs

@@ -3,6 +3,7 @@
 module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
+import HomeAssistant.Controller.Light.Mode (LightingMode (..))
 import qualified Data.Text as T
 import AFRP (Event (..), lMerge, duration, edge)
 import Data.Aeson (Value, object, (.=))
@@ -32,17 +33,11 @@ createBedroomScene = Service
   , serviceTarget= []
   }
 
-data PresenceLights
-  = LightsOn -- Restore lights
-  | LightsOff -- Timer expired, darkness
-  | LightsSleep -- No presence detected, sleep mode
-  deriving (Eq, Show)
-
 -- Bedroom presence
 bedroomPresence :: HASS (Event Value) (Event Presence)
 bedroomPresence = presence "binary_sensor.presence_sensor_bedroom_occupancy"
 
-presenceLightEvents :: HASS (Event Value) (Event PresenceLights)
+presenceLightEvents :: HASS (Event Value) (Event LightingMode)
 presenceLightEvents =
   bedroomPresence >>> AFRP.hold Unoccupied
   >>> arr lightWanted
@@ -50,9 +45,9 @@ presenceLightEvents =
   >>> arr (\(s,(o,n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n)
   where
     lightWanted o = o == Occupied
-    sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightsSleep)
+    sleepEvent = arr not >>> AFRP.edge >>> arr (AFRP.tag LightingSleep)
-    onEvent = AFRP.edge >>> arr (AFRP.tag LightsOn)
+    onEvent = AFRP.edge >>> arr (AFRP.tag LightingOn)
-    offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightsOff)
+    offEvent = arr not >>> AFRP.waitFor 300 >>> arr (AFRP.tag LightingOff)
 
 
 bedroomLightsSignal :: HASS (Event Value) (Map T.Text LightSnapshot)
@@ -63,13 +58,13 @@ bedroomPresenceController = proc x -> do
   p <- presenceLightEvents >>> traceEvent -< x
   snap <- (doSnapshot &&& bedroomLightsSignal) >>> AFRP.snapshot M.empty >>> traceValue -< x
   case p of
-       Event LightsOff -> do
+       Event LightingOff -> do
          callService (light bedroomLights Off) -< ()
-       Event LightsOn -> do
+       Event LightingOn -> do
          -- callService (activateSceneWith "scene.makuuhuone_lights_snapshot" transition) -< ()
          callServicesDyn (concatMap (uncurry toLight)) -< M.toList snap
          returnA -< ()
-       Event LightsSleep -> do
+       Event LightingSleep -> do
          callService createBedroomScene -< ()
          callService (activateSceneWith "scene.makuuhuone_lepotila" transition) -< ()
        _ -> returnA -< ()
@@ -83,7 +78,7 @@ bedroomPresenceController = proc x -> do
       , light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
       ]
     doSnapshot = presenceLightEvents
-      >>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick)
+      >>> arr (\ev -> if ev == Event LightingSleep then Event () else Tick)
     transition = Just $ object ["transition" .= (1:: Int)]
 
 

src/HomeAssistant/Controller/Hallway.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE Arrows #-}
 module HomeAssistant.Controller.Hallway where
 
-import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..))
+import HomeAssistant.Controller (Presence, HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..))
+import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
 import AFRP (Event (..))
 import qualified AFRP
 import Data.Aeson (Value)
@@ -15,25 +16,16 @@ import Data.Default (def)
 hallwayPresence :: HASS (Event Value) Presence
 hallwayPresence = motion "binary_sensor.hallway_movement_occupancy" >>> motionToPresence 500
 
-data Lights = LightsOn | LightsOff
-  deriving (Show)
-
-eventLights :: HASS Presence (Event Lights)
-eventLights = AFRP.changes >>> arr (fmap presenceLights)
-  where
-    presenceLights Occupied = LightsOn
-    presenceLights Unoccupied = LightsOff
-
 hallwayLightsController :: HASS (Event Value) ()
 hallwayLightsController = proc x -> do
   now <- AFRP.currentTime -< ()
   p <- hallwayPresence -< x
-  ev <- eventLights -< p
+  ev <- lightingModeEvents -< p
   traceEvent -< ev
   case ev of
        -- The lights entity is a "group of lights" in hass
-       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
+       Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
-       Event LightsOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
+       Event LightingOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
        _ -> returnA -< ()
   where
     lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Controller/Kitchen.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE Arrows #-}
 module HomeAssistant.Controller.Kitchen where
 import HomeAssistant.Controller
+import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
 import AFRP (Event (..))
 import qualified AFRP
 import Data.Aeson (Value)
@@ -13,27 +14,18 @@ import Data.Default (def)
 
 -- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
 
-data Lights = LightsOn | LightsOff | LightsSleep
-  deriving (Show)
-
 kitchenPresence :: HASS (Event Value) Presence
 kitchenPresence = motion "binary_sensor.kitchen_movement_occupancy" >>> motionToPresence 500
 
-eventLights :: HASS Presence (Event Lights)
-eventLights = AFRP.changes >>> arr (fmap presenceLights)
-  where
-    presenceLights Occupied = LightsOn
-    presenceLights Unoccupied = LightsOff
-
 kitchenCeilingController :: HASS (Event Value) ()
 kitchenCeilingController = proc x -> do
   now <- AFRP.currentTime -< ()
   p <- kitchenPresence -< x
-  ev <- eventLights -< p
+  ev <- lightingModeEvents -< p
   traceEvent -< ev
   case ev of
-       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
+       Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
-       Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
+       Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
        _ -> returnA -< ()
   where
     lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
@@ -45,7 +37,7 @@ dinnerLightLevel = entityRead "sensor.sijainti_keittio_light_level" >>> AFRP.hol
 dinnerPresence :: HASS (Event Value) Presence
 dinnerPresence = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied
 
-dinnerLightEvents :: HASS (Event Value) (Event Lights)
+dinnerLightEvents :: HASS (Event Value) (Event LightingMode)
 dinnerLightEvents =
   ((,) <$> dinnerLightLevel <*> dinnerPresence)
   >>> arr lightWanted
@@ -56,29 +48,29 @@ dinnerLightEvents =
 
     onEvent =
       AFRP.edge
-      >>> arr (fmap (const LightsOn))
+      >>> arr (fmap (const LightingOn))
 
     sleepEvent =
       arr not
       >>> AFRP.edge
-      >>> arr (fmap (const LightsSleep))
+      >>> arr (fmap (const LightingSleep))
 
     offEvent =
       arr not
       >>> AFRP.waitFor 300
-      >>> arr (fmap (const LightsOff))
+      >>> arr (fmap (const LightingOff))
 
 dinnerTableController :: HASS (Event Value) ()
 dinnerTableController = proc x -> do
   ev <- dinnerLightEvents -< x
   case ev of
-       Event LightsOn -> do
+       Event LightingOn -> do
          sleep -< False
          callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
-       Event LightsOff -> do
+       Event LightingOff -> do
          sleep -< False
          callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off
-       Event LightsSleep -> do
+       Event LightingSleep -> do
          sleep -< True
        _ -> returnA -< ()
   where

src/HomeAssistant/Controller/Light/Mode.hs

@@ -0,0 +1,19 @@
+module HomeAssistant.Controller.Light.Mode
+  ( LightingMode(..)
+  , toLightingMode
+  , lightingModeEvents
+  ) where
+
+import HomeAssistant.Controller (Presence(..), HASS)
+import qualified AFRP
+import Control.Arrow (Arrow(..), (>>>))
+
+data LightingMode = LightingOn | LightingOff | LightingSleep
+  deriving (Eq, Show)
+
+toLightingMode :: Presence -> LightingMode
+toLightingMode Occupied   = LightingOn
+toLightingMode Unoccupied = LightingOff
+
+lightingModeEvents :: HASS Presence (AFRP.Event LightingMode)
+lightingModeEvents = AFRP.changes >>> arr (fmap toLightingMode)

src/HomeAssistant/Controller/Livingroom.hs

@@ -3,6 +3,7 @@
 module HomeAssistant.Controller.Livingroom where
 
 import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, LightCommand (..), traceEvent, callService, activateScene)
+import HomeAssistant.Controller.Light.Mode (LightingMode (..), lightingModeEvents)
 import qualified AFRP
 import Control.Arrow ((>>>), Arrow (..), returnA)
 import Data.Aeson (Value)
@@ -11,18 +12,9 @@ import Control.Category ((.))
 import Data.Time (LocalTime(..), toGregorian, TimeOfDay (..))
 import Data.Default (def)
 
-data Lights = LightsOn | LightsOff
-  deriving (Show)
-
 livingroomPresence :: HASS (AFRP.Event Value) Presence
 livingroomPresence = presence "binary_sensor.occupancy_olohuone_derived" >>> AFRP.hold Unoccupied
 
-eventLights :: HASS Presence (AFRP.Event Lights)
-eventLights = AFRP.changes >>> arr (fmap presenceLights)
-  where
-    presenceLights Occupied = LightsOn
-    presenceLights Unoccupied = LightsOff
-
 
 -- There's a small race condition / corner case bug in the og implementation
 -- I have a couple of lights in the Livingroom
@@ -44,11 +36,11 @@ lights = [EntityId "light.livingroom_ceiling", EntityId "light.livingroom_sofa"]
 
 livingroomPresenceController :: HASS (AFRP.Event Value) ()
 livingroomPresenceController = proc x -> do
-  ev <- eventLights . livingroomPresence -< x
+  ev <- lightingModeEvents . livingroomPresence -< x
   traceEvent -< ev
   case ev of
-       AFRP.Event LightsOn -> callServiceDyn (light lights) -< On def
+       AFRP.Event LightingOn -> callServiceDyn (light lights) -< On def
-       AFRP.Event LightsOff -> callServiceDyn (light lights) -< Off
+       AFRP.Event LightingOff -> callServiceDyn (light lights) -< Off
        _ -> returnA -< ()
   returnA -< ()