Test the bedroom spec

.gitignore

@@ -5,8 +5,3 @@ dist-newstyle
 .worktrees/
 
 docs/superpowers
-
-*.hp
-*.eventlog
-*.eventlog.html
-*.rrd

default.nix

@@ -1,8 +1,6 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, cereal, cereal-conduit, conduit, containers, directory, ekg-core
+, hedgehog, hspec, hspec-hedgehog, katip, lens, lens-aeson, lib
-, filepath, hedgehog, hspec, hspec-hedgehog, katip, lens
+, network, stm, text, time, uuid, websockets
-, lens-aeson, lib, network, process, stm, text, time
-, unordered-containers, uuid, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -11,16 +9,13 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson annotated-exception async base bytestring cereal
+    aeson annotated-exception async base bytestring katip lens
-    cereal-conduit conduit containers directory ekg-core filepath katip
+    lens-aeson network stm text time uuid websockets
-    lens lens-aeson network process stm text time unordered-containers
-    uuid websockets
   ];
   executableHaskellDepends = [ base ];
   testHaskellDepends = [
-    aeson annotated-exception async base cereal containers directory
+    aeson annotated-exception async base hedgehog hspec hspec-hedgehog
-    ekg-core hedgehog hspec hspec-hedgehog katip process stm text time
+    katip stm text time uuid
-    unordered-containers uuid
   ];
   license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
   mainProgram = "home-assistant-controller";

flake.nix

@@ -20,15 +20,7 @@
       });
     });
     in rec {
-      packages.home-assistant-controller = pkgs.symlinkJoin {
+      packages.home-assistant-controller = pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller;
-        name = "home-assistant-controller";
-        paths = [ (pkgs.haskell.lib.justStaticExecutables hp.home-assistant-controller) ];
-        nativeBuildInputs = [ pkgs.makeWrapper ];
-        postBuild = ''
-          wrapProgram $out/bin/home-assistant-controller \
-            --set HA_RRDTOOL ${pkgs.lib.getBin pkgs.rrdtool}/bin/rrdtool
-        '';
-      };
       defaultPackage = packages.home-assistant-controller;
       devShell = hp.shellFor {
         packages = h: [h.home-assistant-controller];
@@ -42,8 +34,6 @@
           hp.graphmod
 
           hp.haskell-language-server
-
-          rrdtool
         ];
       };
     }

home-assistant-controller.cabal

@@ -62,13 +62,10 @@ library
     exposed-modules:  AFRP
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
-                    , HomeAssistant.Controller.Kitchen
-                    , HomeAssistant.Controller.Children
                     , HomeAssistant.Controller.Ruuvi
                     , HomeAssistant.Runtime
                     , HomeAssistant.Runtime.Bus
                     , HomeAssistant.Runtime.Connection
-                    , HomeAssistant.Runtime.Metrics
                     , HomeAssistant.Runtime.Supervisor
 
     -- Modules included in this library but not exported.
@@ -92,16 +89,6 @@ library
                     , annotated-exception
                     , uuid
                     , katip
-                    , containers
-                    , ekg-core
-                    , unordered-containers
-                    , process
-                    , directory
-                    , cereal
-                    , containers
-                    , filepath
-                    , conduit
-                    , cereal-conduit
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -132,7 +119,7 @@ executable home-assistant-controller
 
     -- Base language which the package is written in.
     default-language: GHC2024
-    ghc-options: -threaded -with-rtsopts=-T
+    ghc-options: -threaded
 
 test-suite home-assistant-controller-test
     -- Import common warning flags.
@@ -142,13 +129,11 @@ test-suite home-assistant-controller-test
     default-language: GHC2024
 
     -- Modules included in this executable, other than Main.
-    other-modules:    AFRPLawsSpec
+    other-modules:    AFRPSpec
-                    , AFRPSpec
                     , BackoffProp
                     , BedroomSpec
                     , BusSpec
                     , ConnectionSpec
-                    , MetricsSpec
                     , RuntimeSpec
                     , SupervisorSpec
                     , Support
@@ -172,7 +157,6 @@ test-suite home-assistant-controller-test
         hspec,
         stm,
         aeson,
-        cereal,
         text,
         async,
         hedgehog,
@@ -180,9 +164,4 @@ test-suite home-assistant-controller-test
         annotated-exception,
         time,
         uuid,
-        katip,
+        katip
-        containers,
-        ekg-core,
-        unordered-containers,
-        process,
-        directory

src/AFRP.hs

@@ -1,16 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE Arrows #-}
 
 module AFRP
   ( Mealy(..)
-  , Auto(..)
-  , DecodedAuto(..)
   , eff
-  , withEntities
   , Event(..)
   , hold
   , events
-  -- , switch
+  , switch
   , preMapAccum
   , preMapAccumRequest
   , mapAccum
@@ -22,12 +18,8 @@ module AFRP
   , (>>|)
   , toEvent
   , lMerge
-  , Pair(..)
   , Request(..)
-  , SerializeUTCTime(..)
-  , SerializeLocalTime(..)
   , edge
-  , waitFor
   , duration
   , tag
   , isEvent
@@ -35,295 +27,79 @@ module AFRP
   , sample
   , rollup
   , sliding
+  , fixed
   , debounce
-  , currentTime
-  , onEvent
-  , save
-  , load
-  , stepAuto
-  , stepAutoSerializing
   ) where
 
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
-import Control.Arrow (Arrow(..), ArrowChoice(..))
+import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..))
-import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime (LocalTime), utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime, TimeOfDay (TimeOfDay), diffLocalTime)
+import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
+import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
+import Data.Monoid (Endo(..))
 import Data.UUID (UUID)
-import qualified Data.Set as S
-import qualified Data.Text as T
-import Data.Serialize (Get, Putter, Serialize (put), runGet, get)
-import qualified Data.ByteString as B
-import Control.Exception (IOException, handle, throwIO)
-import System.IO.Error (isDoesNotExistError)
-import GHC.Generics (Generic)
-import Data.Sequence (Seq, (|>))
-import qualified Data.Foldable as F
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Conduit (ConduitT, (.|))
-import qualified Data.Conduit.Cereal as CC
-import qualified Conduit as C
-
-
-data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
-
-data State s = State {state :: !s, dirty :: !Bool}
-             deriving Functor
-
-
-instance Semigroup s => Semigroup (State s) where
-  s1 <> s2 = State (state s1 <> state s2) (dirty s1 || dirty s2)
-
-instance Monoid s => Monoid (State s) where
-  mempty = State mempty False
-
-instance Applicative State where
-  pure a = State a False
-  s1 <*> s2 = State
-      { state =
-          let a = state s2
-              f = state s1
-          in f a
-      , dirty = dirty s1 || dirty s2
-      }
-
-mergeState :: State s1 -> State s2 -> State (s1, s2)
-mergeState s1 s2 = (,) <$> s1 <*> s2
-
-
-mergeCodec :: Codec s -> Codec s1 -> Codec (s, s1)
-mergeCodec (Codec agetter aputter) (Codec bgetter bputter) = Codec (mergeGet agetter bgetter) (mergePut aputter bputter)
-  where
-    mergePut :: Putter s -> Putter s1 -> Putter (s, s1)
-    mergePut p1 p2 (s, s1) = p1 s >> p2 s1
-    mergeGet :: Get s -> Get s' -> Get (s, s')
-    mergeGet g1 g2 = (,) <$> g1 <*> g2
-
-data Pair a b = Pair !a !b
 
 data Request = Request
   { requestTime :: !UTCTime
-  , requestTimeZone :: !TimeZone
   , requestTraceId :: !UUID
-  } deriving (Show, Eq)
-
-
-data Auto m a b
-  = Fun (Request -> a -> b) -- Stateless variant, needed at least for 'id'
-  | forall s. Stateful !(Codec s) !(State s) !(State s -> Request -> a -> m (b, State s))  -- State is explicitly part of it
-
-
-instance Monad m => Functor (Auto m a) where
-  fmap f = \case
-    Fun x -> Fun $ \req -> f . x req
-    Stateful codec s x -> Stateful codec s $ \s' req a -> do
-      (a',s'') <- x s' req a
-      pure (f a', s'')
-
-instance Monad m => Applicative (Auto m a) where
-  pure a = Fun (\_req -> const a)
-  fa <*> fb =
-    case (fa,fb) of
-         (Fun af, Fun bf) -> Fun $ \req -> (af req <*> bf req)
-         (Stateful codec s af, Fun bf) -> Stateful codec s
-          (\s' req x -> do
-           let a = bf req x
-           (h, s'') <- af s' req x
-           pure (h a, s'')
-          )
-         (Fun af, Stateful codec s bf) -> Stateful codec s
-          (\s' req x -> do
-           (a, s'') <- bf s' req x
-           let h = af req x
-           pure (h a, s'')
-          )
-         (Stateful acodec as af, Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
-          (\s' req x -> do
-           (a, as') <- bf (snd <$> s') req x
-           (h, bs') <- af (fst <$> s') req x
-           pure (h a, mergeState bs' as')
-          )
-
-
-instance (Monad m, Semigroup b) => Semigroup (Auto m a b) where
-  fa <> fb =
-    case (fa,fb) of
-         (Fun af, Fun bf) -> Fun (af <> bf)
-         (Stateful codec s af, Fun bf) -> Stateful codec s
-           (\s' req a -> do
-            (ab, s'') <- af s' req a
-            let bb = bf req a
-            pure (ab <> bb, s'')
-           )
-         (Fun af, Stateful codec s bf) -> Stateful codec s
-           (\s' req a -> do
-            let ab = af req a
-            (bb, s'') <- bf s' req a
-            pure (ab <> bb, s'')
-           )
-         (Stateful acodec as af , Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
-           (\s req a -> do
-            (ab, as'') <- af (fst <$> s) req a
-            (bb, bs'') <- bf (snd <$> s) req a
-            pure (ab <> bb, mergeState as'' bs'')
-           )
-
-
-instance (Monad m, Monoid b) => Monoid (Auto m a b) where
-  mempty = Fun $ \_req _ -> mempty
-
-
-instance Monad m => Category (Auto m) where
-  id = Fun $ \_ -> id
-  af . ag =
-    case (af, ag) of
-         (Fun f, Fun g) -> Fun (\req -> f req . g req)
-         (Stateful codec s f, Fun g) -> Stateful codec s (\s' req -> f s' req . g req)
-         (Fun f, Stateful codec s g) -> Stateful codec s (\s' req -> fmap (first (f req)) . g s' req)
-         (Stateful fcodec fs f , Stateful gcodec gs g) ->
-           Stateful (mergeCodec fcodec gcodec) (mergeState fs gs) (\s req a -> do
-                       (b, s') <- g (snd <$> s) req a
-                       (c, s'') <- f (fst <$> s) req b
-                       pure (c, mergeState s'' s'))
-
-
-
-instance Monad m => Arrow (Auto m) where
-  arr f = Fun $ const f
-  first = \case
-    Fun f -> Fun $ \req -> first (f req)
-    Stateful codec s f -> Stateful codec s $ \s' req (b,d) -> do
-      (c, s'') <- f s' req b
-      pure ((c,d), s'')
-
-instance Monad m => ArrowChoice (Auto m) where
-  left = \case
-    Fun f -> Fun $ \req ->
-      \case
-        Left b -> Left $ f req b
-        Right d -> Right d
-    Stateful codec s f -> Stateful codec s $ \s' req -> \case
-      Right d -> pure (Right d, s')
-      Left b -> do
-        (c, s'') <- f s' req b
-        pure (Left c, s'')
-
-
-serialize :: Monad m => Auto eff a b -> ConduitT i B.ByteString m ()
-serialize = \case
-  Fun _ -> CC.sourcePut (put ())
-  Stateful Codec{putter} s _ -> CC.sourcePut (putter (state s))
-
-data DecodedAuto m a b
-  = Decoded (Auto m a b) -- decoded from serialized state
-  | FailDecode String (Auto m a b) -- gives back the original + errmsg
-
-deserialize :: B.ByteString -> Auto m a b -> DecodedAuto m a b
-deserialize bs = \case
-  Fun f -> Decoded (Fun f) -- no state to decode, success by default
-  Stateful codec s f ->
-    either
-      (\err -> FailDecode err (Stateful codec s f))
-      (\s' -> Decoded $ Stateful codec (pure s') f)
-      $ runGet (getter codec) bs
-
-
-save :: FilePath -> Auto m a b -> IO (Auto m a b)
-save path s
-  | isDirty s = do
-    -- Using conduit  machinery as it handles the exception handling for me
-    () <- C.runResourceT $ C.runConduit (serialize s .| C.sinkFileCautious path)
-    pure $ cleanDirty s
-  | otherwise = pure s
-  where
-    cleanDirty :: Auto m a b -> Auto m a b
-    cleanDirty (Stateful codec s' f) = Stateful codec s'{dirty=False} f
-    cleanDirty a = a
-    isDirty :: Auto m a b -> Bool
-    isDirty (Stateful _ s' _) = dirty s'
-    isDirty _ = False
-
-
-load :: forall m a b. FilePath -> Auto m a b -> IO (DecodedAuto m a b)
-load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path)
-  where
-    defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
-    defaultOnMissingFile e
-      | isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
-      | otherwise = throwIO 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
-  , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b
   }
+  deriving Show
 
-
+newtype Mealy eff a b = Mealy
-instance Semigroup b => Semigroup (Mealy eff a b) where
+  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (b, Mealy eff a b) }
-  Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt -> af nt <> bf nt
-
-
-instance Monoid b => Monoid (Mealy eff a b) where
-  mempty = Mealy mempty $ \_nt -> mempty
-    -- where
-    --   m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = Mealy mempty $ \nt -> do
+eff f = Mealy $ \nt req x ->
-  Stateful (Codec get put) (State () False) $ \s req a -> do
+  nt (f req x) >>= \b -> pure (b, eff f)
-    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
-  id = Mealy mempty (\_ -> id)
+  id = Mealy (\_ _ x -> pure (x, id))
-  (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do
+  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
-    f nt . g nt
+    (b, g') <- g nt t a
+    (c, f') <- f nt t b
+    pure (c, f' . g')
 
 instance Arrow (Mealy eff) where
-  arr f = Mealy mempty $ \_nt -> arr f
+  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
-  first (Mealy st f) = Mealy st $ \nt -> first (f nt)
+  first (Mealy f) = Mealy $ \nt t (b,d) -> do
+    (c, f') <- f nt t b
+    pure ((c, d), first f')
 
 instance ArrowChoice (Mealy eff) where
-  left (Mealy st f) = Mealy st $ \nt -> left (f nt)
+  left (Mealy f) = Mealy $ \nt t -> \case
+    Left b -> do
+      (c, f') <- f nt t b
+      pure (Left c, left f')
+    Right d -> pure (Right d, left (Mealy f))
 
+instance ArrowLoop (Mealy eff) where
+  loop (Mealy f) = Mealy $ \nt t b -> do
+    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
+    pure (c, loop f')
 
 instance Functor (Mealy eff a) where
-  fmap f (Mealy st g) = Mealy st $ \nt -> fmap f (g nt)
+  fmap f (Mealy g) = Mealy $ \nt t a -> do
+    (b, g') <- g nt t a
+    pure (f b, fmap f g')
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy mempty $ \_ -> pure b
+  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
-  Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt ->
+  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
-    f nt <*> x nt
+    (f', fNext) <- f nt t a
+    (x', xNext) <- x nt t a
+    pure (f' x', fNext <*> xNext)
 
 data Event a
   = Tick
   | Event a
-  deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
+  deriving (Show, Eq, Functor, Foldable, Traversable)
-
-instance Serialize a => Serialize (Event a)
-
-instance Semigroup (Event a) where
-  (<>) = lMerge
-
-instance Monoid (Event a) where
-  mempty = Tick
-
-hold :: (Serialize a, Eq a) => a -> Mealy m (Event a) a
-hold def = mapAccum step def id
-  where
-    step prev = \case
-      Tick -> prev
-      Event new -> new
 
+hold :: a -> Mealy eff (Event a) a
+hold a = Mealy $ \_ _ -> \case
+  Tick -> pure (a, hold a)
+  Event a' -> pure (a', hold a')
 
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case
@@ -337,89 +113,51 @@ isEvent _ = True
 tag :: b -> Event a -> Event b
 tag b ev = b <$ ev
 
--- switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
+switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
--- switch (Mealy st f) s = Mealy st $ \nt t a -> do
+switch (Mealy f) s = Mealy $ \nt t a -> do
---   Pair (b, ev) f' <- f nt t a
+  ((b, ev), f') <- f nt t a
---   case ev of
+  case ev of
---           Tick -> pure (Pair b (switch f' s))
+          Tick -> pure (b, switch f' s)
---           Event x -> runMealy (s x) nt t a
+          Event x -> runMealy (s x) nt t a
 
 sample :: Mealy eff (a, Event b) (Event a)
 sample = arr (uncurry tag)
 
-
+preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
+preMapAccum f x extract = go x
-preMapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
   where
-    step :: State x -> a -> (b, State x)
+    go b = Mealy $ \_ _ a ->
-    step s a = let s' = f (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
+      let next = f b a
+      in pure (extract b, go next)
 
-
+preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccumRequest f x extract = go x
-mapAccum step x extract = Mealy mempty $ \_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
-
-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)
   where
-    step :: State x -> a -> (b, State x)
+    go b = Mealy $ \_ t a ->
-    step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
+      let next = f t b a
+      in pure (extract b, go next)
 
-preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccumRequest step x extract = Mealy mempty $ \_ -> preMapAccumRequest' step x extract
+mapAccum f x extract = go x
-
-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)
   where
-    step :: State x -> Request -> a -> (b, State x)
+    go b = Mealy $ \_ _ a ->
-    step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
+      let next = f b a
+      in pure (extract next, go next)
 
-mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccumRequest step x extract = Mealy mempty $ \_ -> mapAccumRequest' step x extract
+mapAccumRequest f x extract = go x
-
-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)
   where
-    step :: State x -> Request -> a -> (b, State x)
+    go b = Mealy $ \_ t a ->
-    step s req a = let s' = f req (state s) a in (extract s', State s' (dirty s || state s /= s'))
+      let next = f t b a
+      in pure (extract next, go next)
 
 data DelayState x a = DelayState
   { pending :: x
   , output  :: !(Event a)
   }
-  deriving (Generic, Eq)
 
-instance (Serialize x, Serialize a) => Serialize (DelayState x a)
 
-newtype SerializeUTCTime = SerializeUTCTime UTCTime
+delayEvent :: NominalDiffTime -> Mealy eff (Event a) (Event a)
-  deriving (Eq, Show)
-
-instance Serialize SerializeUTCTime where
-  put (SerializeUTCTime (UTCTime day time)) = do
-    put (toModifiedJulianDay day)
-    put (diffTimeToPicoseconds time)
-
-  get = do
-    day  <- ModifiedJulianDay <$> get
-    time <- picosecondsToDiffTime <$> get
-    pure $ SerializeUTCTime (UTCTime day time)
-
-newtype SerializeLocalTime = SerializeLocalTime LocalTime
-  deriving (Eq, Show)
-
-instance Serialize SerializeLocalTime where
-  put (SerializeLocalTime (LocalTime day time)) = do
-    put (toModifiedJulianDay day)
-    let TimeOfDay h m s = time
-    put (h,m, toRational s)
-  get = do
-    day  <- ModifiedJulianDay <$> get
-    (h,m,s) <- get
-    pure $ SerializeLocalTime (LocalTime day (TimeOfDay h m (fromRational s)))
-
-delayEvent :: (Eq a, Serialize a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
 delayEvent delay =
   mapAccumRequest step initial output
   where
@@ -431,17 +169,17 @@ delayEvent delay =
           queued =
             case input of
               Tick    -> pending st
-              Event x -> pending st ++ [(SerializeUTCTime $ delay `addUTCTime` now, x)]
+              Event x -> pending st ++ [(delay `addUTCTime` now, x)]
 
       in case queued of
-           (SerializeUTCTime due, x) : rest
+           (due, x) : rest
              | due <= now ->
                  DelayState rest (Event x)
 
            _ ->
                  DelayState queued Tick
 
-debounce :: (Serialize a, Eq a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
+debounce :: NominalDiffTime -> Mealy eff (Event a) (Event a)
 debounce delay =
   mapAccumRequest step initial output
   where
@@ -450,13 +188,13 @@ debounce delay =
       let now = requestTime req
           held = case input of
                       Tick -> pending st
-                      Event x -> Just (SerializeUTCTime $ delay `addUTCTime` now, x)
+                      Event x -> Just (delay `addUTCTime` now, x)
       in case held of
-              Just (SerializeUTCTime due, x)
+              Just (due, x)
                 | due <= now -> DelayState Nothing (Event x)
               _ -> DelayState held Tick
 
-changes :: (Serialize a, Eq a) => Mealy eff a (Event a)
+changes :: Eq a => Mealy eff a (Event a)
 changes = mapAccum go Nothing (maybe Tick snd)
   where
     go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
@@ -489,126 +227,65 @@ lMerge (Event a) _ = Event a
 lMerge Tick (Event a) = Event a
 
 edge :: Mealy eff Bool (Event ())
-edge =
+edge = go False
-  mapAccum
-    (\(_, current) new -> (current, new))
-    (False, False)
-    (\(old, current) ->
-      if not old && current
-        then Event ()
-        else Tick)
-
-
-
-data WaitingFor
-  = Waiting
-  | Pending { waitingForStart :: SerializeLocalTime, waitingForCurrent :: SerializeLocalTime }
-  deriving (Show, Eq, Generic)
-
-instance Serialize WaitingFor
-
-waitFor :: NominalDiffTime -> Mealy eff Bool (Event ())
-waitFor delta =
-  mapAccumRequest step Waiting extract >>> edge
   where
-    extract :: WaitingFor -> Bool
+    go True = Mealy $ \_ _ -> \case
-    extract Waiting = False
+      True -> pure (Tick, go True)
-    extract Pending{waitingForStart=SerializeLocalTime s, waitingForCurrent=SerializeLocalTime e} =
+      False -> pure (Tick, go False)
-      e `diffLocalTime` s >= delta
+    go False = Mealy $ \_ _ -> \case
-    step :: Request -> WaitingFor -> Bool -> WaitingFor
+      True -> pure (Event (), go True)
-    step _req _prev False = Waiting
+      False -> pure (Tick, go False)
-    step req prev True =
+
-      let now = SerializeLocalTime $ requestLocalTime req
-      in case prev of
-              Waiting -> Pending now now
-              pending -> pending{waitingForCurrent = now}
 
 duration :: forall eff a. Mealy eff a NominalDiffTime
-duration = mapAccumRequest go (Nothing @(SerializeUTCTime, SerializeUTCTime)) (maybe 0 delta)
+duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
   where
-    delta :: (SerializeUTCTime, SerializeUTCTime) -> NominalDiffTime
+    go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
-    delta (SerializeUTCTime start, SerializeUTCTime end) = end `diffUTCTime` start
+    go req Nothing _ = Just (requestTime req, requestTime req `diffUTCTime` requestTime req)
-    go :: Request -> Maybe (SerializeUTCTime, SerializeUTCTime) -> a -> Maybe (SerializeUTCTime, SerializeUTCTime)
+    go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)
-    go req Nothing _ = Just (SerializeUTCTime $ requestTime req, SerializeUTCTime $ requestTime req)
+
-    go req (Just (startTime, _)) _ = Just (startTime, SerializeUTCTime $ requestTime req)
 
 
 -- | Rollup, hold back bursty messages
 --
 -- Consider a case where you have a  bursty set of data. You care to get an immediate response,
--- but don't want to spam the output.
+-- but don't want to spam the output
 rollup
-  :: (Serialize a, Eq a)
+  :: Int -- ^ How many items to pass through before burst protection
-  => Int -- ^ How many items to pass through before burst protection
+  -> Int -- ` How many seconds to collect the bursty data
-  -> Int -- ^ How many seconds to collect the bursty data
   -> Mealy eff (Event a) (Event [a])
-rollup limit seconds =
+rollup limit seconds = mapAccumRequest go (Left Tick) (either id (\(_, _, _, ev) -> ev))
-  mapAccumRequest
-    go
-    (Left Tick)
-    (either id (\(_, _, _, ev) -> ev))
   where
-    go
+    e a = Endo ([a] ++)
-      :: Request
+    go :: Request -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a]) -> Event a -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a])
-      -> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
+    go _ (Left _) Tick = Left Tick
-      -> Event a
+    go req (Left _) (Event a) = Right (addUTCTime (fromIntegral seconds) (requestTime req), 1, mempty, Event [a])
-      -> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
+    go req (Right (end, n, acc, _)) Tick
-
+      | requestTime req >= end = Left (Event $ appEndo acc [])
-    go _ (Left _) Tick =
+      | otherwise = Right (end, n, acc, Tick)
-      Left Tick
+    go req (Right (end, n, acc, _)) (Event a)
-
+      | requestTime req >= end = Left (Event $ appEndo acc [a])
-    go req (Left _) (Event a) =
+      | n < limit = Right (end, n+1, acc, Event [a])
-      Right
+      | otherwise = Right (end, n+1, acc <> e a, Tick)
-        ( SerializeUTCTime $ addUTCTime (fromIntegral seconds) (requestTime req)
-        , 1
-        , mempty
-        , Event [a]
-        )
-
-    go req (Right (SerializeUTCTime end, n, acc, _)) Tick
-      | requestTime req >= end =
-          Left (Event $ F.toList acc)
-      | otherwise =
-          Right (SerializeUTCTime end, n, acc, Tick)
-
-    go req (Right (SerializeUTCTime end, n, acc, _)) (Event a)
-      | requestTime req >= end =
-          Left (Event $ F.toList (acc |> a))
-      | n < limit =
-          Right (SerializeUTCTime end, n + 1, acc, Event [a])
-      | otherwise =
-          Right (SerializeUTCTime end, n + 1, acc |> a, Tick)
-
 
 -- Sliding window into the events
-sliding :: (Serialize a, Eq a) => Int -> Mealy eff (Event a) [a]
+sliding :: Int -> Mealy eff (Event a) [a]
 sliding size = mapAccum go [] id
   where
     go :: [a] -> Event a -> [a]
     go acc Tick = acc
     go acc (Event a) = let xs = acc ++ [a] in drop (max 0 (length xs - size)) xs
 
-
+fixed :: Int -> Mealy eff (Event a) [a]
-requestLocalTime :: Request -> LocalTime
+fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
-requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
+  where
-
+    e a = Endo ([a] ++)
-currentTime :: Mealy eff a LocalTime
+    go :: Request -> Maybe (UTCTime, Endo [a]) -> Event a -> Maybe (UTCTime, Endo [a])
-currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
+    go req Nothing Tick = Just (addUTCTime (fromIntegral seconds) (requestTime req), mempty)
-  requestLocalTime req
+    go req Nothing (Event a) = Just (addUTCTime (fromIntegral seconds) (requestTime req), e a)
-
+    go req (Just (end, acc)) ev =
-
+      case ev of
-stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)
+           Tick | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, mempty)
-stepAuto (Fun f) req a = pure (f req a, Fun f)
+                | otherwise -> Just (end, acc)
-stepAuto (Stateful codec s f) req a = do
+           Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a)
-  (b, s') <- f s req a
+                   | otherwise -> Just (end, acc <> e a)
-  pure (b, Stateful codec s' f)
-
-
-stepAutoSerializing :: MonadIO m => FilePath -> Auto m a b -> Request -> a -> m (b, Auto m a b)
-stepAutoSerializing path f req a = do
-  (b,x) <- stepAuto f req a
-  y <- liftIO $ save path x
-  pure (b,y)
-
-onEvent :: Mealy eff a () -> Mealy eff (Event a) ()
-onEvent f = events >>> (arr (const ()) ||| f)

src/HomeAssistant/Controller.hs

@@ -8,7 +8,6 @@ module HomeAssistant.Controller
   , HASSEff(..)
   , HASS
   , callService
-  , callServiceDyn
   , entityChangeEvent
   , entityChangeEvent'
   , entityRead
@@ -24,25 +23,20 @@ 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, object, (.=))
+import Data.Aeson (Value)
 import qualified Data.Text as T
-import qualified Data.Set as S
 import Control.Lens (has, only, (^?), to)
-import Data.Aeson.Lens (key, _String, _Integral)
+import Data.Aeson.Lens (key, _String)
 import qualified Data.Text.Lens as TL
 import Data.Bool (bool)
-import Data.Serialize (Serialize)
-import GHC.Generics (Generic)
 
 data Target = EntityId !T.Text | AreaId !T.Text
-  deriving (Show,Eq,Ord)
+  deriving (Show,Eq)
 
 data Service = Service
   { serviceDomain :: T.Text
@@ -62,20 +56,15 @@ type HASS a b = Mealy HASSEff a b
 callService :: Service -> HASS a ()
 callService service = eff (\req _ -> CallService req service)
 
-callServiceDyn :: (a -> Service) -> HASS a ()
-callServiceDyn mkService = eff (\req a -> CallService req (mkService a))
-
 debug :: Show a => HASS a a
 debug = proc x -> do
   eff (const Debug) -< x
   returnA -< x
 
 traceEvent :: Show a => HASS (Event a) (Event a)
-traceEvent = proc ev -> do
+traceEvent = Mealy $ \nt req -> \case
-  case ev of
+  Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
-       Event a -> eff Trace -< a
+  Tick -> pure (Tick, traceEvent)
-       Tick -> returnA -< ()
-  returnA -< ev
 
 traceValue :: Show a => HASS a a
 traceValue = proc x -> do
@@ -83,14 +72,10 @@ traceValue = proc x -> do
   returnA -< x
 
 data DoorState = Open | Closed
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq)
-
-instance Serialize DoorState
 
 data Presence = Occupied | Unoccupied
-  deriving (Show, Eq, Generic)
+  deriving (Show, Eq)
-
-instance Serialize Presence
 
 presence :: T.Text -> HASS (Event Value) (Event Presence)
 presence entityId =entityBool entityId
@@ -98,21 +83,12 @@ presence entityId =entityBool entityId
 
 
 
-data Light
-  = Off
-  | On { brightnessPercentage :: Maybe Double }
 
 -- Turn off lights when door is closed
-light :: [Target] -> Light -> Service
+light :: [Target] -> Bool -> Service
-light targets (On {brightnessPercentage}) = Service
+light targets b = Service
   { serviceDomain="light"
-  , serviceName= "turn_on"
+  , serviceName= bool "turn_off" "turn_on" b
-  , serviceData=fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage
-  , serviceTarget=targets
-  }
-light targets Off = Service
-  { serviceDomain="light"
-  , serviceName= "turn_off"
   , serviceData=Nothing
   , serviceTarget=targets
   }
@@ -131,20 +107,20 @@ 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 = events >>| filterA isEntity
   where
     isEntity :: Value -> Bool
-    isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId)
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
 
 entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a)
 entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
   where
-    state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to read
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
 
 entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool)
 entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
   where
-    state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to toBool
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool
     toBool = \case
       "on" -> True
       "off" -> False
@@ -155,11 +131,3 @@ 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 Off) -< ()
+       Event Unoccupied -> callService createBedroomScene >>> callService (light bedroomLights False) -< ()
        Event Occupied -> callService (activateScene "makuuhuone_lights_snapshot") -< ()
        _ -> returnA -< ()
 
@@ -79,7 +79,7 @@ ikeaQuickButton entityId =
   >>| arr (maybe (Left ()) Right . eventType)
   >>> toEvent
   where
-    eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed
+    eventType v = v ^? key "event" . key "data" . key "new_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed
 
 
 data BedroomControls
@@ -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"] Off) -< ()
+       Event (Masse (OffButton _)) -> callService (light [AreaId "makuuhuone"] False) -< ()
        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"] Off) -< ()
+       Event (Enishen (OffButton _)) -> callService (light [AreaId "makuuhuone"] False) -< ()
        _ -> returnA -< ()
 
 
@@ -131,12 +131,12 @@ door = entityBool "binary_sensor.makuuhuone_ovi_contact"
 waitFor :: NominalDiffTime -> HASS a (Event ())
 waitFor n = duration >>> arr (> n) >>> edge
 
-
 delayedDoor :: HASS (Event Value) (Event DoorState)
 delayedDoor = door
   >>> AFRP.debounce 15
   >>> AFRP.hold Open
   >>> AFRP.changes
+  >>> traceEvent
 
 humidifierController :: HASS (Event Value) ()
 humidifierController = proc x -> do

src/HomeAssistant/Controller/Children.hs

@@ -1,82 +0,0 @@
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE OverloadedStrings #-}
-module HomeAssistant.Controller.Children where
-import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..))
-import AFRP (Event)
-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
-
--- 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/Controller/Kitchen.hs

@@ -1,59 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Arrows #-}
-module HomeAssistant.Controller.Kitchen where
-import HomeAssistant.Controller
-import AFRP (Event (..))
-import qualified AFRP
-import Data.Aeson (Value)
-import Control.Arrow ((>>>), Arrow (..), returnA)
-import Data.Bool (bool)
-import GHC.Generics (Generic)
-import Data.Serialize (Serialize)
-import Prelude hiding (id)
-import Data.Time (LocalTime(..), TimeOfDay (..))
-
-
--- Kitchen has two "presence" sensors. One IKEA motion sensor and one SwitchBot presence sensor
-data Motion = MotionDetected | MotionNotDetected | MotionUnknown
-  deriving (Show, Eq, Generic)
-
-instance Serialize Motion
-
-data Lights = LightsOn | LightsOff
-  deriving (Show)
-
-kitchenMotion :: HASS (Event Value) Motion
-kitchenMotion = entityBool "binary_sensor.kitchen_movement_occupancy"
-  >>> arr (fmap (bool MotionNotDetected MotionDetected))
-  >>> traceEvent
-  >>> AFRP.hold MotionUnknown
-
-
-kitchenPresence :: HASS Motion Presence
-kitchenPresence = (eventOccupied &&& eventUnoccupied)
-  >>> arr (uncurry AFRP.lMerge) >>> traceEvent
-  >>> AFRP.hold Unoccupied
-  where
-    eventOccupied :: HASS Motion (Event Presence)
-    eventOccupied = arr (== MotionDetected) >>> AFRP.edge >>> arr (fmap (const Occupied))
-    eventUnoccupied :: HASS Motion (Event Presence)
-    eventUnoccupied = arr (== MotionNotDetected) >>> AFRP.waitFor 300 >>> arr (AFRP.tag Unoccupied)
-
-eventLights :: HASS Presence (Event Lights)
-eventLights = AFRP.changes >>> arr (fmap presenceLights)
-  where
-    presenceLights Occupied = LightsOn
-    presenceLights Unoccupied = LightsOff
-
-kitchenMotionController :: HASS (Event Value) ()
-kitchenMotionController = proc x -> do
-  now <- AFRP.currentTime -< ()
-  p <- kitchenMotion >>> kitchenPresence -< x
-  ev <- eventLights -< p
-  traceEvent -< ev
-  case ev of
-       Event LightsOn | lightsAllowed now -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< On Nothing
-       Event LightsOff -> callServiceDyn (light [EntityId "light.kitchen_ceiling"]) -< Off
-       _ -> returnA -< ()
-  where
-    lightsAllowed (LocalTime _ tod) = not (tod > TimeOfDay 1 45 0 && tod < TimeOfDay 5 0 0)

src/HomeAssistant/Controller/Ruuvi.hs

@@ -13,8 +13,6 @@ import Control.Category ((>>>))
 import Data.Aeson (Value)
 import HomeAssistant.Controller (entityRead, traceEvent, HASS)
 import Control.Arrow (Arrow(..))
-import GHC.Generics (Generic)
-import Data.Serialize (Serialize)
 
 ruuviTemperatures :: Mealy eff (Event Value) Double
 ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
@@ -23,9 +21,7 @@ ruuviPressures :: Mealy eff (Event Value) Double
 ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
 
 data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
-            deriving (Show, Eq, Generic)
+            deriving (Show, Eq)
-
-instance Serialize Ruuvi
 
 ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
 ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes

src/HomeAssistant/Runtime.hs

@@ -13,12 +13,12 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
+import AFRP (Event (..), Mealy (..), Request (..))
 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, getCurrentTimeZone)
+import Data.Time (getCurrentTime)
 import Data.Void (Void, absurd)
 import HomeAssistant.Controller (HASS, HASSEff (..))
 import HomeAssistant.Runtime.Bus
@@ -31,20 +31,13 @@ import Data.UUID (UUID, toText)
 import qualified Data.UUID.V4 as UUID.V4
 import Katip (runKatipT, logF, sl, Severity (..), ls, Namespace (Namespace), runKatipContextT)
 import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Fix (MonadFix)
 import HomeAssistant.Controller.Ruuvi (ruuviController)
-import HomeAssistant.Controller.Children (schoolLightController)
-import Data.Maybe (fromMaybe)
-import qualified System.Metrics
-import qualified HomeAssistant.Runtime.Metrics
-import System.FilePath ((</>))
-import HomeAssistant.Controller.Kitchen (kitchenMotionController)
 
-step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
+step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
-step path trace st a = do
+step nt trace (Mealy f) a = do
   now <- liftIO getCurrentTime
-  tz <- liftIO getCurrentTimeZone
+  f nt (Request now trace) a
-  let req = Request now tz trace
-  stepAutoSerializing path st req a
 
 data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
 
@@ -53,31 +46,24 @@ controllers =
   [ Controller "bedroom-presence" bedroomPresenceController False
   , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
   , Controller "bedroom-drawer" bedroomDrawerController True
-  , Controller "bedroom-humidifier" humidifierController True
+  , Controller "bedroom-humidifier" humidifierController False
   , Controller "ruuvi-controller" ruuviController False
-  , Controller "school-light-controller" schoolLightController True
-  , Controller "kitchen-motion-controller" kitchenMotionController True
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the
 -- bus. A restart re-dups the inbound channel and starts from the machine's
 -- initial state; messages broadcast during the restart window are lost.
-runController :: FilePath -> Bus -> Controller -> IO Void
+runController :: Bus -> Controller -> IO Void
-runController rootDir bus (Controller name machine _enabled) = do
+runController bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
-  let ns = Namespace [name]
+  go inbound machine
-  let workerDefinition = runMealy machine (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus)
-  let path  = rootDir </> T.unpack name
-  worker <- load path workerDefinition >>= \case
-    Decoded a -> pure a
-    FailDecode err a -> a <$ putStrLn ("Failed to load (" <> T.unpack name <> "): " <> err)
-  go path inbound worker
   where
-    go path inbound f = do
+    go inbound f = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
-      (_, next) <- step path uuid f msg
+      let ns = Namespace [name]
-      go path inbound next
+      (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f (Event msg)
+      go inbound f'
 
 defaultMain :: IO ()
 defaultMain = withSocketsDo $ do
@@ -85,18 +71,10 @@ defaultMain = withSocketsDo $ do
   withBus severity $ \bus -> do
     token <- getEnv "HA_TOKEN"
     host <- getEnv "HA_HOST"
-    rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
+    let workers =
-    store <- System.Metrics.newStore
+          [ ("reader", readerAction host 8123 token bus)
-    System.Metrics.registerGcMetrics store
-    rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
-    rrdtool <- fromMaybe "rrdtool" <$> lookupEnv "HA_RRDTOOL"
-    let active = [c | c@(Controller _ _ True) <- controllers]
-        ents = foldMap (\(Controller _ m _) -> entities m) active
-        workers =
-          [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction bus)
-          ] ++ [ (name, runController rootPath bus c) | c@(Controller name _ True) <- controllers ]
+          ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
-            ++ [("metrics", HomeAssistant.Runtime.Metrics.metricsAction store rrdPath rrdtool)]
     as <- mapM (\(name, act) -> async (supervised name defaultBackoff act)) workers
     (_, v) <- waitAny as
     absurd v

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(..), Event(..))
+import AFRP (Request(..))
 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 (Event Value)
+  { busInbound  :: TChan Value
   , busOutbound :: TChan (Request, Service)
   , busConn     :: TVar (Maybe Connection)
   , busGen      :: CallIdGen

src/HomeAssistant/Runtime/Connection.hs

@@ -5,30 +5,23 @@ module HomeAssistant.Runtime.Connection
   ( readerAction
   , writerAction
   , encodeService
-  , dedupeBatch
   ) where
 
 import Control.Concurrent.STM
-  ( TChan
+  ( atomically
-  , atomically
   , readTChan
   , readTVar
   , retry
-  , tryReadTChan
   , 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 Control.Monad (forever)
 import Data.Aeson (Value, eitherDecode, encode, object, (.=))
 import Data.Aeson.Lens (key, _String)
-import Data.List (sort)
+import qualified Data.ByteString.Lazy as BL
-import qualified Data.Map.Strict as M
-import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Void (Void)
 import HomeAssistant.Controller (Service (..), Target (..))
@@ -37,16 +30,16 @@ 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(..), Event(..))
+import AFRP (Request(..))
 
 -- | Connect, authenticate, subscribe, then receive and broadcast forever.
 -- Restarting this action reconnects. All setup sends happen before the
 -- connection is published in the bus, so only the writer sends afterwards.
-readerAction :: String -> Int -> String -> S.Set T.Text -> Bus -> IO Void
+readerAction :: String -> Int -> String -> Bus -> IO Void
-readerAction host port token ents bus =
+readerAction host port token bus =
   WS.runClient host port "/api/websocket" $ \conn -> do
     handshake conn token
-    subscribe bus conn ents
+    subscribe bus conn
     atomically $ writeTVar (busConn bus) (Just conn)
     putStrLn "[reader] connected"
     -- Unpublish on exit so the writer blocks and the backlog survives the outage.
@@ -69,34 +62,23 @@ expectType expected msg =
     Just t | t == expected -> pure ()
     _ -> throw (Fatal $ "expected " <> expected <> ", got: " <> T.pack (show msg))
 
-subscribe :: Bus -> WS.Connection -> S.Set T.Text -> IO ()
+subscribe :: Bus -> WS.Connection -> IO ()
-subscribe bus conn ents =
+subscribe bus conn = do
-  forM_ (S.toList ents) $ \entityId -> do
-    print entityId
   sid <- generateCallId (busGen bus)
   WS.sendTextData conn $ encode $ object
     [ "id"         .= sid
-      , "type"       .= ("subscribe_trigger" :: T.Text)
+    , "type"       .= ("subscribe_events" :: T.Text)
-      , "trigger"    .= object
+    , "event_type" .= ("state_changed" :: T.Text)
-        [ "platform" .= ("state" :: T.Text)
-        , "entity_id" .= entityId
-        ]
     ]
 
 -- | 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
-  winner <- race (threadDelay 1_000_000) (WS.receiveData conn)
+  msg <- WS.receiveData conn :: IO BL.ByteString
-  case winner of
+  case eitherDecode msg 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)
+    Right v  -> atomically $ writeTChan (busInbound bus) v
 
 receiveJSON :: WS.Connection -> IO Value
 receiveJSON conn = do
@@ -105,41 +87,16 @@ receiveJSON conn = do
     Left err -> throw (Fatal $ "Invalid JSON from Home Assistant: " <> T.pack err)
     Right x  -> pure x
 
--- | Floor between sends within a batch: 100ms, so a many-distinct-target
+writerAction :: Bus -> IO Void
--- flood still caps at ~10 sends/sec even after dedupe.
+writerAction bus = forever $ do
-minInterval :: Int
+  (request, svc) <- atomically $ readTChan (busOutbound bus)
-minInterval = 100000
+  conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
-
--- | Non-blocking drain of everything queued on a channel. Returns items
--- oldest-first (FIFO from the channel), so prepending the blocking
--- `readTChan` item keeps the whole batch oldest-first for `dedupeBatch`.
-drainTry :: TChan a -> IO [a]
-drainTry chan = go []
-  where
-    go acc = do
-      m <- atomically $ tryReadTChan chan
-      case m of
-        Nothing -> pure (reverse acc)
-        Just x  -> go (x : acc)
-
-sendWithId :: Bus -> WS.Connection -> Request -> Service -> IO ()
-sendWithId bus conn request svc = do
   callId <- generateCallId (busGen bus)
   let textData = encode $ encodeService callId svc
   runKatipContextT (busLogEnv bus) (sl "traceId" (toText (requestTraceId request))) "connection" $
     logFM DebugS (ls textData)
   WS.sendTextData conn textData
 
-writerAction :: Bus -> IO Void
-writerAction bus = forever $ do
-  first <- atomically $ readTChan (busOutbound bus)
-  rest  <- drainTry (busOutbound bus)
-  let deduped = dedupeBatch (first : rest)
-  conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
-  forM_ deduped $ \(request, svc) -> do
-    sendWithId bus conn request svc
-    threadDelay minInterval
-
 encodeService :: Int -> Service -> Value
 encodeService callId Service{..} = object $
   [ "id"      .= callId
@@ -149,18 +106,6 @@ encodeService callId Service{..} = object $
   , "target"  .= targetObject serviceTarget
   ] <> maybe [] (\d -> ["service_data" .= d]) serviceData
 
--- | Collapse a drained batch of outbound calls: the newest call per
--- `(domain, service, sorted-targets)` survives; older duplicates are
--- dropped. `serviceData` is not part of the key, so a newer `turn_on`
--- with different brightness supersedes an older one to the same target.
-dedupeBatch :: [(Request, Service)] -> [(Request, Service)]
-dedupeBatch = M.elems . foldl' ins M.empty
-  where
-    ins m (req, svc) = M.insert (dedupeKey svc) (req, svc) m
-
-dedupeKey :: Service -> (T.Text, T.Text, [Target])
-dedupeKey Service{..} = (serviceDomain, serviceName, sort serviceTarget)
-
 -- | A single target encodes as a scalar; multiple encode as a list. Empty
 -- lists are omitted so Home Assistant receives only populated keys.
 targetObject :: [Target] -> Value

src/HomeAssistant/Runtime/Metrics.hs

@@ -1,119 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module HomeAssistant.Runtime.Metrics
-  ( DsType (..)
-  , DsSpec (..)
-  , dsTypeOf
-  , sanitizeName
-  , buildSchema
-  , buildCreateArgs
-  , buildUpdateArgs
-  , ensureRrd
-  , sampleAndUpdate
-  , metricsAction
-  ) where
-
-import Control.Concurrent (threadDelay)
-import Control.Monad (forever, unless)
-import Data.Char (ord)
-import Data.Int (Int64)
-import Data.List (intercalate, sortBy)
-import Data.Ord (comparing)
-import Data.Text (Text)
-import Data.Void (Void)
-import Numeric (showHex)
-import qualified Data.Text as T
-import qualified Data.HashMap.Strict as HM
-import qualified System.Metrics as M (Value (..), Sample, Store, sampleAll)
-import System.Directory (doesFileExist)
-import System.Process (callProcess)
-
-data DsType = Derive | Gauge
-  deriving (Eq, Show)
-
-data DsSpec = DsSpec
-  { dsEkgName :: Text
-  , dsName    :: String
-  , dsType    :: DsType
-  }
-  deriving (Eq, Show)
-
-dsTypeOf :: M.Value -> Maybe DsType
-dsTypeOf (M.Counter _) = Just Derive
-dsTypeOf (M.Gauge _)   = Just Gauge
-dsTypeOf _             = Nothing
-
--- | Maps an ekg metric label to a valid rrd DS name (≤19 chars, [A-Za-z0-9_]).
--- Long names keep the first 15 chars plus a 3-hex hash suffix for uniqueness.
-sanitizeName :: Text -> String
-sanitizeName name
-  | length sanitized <= 19 = sanitized
-  | otherwise = take 15 sanitized ++ "_" ++ paddedHash
-  where
-    sanitized = T.unpack (T.replace "." "_" name)
-    paddedHash = let h = showHex (sum (map ord sanitized) `mod` 4096) ""
-                 in replicate (3 - length h) '0' ++ h
-
-buildSchema :: M.Sample -> [DsSpec]
-buildSchema sample =
-  sortBy (comparing dsName)
-    [ DsSpec ekgName (sanitizeName ekgName) dt
-    | (ekgName, val) <- HM.toList sample
-    , Just dt <- [dsTypeOf val]
-    ]
-
-buildCreateArgs :: FilePath -> Int -> [(String, DsType)] -> [String]
-buildCreateArgs path step specs =
-  ["create", path, "--step", show step]
-  ++ concatMap dsArg specs
-  ++ rras
-  where
-    dsArg (name, Derive) = ["DS:" ++ name ++ ":DERIVE:20:0:U"]
-    dsArg (name, Gauge)  = ["DS:" ++ name ++ ":GAUGE:20:0:U"]
-    rras =
-      [ "RRA:AVERAGE:0.5:1:6000"
-      , "RRA:MAX:0.5:1:6000"
-      , "RRA:AVERAGE:0.5:360:1680"
-      , "RRA:MAX:0.5:360:1680"
-      ]
-
-buildUpdateArgs :: FilePath -> [String] -> [Maybe Int64] -> [String]
-buildUpdateArgs path names values =
-  [ "update"
-  , path
-  , "--template"
-  , intercalate ":" names
-  , "N:" ++ intercalate ":" (map renderValue values)
-  ]
-  where
-    renderValue Nothing  = "U"
-    renderValue (Just n) = show n
-
-lookupValue :: M.Sample -> Text -> Maybe Int64
-lookupValue sample name = case HM.lookup name sample of
-  Just (M.Counter n) -> Just n
-  Just (M.Gauge n)   -> Just n
-  _                  -> Nothing
-
-ensureRrd :: FilePath -> FilePath -> [DsSpec] -> IO ()
-ensureRrd rrdtool rrdPath schema = do
-  exists <- doesFileExist rrdPath
-  unless exists $
-    callProcess rrdtool (buildCreateArgs rrdPath 10 (map toPair schema))
-  where
-    toPair s = (dsName s, dsType s)
-
-sampleAndUpdate :: M.Store -> FilePath -> FilePath -> [DsSpec] -> IO ()
-sampleAndUpdate store rrdtool rrdPath schema = do
-  sample <- M.sampleAll store
-  let names = map dsName schema
-      values = map (lookupValue sample . dsEkgName) schema
-  callProcess rrdtool (buildUpdateArgs rrdPath names values)
-
-metricsAction :: M.Store -> FilePath -> FilePath -> IO Void
-metricsAction store rrdPath rrdtool = do
-  schema <- buildSchema <$> M.sampleAll store
-  ensureRrd rrdtool rrdPath schema
-  forever $ do
-    sampleAndUpdate store rrdtool rrdPath schema
-    threadDelay 10000000

test/AFRPLawsSpec.hs

@@ -1,256 +0,0 @@
-module AFRPLawsSpec (spec) where
-
-import AFRP
-import Control.Arrow (arr, first, left, (***), (+++))
-import Control.Category ((>>>))
-import qualified Control.Category as Cat (id)
-import Data.Functor.Identity (Identity (..))
-import Hedgehog (Gen, PropertyT)
-import qualified Hedgehog.Gen as Gen
-import qualified Hedgehog.Range as Range
-import Support (fakeRequest)
-import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Hedgehog (forAll, forAllWith, hedgehog, (===))
-
--- | Law tests for the Mealy instances. Two machines count as equal when
--- they emit equal outputs on every input sequence, so each law runs both
--- sides on generated inputs.
-
-runPure :: Mealy Identity a b -> [a] -> [b]
-runPure m = go (runMealy m id)
-  where
-    go _ [] = []
-    go w (a : as) = case runIdentity (stepAuto w fakeRequest a) of
-      (b, w') -> b : go w' as
-
--- | Machines wrap functions and have no Show; name them for forAll instead.
-forAllMealy :: Gen (Mealy Identity a b) -> PropertyT IO (Mealy Identity a b)
-forAllMealy = forAllWith (const "<mealy>")
-
-intGen :: Gen Int
-intGen = Gen.int (Range.linear (-5) 5)
-
-ints :: Gen [Int]
-ints = Gen.list (Range.linear 0 30) intGen
-
-intPairs :: Gen [(Int, Int)]
-intPairs = Gen.list (Range.linear 0 30) ((,) <$> intGen <*> intGen)
-
-intEithers :: Gen [Either Int Int]
-intEithers = Gen.list (Range.linear 0 30) $
-  Gen.choice [Left <$> intGen, Right <$> intGen]
-
-nestedPairs :: Gen [((Int, Int), Int)]
-nestedPairs = Gen.list (Range.linear 0 30) ((,) <$> ((,) <$> intGen <*> intGen) <*> intGen)
-
-nestedEithers :: Gen [Either (Either Int Int) Int]
-nestedEithers = Gen.list (Range.linear 0 30) $
-  Gen.choice
-    [ Left <$> Gen.choice [Left <$> intGen, Right <$> intGen]
-    , Right <$> intGen
-    ]
-
--- | Stateful Int machines: the arrow variables of the laws.
-statefulGen :: Gen (Mealy Identity Int Int)
-statefulGen = Gen.choice
-  [ (\k -> mapAccum (+) k id) <$> intGen
-  , (\k -> preMapAccum (+) k id) <$> intGen
-  , (\k -> mapAccum (*) 1 (+ k)) <$> intGen
-  ]
-
-eventArrowGen :: Gen (Mealy Identity Int (Event Int))
-eventArrowGen = Gen.choice
-  [ pure changes
-  , (\k -> mapAccum (+) k Event) <$> intGen
-  , (\k -> preMapAccum (+) k (Event . (* 2))) <$> intGen
-  ]
-
-funArrowGen :: Gen (Mealy Identity Int (Int -> Int))
-funArrowGen = Gen.choice
-  [ (\k -> mapAccum (+) k (*)) <$> intGen
-  , pure (preMapAccum (*) 1 (+))
-  ]
-
-spec :: Spec
-spec = describe "Mealy laws" $ do
-  semigroupSpec
-  monoidSpec
-  categorySpec
-  arrowSpec
-  arrowChoiceSpec
-  functorSpec
-  applicativeSpec
-
-semigroupSpec :: Spec
-semigroupSpec = describe "Semigroup (<>)" $ do
-  it "(a <> b) <> c = a <> (b <> c)" $ hedgehog $ do
-    a <- forAllMealy eventArrowGen
-    b <- forAllMealy eventArrowGen
-    c <- forAllMealy eventArrowGen
-    xs <- forAll ints
-    runPure ((a <> b) <> c) xs === runPure (a <> (b <> c)) xs
-
-monoidSpec :: Spec
-monoidSpec = describe "Monoid" $ do
-  it "mempty <> a = a" $ hedgehog $ do
-    a <- forAllMealy eventArrowGen
-    xs <- forAll ints
-    runPure (mempty <> a) xs === runPure a xs
-
-  it "a <> mempty = a" $ hedgehog $ do
-    a <- forAllMealy eventArrowGen
-    xs <- forAll ints
-    runPure (a <> mempty) xs === runPure a xs
-
-categorySpec :: Spec
-categorySpec = describe "Category" $ do
-  it "id >>> f = f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (Cat.id >>> f) xs === runPure f xs
-
-  it "f >>> id = f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (f >>> Cat.id) xs === runPure f xs
-
-  it "(f >>> g) >>> h = f >>> (g >>> h)" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    g <- forAllMealy statefulGen
-    h <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure ((f >>> g) >>> h) xs === runPure (f >>> (g >>> h)) xs
-
-arrowSpec :: Spec
-arrowSpec = describe "Arrow" $ do
-  it "arr id = id" $ hedgehog $ do
-    xs <- forAll ints
-    runPure (arr id :: Mealy Identity Int Int) xs === runPure Cat.id xs
-
-  it "arr (f >>> g) = arr f >>> arr g" $ hedgehog $ do
-    p <- forAll intGen
-    q <- forAll intGen
-    xs <- forAll ints
-    let f = (+ p)
-        g = (* q)
-    runPure (arr (f >>> g)) xs === runPure (arr f >>> arr g) xs
-
-  it "first (arr f) = arr (first f)" $ hedgehog $ do
-    p <- forAll intGen
-    ps <- forAll intPairs
-    let f = (+ p)
-    runPure (first (arr f)) ps === runPure (arr (first f)) ps
-
-  it "first (f >>> g) = first f >>> first g" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    g <- forAllMealy statefulGen
-    ps <- forAll intPairs
-    runPure (first (f >>> g)) ps === runPure (first f >>> first g) ps
-
-  it "first f >>> arr fst = arr fst >>> f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    ps <- forAll intPairs
-    runPure (first f >>> arr fst) ps === runPure (arr fst >>> f) ps
-
-  it "first f >>> arr (id *** g) = arr (id *** g) >>> first f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    p <- forAll intGen
-    ps <- forAll intPairs
-    let g = (* p)
-    runPure (first f >>> arr (id *** g)) ps
-      === runPure (arr (id *** g) >>> first f) ps
-
-  it "first (first f) >>> arr assoc = arr assoc >>> first f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    ts <- forAll nestedPairs
-    let assoc ((a, b), c) = (a, (b, c))
-    runPure (first (first f) >>> arr assoc) ts
-      === runPure (arr assoc >>> first f) ts
-
-arrowChoiceSpec :: Spec
-arrowChoiceSpec = describe "ArrowChoice" $ do
-  it "left (arr f) = arr (left f)" $ hedgehog $ do
-    p <- forAll intGen
-    es <- forAll intEithers
-    let f = (+ p)
-    runPure (left (arr f)) es === runPure (arr (left f)) es
-
-  it "left (f >>> g) = left f >>> left g" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    g <- forAllMealy statefulGen
-    es <- forAll intEithers
-    runPure (left (f >>> g)) es === runPure (left f >>> left g) es
-
-  it "f >>> arr Left = arr Left >>> left f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (f >>> arr (Left @Int @Int)) xs
-      === runPure (arr (Left @Int @Int) >>> left f) xs
-
-  it "left f >>> arr (id +++ g) = arr (id +++ g) >>> left f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    p <- forAll intGen
-    es <- forAll intEithers
-    let g = (* p)
-    runPure (left f >>> arr (id +++ g)) es
-      === runPure (arr (id +++ g) >>> left f) es
-
-  it "left (left f) >>> arr assocsum = arr assocsum >>> left f" $ hedgehog $ do
-    f <- forAllMealy statefulGen
-    es <- forAll nestedEithers
-    let assocsum (Left (Left x)) = Left x
-        assocsum (Left (Right y)) = Right (Left y)
-        assocsum (Right z) = Right (Right z)
-    runPure (left (left f) >>> arr assocsum) es
-      === runPure (arr assocsum >>> left f) es
-
-functorSpec :: Spec
-functorSpec = describe "Functor" $ do
-  it "fmap id = id" $ hedgehog $ do
-    m <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (fmap id m) xs === runPure m xs
-
-  it "fmap (f . g) = fmap f . fmap g" $ hedgehog $ do
-    m <- forAllMealy statefulGen
-    p <- forAll intGen
-    q <- forAll intGen
-    xs <- forAll ints
-    let f = (+ p)
-        g = (* q)
-    runPure (fmap (f . g) m) xs === runPure (fmap f (fmap g m)) xs
-
-applicativeSpec :: Spec
-applicativeSpec = describe "Applicative" $ do
-  it "pure id <*> v = v" $ hedgehog $ do
-    v <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (pure id <*> v) xs === runPure v xs
-
-  it "pure f <*> pure x = pure (f x)" $ hedgehog $ do
-    p <- forAll intGen
-    x <- forAll intGen
-    xs <- forAll ints
-    let f = (+ p)
-    runPure (pure f <*> pure x) xs === runPure (pure (f x)) xs
-
-  it "u <*> pure y = pure ($ y) <*> u" $ hedgehog $ do
-    u <- forAllMealy funArrowGen
-    y <- forAll intGen
-    xs <- forAll ints
-    runPure (u <*> pure y) xs === runPure (pure ($ y) <*> u) xs
-
-  it "pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ hedgehog $ do
-    u <- forAllMealy funArrowGen
-    v <- forAllMealy funArrowGen
-    w <- forAllMealy statefulGen
-    xs <- forAll ints
-    runPure (pure (.) <*> u <*> v <*> w) xs
-      === runPure (u <*> (v <*> w)) xs
-
-  it "fmap f x = pure f <*> x" $ hedgehog $ do
-    x <- forAllMealy statefulGen
-    p <- forAll intGen
-    xs <- forAll ints
-    let f = (+ p)
-    runPure (fmap f x) xs === runPure (pure f <*> x) xs

test/AFRPSpec.hs

@@ -1,18 +1,13 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module AFRPSpec (spec) where
 
-import Control.Arrow (arr, (&&&), first, left)
+import Control.Arrow (arr)
 import Control.Category ((>>>))
 import Control.Monad.Fix (MonadFix (..))
 import Data.Foldable (for_)
 import AFRP
 import Data.Functor.Identity (Identity (..))
 import Data.List (sort)
-import Data.Serialize (get, put, runGet, runPut)
+import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime)
-import qualified Data.Set as S
-import qualified Data.Text as T
-import Data.Time (Day (..), NominalDiffTime, LocalTime(..), TimeOfDay(..), UTCTime (..), picosecondsToDiffTime, utc)
 import Data.UUID (nil)
 import Hedgehog
 import qualified Hedgehog.Gen as Gen
@@ -21,29 +16,22 @@ import Test.Hspec
 import Test.Hspec.Hedgehog
 
 fakeRequest :: Request
-fakeRequest = Request (sec 0) utc nil
+fakeRequest = Request (sec 0) nil
 
 sec :: Integer -> UTCTime
 sec n = UTCTime (toEnum 0) (fromIntegral n)
 
-untime :: SerializeUTCTime -> UTCTime
-untime (SerializeUTCTime t) = t
-
 runPure :: Mealy Identity a b -> [a] -> [b]
-runPure m = go (runMealy m id)
+runPure _ [] = []
-  where
+runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
-    go _ [] = []
+  (b, m') -> b : runPure m' as
-    go w (a : as) = case runIdentity (stepAuto w fakeRequest a) of
-      (b, w') -> b : go w' as
 
 -- | Run a Mealy with a per-step wall clock (seconds since the day-0 epoch).
 runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b]
-runTimed m = go (runMealy m id)
+runTimed _ [] = []
-  where
+runTimed m ((s, a) : as) =
-    go _ [] = []
+  case runIdentity (AFRP.runMealy m id (Request (sec s) nil) a) of
-    go w ((s, a) : as) =
+    (b, m') -> b : runTimed m' as
-      case runIdentity (stepAuto w (Request (sec s) utc nil) a) of
-        (b, w') -> b : go w' as
 
 -- | A minimal State monad for observing effectful arrows (e.g. whenA gating).
 newtype St a = St { unSt :: Int -> (a, Int) }
@@ -62,15 +50,15 @@ instance MonadFix St where
   mfix f = St $ \s -> let (a, s') = unSt (f a) s in (a, s')
 
 runStEff :: Mealy St a b -> Int -> [a] -> ([b], Int)
-runStEff m = go (runMealy m id)
+runStEff m s0 as = go m s0 as
   where
     go _ s [] = ([], s)
-    go w s (a : rest) = case unSt (stepAuto w fakeRequest a) s of
+    go m' s (a : rest) =
-      ((b, w'), s') -> let (bs, s'') = go w' s' rest in (b : bs, s'')
+      case unSt (AFRP.runMealy m' id fakeRequest a) s of
+        ((b, m''), s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
 
 spec :: Spec
 spec = describe "AFRP" $ do
-  entitiesSpec
   holdSpec
   eventsSpec
   isEventSpec
@@ -87,8 +75,9 @@ spec = describe "AFRP" $ do
   delayEventSpec
   debounceSpec
   rollupSpec
-  serializeSpec
+  fixedSpec
   effSpec
+  switchSpec
   mapAccumRequestSpec
   preMapAccumRequestSpec
   whenASpec
@@ -145,23 +134,6 @@ 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" $
@@ -216,7 +188,6 @@ edgeSpec = describe "edge" $ do
               else o' === Tick
         _ -> failure
 
-
 filterASpec :: Spec
 filterASpec = describe "filterA" $ do
   it "lets through values matching predicate" $
@@ -399,6 +370,36 @@ rollupSpec = describe "rollup" $ do
           emitted = concat [xs | Event xs <- out]
       sort emitted === sort [x | Event x <- evs]
 
+fixedSpec :: Spec
+fixedSpec = describe "fixed" $ do
+  it "accumulates events within a window and rolls over on expiry" $
+    runTimed (fixed 10)
+             [ (0, Event 'a'), (1, Event 'b'), (2, Tick)
+             , (12, Event 'c'), (13, Tick)
+             ]
+      `shouldBe` [ ['a'], ['a', 'b'], ['a', 'b']
+                 , ['c'], ['c']
+                 ]
+
+  it "starts a window even on a leading Tick" $
+    runTimed (fixed 10)
+             [ (0, Tick), (1, Event 'a')
+             , (12, Tick), (13, Tick)
+             , (25, Event 'b')
+             ]
+      `shouldBe` [ [], ['a'], [], [], ['b'] ]
+
+  it "output is always the current window's accumulated list" $
+    hedgehog $ do
+      w <- forAll $ Gen.int (Range.constant 1 10)
+      evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
+      let out = runTimed (fixed w) (zip [0 ..] evs)
+          expected =
+            [ [ x | Event x <- take (i - lo + 1) (drop lo evs) ]
+            | i <- [0 .. length evs - 1]
+            , let lo = (i `div` w) * w
+            ]
+      out === expected
 
 eventGen :: Gen (Event Char)
 eventGen = Gen.frequency
@@ -406,39 +407,11 @@ eventGen = Gen.frequency
   , (1, pure Tick)
   ]
 
-timeGen :: Gen SerializeUTCTime
-timeGen = do
-  day <- ModifiedJulianDay . fromIntegral <$> Gen.int (Range.linear 0 100000)
-  pico <- picosecondsToDiffTime . fromIntegral
-    <$> Gen.int (Range.linear 0 (86400 * 10 ^ (12 :: Int) - 1))
-  pure $ SerializeUTCTime (UTCTime day pico)
-
-localTimeGen :: Gen SerializeLocalTime
-localTimeGen = do
-  day <- ModifiedJulianDay . fromIntegral <$> genInt 0 100000
-  tod <- TimeOfDay <$> genInt 0 23 <*> genInt 0 59 <*> (fromIntegral <$> genInt 0 60)
-  pure $ SerializeLocalTime (LocalTime day tod)
-  where
-    genInt a b = Gen.int (Range.linear a b)
-
-serializeSpec :: Spec
-serializeSpec = do
-  describe "SerializeUTCTime" $ do
-    it "get (put x) == pure x" $
-      hedgehog $ do
-        x <- forAll timeGen
-        tripping x (runPut . put) (runGet get)
-  describe "SerializeLocalTime" $ do
-    it "get (put x) == pure x" $
-      hedgehog $ do
-        x <- forAll localTimeGen
-        tripping x (runPut . put) (runGet get)
-
 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 :: Int, 3, 4]
+      `shouldBe` [2, 3, 4]
 
   it "output equals f(input) for every step" $
     hedgehog $ do
@@ -446,17 +419,41 @@ effSpec = describe "eff" $ do
       let out = runPure (eff (\_ x -> Identity (x * 2))) xs
       out === map (* 2) xs
 
+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)))
+                     (const (arr (const 99))))
+             [1, 2, 3, 4, 5]
+      `shouldBe` [1, 2, 99, 99, 99]
+
+  it "never switches if no Event is emitted" $
+    runPure (switch (arr (\x -> (x, Tick :: Event ())))
+                     (const (arr (const 99))))
+             [1, 2, 3]
+      `shouldBe` [1, 2, 3]
+
+  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
+          (pre, _post) = break (>= threshold) xs
+      take (length pre) out === pre
+      drop (length pre) out === replicate (length xs - length pre) 99
+
 mapAccumRequestSpec :: Spec
 mapAccumRequestSpec = describe "mapAccumRequest" $ do
   it "accumulates request times, post-state extraction" $
-    runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
+    runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
              [(0, 'a'), (5, 'b'), (10, 'c')]
       `shouldBe` [ [sec 0], [sec 0, sec 5], [sec 0, sec 5, sec 10] ]
 
   it "output i is every request time seen so far" $
     hedgehog $ do
       secs' <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100))
-      let out = runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
+      let out = runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take (i + 1) secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -464,14 +461,14 @@ mapAccumRequestSpec = describe "mapAccumRequest" $ do
 preMapAccumRequestSpec :: Spec
 preMapAccumRequestSpec = describe "preMapAccumRequest" $ do
   it "accumulates request times, pre-state extraction" $
-    runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
+    runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
              [(0, 'a'), (5, 'b'), (10, 'c')]
       `shouldBe` [ [], [sec 0], [sec 0, sec 5] ]
 
   it "output i is every request time before the current step" $
     hedgehog $ do
       secs' <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100))
-      let out = runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
+      let out = runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take i secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -511,7 +508,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 odd x then Left ()
+            [ if not (even x) then Left ()
               else if x > 0 then Right x
               else Left ()
             | x <- xs ]
@@ -521,67 +518,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 @Int 2, Tick]
+      `shouldBe` [Tick, Event 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 = take n $ zip vals evs
+          ps = zip (take n vals) (take n evs)
           out = runPure sample ps
       for_ (zip ps out) $ \((v, ev), o) ->
         o === tag v ev
-
--- | A stateless arrow carrying a fixed entity set, for testing propagation.
-subscribed :: S.Set T.Text -> Mealy Identity Int Int
-subscribed ents = Mealy ents $ \_ -> Fun $ \_ a -> a
-
--- | Same as 'subscribed' but yields a function, for testing '<*>'.
-subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
-subscribedF ents = Mealy ents $ \_ -> Fun $ \_ a -> (a +)
-
-entitiesSpec :: Spec
-entitiesSpec = describe "entities" $ do
-  it "id carries no entities" $
-    entities (arr id :: Mealy Identity Int Int) `shouldBe` S.empty
-
-  it "arr carries no entities" $
-    entities (arr (+ 1) :: Mealy Identity Int Int) `shouldBe` S.empty
-
-  it "eff carries no entities" $
-    entities (eff (\_ x -> Identity (x + 1 :: Int))) `shouldBe` S.empty
-
-  it "primitive combinators carry no entities" $ do
-    entities (hold 'a') `shouldBe` S.empty
-    entities (changes @Int) `shouldBe` S.empty
-    entities edge `shouldBe` S.empty
-    entities (sliding (3 :: Int) :: Mealy Identity (Event Int) [Int]) `shouldBe` S.empty
-
-  it "Category (.) unions entity sets" $
-    entities (subscribed (S.singleton "a") >>> subscribed (S.singleton "b"))
-      `shouldBe` S.fromList ["a", "b"]
-
-  it "Applicative (<*>) unions entity sets" $
-    entities (subscribedF (S.singleton "a") <*> subscribed (S.singleton "b"))
-      `shouldBe` S.fromList ["a", "b"]
-
-  it "Arrow (&&&) unions entity sets" $
-    entities (subscribed (S.singleton "a") &&& subscribed (S.singleton "b"))
-      `shouldBe` S.fromList ["a", "b"]
-
-  it "(>>>) unions entity sets" $
-    entities (subscribed (S.singleton "a") >>> arr id >>> subscribed (S.singleton "b"))
-      `shouldBe` S.fromList ["a", "b"]
-
-  it "left preserves the entity set" $
-    entities (left (subscribed (S.singleton "a")) :: Mealy Identity (Either Int Int) (Either Int Int))
-      `shouldBe` S.singleton "a"
-
-  it "first preserves the entity set" $
-    entities (first (subscribed (S.singleton "a")) :: Mealy Identity (Int, Int) (Int, Int))
-      `shouldBe` S.singleton "a"
-
-  it "fmap preserves the entity set" $
-    entities (fmap (+ 1) (subscribed (S.singleton "a")))
-      `shouldBe` S.singleton "a"

test/BedroomSpec.hs

@@ -2,8 +2,7 @@
 
 module BedroomSpec (spec) where
 
-import AFRP (Event (..), entities)
+import AFRP (Event (..))
-import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Aeson (Value)
 import HomeAssistant.Controller
@@ -22,39 +21,9 @@ drawerState = Event . stateEvent "binary_sensor.bedroom_nightstand_drawer_sensor
 
 spec :: Spec
 spec = describe "Bedroom" $ do
-  entitySpec
   drawerSpec
   buttonSpec
 
-entitySpec :: Spec
-entitySpec = describe "entities" $ do
-  it "entityChangeEvent' registers its entity id" $
-    entities (entityChangeEvent' "sensor.foo")
-      `shouldBe` S.singleton "sensor.foo"
-
-  it "entityRead / entityBool inherit the entity id" $ do
-    entities (entityRead @Double "sensor.bar") `shouldBe` S.singleton "sensor.bar"
-    entities (entityBool "binary_sensor.baz") `shouldBe` S.singleton "binary_sensor.baz"
-
-  it "bedroomDrawerController subscribes to the drawer sensor" $
-    entities bedroomDrawerController
-      `shouldBe` S.singleton "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contact"
-
-  it "bedroomButtonController subscribes to both remote event entities" $
-    entities bedroomButtonController
-      `shouldBe` S.fromList
-        [ "event.bedroom_quick_remote_masse_action"
-        , "event.bedroom_quick_jemina_action"
-        ]
-
-  it "bedroomPresenceController subscribes to the presence sensor" $
-    entities bedroomPresenceController
-      `shouldBe` S.singleton "binary_sensor.presence_sensor_bedroom_occupancy"
-
-  it "humidifierController subscribes to the door sensor" $
-    entities humidifierController
-      `shouldBe` S.singleton "binary_sensor.makuuhuone_ovi_contact"
-
 drawerSpec :: Spec
 drawerSpec = describe "bedroomDrawerController" $ do
   let entity = EntityId "switch.bedroom_drawer_light_masse"
@@ -102,7 +71,7 @@ buttonSpec = describe "bedroomButtonController" $ do
 
   it "Masse off click turns the bedroom lights off" $
     services (runHASS bedroomButtonController [masseButton "2_short_release"])
-      `shouldBe` [[light [area] Off]]
+      `shouldBe` [[light [area] False]]
 
   it "Enishen single click turns on her nightstand scene (lowest)" $
     services (runHASS bedroomButtonController [enishenButton "1_short_release"])
@@ -118,7 +87,7 @@ buttonSpec = describe "bedroomButtonController" $ do
 
   it "Enishen off click turns the bedroom lights off" $
     services (runHASS bedroomButtonController [enishenButton "2_short_release"])
-      `shouldBe` [[light [area] Off]]
+      `shouldBe` [[light [area] False]]
 
   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 (..), Event (..))
+import AFRP (Request (..))
 import Control.Concurrent.STM
   ( atomically
   , dupTChan
@@ -10,7 +10,7 @@ import Control.Concurrent.STM
   , writeTChan
   )
 import Data.Aeson (Value (..))
-import Data.Time (UTCTime (..), utc)
+import Data.Time (UTCTime (..))
 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) (Event (Number 1))
+    atomically $ writeTChan (busInbound bus) (Number 1)
-    atomically $ writeTChan (busInbound bus) (Event (Number 2))
+    atomically $ writeTChan (busInbound bus) (Number 2)
     r1 <- atomically $ (,) <$> readTChan p1 <*> readTChan p1
     r2 <- atomically $ (,) <$> readTChan p2 <*> readTChan p2
-    r1 `shouldBe` (Event (Number 1), Event (Number 2))
+    r1 `shouldBe` (Number 1, Number 2)
-    r2 `shouldBe` (Event (Number 1), Event (Number 2))
+    r2 `shouldBe` (Number 1, Number 2)
 
   it "channelHassEval writes CallService to the outbound channel" $ withBus InfoS $ \bus -> do
-    let req = Request (UTCTime (toEnum 0) 0) utc nil
+    let req = Request (UTCTime (toEnum 0) 0) nil
         svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
     runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
       channelHassEval bus (CallService req svc)

test/ConnectionSpec.hs

@@ -2,19 +2,14 @@
 
 module ConnectionSpec (spec) where
 
-import AFRP (Request(..))
 import Data.Aeson (object, (.=))
-import Data.Maybe (fromJust)
 import Data.Text (Text)
-import Data.Time (UTCTime (..), utc)
-import Data.UUID (fromString)
 import HomeAssistant.Controller (Service (..), Target(..))
-import HomeAssistant.Runtime.Connection (encodeService, dedupeBatch)
+import HomeAssistant.Runtime.Connection (encodeService)
 import Test.Hspec
 
 spec :: Spec
-spec = do
+spec = describe "encodeService" $ do
-  describe "encodeService" $ do
   it "encodes a call_service message" $
     encodeService 7 (Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"])
       `shouldBe` object
@@ -35,45 +30,3 @@ spec = do
         , "target" .= object ["entity_id" .= ("light.bedroom_masse" :: Text)]
         , "service_data" .= object ["brightness" .= (200 :: Int)]
         ]
-
-  describe "dedupeBatch" $ do
-    it "collapses identical calls to one" $
-      let batch = [ (req 1, lightOn [AreaId "x"])
-                  , (req 2, lightOn [AreaId "x"])
-                  , (req 3, lightOn [AreaId "x"])
-                  ]
-      in dedupeBatch batch `shouldBe` [(req 3, lightOn [AreaId "x"])]
-
-    it "keeps same-target different-service calls separate" $
-      let batch = [ (req 1, lightOn  [AreaId "x"])
-                  , (req 2, lightOff [AreaId "x"])
-                  ]
-          result = dedupeBatch batch
-      in length result `shouldBe` 2
-
-    it "newest call wins for the same key" $
-      let batch = [ (req 1, lightOn [AreaId "x"])
-                  , (req 2, lightOn [AreaId "x"])
-                  , (req 3, lightOn [AreaId "x"])
-                  ]
-      in map requestTraceId (map fst (dedupeBatch batch)) `shouldBe`
-           [fromJust (fromString "00000000-0000-0000-0000-000000000003")]
-
-    it "treats target lists in different order as the same key" $
-      let batch = [ (req 1, lightOn [EntityId "a", EntityId "b"])
-                  , (req 2, lightOn [EntityId "b", EntityId "a"])
-                  ]
-      in length (dedupeBatch batch) `shouldBe` 1
-
-req :: Int -> Request
-req n = Request (UTCTime (toEnum 0) (fromIntegral (0 :: Int))) utc
-          (fromJust (fromString uuid))
-  where
-    pad i = replicate (12 - length (show i)) '0' <> show i
-    uuid = "00000000-0000-0000-0000-" <> pad n
-
-lightOn :: [Target] -> Service
-lightOn targets = Service "light" "turn_on" Nothing targets
-
-lightOff :: [Target] -> Service
-lightOff targets = Service "light" "turn_off" Nothing targets

test/Main.hs

@@ -1,24 +1,20 @@
 module Main (main) where
 
 import Test.Hspec (hspec)
-import qualified AFRPLawsSpec
 import qualified AFRPSpec
 import qualified BackoffProp
 import qualified BedroomSpec
 import qualified BusSpec
 import qualified ConnectionSpec
-import qualified MetricsSpec
 import qualified RuntimeSpec
 import qualified SupervisorSpec
 
 main :: IO ()
 main = hspec $ do
-  AFRPLawsSpec.spec
   AFRPSpec.spec
   BedroomSpec.spec
   BusSpec.spec
   ConnectionSpec.spec
-  MetricsSpec.spec
   RuntimeSpec.spec
   SupervisorSpec.spec
   BackoffProp.spec

test/MetricsSpec.hs

@@ -1,150 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module MetricsSpec (spec) where
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HM
-import Data.Int (Int64)
-import Data.Text (Text)
-import HomeAssistant.Runtime.Metrics
-  ( DsType (..)
-  , DsSpec (..)
-  , dsTypeOf
-  , sanitizeName
-  , buildSchema
-  , buildCreateArgs
-  , buildUpdateArgs
-  , ensureRrd
-  , sampleAndUpdate
-  , metricsAction
-  )
-import qualified System.Metrics as M (Value (..))
-import Test.Hspec
-import Control.Exception (try, SomeException)
-import System.Directory (findExecutable, getTemporaryDirectory, removeFile)
-import System.Exit (ExitCode (ExitSuccess))
-import System.Process (readProcessWithExitCode)
-import qualified System.Metrics as Metrics
-import qualified System.Metrics.Counter as Counter
-import qualified System.Metrics.Gauge as Gauge
-
-spec :: Spec
-spec = do
-  describe "dsTypeOf" $ do
-    it "maps Counter to Derive" $
-      dsTypeOf (M.Counter 1000) `shouldBe` Just Derive
-
-    it "maps Gauge to Gauge" $
-      dsTypeOf (M.Gauge 500) `shouldBe` Just Gauge
-
-    it "maps Label to Nothing" $
-      dsTypeOf (M.Label "hello") `shouldBe` Nothing
-
-  describe "sanitizeName" $ do
-    it "replaces dots with underscores for short names" $
-      sanitizeName ("rts.gc.cpu_ms" :: Text) `shouldBe` "rts_gc_cpu_ms"
-
-    it "shortens names longer than 19 chars to 15 chars + _ + 3 hex" $ do
-      let result = sanitizeName ("rts.gc.par_balanced_bytes_copied" :: Text)
-      length result `shouldBe` 19
-      take 15 result `shouldBe` "rts_gc_par_bala"
-      drop 15 result `shouldBe` "_" ++ drop 16 result
-
-    it "is deterministic (same input -> same output)" $
-      sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
-        `shouldBe` sanitizeName ("rts.gc.peak_megabytes_allocated" :: Text)
-
-  describe "buildSchema" $ do
-    it "builds sorted DsSpecs from counters and gauges, skipping labels" $
-      let sample :: HashMap Text M.Value
-          sample = HM.fromList
-            [ ("x.allocated", M.Counter 1000)
-            , ("a.bytes_used", M.Gauge 500)
-            , ("c.label_thing", M.Label "irrelevant")
-            ]
-      in buildSchema sample `shouldBe`
-           [ DsSpec "a.bytes_used" "a_bytes_used" Gauge
-           , DsSpec "x.allocated" "x_allocated" Derive
-           ]
-
-    it "produces dsName <= 19 chars for long ekg GC metric names" $
-      let sample :: HashMap Text M.Value
-          sample = HM.fromList
-            [ ("rts.gc.par_balanced_bytes_copied", M.Gauge 1)
-            , ("rts.gc.peak_megabytes_allocated", M.Gauge 2)
-            , ("rts.gc.cumulative_bytes_used", M.Counter 3)
-            ]
-      in map (length . dsName) (buildSchema sample) `shouldSatisfy` all (<= 19)
-
-  describe "buildCreateArgs" $ do
-    it "builds create argv with mixed DERIVE and GAUGE DSes and RRAs" $
-      buildCreateArgs "test.rrd" 10
-        [ ("ds1", Derive)
-        , ("ds2", Gauge)
-        ]
-        `shouldBe`
-          [ "create"
-          , "test.rrd"
-          , "--step"
-          , "10"
-          , "DS:ds1:DERIVE:20:0:U"
-          , "DS:ds2:GAUGE:20:0:U"
-          , "RRA:AVERAGE:0.5:1:6000"
-          , "RRA:MAX:0.5:1:6000"
-          , "RRA:AVERAGE:0.5:360:1680"
-          , "RRA:MAX:0.5:360:1680"
-          ]
-
-  describe "buildUpdateArgs" $ do
-    it "builds update argv with numeric values" $
-      buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Just 200]
-        `shouldBe`
-          [ "update"
-          , "test.rrd"
-          , "--template"
-          , "ds1:ds2"
-          , "N:100:200"
-          ]
-
-    it "renders Nothing as U (unknown)" $
-      buildUpdateArgs "test.rrd" ["ds1", "ds2"] [Just 100, Nothing]
-        `shouldBe`
-          [ "update"
-          , "test.rrd"
-          , "--template"
-          , "ds1:ds2"
-          , "N:100:U"
-          ]
-
-    it "renders all-Nothing as all-U" $
-      buildUpdateArgs "test.rrd" ["ds1"] [Nothing]
-        `shouldBe`
-          [ "update"
-          , "test.rrd"
-          , "--template"
-          , "ds1"
-          , "N:U"
-          ]
-
-  describe "end-to-end (rrdtool-gated)" $ do
-    it "creates an rrd, samples, and updates it" $ do
-      mRrdtool <- findExecutable "rrdtool"
-      case mRrdtool of
-        Nothing -> pendingWith "rrdtool not on PATH"
-        Just rrdtool -> do
-          store <- Metrics.newStore
-          c <- Metrics.createCounter "test.counter" store
-          g <- Metrics.createGauge "test.gauge" store
-          Counter.inc c
-          Gauge.set g 42
-          tmp <- getTemporaryDirectory
-          let rrdPath = tmp ++ "/hass-controller-metrics-test.rrd"
-          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
-          schema <- buildSchema <$> Metrics.sampleAll store
-          ensureRrd rrdtool rrdPath schema
-          sampleAndUpdate store rrdtool rrdPath schema
-          (rc, out, _) <- readProcessWithExitCode rrdtool ["fetch", rrdPath, "AVERAGE"] ""
-          rc `shouldBe` ExitSuccess
-          length out `shouldSatisfy` (> 0)
-          _ <- try (removeFile rrdPath) :: IO (Either SomeException ())
-          return ()

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) (Event (doorEvent "on"))  -- initial value: no change event
+--     atomically $ writeTChan (busInbound bus) (doorEvent "on")  -- initial value: no change event
---     atomically $ writeTChan (busInbound bus) (Event (doorEvent "off")) -- door closes: lights on
+--     atomically $ writeTChan (busInbound bus) (doorEvent "off") -- door closes: lights on
---     atomically $ writeTChan (busInbound bus) (Event (doorEvent "on"))  -- door opens: lights off
+--     atomically $ writeTChan (busInbound bus) (doorEvent "on")  -- door opens: lights off
 --     putStrLn "After the writes"
 --     Right (_, svc1) <- boundedRead (busOutbound bus)
 --     Right (_, svc2) <- boundedRead (busOutbound bus)
@@ -32,11 +32,9 @@ spec = pure ()
 -- doorEvent :: Text -> Value
 -- doorEvent state = object
 --   [ "event" .= object
---     [ "variables" .= object
+--     [ "data" .= object
---       [ "trigger" .= object
 --       [ "entity_id" .= ("binary_sensor.makuuhuone_ovi_contact" :: Text)
---         , "to_state" .= object ["state" .= state]
+--       , "new_state" .= object ["state" .= state]
---         ]
 --       ]
 --     ]
 --   ]

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 (..), utc)
+import Data.Time (UTCTime (..))
 import Data.UUID (nil)
-import AFRP (Mealy (..), Request (..), stepAuto)
+import AFRP (Mealy (..), Request (..))
 import HomeAssistant.Controller (HASSEff (..), Service)
 
 fakeRequest :: Request
-fakeRequest = Request (sec 0) utc nil
+fakeRequest = Request (sec 0) nil
 
 sec :: Integer -> UTCTime
 sec n = UTCTime (toEnum 0) (fromIntegral n)
@@ -49,41 +49,33 @@ 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 m = go (runMealy m interp)
+runHASS _ [] = []
-  where
+runHASS m (a : as) =
-    go _ [] = []
+  case runAcc (runMealy m interp fakeRequest a) [] of
-    go w (a : as) =
+    ((b, m'), svcs) -> (b, svcs) : runHASS m' as
-      case runAcc (stepAuto w fakeRequest a) [] of
-        ((b, w'), svcs) -> (b, svcs) : go w' as
 
 services :: [(b, [Service])] -> [[Service]]
 services = map snd
 
--- | Build a state-trigger payload matching `entityChangeEvent'` / `entityBool'`
+-- | Build a state-change event payload matching `entityChangeEvent'` / `entityBool'` lenses.
--- 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
+    [ "data" .= object
-      [ "trigger" .= object
       [ "entity_id" .= entityId
-        , "to_state" .= object [ "state" .= state ]
+      , "new_state" .= object [ "state" .= state ]
-        ]
       ]
     ]
   ]
 
--- | Build an Ikea button trigger payload matching `ikeaQuickButton` lenses.
+-- | Build an Ikea button event payload matching `ikeaQuickButton` lenses.
 buttonEvent :: T.Text -> T.Text -> Value
 buttonEvent entityId eventType = object
   [ "event" .= object
-    [ "variables" .= object
+    [ "data" .= object
-      [ "trigger" .= object
       [ "entity_id" .= entityId
-        , "to_state" .= object
+      , "new_state" .= object
         [ "attributes" .= object [ "event_type" .= eventType ] ]
       ]
     ]
   ]
-  ]