Test the bedroom spec

test/Support.hs

@@ -0,0 +1,81 @@
+{-# 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-change event payload matching `entityChangeEvent'` / `entityBool'` lenses.
+stateEvent :: T.Text -> T.Text -> Value
+stateEvent entityId state = object
+  [ "event" .= object
+    [ "data" .= object
+      [ "entity_id" .= entityId
+      , "new_state" .= object [ "state" .= state ]
+      ]
+    ]
+  ]
+
+-- | Build an Ikea button event payload matching `ikeaQuickButton` lenses.
+buttonEvent :: T.Text -> T.Text -> Value
+buttonEvent entityId eventType = object
+  [ "event" .= object
+    [ "data" .= object
+      [ "entity_id" .= entityId
+      , "new_state" .= object
+        [ "attributes" .= object [ "event_type" .= eventType ] ]
+      ]
+    ]
+  ]