From 6bb96833e19586b16be4b52ab6792f5c6de001de Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 25 Aug 2026 19:05:52 +0300 Subject: [PATCH] A lot of internals as I tried to do a switch based logic --- src/AFRP.hs | 52 ++++++++++++++- src/HomeAssistant/Controller.hs | 29 +++++++-- src/HomeAssistant/Controller/Bedroom.hs | 6 +- src/HomeAssistant/Controller/Children.hs | 82 ++++++++++++++++++++++-- src/HomeAssistant/Runtime.hs | 11 ++-- src/HomeAssistant/Runtime/Bus.hs | 4 +- src/HomeAssistant/Runtime/Connection.hs | 19 ++++-- test/AFRPSpec.hs | 58 +++++++++++++---- test/BedroomSpec.hs | 4 +- test/BusSpec.hs | 14 ++-- test/RuntimeSpec.hs | 6 +- test/Support.hs | 4 +- 12 files changed, 234 insertions(+), 55 deletions(-) diff --git a/src/AFRP.hs b/src/AFRP.hs index 1374e00..c2965b6 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -1,8 +1,10 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Arrows #-} module AFRP ( Mealy(..) , eff + , withEntities , Event(..) , hold , events @@ -20,6 +22,7 @@ module AFRP , lMerge , Request(..) , edge + , dropFirst , duration , tag , isEvent @@ -29,12 +32,14 @@ module AFRP , sliding , fixed , debounce + , currentTime + , onEvent ) where import Control.Category (Category(..), (>>>)) import Prelude hiding ((.), id) import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..)) -import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime) +import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime) import Control.Monad.Fix (MonadFix (mfix)) import Data.Either (fromLeft) import Data.Bool (bool) @@ -45,6 +50,7 @@ import qualified Data.Text as T data Request = Request { requestTime :: !UTCTime + , requestTimeZone :: !TimeZone , requestTraceId :: !UUID } deriving Show @@ -56,10 +62,27 @@ data Mealy eff a b = Mealy , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) } + +instance Semigroup b => Semigroup (Mealy eff a b) where + Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do + (x, af') <- af nt r a + (x', bf') <- bf nt r a + pure (x <> x', af' <> bf') + + +instance Monoid b => Monoid (Mealy eff a b) where + mempty = Mealy mempty $ \_ _ _ -> pure (mempty, mempty) + eff :: (Request -> a -> eff b) -> Mealy eff a b eff f = Mealy mempty $ \nt req x -> nt (f req x) >>= \b -> pure (b, eff f) +-- | 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 id = Mealy mempty (\_ _ x -> pure (x, id)) (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do @@ -102,6 +125,12 @@ data Event a | Event a deriving (Show, Eq, Functor, Foldable, Traversable) +instance Semigroup (Event a) where + (<>) = lMerge + +instance Monoid (Event a) where + mempty = Tick + hold :: a -> Mealy eff (Event a) a hold a = Mealy mempty $ \_ _ -> \case Tick -> pure (a, hold a) @@ -243,6 +272,18 @@ edge = go False False -> pure (Tick, go False) +-- | Drop the first 'Event' and pass through everything after. Useful for +-- ignoring a self-triggered event (e.g. a service call that changes the +-- very entity the arrow listens to). +dropFirst :: Mealy eff (Event a) (Event a) +dropFirst = go False + where + go seen = Mealy mempty $ \_ _ input -> + case input of + Event _ | not seen -> pure (Tick, go True) + _ -> pure (input, go seen) + + duration :: forall eff a. Mealy eff a NominalDiffTime duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd) where @@ -295,3 +336,12 @@ fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd)) | otherwise -> Just (end, acc) Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a) | otherwise -> Just (end, acc <> e a) + + +currentTime :: Mealy eff a LocalTime +currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ -> + pure (utcToLocalTime requestTimeZone requestTime, currentTime) + + +onEvent :: Mealy eff a () -> Mealy eff (Event a) () +onEvent f = events >>> (arr (const ()) ||| f) diff --git a/src/HomeAssistant/Controller.hs b/src/HomeAssistant/Controller.hs index a5aef1c..d88627d 100644 --- a/src/HomeAssistant/Controller.hs +++ b/src/HomeAssistant/Controller.hs @@ -23,16 +23,18 @@ module HomeAssistant.Controller , traceValue , switch , Target(..) + , brightness + , Light(..) ) where import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request) import Control.Arrow (Arrow(..), returnA) import Control.Category ((>>>)) -import Data.Aeson (Value) +import Data.Aeson (Value, object, (.=)) import qualified Data.Text as T import qualified Data.Set as S import Control.Lens (has, only, (^?), to) -import Data.Aeson.Lens (key, _String) +import Data.Aeson.Lens (key, _String, _Integral) import qualified Data.Text.Lens as TL import Data.Bool (bool) @@ -84,12 +86,21 @@ presence entityId =entityBool entityId +data Light + = Off + | On { brightnessPercentage :: Maybe Double } -- Turn off lights when door is closed -light :: [Target] -> Bool -> Service -light targets b = Service +light :: [Target] -> Light -> Service +light targets (On {brightnessPercentage}) = Service { serviceDomain="light" - , serviceName= bool "turn_off" "turn_on" b + , serviceName= "turn_on" + , serviceData=fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage + , serviceTarget=targets + } +light targets Off = Service + { serviceDomain="light" + , serviceName= "turn_off" , serviceData=Nothing , serviceTarget=targets } @@ -132,3 +143,11 @@ entityRead entityId = entityRead' entityId >>> toEvent entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool) entityBool entityId = entityBool' entityId >>> toEvent + +brightness :: T.Text -> HASS (Event Value) (Event Int) +brightness entityId = + entityChangeEvent' entityId + >>| arr (maybe (Left ()) Right . eventBrightness) + >>> AFRP.toEvent + where + eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral diff --git a/src/HomeAssistant/Controller/Bedroom.hs b/src/HomeAssistant/Controller/Bedroom.hs index e96eb74..7418e1a 100644 --- a/src/HomeAssistant/Controller/Bedroom.hs +++ b/src/HomeAssistant/Controller/Bedroom.hs @@ -46,7 +46,7 @@ bedroomPresenceController :: HASS (Event Value) () bedroomPresenceController = proc x -> do p <- bedroomPresence -< x case p of - Event Unoccupied -> callService createBedroomScene >>> callService (light bedroomLights False) -< () + Event Unoccupied -> callService createBedroomScene >>> callService (light bedroomLights Off) -< () Event Occupied -> callService (activateScene "makuuhuone_lights_snapshot") -< () _ -> returnA -< () @@ -101,11 +101,11 @@ bedroomButtonController = proc x -> do Event (Masse (OnButton ShortRelease)) -> callService (activateScene "scene.makuuhuone_masse") -< () Event (Masse (OnButton DoubleClick)) -> callService (activateScene "scene.makuuhuone_keski") -< () Event (Masse (OnButton LongClick)) -> callService (activateScene "scene.makuuhuone_kirkas") -< () - Event (Masse (OffButton _)) -> callService (light [AreaId "makuuhuone"] False) -< () + Event (Masse (OffButton _)) -> callService (light [AreaId "makuuhuone"] Off) -< () Event (Enishen (OnButton ShortRelease)) -> callService (activateScene "scene.makuuhuone_jemina") -< () Event (Enishen (OnButton DoubleClick)) -> callService (activateScene "scene.makuuhuone_keski") -< () Event (Enishen (OnButton LongClick)) -> callService (activateScene "scene.makuuhuone_kirkas") -< () - Event (Enishen (OffButton _)) -> callService (light [AreaId "makuuhuone"] False) -< () + Event (Enishen (OffButton _)) -> callService (light [AreaId "makuuhuone"] Off) -< () _ -> returnA -< () diff --git a/src/HomeAssistant/Controller/Children.hs b/src/HomeAssistant/Controller/Children.hs index 5141cd7..9be9c63 100644 --- a/src/HomeAssistant/Controller/Children.hs +++ b/src/HomeAssistant/Controller/Children.hs @@ -1,14 +1,82 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} module HomeAssistant.Controller.Children where -import HomeAssistant.Controller (HASS) +import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..)) import AFRP (Event) -import Data.Aeson (Value) -import Control.Arrow (Arrow(..)) +import qualified AFRP +import Control.Arrow (Arrow(..), (>>>)) +import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..)) +import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek) +import Data.Functor.Contravariant (Predicate (..), (>$<)) + +-- Let's see building some reasonable interface for utctime +dow :: Day -> (WeekOfYear, Int) +dow = mondayStartWeek + + +weekday :: Predicate Day +weekday = Predicate (betweenInclusive 1 5 . snd . dow) + where + betweenInclusive a b c = c >= a && c <= b + +time :: (Int, Int) -> Predicate TimeOfDay +time (h,m) = mconcat + [ Predicate (equals h . todHour) + , Predicate (equals m . todMin) + ] + where + equals a b = a == b + + +atTime :: Predicate LocalTime -> HASS a (Event ()) +atTime p = AFRP.currentTime + >>> arr (getPredicate p) + >>> AFRP.edge -- I don't have any proper presence sensors in their bedroom -- and they are notoriously bad at changing clothes in complete darkness -- So I have set up an automation that attempts to turn on the lights sometime -- before they leave for school and turns them off a bit later --- --- I don't have enough primitives for this yet, leaving as a placeholder -schoolLightController :: HASS (Event Value) () -schoolLightController = arr (const ()) + +-- Don't mconcat these predicates they have && behavior +-- if you mconcat the actual arrows, they combine the behaviors of the separate branches +-- essentially becoming || behavior +timersOff :: [Predicate LocalTime] +timersOff = + [ day 1 <> at (08,15) + , day 2 <> at (09,15) + , day 3 <> at (08,15) + , day 4 <> at (08,15) + , day 5 <> at (08,15) + , at (18,57) -- debug + ] + where + dayOfWeek = snd . mondayStartWeek . localDay + at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m) + day n = dayOfWeek >$< Predicate (== n) + +timersOn :: [Predicate LocalTime] +timersOn = + [ day 1 <> at (07,30) + , day 2 <> at (08,30) + , day 3 <> at (07,30) + , day 4 <> at (07,30) + , day 5 <> at (07,30) + , at (18,55) -- debug + ] + where + dayOfWeek = snd . mondayStartWeek . localDay + at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m) + day n = dayOfWeek >$< Predicate (== n) + +schoolLightController :: HASS a () +schoolLightController = lightsOn <> lightsOff + + +lightsOn :: HASS a () +lightsOn = foldMap atTime timersOn + >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] On{brightnessPercentage = Just 100})) + +lightsOff :: HASS a () +lightsOff = foldMap atTime timersOff + >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off)) diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs index d73f937..6895c4c 100644 --- a/src/HomeAssistant/Runtime.hs +++ b/src/HomeAssistant/Runtime.hs @@ -18,7 +18,7 @@ import Control.Concurrent.Async (async, waitAny) import Control.Concurrent.STM (atomically, dupTChan, readTChan) import Data.Aeson (Value) import qualified Data.Text as T -import Data.Time (getCurrentTime) +import Data.Time (getCurrentTime, getCurrentTimeZone) import Data.Void (Void, absurd) import HomeAssistant.Controller (HASS, HASSEff (..)) import HomeAssistant.Runtime.Bus @@ -33,11 +33,13 @@ import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), run import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Fix (MonadFix) import HomeAssistant.Controller.Ruuvi (ruuviController) +import HomeAssistant.Controller.Children (schoolLightController) step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b) step nt trace (Mealy _ f) a = do now <- liftIO getCurrentTime - f nt (Request now trace) a + tz <- liftIO getCurrentTimeZone + f nt (Request now tz trace) a data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool @@ -47,7 +49,8 @@ controllers = , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation , Controller "bedroom-drawer" bedroomDrawerController True , Controller "bedroom-humidifier" humidifierController False - , Controller "ruuvi-controller" ruuviController True + , Controller "ruuvi-controller" ruuviController False + , Controller "school-light-controller" schoolLightController True ] -- | Steps the machine for every inbound message; service calls go to the @@ -62,7 +65,7 @@ runController bus (Controller name machine _enabled) = do msg <- atomically (readTChan inbound) uuid <- UUID.V4.nextRandom let ns = Namespace [name] - (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f (Event msg) + (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg go inbound f' defaultMain :: IO () diff --git a/src/HomeAssistant/Runtime/Bus.hs b/src/HomeAssistant/Runtime/Bus.hs index 8087b40..c02c2e1 100644 --- a/src/HomeAssistant/Runtime/Bus.hs +++ b/src/HomeAssistant/Runtime/Bus.hs @@ -26,14 +26,14 @@ import Katip (LogEnv, closeScribes, mkHandleScribe, ColorStrategy (..), permitIt import Control.Exception (bracket) import System.IO (stdout) import Data.UUID (toText) -import AFRP (Request(..)) +import AFRP (Request(..), Event(..)) import Control.Monad.IO.Class (MonadIO, liftIO) -- | Shared runtime state: inbound is a broadcast channel (controllers -- read from 'dupTChan' copies), outbound queues service calls for the -- writer, conn holds the current websocket (Nothing before first connect). data Bus = Bus - { busInbound :: TChan Value + { busInbound :: TChan (Event Value) , busOutbound :: TChan (Request, Service) , busConn :: TVar (Maybe Connection) , busGen :: CallIdGen diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 795d6e5..0574b05 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -15,13 +15,14 @@ import Control.Concurrent.STM , writeTChan , writeTVar ) +import Control.Concurrent.Async (race) +import Control.Concurrent (threadDelay) import Control.Exception (onException) import Control.Exception.Annotated (throw) import Control.Lens ((^?)) import Control.Monad (forever, forM_) import Data.Aeson (Value, eitherDecode, encode, object, (.=)) import Data.Aeson.Lens (key, _String) -import qualified Data.ByteString.Lazy as BL import qualified Data.Set as S import qualified Data.Text as T import Data.Void (Void) @@ -31,7 +32,7 @@ import HomeAssistant.Runtime.Supervisor (Fatal (..)) import qualified Network.WebSockets as WS import Katip (runKatipContextT, sl, logFM, Severity (..), ls) import Data.UUID (toText) -import AFRP (Request(..)) +import AFRP (Request(..), Event(..)) -- | Connect, authenticate, subscribe, then receive and broadcast forever. -- Restarting this action reconnects. All setup sends happen before the @@ -79,12 +80,18 @@ subscribe bus conn ents = -- | Undecodable messages are skipped: reconnecting cannot fix a decode -- problem, so crashing here would only produce a hot restart loop. +-- +-- Each read races a one-second timeout: a timeout broadcasts 'Tick' so +-- time-based primitives (debounce, rollup, fixed, ...) keep advancing +-- even when no state changes arrive. receiveLoop :: Bus -> WS.Connection -> IO Void receiveLoop bus conn = forever $ do - msg <- WS.receiveData conn :: IO BL.ByteString - case eitherDecode msg of - Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err - Right v -> atomically $ writeTChan (busInbound bus) v + winner <- race (threadDelay 1000000) (WS.receiveData conn) + case winner of + Left () -> atomically $ writeTChan (busInbound bus) Tick + Right msg -> case eitherDecode msg of + Left err -> putStrLn $ "[reader] skipping undecodable message: " <> err + Right v -> atomically $ writeTChan (busInbound bus) (Event v) receiveJSON :: WS.Connection -> IO Value receiveJSON conn = do diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs index aa6acc5..1f28816 100644 --- a/test/AFRPSpec.hs +++ b/test/AFRPSpec.hs @@ -11,7 +11,7 @@ import Data.Functor.Identity (Identity (..)) import Data.List (sort) import qualified Data.Set as S import qualified Data.Text as T -import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime) +import Data.Time (NominalDiffTime, UTCTime (..), utc) import Data.UUID (nil) import Hedgehog import qualified Hedgehog.Gen as Gen @@ -20,7 +20,7 @@ import Test.Hspec import Test.Hspec.Hedgehog fakeRequest :: Request -fakeRequest = Request (sec 0) nil +fakeRequest = Request (sec 0) utc nil sec :: Integer -> UTCTime sec n = UTCTime (toEnum 0) (fromIntegral n) @@ -34,7 +34,7 @@ runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b] runTimed _ [] = [] runTimed m ((s, a) : as) = - case runIdentity (AFRP.runMealy m id (Request (sec s) nil) a) of + case runIdentity (AFRP.runMealy m id (Request (sec s) utc nil) a) of (b, m') -> b : runTimed m' as -- | A minimal State monad for observing effectful arrows (e.g. whenA gating). @@ -72,6 +72,7 @@ spec = describe "AFRP" $ do lMergeSpec changesSpec edgeSpec + dropFirstSpec filterASpec slidingSpec mapAccumSpec @@ -139,6 +140,23 @@ lMergeSpec = describe "lMerge" $ do it "prefers right Event if left is Tick" $ lMerge Tick (Event (2 :: Int)) `shouldBe` Event (2 :: Int) + it "Tick is a left identity" $ + hedgehog $ do + e <- forAll eventGen + lMerge Tick e === e + + it "Tick is a right identity" $ + hedgehog $ do + e <- forAll eventGen + lMerge e Tick === e + + it "is associative" $ + hedgehog $ do + a <- forAll eventGen + b <- forAll eventGen + c <- forAll eventGen + lMerge a (lMerge b c) === lMerge (lMerge a b) c + changesSpec :: Spec changesSpec = describe "changes" $ do it "first output is always Tick" $ @@ -193,6 +211,20 @@ edgeSpec = describe "edge" $ do else o' === Tick _ -> failure +dropFirstSpec :: Spec +dropFirstSpec = describe "dropFirst" $ do + it "drops the first Event, passes the rest" $ + runPure dropFirst [Tick, Event 1, Event 2, Event 3] + `shouldBe` [Tick, Tick, Event 2, Event 3 :: Event Int] + + it "passes Tick through untouched before first Event" $ + runPure dropFirst [Tick, Tick, Tick :: Event Int] + `shouldBe` [Tick, Tick, Tick :: Event Int] + + it "drops only the first Event, Ticks before it are inert" $ + runPure dropFirst [Tick, Tick, Event 'a', Tick, Event 'b'] + `shouldBe` [Tick, Tick, Tick, Tick, Event 'b' :: Event Char] + filterASpec :: Spec filterASpec = describe "filterA" $ do it "lets through values matching predicate" $ @@ -250,7 +282,7 @@ mapAccumSpec = describe "mapAccum" $ do for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) -> cur === sum (take (i + 1) xs) - preMapAccumSpec :: Spec +preMapAccumSpec :: Spec preMapAccumSpec = describe "preMapAccum" $ do it "running sum with pre-state extraction" $ runPure (preMapAccum (+) (0 :: Int) id) [1, 2, 3] @@ -416,7 +448,7 @@ effSpec :: Spec effSpec = describe "eff" $ do it "lifts a pure effect function into a stateless Mealy" $ runPure (eff (\_ x -> Identity (x + 1))) [1, 2, 3] - `shouldBe` [2, 3, 4] + `shouldBe` [2 :: Int, 3, 4] it "output equals f(input) for every step" $ hedgehog $ do @@ -427,7 +459,7 @@ effSpec = describe "eff" $ do switchSpec :: Spec switchSpec = describe "switch" $ do it "switches to the continuation at the first Event" $ - runPure (switch (arr (\x -> (x, if x >= 3 then Event () else Tick))) + runPure (switch (arr (\x -> (x, if x >= (3 :: Int) then Event () else Tick))) (const (arr (const 99)))) [1, 2, 3, 4, 5] `shouldBe` [1, 2, 99, 99, 99] @@ -436,14 +468,14 @@ switchSpec = describe "switch" $ do runPure (switch (arr (\x -> (x, Tick :: Event ()))) (const (arr (const 99)))) [1, 2, 3] - `shouldBe` [1, 2, 3] + `shouldBe` [1, 2, 3 :: Int] it "prefix outputs come from the first arrow, suffix from the continuation" $ hedgehog $ do threshold <- forAll $ Gen.int (Range.linear (-20) 20) xs <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear (-20) 20)) - let first = arr (\x -> (x, if x >= threshold then Event () else Tick)) - out = runPure (switch first (const (arr (const 99)))) xs + let firstArr = arr (\x -> (x, if x >= threshold then Event () else Tick)) + out = runPure (switch firstArr (const (arr (const 99)))) xs (pre, _post) = break (>= threshold) xs take (length pre) out === pre drop (length pre) out === replicate (length xs - length pre) 99 @@ -513,7 +545,7 @@ thenASpec = describe "thenA" $ do xs <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear (-20) 20)) let out = runPure (filterA (even @Int) >>| filterA (> 0)) xs expected = - [ if not (even x) then Left () + [ if odd x then Left () else if x > 0 then Right x else Left () | x <- xs ] @@ -523,14 +555,14 @@ sampleSpec :: Spec sampleSpec = describe "sample" $ do it "tags the current value onto the Event structure" $ runPure sample [(1, Tick), (2, Event 'a'), (3, Tick)] - `shouldBe` [Tick, Event 2, Tick] + `shouldBe` [Tick, Event @Int 2, Tick] it "output is Event a iff the input event is present" $ hedgehog $ do vals <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100)) evs <- forAll $ Gen.list (Range.linear 0 30) eventGen let n = min (length vals) (length evs) - ps = zip (take n vals) (take n evs) + ps = take n $ zip vals evs out = runPure sample ps for_ (zip ps out) $ \((v, ev), o) -> o === tag v ev @@ -552,7 +584,7 @@ entitiesSpec = describe "entities" $ do entities (arr (+ 1) :: Mealy Identity Int Int) `shouldBe` S.empty it "eff carries no entities" $ - entities (eff (\_ x -> Identity (x + 1))) `shouldBe` S.empty + entities (eff (\_ x -> Identity (x + 1 :: Int))) `shouldBe` S.empty it "primitive combinators carry no entities" $ do entities (hold 'a') `shouldBe` S.empty diff --git a/test/BedroomSpec.hs b/test/BedroomSpec.hs index a8c8d4a..86be855 100644 --- a/test/BedroomSpec.hs +++ b/test/BedroomSpec.hs @@ -102,7 +102,7 @@ buttonSpec = describe "bedroomButtonController" $ do it "Masse off click turns the bedroom lights off" $ services (runHASS bedroomButtonController [masseButton "2_short_release"]) - `shouldBe` [[light [area] False]] + `shouldBe` [[light [area] Off]] it "Enishen single click turns on her nightstand scene (lowest)" $ services (runHASS bedroomButtonController [enishenButton "1_short_release"]) @@ -118,7 +118,7 @@ buttonSpec = describe "bedroomButtonController" $ do it "Enishen off click turns the bedroom lights off" $ services (runHASS bedroomButtonController [enishenButton "2_short_release"]) - `shouldBe` [[light [area] False]] + `shouldBe` [[light [area] Off]] it "ignores the initial press (scene only fires on release)" $ services (runHASS bedroomButtonController [masseButton "1_initial_press"]) diff --git a/test/BusSpec.hs b/test/BusSpec.hs index d4eb40e..f7cf2f2 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -2,7 +2,7 @@ module BusSpec (spec) where -import AFRP (Request (..)) +import AFRP (Request (..), Event (..)) import Control.Concurrent.STM ( atomically , dupTChan @@ -10,7 +10,7 @@ import Control.Concurrent.STM , writeTChan ) import Data.Aeson (Value (..)) -import Data.Time (UTCTime (..)) +import Data.Time (UTCTime (..), utc) import Data.UUID (nil) import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..)) import HomeAssistant.Runtime.Bus @@ -22,15 +22,15 @@ spec = describe "Bus" $ do it "broadcasts inbound messages to every dup'd channel in order" $ withBus InfoS $ \bus -> do p1 <- atomically $ dupTChan (busInbound bus) p2 <- atomically $ dupTChan (busInbound bus) - atomically $ writeTChan (busInbound bus) (Number 1) - atomically $ writeTChan (busInbound bus) (Number 2) + atomically $ writeTChan (busInbound bus) (Event (Number 1)) + atomically $ writeTChan (busInbound bus) (Event (Number 2)) r1 <- atomically $ (,) <$> readTChan p1 <*> readTChan p1 r2 <- atomically $ (,) <$> readTChan p2 <*> readTChan p2 - r1 `shouldBe` (Number 1, Number 2) - r2 `shouldBe` (Number 1, Number 2) + r1 `shouldBe` (Event (Number 1), Event (Number 2)) + r2 `shouldBe` (Event (Number 1), Event (Number 2)) it "channelHassEval writes CallService to the outbound channel" $ withBus InfoS $ \bus -> do - let req = Request (UTCTime (toEnum 0) 0) nil + let req = Request (UTCTime (toEnum 0) 0) utc nil svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"] runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $ channelHassEval bus (CallService req svc) diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs index d520982..2f85fdd 100644 --- a/test/RuntimeSpec.hs +++ b/test/RuntimeSpec.hs @@ -16,9 +16,9 @@ spec = pure () -- putStrLn "Before the delay" -- threadDelay 100000 -- let the controller dup its inbound channel -- putStrLn "After the delay" --- atomically $ writeTChan (busInbound bus) (doorEvent "on") -- initial value: no change event --- atomically $ writeTChan (busInbound bus) (doorEvent "off") -- door closes: lights on --- atomically $ writeTChan (busInbound bus) (doorEvent "on") -- door opens: lights off +-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "on")) -- initial value: no change event +-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "off")) -- door closes: lights on +-- atomically $ writeTChan (busInbound bus) (Event (doorEvent "on")) -- door opens: lights off -- putStrLn "After the writes" -- Right (_, svc1) <- boundedRead (busOutbound bus) -- Right (_, svc2) <- boundedRead (busOutbound bus) diff --git a/test/Support.hs b/test/Support.hs index b238d3a..76844a2 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -14,13 +14,13 @@ module Support import Control.Monad.Fix (MonadFix (..)) import Data.Aeson (Value, object, (.=)) import qualified Data.Text as T -import Data.Time (UTCTime (..)) +import Data.Time (UTCTime (..), utc) import Data.UUID (nil) import AFRP (Mealy (..), Request (..)) import HomeAssistant.Controller (HASSEff (..), Service) fakeRequest :: Request -fakeRequest = Request (sec 0) nil +fakeRequest = Request (sec 0) utc nil sec :: Integer -> UTCTime sec n = UTCTime (toEnum 0) (fromIntegral n)