88 lines
2.5 KiB
Haskell
88 lines
2.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Support
|
|
( Acc(..)
|
|
, interp
|
|
, runHASS
|
|
, services
|
|
, fakeRequest
|
|
, sec
|
|
, stateEvent
|
|
, buttonEvent
|
|
) where
|
|
|
|
import Control.Monad.Fix (MonadFix (..))
|
|
import Data.Aeson (Value, object, (.=))
|
|
import qualified Data.Text as T
|
|
import Data.Time (UTCTime (..))
|
|
import Data.UUID (nil)
|
|
import AFRP (Mealy (..), Request (..))
|
|
import HomeAssistant.Controller (HASSEff (..), Service)
|
|
|
|
fakeRequest :: Request
|
|
fakeRequest = Request (sec 0) nil
|
|
|
|
sec :: Integer -> UTCTime
|
|
sec n = UTCTime (toEnum 0) (fromIntegral n)
|
|
|
|
-- | A pure Writer-like monad accumulating `Service` calls per step.
|
|
newtype Acc a = Acc { runAcc :: [Service] -> (a, [Service]) }
|
|
|
|
instance Functor Acc where
|
|
fmap f (Acc g) = Acc $ \s -> let (a, s') = g s in (f a, s')
|
|
|
|
instance Applicative Acc where
|
|
pure a = Acc (\s -> (a, s))
|
|
Acc f <*> Acc x = Acc $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'')
|
|
|
|
instance Monad Acc where
|
|
Acc m >>= k = Acc $ \s -> let (a, s') = m s; (b, s'') = runAcc (k a) s' in (b, s'')
|
|
|
|
instance MonadFix Acc where
|
|
mfix f = Acc $ \s -> let (a, s') = runAcc (f a) s in (a, s')
|
|
|
|
-- | Interpret `HASSEff` in `Acc`: record `CallService`, drop tracing/debug.
|
|
interp :: HASSEff a -> Acc a
|
|
interp (CallService _ svc) = Acc $ \s -> ((), s ++ [svc])
|
|
interp (Debug _) = pure ()
|
|
interp (Trace _ _) = pure ()
|
|
|
|
-- | Run a HASS arrow over a list of inputs, collecting per-step emitted services.
|
|
runHASS :: Mealy HASSEff a b -> [a] -> [(b, [Service])]
|
|
runHASS _ [] = []
|
|
runHASS m (a : as) =
|
|
case runAcc (runMealy m interp fakeRequest a) [] of
|
|
((b, m'), svcs) -> (b, svcs) : runHASS m' as
|
|
|
|
services :: [(b, [Service])] -> [[Service]]
|
|
services = map snd
|
|
|
|
-- | Build a state-trigger payload matching `entityChangeEvent'` / `entityBool'`
|
|
-- lenses. The subscribe_trigger websocket event wraps the trigger datum under
|
|
-- `event.variables.trigger`, with `entity_id` and `to_state.state` fields.
|
|
stateEvent :: T.Text -> T.Text -> Value
|
|
stateEvent entityId state = object
|
|
[ "event" .= object
|
|
[ "variables" .= object
|
|
[ "trigger" .= object
|
|
[ "entity_id" .= entityId
|
|
, "to_state" .= object [ "state" .= state ]
|
|
]
|
|
]
|
|
]
|
|
]
|
|
|
|
-- | Build an Ikea button trigger payload matching `ikeaQuickButton` lenses.
|
|
buttonEvent :: T.Text -> T.Text -> Value
|
|
buttonEvent entityId eventType = object
|
|
[ "event" .= object
|
|
[ "variables" .= object
|
|
[ "trigger" .= object
|
|
[ "entity_id" .= entityId
|
|
, "to_state" .= object
|
|
[ "attributes" .= object [ "event_type" .= eventType ] ]
|
|
]
|
|
]
|
|
]
|
|
]
|