This commit is contained in:
MasseR committed 2026-10-23 16:00:19 +03:00
1 parent 022342af32
commit 617bd255ff
10 files changed
+124 -71

No files matched your search

+1
View File
@@ -60,6 +60,7 @@ library
-- Modules exported by the library.
exposed-modules: AFRP
, AFRP.Diagram
, HomeAssistant.Controller
, HomeAssistant.Controller.Bedroom
, HomeAssistant.Controller.Children
+24 -22
View File
@@ -5,7 +5,7 @@ module AFRP
, Auto(..)
, DecodedAuto(..)
, eff
, withEntities
, named
, Event(..)
, hold
, holdKnown
@@ -67,6 +67,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 +259,54 @@ 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 (emptyDiagram 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 ad bd) $ \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)
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)
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 +371,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 +383,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 +392,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)
@@ -606,7 +608,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
+44
View File
@@ -0,0 +1,44 @@
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 String) -> Maybe String
renderF = \case
Empty -> Nothing
Step n x -> Just $ T.unpack n <> 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 $ Text.printf "(%s, %s)" a b
Both (Just a) _ -> Just a
Both _ b -> b
Branch (Just a) (Just b) -> Just $ Text.printf "(%s || %s)" a b
Branch (Just a) Nothing -> Just $ Text.printf "(%s || <skip>)" a
Branch _ b -> b
Merge (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
Merge (Just a) _ -> Just a
Merge _ b -> b
Compose (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
Compose (Just a) _ -> Just a
Compose _ b -> b
+15 -15
View File
@@ -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 -< ()
@@ -137,8 +137,8 @@ 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) -< ()
Event Open -> callService "drawer light on" (switchService [entity] True) -< ()
Event Closed -> callService "drawer light off" (switchService [entity] False) -< ()
_ -> returnA -< ()
where
entity = EntityId "switch.bedroom_drawer_light_masse"
@@ -163,8 +163,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
+8 -8
View File
@@ -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
+15 -10
View File
@@ -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
+3 -2
View File
@@ -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)
+2 -2
View File
@@ -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)
+8 -8
View File
@@ -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)
@@ -64,16 +64,16 @@ dinnerTableController = proc x -> do
ev <- dinnerLightEvents -< x
case ev of
Event LightingOn -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< On def
sleep "sleep off"-< False
callServiceDyn "Dining light on" (light [EntityId "light.kitchen_dining_large"]) -< On def
Event LightingOff -> do
sleep -< False
callServiceDyn (light [EntityId "light.kitchen_dining_large"]) -< Off
sleep "sleep off" -< False
callServiceDyn "Dining light off" (light [EntityId "light.kitchen_dining_large"]) -< Off
Event LightingSleep -> do
sleep -< True
sleep "sleep on" -< True
_ -> returnA -< ()
where
sleep = callServiceDyn (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
sleep lbl = callServiceDyn lbl (switchService [EntityId "switch.adaptive_lighting_ruokapoydan_valot_sleep_mode"])
kitchenMotionController :: HASS (Event Value) ()
kitchenMotionController = kitchenCeilingController <> dinnerTableController
+4 -4
View File
@@ -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 -< ()