A lot of internals as I tried to do a switch based logic

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)

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

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 -< ()
 
 

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))

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 ()

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

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
+  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) v
+      Right v  -> atomically $ writeTChan (busInbound bus) (Event v)
 
 receiveJSON :: WS.Connection -> IO Value
 receiveJSON conn = do

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

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"])

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)

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)

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)