Rename light command layer (Light, LightSettings, BrightnessSettings)

This commit is contained in:
2026-09-29 23:14:07 +03:00
parent fefeae6301
commit 7ce994e814
6 changed files with 36 additions and 36 deletions
+23 -23
View File
@@ -3,6 +3,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE DuplicateRecordFields #-}
module HomeAssistant.Controller module HomeAssistant.Controller
( Service(..) ( Service(..)
@@ -30,7 +31,7 @@ module HomeAssistant.Controller
, switch , switch
, Target(..) , Target(..)
, brightness , brightness
, Light(..) , LightCommand(..)
, lightSignal , lightSignal
, LightStatus(..) , LightStatus(..)
, ikeaQuickButton , ikeaQuickButton
@@ -40,9 +41,9 @@ module HomeAssistant.Controller
, activateSceneWith , activateSceneWith
, ikeaBoxRemote , ikeaBoxRemote
, IkeaController(..) , IkeaController(..)
, LightSettings(..) , LightAttributes(..)
, BrightnessSettings(..) , Brightness(..)
, formatLightSettings , formatLightAttributes
) where ) where
import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge) import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
@@ -152,44 +153,43 @@ motionToPresence delay = (eventOccupied &&& eventUnoccupied)
instance Serialize Motion instance Serialize Motion
data BrightnessSettings = BrightnessPercentage Double | Brightness Int data Brightness = BrightnessPercent Double | BrightnessAbsolute Int
deriving (Show, Generic) deriving (Show, Generic)
instance Default BrightnessSettings where instance Default Brightness where
data LightSettings = LightSettings data LightAttributes = LightAttributes
{ lightSettingsBrightness :: Maybe BrightnessSettings { lightBrightness :: Maybe Brightness
, lightSettingsTemperature :: Maybe Int , lightColorTemperature :: Maybe Int
, lightSettingsTransition :: Maybe Double , lightTransition :: Maybe Double
} }
deriving (Show, Generic) deriving (Show, Generic)
instance Default LightSettings where instance Default LightAttributes where
formatLightSettings :: LightSettings -> Maybe Value formatLightAttributes :: LightAttributes -> Maybe Value
formatLightSettings s = toObject $ catMaybes formatLightAttributes LightAttributes{lightBrightness, lightColorTemperature, lightTransition} = toObject $ catMaybes
[ ["transition" .= x | x <- lightSettingsTransition s] [ ["transition" .= x | x <- lightTransition]
, ["color_temp_kelvin" .= k | k <- lightSettingsTemperature s] , ["color_temp_kelvin" .= k | k <- lightColorTemperature]
, ["brightness" .= b | Brightness b <- lightSettingsBrightness s] , ["brightness" .= b | BrightnessAbsolute b <- lightBrightness]
, ["brightness_pct" .= b | BrightnessPercentage b <- lightSettingsBrightness s] , ["brightness_pct" .= b | BrightnessPercent b <- lightBrightness]
] ]
where where
toObject :: [Pair] -> Maybe Value toObject :: [Pair] -> Maybe Value
toObject [] = Nothing toObject [] = Nothing
toObject xs = Just $ object xs toObject xs = Just $ object xs
data Light data LightCommand
= Off = Off
| On LightSettings | On LightAttributes
-- Turn off lights when door is closed -- Turn off lights when door is closed
light :: [Target] -> Light -> Service light :: [Target] -> LightCommand -> Service
light targets (On settings) = Service light targets (On settings) = Service
{ serviceDomain="light" { serviceDomain="light"
, serviceName= "turn_on" , serviceName= "turn_on"
-- , serviceData= fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage , serviceData= formatLightAttributes settings
, serviceData= formatLightSettings settings
, serviceTarget=targets , serviceTarget=targets
} }
light targets Off = Service light targets Off = Service
+2 -2
View File
@@ -79,8 +79,8 @@ bedroomPresenceController = proc x -> do
toLight :: T.Text -> LightStatus -> [Service] toLight :: T.Text -> LightStatus -> [Service]
toLight entityId LightStatus{lightEnabled=False} = [light [EntityId entityId] Off] toLight entityId LightStatus{lightEnabled=False} = [light [EntityId entityId] Off]
toLight entityId LightStatus{lightEnabled=True, lightTemperature=t, lightBrightness=b} = toLight entityId LightStatus{lightEnabled=True, lightTemperature=t, lightBrightness=b} =
[ light [EntityId entityId] (On def{lightSettingsTemperature=Just t}) [ light [EntityId entityId] (On def{lightColorTemperature=Just t})
, light [EntityId entityId] (On def{lightSettingsTransition=Just 5, lightSettingsBrightness=Just (Brightness b)}) , light [EntityId entityId] (On def{lightTransition=Just 5, lightBrightness=Just (BrightnessAbsolute b)})
] ]
doSnapshot = presenceLightEvents doSnapshot = presenceLightEvents
>>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick) >>> arr (\ev -> if ev == Event LightsSleep then Event () else Tick)
+2 -2
View File
@@ -1,7 +1,7 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module HomeAssistant.Controller.Children where module HomeAssistant.Controller.Children where
import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene, LightSettings (..), BrightnessSettings (..)) import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, LightCommand(..), ikeaQuickButton, IkeaGesture (..), IkeaButton (..), traceEvent, activateScene, LightAttributes (..), Brightness (..))
import AFRP (Event (..)) import AFRP (Event (..))
import qualified AFRP import qualified AFRP
import Control.Arrow (Arrow(..), (>>>), returnA) import Control.Arrow (Arrow(..), (>>>), returnA)
@@ -75,7 +75,7 @@ schoolLightController = lightsOn <> lightsOff
lightsOn :: HASS a () lightsOn :: HASS a ()
lightsOn = foldMap atTime timersOn lightsOn = foldMap atTime timersOn
>>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] (On def{lightSettingsBrightness=Just $ BrightnessPercentage 100} ))) >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] (On def{lightBrightness=Just $ BrightnessPercent 100} )))
lightsOff :: HASS a () lightsOff :: HASS a ()
lightsOff = foldMap atTime timersOff lightsOff = foldMap atTime timersOff
+1 -1
View File
@@ -2,7 +2,7 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
module HomeAssistant.Controller.Hallway where module HomeAssistant.Controller.Hallway where
import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), Light (..)) import HomeAssistant.Controller (Presence (..), HASS, motion, motionToPresence, traceEvent, callServiceDyn, light, Target (..), LightCommand (..))
import AFRP (Event (..)) import AFRP (Event (..))
import qualified AFRP import qualified AFRP
import Data.Aeson (Value) import Data.Aeson (Value)
+1 -1
View File
@@ -2,7 +2,7 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
module HomeAssistant.Controller.Livingroom where module HomeAssistant.Controller.Livingroom where
import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, Light (..), traceEvent, callService, activateScene) import HomeAssistant.Controller (HASS, Presence (..), Target (..), presence, callServiceDyn, light, LightCommand (..), traceEvent, callService, activateScene)
import qualified AFRP import qualified AFRP
import Control.Arrow ((>>>), Arrow (..), returnA) import Control.Arrow ((>>>), Arrow (..), returnA)
import Data.Aeson (Value) import Data.Aeson (Value)
+7 -7
View File
@@ -2,7 +2,7 @@
module ControllerSpec where module ControllerSpec where
import Test.Hspec import Test.Hspec
import Data.Default (def) import Data.Default (def)
import HomeAssistant.Controller (BrightnessSettings(..), formatLightSettings, LightSettings(..)) import HomeAssistant.Controller (Brightness(..), formatLightAttributes, LightAttributes(..))
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import HomeAssistant.Controller () import HomeAssistant.Controller ()
@@ -11,19 +11,19 @@ spec :: Spec
spec = describe "Generic controller" $ spec = describe "Generic controller" $
describe "Light settings" $ do describe "Light settings" $ do
it "formats the default as empty" $ it "formats the default as empty" $
formatLightSettings def `shouldBe` Nothing formatLightAttributes def `shouldBe` Nothing
it "formats the transition" $ it "formats the transition" $
formatLightSettings def{lightSettingsTransition=Just 5} `shouldBe` formatLightAttributes def{lightTransition=Just 5} `shouldBe`
Just (object ["transition" .= (5 :: Int)]) Just (object ["transition" .= (5 :: Int)])
it "formats the temperature" $ it "formats the temperature" $
formatLightSettings def{lightSettingsTemperature=Just 5} `shouldBe` formatLightAttributes def{lightColorTemperature=Just 5} `shouldBe`
Just (object ["color_temp_kelvin" .= (5 :: Int)]) Just (object ["color_temp_kelvin" .= (5 :: Int)])
it "formats the brightness as percentage" $ it "formats the brightness as percentage" $
formatLightSettings def{lightSettingsBrightness=Just (BrightnessPercentage 100)} `shouldBe` formatLightAttributes def{lightBrightness=Just (BrightnessPercent 100)} `shouldBe`
Just (object ["brightness_pct" .= (100 :: Int)]) Just (object ["brightness_pct" .= (100 :: Int)])
it "formats the brightness as absolute" $ it "formats the brightness as absolute" $
formatLightSettings def{lightSettingsBrightness=Just (Brightness 200)} `shouldBe` formatLightAttributes def{lightBrightness=Just (BrightnessAbsolute 200)} `shouldBe`
Just (object ["brightness" .= (200 :: Int)]) Just (object ["brightness" .= (200 :: Int)])
it "formats multiple values" $ it "formats multiple values" $
formatLightSettings def{lightSettingsTransition = Just 5, lightSettingsBrightness=Just (Brightness 200)} `shouldBe` formatLightAttributes def{lightTransition = Just 5, lightBrightness=Just (BrightnessAbsolute 200)} `shouldBe`
Just (object ["brightness" .= (200 :: Int), "transition" .= (5 :: Int)]) Just (object ["brightness" .= (200 :: Int), "transition" .= (5 :: Int)])