WIP: Rendering shape #8
No files matched your search
@@ -60,6 +60,7 @@ library
|
||||
|
||||
-- Modules exported by the library.
|
||||
exposed-modules: AFRP
|
||||
, AFRP.Diagram
|
||||
, HomeAssistant.Controller
|
||||
, HomeAssistant.Controller.Bedroom
|
||||
, HomeAssistant.Controller.Children
|
||||
|
||||
+48
-22
@@ -1,11 +1,13 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module AFRP
|
||||
( Mealy(..)
|
||||
, Auto(..)
|
||||
, DecodedAuto(..)
|
||||
, eff
|
||||
, withEntities
|
||||
, named
|
||||
, Event(..)
|
||||
, hold
|
||||
, holdKnown
|
||||
@@ -18,8 +20,10 @@ module AFRP
|
||||
, changes
|
||||
, whenA
|
||||
, filterA
|
||||
, filterEvent
|
||||
, thenA
|
||||
, (>>|)
|
||||
, (>>||)
|
||||
, toEvent
|
||||
, lMerge
|
||||
, Pair(..)
|
||||
@@ -67,6 +71,8 @@ import qualified Data.Conduit.Cereal as CC
|
||||
import qualified Conduit as C
|
||||
import Control.Monad.Catch (MonadCatch, handle)
|
||||
import Control.Exception.Annotated (throw)
|
||||
import AFRP.Diagram
|
||||
import Data.Text (Text)
|
||||
|
||||
|
||||
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
|
||||
| otherwise = throw e
|
||||
|
||||
|
||||
-- | 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
|
||||
-- trigger subscriptions.
|
||||
data Mealy eff a b = Mealy
|
||||
{ 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
|
||||
}
|
||||
|
||||
-- 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
|
||||
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
|
||||
mempty = Mealy mempty $ \_nt -> mempty
|
||||
mempty = Mealy mempty emptyDiagram $ \_nt -> mempty
|
||||
|
||||
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
|
||||
b <- nt (f req a)
|
||||
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
|
||||
{- HLINT ignore "Use const" -}
|
||||
id = Mealy mempty $ \_nt -> id
|
||||
(Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do
|
||||
id = Mealy mempty emptyDiagram $ \_nt -> id
|
||||
(Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then bd ad) $ \nt -> do
|
||||
f nt . g nt
|
||||
|
||||
instance Arrow (Mealy eff) where
|
||||
arr f = Mealy mempty $ \_nt -> arr f
|
||||
first (Mealy st f) = Mealy st $ \nt -> first (f nt)
|
||||
arr f = Mealy mempty emptyDiagram $ \_nt -> arr f
|
||||
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
|
||||
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
|
||||
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
|
||||
pure b = Mealy mempty $ \_ -> pure b
|
||||
Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt ->
|
||||
pure b = Mealy mempty emptyDiagram $ \_ -> pure b
|
||||
Mealy ast ad f <*> Mealy bst bd x = Mealy (ast <> bst) (combineDiagram Compose ad bd) $ \nt ->
|
||||
f nt <*> x nt
|
||||
|
||||
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 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 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' 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'))
|
||||
|
||||
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' 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'))
|
||||
|
||||
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' 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 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 f g = f >>> arr Left ||| g
|
||||
|
||||
@@ -492,6 +509,15 @@ thenA f g = f >>> arr Left ||| g
|
||||
|
||||
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 = arr (either (const Tick) Event)
|
||||
|
||||
@@ -606,7 +632,7 @@ requestLocalTime :: Request -> LocalTime
|
||||
requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
|
||||
|
||||
currentTime :: Mealy eff a LocalTime
|
||||
currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
|
||||
currentTime = Mealy mempty emptyDiagram $ \_nt -> Fun $ \req _ ->
|
||||
requestLocalTime req
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -5,7 +5,7 @@ module HomeAssistant.Controller.Bedroom where
|
||||
|
||||
import HomeAssistant.Controller
|
||||
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 Control.Arrow ((>>>), returnA, arr, Arrow (..))
|
||||
import Data.Bool (bool)
|
||||
@@ -69,12 +69,12 @@ bedroomPresenceController = proc x -> do
|
||||
_ <- AFRP.changes >>> traceEvent -< snap
|
||||
case p of
|
||||
Event LightingOff -> do
|
||||
callService (light bedroomLightTargets Off) -< ()
|
||||
callService "Turn off lights" (light bedroomLightTargets Off) -< ()
|
||||
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 -< ()
|
||||
Event LightingSleep -> do
|
||||
callService (activateScene "scene.makuuhuone_lepotila") -< ()
|
||||
callService "Turn on sleep" (activateScene "scene.makuuhuone_lepotila") -< ()
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
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
|
||||
case ev of
|
||||
Event (Masse (OnButton ShortRelease)) -> do
|
||||
callService (activateScene "scene.makuuhuone_masse") -< ()
|
||||
callService "scene.makuuhuone_masse" (activateScene "scene.makuuhuone_masse") -< ()
|
||||
Event (Masse (OnButton DoubleClick)) -> do
|
||||
callService (activateScene "scene.makuuhuone_keski") -< ()
|
||||
callService "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
|
||||
Event (Masse (OnButton LongClick)) -> do
|
||||
callService (activateScene "scene.makuuhuone_kirkas") -< ()
|
||||
callService "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
|
||||
Event (Masse (OffButton _)) -> do
|
||||
callService (light [AreaId "makuuhuone"] Off) -< ()
|
||||
callService "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
|
||||
Event (Enishen (OnButton ShortRelease)) -> do
|
||||
callService (activateScene "scene.makuuhuone_jemina") -< ()
|
||||
callService "scene.makuuhuone_jemina" (activateScene "scene.makuuhuone_jemina") -< ()
|
||||
Event (Enishen (OnButton DoubleClick)) -> do
|
||||
callService (activateScene "scene.makuuhuone_keski") -< ()
|
||||
callService "scene.makuuhuone_keski" (activateScene "scene.makuuhuone_keski") -< ()
|
||||
Event (Enishen (OnButton LongClick)) -> do
|
||||
callService (activateScene "scene.makuuhuone_kirkas") -< ()
|
||||
callService "scene.makuuhuone_kirkas" (activateScene "scene.makuuhuone_kirkas") -< ()
|
||||
Event (Enishen (OffButton _)) -> do
|
||||
callService (light [AreaId "makuuhuone"] Off) -< ()
|
||||
callService "Lights off" (light [AreaId "makuuhuone"] Off) -< ()
|
||||
_ -> returnA -< ()
|
||||
|
||||
|
||||
@@ -134,14 +134,16 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
|
||||
>>> arr (fmap (bool Closed Open))
|
||||
|
||||
bedroomDrawerController :: HASS (Event Value) ()
|
||||
bedroomDrawerController = proc x -> do
|
||||
st <- drawer >>> traceEvent -< x
|
||||
case st of
|
||||
Event Open -> callService (switchService [entity] True) -< ()
|
||||
Event Closed -> callService (switchService [entity] False) -< ()
|
||||
_ -> returnA -< ()
|
||||
bedroomDrawerController =
|
||||
drawer >>>
|
||||
(named "Drawer opened" lightOn <> named "Drawer closed" lightOff)
|
||||
>>> arr (const ())
|
||||
where
|
||||
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 = entityBool "binary_sensor.makuuhuone_ovi_contact"
|
||||
@@ -163,8 +165,8 @@ humidifierController = proc x -> do
|
||||
case st of
|
||||
-- Turn the humidifier on when the door is closed
|
||||
-- the humidifier is low-powered, no point in losing all the humidity
|
||||
Event Open -> callService (humidifier False) -< ()
|
||||
Event Closed -> callService (humidifier True) -< ()
|
||||
Event Open -> callService "Humidifier off" (humidifier False) -< ()
|
||||
Event Closed -> callService "Humidifier on" (humidifier True) -< ()
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
humidifier state = Service
|
||||
|
||||
@@ -85,11 +85,11 @@ schoolLightController = lightsOn <> lightsOff
|
||||
|
||||
lightsOn :: HASS a ()
|
||||
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 = 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))
|
||||
@@ -99,10 +99,10 @@ childrenBedroomButtonController :: HASS (Event Value) ()
|
||||
childrenBedroomButtonController = proc x -> do
|
||||
ev <- childrenBedroomButton >>> traceEvent -< x
|
||||
case ev of
|
||||
Event (OnButton ShortRelease) -> callService (activateScene "scene.lasten_nukkuvalmistelu") -< ()
|
||||
Event (OnButton DoubleClick) -> callService (activateScene "scene.lasten_luku") -< ()
|
||||
Event (OnButton LongClick) -> callService (activateScene "scene.lasten_kirkas") -< ()
|
||||
Event (OffButton _) -> callService (light [AreaId "lasten_makuuhuone"] Off) -< ()
|
||||
Event (OnButton ShortRelease) -> callService "scene.lasten_nukkuvalmistelu" (activateScene "scene.lasten_nukkuvalmistelu") -< ()
|
||||
Event (OnButton DoubleClick) -> callService "scene.lasten_luku" (activateScene "scene.lasten_luku") -< ()
|
||||
Event (OnButton LongClick) -> callService "scene.lasten_kirkas" (activateScene "scene.lasten_kirkas") -< ()
|
||||
Event (OffButton _) -> callService "Lights off" (light [AreaId "lasten_makuuhuone"] Off) -< ()
|
||||
_ -> returnA -< ()
|
||||
|
||||
newtype PM25 = PM25 Float
|
||||
@@ -153,8 +153,8 @@ childrenAirFilterController = proc ev -> do
|
||||
humidifier <- humidifierOperatingState >>> AFRP.holdKnown >>> arr join -< ev
|
||||
case level of
|
||||
Event PM25High ->
|
||||
AFRP.whenA (== Just Idle) (callService (fanOnTo (Percentage 80))) -< humidifier
|
||||
Event PM25Low -> callService (fanOnTo (Percentage 20)) -< ()
|
||||
AFRP.whenA (== Just Idle) (callService "Fan strong" (fanOnTo (Percentage 80))) -< humidifier
|
||||
Event PM25Low -> callService "Fan low" (fanOnTo (Percentage 20)) -< ()
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
fanOnTo percentage = Service
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module HomeAssistant.Controller.Effect
|
||||
( HASSEff(..)
|
||||
@@ -13,9 +14,10 @@ module HomeAssistant.Controller.Effect
|
||||
, traceValue
|
||||
) where
|
||||
|
||||
import AFRP (Mealy, eff, Event (..), Request)
|
||||
import AFRP (Mealy, eff, Event (..), Request, named)
|
||||
import Control.Arrow (returnA)
|
||||
import HomeAssistant.Controller.Service (Service)
|
||||
import HomeAssistant.Controller.Service (Service (..))
|
||||
import qualified Data.Text as T
|
||||
|
||||
data HASSEff a where
|
||||
CallService :: Request -> Service -> HASSEff ()
|
||||
@@ -25,17 +27,20 @@ data HASSEff a where
|
||||
|
||||
type HASS a b = Mealy HASSEff a b
|
||||
|
||||
callService :: Service -> HASS a ()
|
||||
callService service = eff (\req _ -> CallService req service)
|
||||
serviceLabel :: T.Text -> HASS a b -> HASS a b
|
||||
serviceLabel lbl = named ("Service: " <> lbl)
|
||||
|
||||
callServices :: [Service] -> HASS a ()
|
||||
callServices service = eff (\req _ -> CallServices req service)
|
||||
callService :: T.Text -> Service -> HASS a ()
|
||||
callService lbl service = serviceLabel lbl $ eff (\req _ -> CallService req service)
|
||||
|
||||
callServiceDyn :: (a -> Service) -> HASS a ()
|
||||
callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
|
||||
callServices :: T.Text -> [Service] -> HASS a ()
|
||||
callServices lbl service = serviceLabel lbl $ eff (\req _ -> CallServices req service)
|
||||
|
||||
callServicesDyn :: (a -> [Service]) -> HASS a ()
|
||||
callServicesDyn mkService = eff (\req a -> CallServices req (mkService a))
|
||||
callServiceDyn :: T.Text -> (a -> Service) -> HASS 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 = proc x -> do
|
||||
|
||||
@@ -10,7 +10,7 @@ module HomeAssistant.Controller.Entity
|
||||
, entityBool'
|
||||
) where
|
||||
|
||||
import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent)
|
||||
import AFRP (Mealy (..), Event, events, filterA, (>>|), toEvent, named)
|
||||
import Control.Arrow (arr)
|
||||
import Control.Category ((>>>))
|
||||
import Data.Aeson (Value)
|
||||
@@ -19,12 +19,13 @@ import qualified Data.Text as T
|
||||
import qualified Data.Set as S
|
||||
import Control.Lens (has, only, (^?), to)
|
||||
import qualified Data.Text.Lens as TL
|
||||
import AFRP.Diagram (emptyDiagram)
|
||||
|
||||
entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
|
||||
entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
|
||||
|
||||
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
|
||||
isEntity :: Value -> Bool
|
||||
isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId)
|
||||
|
||||
@@ -24,8 +24,8 @@ hallwayLightsController = proc x -> do
|
||||
traceEvent -< ev
|
||||
case ev of
|
||||
-- The lights entity is a "group of lights" in hass
|
||||
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< On def
|
||||
Event LightingOff -> callServiceDyn (light [EntityId "light.hallway_lights"]) -< Off
|
||||
Event LightingOn | lightsAllowed now -> callServiceDyn "Lights on" (light [EntityId "light.hallway_lights"]) -< On def
|
||||
Event LightingOff -> callServiceDyn "Lights off" (light [EntityId "light.hallway_lights"]) -< Off
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)
|
||||
@@ -2,7 +2,7 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
module HomeAssistant.Controller.Kitchen where
|
||||
import HomeAssistant.Controller
|
||||
import AFRP (Event (..))
|
||||
import AFRP (Event (..), (>>||))
|
||||
import qualified AFRP
|
||||
import Data.Aeson (Value)
|
||||
import Control.Arrow ((>>>), Arrow (..), returnA)
|
||||
@@ -23,8 +23,8 @@ kitchenCeilingController = proc x -> do
|
||||
ev <- lightingModeEvents -< p
|
||||
traceEvent -< ev
|
||||
case ev of
|
||||
Event LightingOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On def
|
||||
Event LightingOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
|
||||
Event LightingOn | lightsAllowed now -> callServiceDyn "light.kitchen_ceiling on" (light [EntityId "light.kitchen_ceiling"]) -< On def
|
||||
Event LightingOff -> callServiceDyn "light.kitchen_ceiling off" (light [EntityId "light.kitchen_ceiling"]) -< Off
|
||||
_ -> returnA -< ()
|
||||
where
|
||||
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 = presence "binary_sensor.sijainti_keittio_occupancy" >>> AFRP.hold Unoccupied
|
||||
|
||||
dinnerLightEvents :: HASS (Event Value) (Event LightingMode)
|
||||
dinnerLightEvents =
|
||||
|
||||
dinnerTableController :: HASS (Event Value) ()
|
||||
dinnerTableController =
|
||||
((,) <$> dinnerLightLevel <*> dinnerPresence)
|
||||
>>> arr lightWanted
|
||||
>>> (sleepEvent &&& offEvent &&& onEvent)
|
||||
>>> arr (\(s, (o, n)) -> s `AFRP.lMerge` o `AFRP.lMerge` n)
|
||||
-- These are done "in parallel", there is a chance that two services are called in one go
|
||||
>>> 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
|
||||
lightWanted (lightLevel, occ) = occ == Occupied && lightLevel < 13
|
||||
|
||||
onEvent =
|
||||
lightsOn =
|
||||
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
|
||||
>>> AFRP.edge
|
||||
>>> arr (fmap (const LightingSleep))
|
||||
>>|| sleep "sleep on" True
|
||||
|
||||
offEvent =
|
||||
lightsOff =
|
||||
arr not
|
||||
>>> 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 = kitchenCeilingController <> dinnerTableController
|
||||
@@ -39,8 +39,8 @@ livingroomPresenceController = proc x -> do
|
||||
ev <- lightingModeEvents . livingroomPresence -< x
|
||||
traceEvent -< ev
|
||||
case ev of
|
||||
AFRP.Event LightingOn -> callServiceDyn (light livingroomLightTargets) -< On def
|
||||
AFRP.Event LightingOff -> callServiceDyn (light livingroomLightTargets) -< Off
|
||||
AFRP.Event LightingOn -> callServiceDyn "Lights on" (light livingroomLightTargets) -< On def
|
||||
AFRP.Event LightingOff -> callServiceDyn "Lights off" (light livingroomLightTargets) -< Off
|
||||
_ -> returnA -< ()
|
||||
returnA -< ()
|
||||
|
||||
@@ -88,6 +88,6 @@ livingroomPlantLights = (season &&& tod)
|
||||
where
|
||||
setLights = proc mode -> do
|
||||
case mode of
|
||||
AFRP.Event Growth -> callService (activateScene "scene.olohuoneen_kasvivalo") -< ()
|
||||
AFRP.Event Ambience -> callService (activateScene "scene.kasvivalo_iltatila") -< ()
|
||||
AFRP.Event Growth -> callService "scene.olohuoneen_kasvivalo" (activateScene "scene.olohuoneen_kasvivalo") -< ()
|
||||
AFRP.Event Ambience -> callService "scene.kasvivalo_iltatila" (activateScene "scene.kasvivalo_iltatila") -< ()
|
||||
_ -> returnA -< ()
|
||||
@@ -48,6 +48,7 @@ import Text.Read (readMaybe)
|
||||
import UnliftIO.Async
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
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 path name trace st a = do
|
||||
@@ -122,6 +123,8 @@ defaultMain =
|
||||
rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
|
||||
metricsPort <- lookupPort
|
||||
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
|
||||
workers =
|
||||
[ ("reader", readerAction host 8123 token ents bus),
|
||||
|
||||
+3
-2
@@ -20,6 +20,7 @@ import qualified Hedgehog.Range as Range
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Hedgehog
|
||||
import Data.Maybe (listToMaybe)
|
||||
import AFRP.Diagram (emptyDiagram)
|
||||
|
||||
fakeRequest :: Request
|
||||
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.
|
||||
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 '<*>'.
|
||||
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 = describe "entities" $ do
|
||||
|
||||
+9
-2
@@ -11,6 +11,7 @@ import HomeAssistant.Controller.Kitchen
|
||||
import Support
|
||||
import Test.Hspec
|
||||
import Data.Default (def)
|
||||
import Data.Time (getCurrentTime, addUTCTime)
|
||||
|
||||
-- Helper functions for creating test events
|
||||
testDinnerLightLevel :: Int -> Event Value
|
||||
@@ -37,9 +38,15 @@ dinnerTableSpec = describe "dinnerTableController" $ do
|
||||
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)]]
|
||||
|
||||
it "turns lights off when presence is unoccupied" $ do
|
||||
services (runHASS dinnerTableController [testDinnerLightLevel 10, testDinnerPresence "off"])
|
||||
it "turns lights to sleep when presence is unoccupied" $ do
|
||||
now <- getCurrentTime
|
||||
services (runHASSTimed dinnerTableController [(now, testDinnerLightLevel 10), (now, testDinnerPresence "off")])
|
||||
`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
|
||||
services (runHASS dinnerTableController [Tick])
|
||||
|
||||
Reference in new issue
Block a user