rollup, sliding and fixed windows

default.nix

@@ -15,7 +15,7 @@ mkDerivation {
   executableHaskellDepends = [ base ];
   testHaskellDepends = [
     aeson annotated-exception async base hedgehog hspec hspec-hedgehog
-    stm text time
+    katip stm text time uuid
   ];
   license = lib.meta.getLicenseFromSpdxId "BSD-3-Clause";
   mainProgram = "home-assistant-controller";

home-assistant-controller.cabal

@@ -62,6 +62,7 @@ library
     exposed-modules:  AFRP
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
+                    , HomeAssistant.Controller.Ruuvi
                     , HomeAssistant.Runtime
                     , HomeAssistant.Runtime.Bus
                     , HomeAssistant.Runtime.Connection

src/AFRP.hs

@@ -25,6 +25,9 @@ module AFRP
   , isEvent
   , delayEvent
   , sample
+  , rollup
+  , sliding
+  , fixed
   ) where
 
 import Control.Category (Category(..), (>>>))
@@ -34,6 +37,7 @@ 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)
 
 data Request = Request
@@ -221,5 +225,44 @@ duration :: forall eff a. Mealy eff a NominalDiffTime
 duration = mapAccumRequest go (Nothing @(UTCTime, NominalDiffTime)) (maybe 0 snd)
   where
     go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
-    go req Nothing _ = Just $ (requestTime req, requestTime req `diffUTCTime` requestTime req)
+    go req Nothing _ = Just (requestTime req, requestTime req `diffUTCTime` requestTime req)
     go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)
+
+
+
+rollup :: Int -> Int -> Mealy eff (Event a) (Event [a])
+rollup limit seconds = mapAccumRequest go (Left Tick) (either id (\(_, _, _, ev) -> ev))
+  where
+    e a = Endo ([a] ++)
+    go :: Request -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a]) -> Event a -> Either (Event [a]) (UTCTime, Int, Endo [a], Event [a])
+    go _ (Left _) Tick = Left Tick
+    go req (Left _) (Event a) = Right (addUTCTime (fromIntegral seconds) (requestTime req), 1, mempty, Event [a])
+    go req (Right (end, n, acc, _)) Tick
+      | requestTime req >= end = Left (Event $ appEndo acc [])
+      | otherwise = Right (end, n, acc, Tick)
+    go req (Right (end, n, acc, _)) (Event a)
+      | requestTime req >= end = Left (Event $ appEndo acc [a])
+      | n < limit = Right (end, n+1, acc, Event [a])
+      | otherwise = Right (end, n+1, acc <> e a, Tick)
+
+-- Sliding window into the events
+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) = take size (acc ++ [a])
+
+fixed :: Int -> Mealy eff (Event a) [a]
+fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
+  where
+    e a = Endo ([a] ++)
+    go :: Request -> Maybe (UTCTime, Endo [a]) -> Event a -> Maybe (UTCTime, Endo [a])
+    go req Nothing Tick = Just (addUTCTime (fromIntegral seconds) (requestTime req), mempty)
+    go req Nothing (Event a) = Just (addUTCTime (fromIntegral seconds) (requestTime req), e a)
+    go req (Just (end, acc)) ev =
+      case ev of
+           Tick | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, mempty)
+                | otherwise -> Just (end, acc)
+           Event a | requestTime req >= end -> Just (addUTCTime (fromIntegral seconds) end, e a)
+                   | otherwise -> Just (end, acc <> e a)

src/HomeAssistant/Controller.hs

@@ -14,10 +14,6 @@ module HomeAssistant.Controller
   , entityRead'
   , entityBool
   , entityBool'
-  , Ruuvi(..)
-  , ruuvi
-  , ruuviTemperatures
-  , ruuviPressures
   , DoorState(..)
   , light
   , Presence(..)
@@ -29,7 +25,7 @@ module HomeAssistant.Controller
   , Target(..)
   ) where
 
-import AFRP (Mealy (..), eff, Event(..), hold, events, changes, filterA, (>>|), toEvent, Request)
+import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value)
@@ -75,18 +71,6 @@ traceValue = proc x -> do
   eff Trace -< x
   returnA -< x
 
-ruuviTemperatures :: Mealy eff (Event Value) Double
-ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
-
-ruuviPressures :: Mealy eff (Event Value) Double
-ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
-
-data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
-            deriving (Show, Eq)
-
-ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
-ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
-
 data DoorState = Open | Closed
   deriving (Show, Eq)
 

src/HomeAssistant/Controller/Ruuvi.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+module HomeAssistant.Controller.Ruuvi
+  ( Ruuvi(..)
+  , ruuvi
+  , ruuviTemperatures
+  , ruuviPressures
+  , ruuviController
+  ) where
+
+import AFRP (Mealy, Event, hold, changes, rollup)
+import Control.Category ((>>>))
+import Data.Aeson (Value)
+import HomeAssistant.Controller (entityRead, traceEvent, HASS)
+import Control.Arrow (Arrow(..))
+
+ruuviTemperatures :: Mealy eff (Event Value) Double
+ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
+
+ruuviPressures :: Mealy eff (Event Value) Double
+ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
+
+data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
+            deriving (Show, Eq)
+
+ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
+ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
+
+
+ruuviController :: HASS (Event Value) ()
+ruuviController = ruuvi >>> rollup 1 30 >>> traceEvent >>> arr (const ())

src/HomeAssistant/Runtime.hs

@@ -32,6 +32,7 @@ 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)
 
 step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
 step nt trace (Mealy f) a = do
@@ -46,6 +47,7 @@ controllers =
   , Controller "bedroom-button" bedroomButtonController False -- This works but leaving for vacation
   , Controller "bedroom-drawer" bedroomDrawerController True
   , Controller "bedroom-humidifier" humidifierController True
+  , Controller "ruuvi-controller" ruuviController True
   ]
 
 -- | Steps the machine for every inbound message; service calls go to the