MasseR/home-assistant-controller
1
0 Fork 0
Code Issues 2 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

WIP: Rendering shape #8

Draft
MasseR wants to merge 4 commits from rendering-shape into main
pull from: rendering-shape
merge into: MasseR:main
Conversation 0 Commits 4 Files Changed 13
+190 -100
13 changed files with 190 additions and 100 deletions
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

home-assistant-controller.cabal
+1
View File
@@ -60,6 +60,7 @@ library
-- Modules exported by the library. -- Modules exported by the library.
exposed-modules: AFRP exposed-modules: AFRP
, AFRP.Diagram
, HomeAssistant.Controller , HomeAssistant.Controller
, HomeAssistant.Controller.Bedroom , HomeAssistant.Controller.Bedroom
, HomeAssistant.Controller.Children , HomeAssistant.Controller.Children
src/AFRP.hs
+48 -22
View File
@@ -1,11 +1,13 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeOperators #-}
module AFRP module AFRP
( Mealy(..) ( Mealy(..)
, Auto(..) , Auto(..)
, DecodedAuto(..) , DecodedAuto(..)
, eff , eff
, withEntities , named
, Event(..) , Event(..)
, hold , hold
, holdKnown , holdKnown
@@ -18,8 +20,10 @@ module AFRP
, changes , changes
, whenA , whenA
, filterA , filterA
, filterEvent
, thenA , thenA
, (>>|) , (>>|)
, (>>||)
, toEvent , toEvent
, lMerge , lMerge
, Pair(..) , Pair(..)
@@ -67,6 +71,8 @@ import qualified Data.Conduit.Cereal as CC
import qualified Conduit as C import qualified Conduit as C
import Control.Monad.Catch (MonadCatch, handle) import Control.Monad.Catch (MonadCatch, handle)
import Control.Exception.Annotated (throw) import Control.Exception.Annotated (throw)
import AFRP.Diagram
import Data.Text (Text)
data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) } data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
@@ -257,54 +263,58 @@ load path a = handle defaultOnMissingFile (flip deserialize a <$> liftIO (B.read
| isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a | isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
| otherwise = throw e | otherwise = throw e
-- | The set of entity ids an arrow subscribes to. Static: it does not -- | The set of entity ids an arrow subscribes to. Static: it does not
-- change as the machine steps, so the runtime can read it once to build -- change as the machine steps, so the runtime can read it once to build
-- trigger subscriptions. -- trigger subscriptions.
data Mealy eff a b = Mealy data Mealy eff a b = Mealy
{ entities :: S.Set T.Text { entities :: S.Set T.Text
, runDiagramC :: forall x. (DiagramF x -> x) -> x
, runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b
} }
-- Provide a name
named :: Text -> Mealy eff a b -> Mealy eff a b
named n f = f{runDiagramC = \run -> run (Step n (runDiagramC f run))}
instance Semigroup b => Semigroup (Mealy eff a b) where instance Semigroup b => Semigroup (Mealy eff a b) where
Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt -> af nt <> bf nt Mealy ast ad af <> Mealy bst bd bf = Mealy (ast <> bst) (combineDiagram Merge ad bd) $ \nt -> af nt <> bf nt
instance Monoid b => Monoid (Mealy eff a b) where instance Monoid b => Monoid (Mealy eff a b) where
mempty = Mealy mempty $ \_nt -> mempty mempty = Mealy mempty emptyDiagram $ \_nt -> mempty
eff :: (Request -> a -> eff b) -> Mealy eff a b eff :: (Request -> a -> eff b) -> Mealy eff a b
eff f = Mealy mempty $ \nt -> do eff f = Mealy mempty emptyDiagram $ \nt -> do
Stateful (Codec get put) (State () False) $ \s req a -> do Stateful (Codec get put) (State () False) $ \s req a -> do
b <- nt (f req a) b <- nt (f req a)
pure (b, s) pure (b, s)
-- | Override the static entity set of an arrow. Use when a combinator
-- (e.g. 'switch') hides continuation entities from the runtime's
-- startup subscription scan.
withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
withEntities es (Mealy _ f) = Mealy es f
instance Category (Mealy eff) where instance Category (Mealy eff) where
{- HLINT ignore "Use const" -} {- HLINT ignore "Use const" -}
id = Mealy mempty $ \_nt -> id id = Mealy mempty emptyDiagram $ \_nt -> id
(Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then bd ad) $ \nt -> do
f nt . g nt f nt . g nt
instance Arrow (Mealy eff) where instance Arrow (Mealy eff) where
arr f = Mealy mempty $ \_nt -> arr f arr f = Mealy mempty emptyDiagram $ \_nt -> arr f
first (Mealy st f) = Mealy st $ \nt -> first (f nt) first (Mealy st d f) = Mealy st d $ \nt -> first (f nt)
(Mealy ast ad f) &&& (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Both ad bd) $ \nt -> do
f nt &&& g nt
instance ArrowChoice (Mealy eff) where instance ArrowChoice (Mealy eff) where
left (Mealy st f) = Mealy st $ \nt -> left (f nt) left (Mealy st d f) = Mealy st d $ \nt -> left (f nt)
(Mealy ast ad f) +++ (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Branch ad bd) $ \nt -> do
f nt +++ g nt
instance Functor (Mealy eff a) where instance Functor (Mealy eff a) where
fmap f (Mealy st g) = Mealy st $ \nt -> fmap f (g nt) fmap f (Mealy st d g) = Mealy st d $ \nt -> fmap f (g nt)
instance Applicative (Mealy eff a) where instance Applicative (Mealy eff a) where
pure b = Mealy mempty $ \_ -> pure b pure b = Mealy mempty emptyDiagram $ \_ -> pure b
Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt -> Mealy ast ad f <*> Mealy bst bd x = Mealy (ast <> bst) (combineDiagram Compose ad bd) $ \nt ->
f nt <*> x nt f nt <*> x nt
data Event a data Event a
@@ -369,10 +379,10 @@ preMapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure
mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccum step x extract = Mealy mempty $ \_nt -> mapAccum' step x extract mapAccum step x extract = Mealy mempty emptyDiagram $ \_nt -> mapAccum' step x extract
preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccum step x extract = Mealy mempty $ \_nt -> preMapAccum' step x extract preMapAccum step x extract = Mealy mempty emptyDiagram $ \_nt -> preMapAccum' step x extract
mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a) mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
@@ -381,7 +391,7 @@ mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ s
step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s')) step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccumRequest step x extract = Mealy mempty $ \_ -> preMapAccumRequest' step x extract preMapAccumRequest step x extract = Mealy mempty emptyDiagram $ \_ -> preMapAccumRequest' step x extract
preMapAccumRequest' :: forall m x a b. (Serialize x, Eq x, Monad m) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b preMapAccumRequest' :: forall m x a b. (Serialize x, Eq x, Monad m) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a) preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
@@ -390,7 +400,7 @@ preMapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s r
step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s')) step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccumRequest step x extract = Mealy mempty $ \_ -> mapAccumRequest' step x extract mapAccumRequest step x extract = Mealy mempty emptyDiagram $ \_ -> mapAccumRequest' step x extract
mapAccumRequest' :: forall m x a b. (Monad m, Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b mapAccumRequest' :: forall m x a b. (Monad m, Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Auto m a b
mapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a) mapAccumRequest' f x extract = Stateful (Codec get put) (State x False) (\s req a -> pure $ step s req a)
@@ -484,6 +494,13 @@ whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>>
filterA :: (a -> Bool) -> Mealy eff a (Either () a) filterA :: (a -> Bool) -> Mealy eff a (Either () a)
filterA f = arr $ \a -> bool (Left ()) (Right a) (f a) filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
-- filters events through if they match the predicate
filterEvent :: (ArrowChoice cat, Arrow cat) => (a -> Bool) -> Event a `cat` Event a
filterEvent predicate = proc ev -> do
case ev of
Event a | predicate a -> id -< ev
_ -> arr (const Tick) -< ()
thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2) thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
thenA f g = f >>> arr Left ||| g thenA f g = f >>> arr Left ||| g
@@ -492,6 +509,15 @@ thenA f g = f >>> arr Left ||| g
infixl 2 >>| infixl 2 >>|
(>>||) :: (ArrowChoice cat, Arrow cat) => cat a (Event b) -> cat b c -> cat a (Event c)
f >>|| g = proc x -> do
e <- f -< x
case e of
Event e' -> g >>> arr Event -< e'
Tick -> arr (const Tick) -< ()
infixr 1 >>||
toEvent :: Mealy eff (Either () a) (Event a) toEvent :: Mealy eff (Either () a) (Event a)
toEvent = arr (either (const Tick) Event) toEvent = arr (either (const Tick) Event)
@@ -606,7 +632,7 @@ requestLocalTime :: Request -> LocalTime
requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
currentTime :: Mealy eff a LocalTime currentTime :: Mealy eff a LocalTime
currentTime = Mealy mempty $ \_nt -> Fun $ \req _ -> currentTime = Mealy mempty emptyDiagram $ \_nt -> Fun $ \req _ ->
requestLocalTime req requestLocalTime req
src/AFRP/Diagram.hs
+49
View File
@@ -0,0 +1,49 @@
{-# LANGUAGE OverloadedStrings #-}
module AFRP.Diagram where
import Data.Text (Text)
import qualified Text.Printf as Text
import qualified Data.Text as T
-- For rendering the arrows
data DiagramF f
= Empty
| Step Text f -- Named step
| Then f f -- >>>
| Both f f -- &&&
| Branch f f -- |||
| Merge f f -- <>
| Compose f f -- <*>
type DiagramAlgebra a = DiagramF a -> a
type DiagramC= forall a. DiagramAlgebra a -> a
combineDiagram :: (forall a. a -> a -> DiagramF a) -> DiagramC -> DiagramC -> DiagramC
combineDiagram constructor a b r = r (constructor (a r) (b r))
emptyDiagram :: DiagramC
emptyDiagram r = r Empty
renderF :: DiagramF (Maybe T.Text) -> Maybe T.Text
renderF = \case
Empty -> Nothing
Step n x -> Just $ n <> T.pack (maybe "" (Text.printf "( %s )") x)
Then (Just a) (Just b) -> Just $ a <> " -> " <> b
Then (Just a) _ -> Just a
Then _ b -> b
Both (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
Both (Just a) _ -> Just a
Both _ b -> b
Branch (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s || %s)" a b
-- I'm leaving this here. This would be technically more correct (showing
-- the empty branch, ie. the full if-then-else, but often we care about a
-- more simplistic `when` style structure
-- Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "(%s || <skip>)" a
Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "%s" a
Branch _ b -> b
Merge (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
Merge (Just a) _ -> Just a
Merge _ b -> b
Compose (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
Compose (Just a) _ -> Just a
Compose _ b -> b
src/HomeAssistant/Controller/Bedroom.hs
+22 -20
View File
@@ -5,7 +5,7 @@ module HomeAssistant.Controller.Bedroom where
import HomeAssistant.Controller import HomeAssistant.Controller
import qualified Data.Text as T import qualified Data.Text as T
import AFRP (Event (..), lMerge, duration, edge) import AFRP (Event (..), lMerge, duration, edge, filterEvent, named, (>>||))
import Data.Aeson (Value, object, (.=)) import Data.Aeson (Value, object, (.=))
import Control.Arrow ((>>>), returnA, arr, Arrow (..)) import Control.Arrow ((>>>), returnA, arr, Arrow (..))
import Data.Bool (bool) import Data.Bool (bool)
@@ -69,12 +69,12 @@ bedroomPresenceController = proc x -> do
_ <- AFRP.changes >>> traceEvent -< snap _ <- AFRP.changes >>> traceEvent -< snap
case p of case p of
Event LightingOff -> do Event LightingOff -> do
callService (light bedroomLightTargets Off) -< () callService "Turn off lights" (light bedroomLightTargets Off) -< ()
Event LightingOn -> do Event LightingOn -> do
callServicesDyn (\(c,xs) -> concatMap (uncurry (toLight c)) xs) -< (capped, M.toList (getSnapshot snap)) callServicesDyn "Turn on lights (capped)" (\(c,xs) -> concatMap (uncurry (toLight c)) xs) -< (capped, M.toList (getSnapshot snap))
returnA -< () returnA -< ()
Event LightingSleep -> do Event LightingSleep -> do
callService (activateScene "scene.makuuhuone_lepotila") -< () callService "Turn on sleep" (activateScene "scene.makuuhuone_lepotila") -< ()
_ -> returnA -< () _ -> returnA -< ()
where where
toLight :: Bool -> T.Text -> LightObservation -> [Service] toLight :: Bool -> T.Text -> LightObservation -> [Service]
@@ -110,21 +110,21 @@ bedroomButtonController = proc x -> do
-- Any event will cause the sleep mode to be turned off -- Any event will cause the sleep mode to be turned off
case ev of case ev of
Event (Masse (OnButton ShortRelease)) -> do Event (Masse (OnButton ShortRelease)) -> do
callService (activateScene "scene.makuuhuone_masse") -< () callService "scene.makuuhuone_masse" (activateScene "scene.makuuhuone_masse") -< ()
Event (Masse (OnButton DoubleClick)) -> do Event (Masse (OnButton DoubleClick)) -> do
callService (activateScene "scene.makuuhuone_keski") -< () callService "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
Event (Masse (OnButton LongClick)) -> do Event (Masse (OnButton LongClick)) -> do
callService (activateScene "scene.makuuhuone_kirkas") -< () callService "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
Event (Masse (OffButton _)) -> do Event (Masse (OffButton _)) -> do
callService (light [AreaId "makuuhuone"] Off) -< () callService "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
Event (Enishen (OnButton ShortRelease)) -> do Event (Enishen (OnButton ShortRelease)) -> do
callService (activateScene "scene.makuuhuone_jemina") -< () callService "scene.makuuhuone_jemina" (activateScene "scene.makuuhuone_jemina") -< ()
Event (Enishen (OnButton DoubleClick)) -> do Event (Enishen (OnButton DoubleClick)) -> do
callService (activateScene "scene.makuuhuone_keski") -< () callService "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
Event (Enishen (OnButton LongClick)) -> do Event (Enishen (OnButton LongClick)) -> do
callService (activateScene "scene.makuuhuone_kirkas") -< () callService "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
Event (Enishen (OffButton _)) -> do Event (Enishen (OffButton _)) -> do
callService (light [AreaId "makuuhuone"] Off) -< () callService "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
_ -> returnA -< () _ -> returnA -< ()
@@ -134,14 +134,16 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
>>> arr (fmap (bool Closed Open)) >>> arr (fmap (bool Closed Open))
bedroomDrawerController :: HASS (Event Value) () bedroomDrawerController :: HASS (Event Value) ()
bedroomDrawerController = proc x -> do bedroomDrawerController =
st <- drawer >>> traceEvent -< x drawer >>>
case st of (named "Drawer opened" lightOn <> named "Drawer closed" lightOff)
Event Open -> callService (switchService [entity] True) -< () >>> arr (const ())
Event Closed -> callService (switchService [entity] False) -< ()
_ -> returnA -< ()
where where
entity = EntityId "switch.bedroom_drawer_light_masse" entity = EntityId "switch.bedroom_drawer_light_masse"
lightOff = filterEvent (== Closed)
>>|| callService "drawer light off" (switchService [entity] False)
lightOn = filterEvent (== Open)
>>|| callService "drawer light on" (switchService [entity] True)
door :: HASS (Event Value) (Event DoorState) door :: HASS (Event Value) (Event DoorState)
door = entityBool "binary_sensor.makuuhuone_ovi_contact" door = entityBool "binary_sensor.makuuhuone_ovi_contact"
@@ -163,8 +165,8 @@ humidifierController = proc x -> do
case st of case st of
-- Turn the humidifier on when the door is closed -- Turn the humidifier on when the door is closed
-- the humidifier is low-powered, no point in losing all the humidity -- the humidifier is low-powered, no point in losing all the humidity
Event Open -> callService (humidifier False) -< () Event Open -> callService "Humidifier off" (humidifier False) -< ()
Event Closed -> callService (humidifier True) -< () Event Closed -> callService "Humidifier on" (humidifier True) -< ()
_ -> returnA -< () _ -> returnA -< ()
where where
humidifier state = Service humidifier state = Service
src/HomeAssistant/Controller/Children.hs
+8 -8
View File
@@ -85,11 +85,11 @@ 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{lightBrightness=Just $ BrightnessPercent 100} ))) >>> AFRP.onEvent (callService "Lights on" (light [AreaId "lasten_makuuhuone"] (On def{lightBrightness=Just $ BrightnessPercent 100} )))
lightsOff :: HASS a () lightsOff :: HASS a ()
lightsOff = foldMap atTime timersOff lightsOff = foldMap atTime timersOff
>>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off)) >>> AFRP.onEvent (callService "Lights off" (light [AreaId "lasten_makuuhuone"] Off))
childrenBedroomButton :: HASS (Event Value) (Event (IkeaButton IkeaGesture)) childrenBedroomButton :: HASS (Event Value) (Event (IkeaButton IkeaGesture))
@@ -99,10 +99,10 @@ childrenBedroomButtonController :: HASS (Event Value) ()
childrenBedroomButtonController = proc x -> do childrenBedroomButtonController = proc x -> do
ev <- childrenBedroomButton >>> traceEvent -< x ev <- childrenBedroomButton >>> traceEvent -< x
case ev of case ev of
Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< () Event (OnButton ShortRelease) -> callService "scene.lasten_nukkuvalmistelu" (activateScene "scene.lasten_nukkuvalmistelu") -< ()
Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< () Event (OnButton DoubleClick) -> callService "scene.lasten_luku" (activateScene "scene.lasten_luku") -< ()
Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< () Event (OnButton LongClick) -> callService "scene.lasten_kirkas" (activateScene "scene.lasten_kirkas") -< ()
Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< () Event (OffButton _) -> callService "Lights off" (light [AreaId "lasten_makuuhuone"] Off) -< ()
_ -> returnA -< () _ -> returnA -< ()
newtype PM25 = PM25 Float newtype PM25 = PM25 Float
@@ -153,8 +153,8 @@ childrenAirFilterController = proc ev -> do
humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev
case level of case level of
Event PM25High -> Event PM25High ->
AFRP.whenA (== Just Idle) (callService (fanOnTo (Percentage 80))) -< humidifier AFRP.whenA (== Just Idle) (callService "Fan strong" (fanOnTo (Percentage 80))) -< humidifier
Event PM25Low -> callService (fanOnTo (Percentage 20)) -< () Event PM25Low -> callService "Fan low" (fanOnTo (Percentage 20)) -< ()
_ -> returnA -< () _ -> returnA -< ()
where where
fanOnTo percentage = Service fanOnTo percentage = Service
src/HomeAssistant/Controller/Effect.hs
+15 -10
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module HomeAssistant.Controller.Effect module HomeAssistant.Controller.Effect
( HASSEff(..) ( HASSEff(..)
@@ -13,9 +14,10 @@ module HomeAssistant.Controller.Effect
, traceValue , traceValue
) where ) where
import AFRP (Mealy, eff, Event (..), Request) import AFRP (Mealy, eff, Event (..), Request, named)
import Control.Arrow (returnA) import Control.Arrow (returnA)
import HomeAssistant.Controller.Service (Service) import HomeAssistant.Controller.Service (Service (..))
import qualified Data.Text as T
data HASSEff a where data HASSEff a where
CallService :: Request -> Service -> HASSEff () CallService :: Request -> Service -> HASSEff ()
@@ -25,17 +27,20 @@ data HASSEff a where
type HASS a b = Mealy HASSEff a b type HASS a b = Mealy HASSEff a b
callService :: Service -> HASS a () serviceLabel :: T.Text -> HASS a b -> HASS a b
callService service = eff (\req _ -> CallService req service) serviceLabel lbl = named ("Service: " <> lbl)
callServices :: [Service] -> HASS a () callService :: T.Text -> Service -> HASS a ()
callServices service = eff (\req _ -> CallServices req service) callService lbl service = serviceLabel lbl $ eff (\req _ -> CallService req service)
callServiceDyn :: (a -> Service) -> HASS a () callServices :: T.Text -> [Service] -> HASS a ()
callServiceDyn mkService = eff (\req a -> CallService req (mkService a)) callServices lbl service = serviceLabel lbl $ eff (\req _ -> CallServices req service)
callServicesDyn :: (a -> [Service]) -> HASS a () callServiceDyn :: T.Text -> (a -> Service) -> HASS a ()
callServicesDyn mkService = eff (\req a -> CallServices req (mkService a)) callServiceDyn lbl mkService = serviceLabel lbl $ eff (\req a -> CallService req (mkService a))
callServicesDyn :: T.Text -> (a -> [Service]) -> HASS a ()
callServicesDyn lbl mkService = serviceLabel lbl $ eff (\req a -> CallServices req (mkService a))
debug :: Show a => HASS a a debug :: Show a => HASS a a
debug = proc x -> do debug = proc x -> do
src/HomeAssistant/Controller/Entity.hs
+3 -2
View File
@@ -10,7 +10,7 @@ module HomeAssistant.Controller.Entity
, entityBool' , entityBool'
) where ) where
import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent) import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent, named)
import Control.Arrow (arr) import Control.Arrow (arr)
import Control.Category ((>>>)) import Control.Category ((>>>))
import Data.Aeson (Value) import Data.Aeson (Value)
@@ -19,12 +19,13 @@ import qualified Data.Text as T
import qualified Data.Set as S import qualified Data.Set as S
import Control.Lens (has, only, (^?), to) import Control.Lens (has, only, (^?), to)
import qualified Data.Text.Lens as TL import qualified Data.Text.Lens as TL
import AFRP.Diagram (emptyDiagram)
entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value) entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value) entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity) entityChangeEvent' entityId = named entityId $ Mealy (S.singleton entityId) emptyDiagram $ runMealy (events >>| filterA isEntity)
where where
isEntity :: Value -> Bool isEntity :: Value -> Bool
isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId) isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId)
src/HomeAssistant/Controller/Hallway.hs
+2 -2
View File
@@ -24,8 +24,8 @@ hallwayLightsController = proc x -> do
traceEvent -< ev traceEvent -< ev
case ev of case ev of
-- The lights entity is a "group of lights" in hass -- The lights entity is a "group of lights" in hass
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def Event LightingOn | lightsAllowed now -> callServiceDyn "Lights on" (light [EntityId "light.hallway_lights"]) -< On def
Event LightingOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off Event LightingOff -> callServiceDyn "Lights off" (light [EntityId "light.hallway_lights"]) -< Off
_ -> returnA -< () _ -> returnA -< ()
where where
lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0) lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
src/HomeAssistant/Controller/Kitchen.hs
+23 -28
View File
@@ -2,7 +2,7 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
module HomeAssistant.Controller.Kitchen where module HomeAssistant.Controller.Kitchen where
import HomeAssistant.Controller import HomeAssistant.Controller
import AFRP (Event (..)) import AFRP (Event (..), (>>||))
import qualified AFRP import qualified AFRP
import Data.Aeson (Value) import Data.Aeson (Value)
import Control.Arrow ((>>>), Arrow (..), returnA) import Control.Arrow ((>>>), Arrow (..), returnA)
@@ -23,8 +23,8 @@ kitchenCeilingController = proc x -> do
ev <- lightingModeEvents -< p ev <- lightingModeEvents -< p
traceEvent -< ev traceEvent -< ev
case ev of case ev of
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def Event LightingOn | lightsAllowed now -> callServiceDyn "light.kitchen_ceiling on" (light [EntityId "light.kitchen_ceiling"]) -< On def
Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off Event LightingOff -> callServiceDyn "light.kitchen_ceiling off" (light [EntityId "light.kitchen_ceiling"]) -< Off
_ -> returnA -< () _ -> returnA -< ()
where where
lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0) lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
@@ -36,44 +36,39 @@ dinnerLightLevel = entityRead "sensor.sijainti_keittio_light_level" >>> AFRP.hol
dinnerPresence :: HASS (Event Value) Presence dinnerPresence :: HASS (Event Value) Presence
dinnerPresence = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied dinnerPresence = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied
dinnerLightEvents :: HASS (Event Value) (Event LightingMode)
dinnerLightEvents = dinnerTableController :: HASS (Event Value) ()
dinnerTableController =
((,) <$> dinnerLightLevel <*> dinnerPresence) ((,) <$> dinnerLightLevel <*> dinnerPresence)
>>> arr lightWanted >>> arr lightWanted
>>> (sleepEvent &&& offEvent &&& onEvent) -- These are done "in parallel", there is a chance that two services are called in one go
>>> arr (\(s, (o, n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n) >>> mconcat
[ AFRP.named "Lights on" lightsOn
, AFRP.named "Lights sleep" lightsSleep
, AFRP.named "Lights off" lightsOff ]
>>> arr (const ()) -- I don't like this extra arr here
where where
lightWanted (lightLevel, occ) = occ == Occupied && lightLevel < 13 lightWanted (lightLevel, occ) = occ == Occupied && lightLevel < 13
onEvent = lightsOn =
AFRP.edge AFRP.edge
>>> arr (fmap (const LightingOn)) >>|| sleep "sleep off" False
>>> callService "Dining light on" (light [EntityId "light.kitchen_dining_large"] $ On def)
sleepEvent = lightsSleep =
arr not arr not
>>> AFRP.edge >>> AFRP.edge
>>> arr (fmap (const LightingSleep)) >>|| sleep "sleep on" True
offEvent = lightsOff =
arr not arr not
>>> AFRP.waitFor 300 >>> AFRP.waitFor 300
>>> arr (fmap (const LightingOff)) >>|| sleep "sleep off" False
>>> callService "Dining light on" (light [EntityId "light.kitchen_dining_large"] Off)
sleep lbl b = callService lbl (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] b)
dinnerTableController :: HASS (Event Value) ()
dinnerTableController = proc x -> do
ev <- dinnerLightEvents -< x
case ev of
Event LightingOn -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
Event LightingOff -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off
Event LightingSleep -> do
sleep -< True
_ -> returnA -< ()
where
sleep = callServiceDyn (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
kitchenMotionController :: HASS (Event Value) () kitchenMotionController :: HASS (Event Value) ()
kitchenMotionController = kitchenCeilingController <> dinnerTableController kitchenMotionController = kitchenCeilingController <> dinnerTableController
src/HomeAssistant/Controller/Livingroom.hs
+4 -4
View File
@@ -39,8 +39,8 @@ livingroomPresenceController = proc x -> do
ev <- lightingModeEvents . livingroomPresence -< x ev <- lightingModeEvents . livingroomPresence -< x
traceEvent -< ev traceEvent -< ev
case ev of case ev of
AFRP.Event LightingOn -> callServiceDyn (light livingroomLightTargets) -< On def AFRP.Event LightingOn -> callServiceDyn "Lights on" (light livingroomLightTargets) -< On def
AFRP.Event LightingOff -> callServiceDyn (light livingroomLightTargets) -< Off AFRP.Event LightingOff -> callServiceDyn "Lights off" (light livingroomLightTargets) -< Off
_ -> returnA -< () _ -> returnA -< ()
returnA -< () returnA -< ()
@@ -88,6 +88,6 @@ livingroomPlantLights = (season &&& tod)
where where
setLights = proc mode -> do setLights = proc mode -> do
case mode of case mode of
AFRP.Event Growth -> callService (activateScene "scene.olohuoneen_kasvivalo") -< () AFRP.Event Growth -> callService "scene.olohuoneen_kasvivalo" (activateScene "scene.olohuoneen_kasvivalo") -< ()
AFRP.Event Ambience -> callService (activateScene "scene.kasvivalo_iltatila") -< () AFRP.Event Ambience -> callService "scene.kasvivalo_iltatila" (activateScene "scene.kasvivalo_iltatila") -< ()
_ -> returnA -< () _ -> returnA -< ()
src/HomeAssistant/Runtime.hs
+3
View File
@@ -48,6 +48,7 @@ import Text.Read (readMaybe)
import UnliftIO.Async import UnliftIO.Async
import Control.Monad.Catch (MonadCatch) import Control.Monad.Catch (MonadCatch)
import Control.Exception.Annotated (checkpoint, Annotation (..)) import Control.Exception.Annotated (checkpoint, Annotation (..))
import AFRP.Diagram (renderF)
step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b) step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
step path name trace st a = do step path name trace st a = do
@@ -122,6 +123,8 @@ defaultMain =
rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL") rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
metricsPort <- lookupPort metricsPort <- lookupPort
writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20 writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
forM_ controllers $ \(Controller n m) ->
logLocM InfoS $ ls $ n <> ": " <> fromMaybe "" (runDiagramC m renderF)
let ents = foldMap (\(Controller _ m) -> entities m) controllers let ents = foldMap (\(Controller _ m) -> entities m) controllers
workers = workers =
[ ("reader", readerAction host 8123 token ents bus), [ ("reader", readerAction host 8123 token ents bus),
test/AFRPSpec.hs
+3 -2
View File
@@ -20,6 +20,7 @@ import qualified Hedgehog.Range as Range
import Test.Hspec import Test.Hspec
import Test.Hspec.Hedgehog import Test.Hspec.Hedgehog
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import AFRP.Diagram (emptyDiagram)
fakeRequest :: Request fakeRequest :: Request
fakeRequest = Request (sec 0) utc nil "test" fakeRequest = Request (sec 0) utc nil "test"
@@ -536,11 +537,11 @@ sampleSpec = describe "sample" $ do
-- | A stateless arrow carrying a fixed entity set, for testing propagation. -- | A stateless arrow carrying a fixed entity set, for testing propagation.
subscribed :: S.Set T.Text -> Mealy Identity Int Int subscribed :: S.Set T.Text -> Mealy Identity Int Int
subscribed ents = Mealy ents $ \_ -> Fun $ \_ a -> a subscribed ents = Mealy ents emptyDiagram $ \_ -> Fun $ \_ a -> a
-- | Same as 'subscribed' but yields a function, for testing '<*>'. -- | Same as 'subscribed' but yields a function, for testing '<*>'.
subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int) subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
subscribedF ents = Mealy ents $ \_ -> Fun $ \_ a -> (a +) subscribedF ents = Mealy ents emptyDiagram $ \_ -> Fun $ \_ a -> (a +)
entitiesSpec :: Spec entitiesSpec :: Spec
entitiesSpec = describe "entities" $ do entitiesSpec = describe "entities" $ do
test/KitchenSpec.hs
+9 -2
View File
@@ -11,6 +11,7 @@ import HomeAssistant.Controller.Kitchen
import Support import Support
import Test.Hspec import Test.Hspec
import Data.Default (def) import Data.Default (def)
import Data.Time (getCurrentTime, addUTCTime)
-- Helper functions for creating test events -- Helper functions for creating test events
testDinnerLightLevel :: Int -> Event Value testDinnerLightLevel :: Int -> Event Value
@@ -37,9 +38,15 @@ dinnerTableSpec = describe "dinnerTableController" $ do
services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "on"]) services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "on"])
`shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On def)]] `shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] (On def)]]
it "turns lights off when presence is unoccupied" $ do it "turns lights to sleep when presence is unoccupied" $ do
services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "off"]) now <- getCurrentTime
services (runHASSTimed dinnerTableController [(now, testDinnerLightLevel 10), (now, testDinnerPresence "off")])
`shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], []] `shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], []]
it "turns lights off when no presence for 300 seconds" $ do
now <- getCurrentTime
let later = 305 `addUTCTime` now
services (runHASSTimed dinnerTableController [(now, testDinnerLightLevel 10), (now, testDinnerPresence "off"), (later, Tick)])
`shouldBe` [[switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] True], [], [switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"] False, light [EntityId "light.kitchen_dining_large"] Off]]
it "does nothing on Tick" $ do it "does nothing on Tick" $ do
services (runHASS dinnerTableController [Tick]) services (runHASS dinnerTableController [Tick])