Merge pull request 'Control the kitchen lights' (#1) from kitchen-lights into main

Reviewed-on: #1

.gitignore

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

default.nix

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

home-assistant-controller.cabal

@@ -62,6 +62,7 @@ library
     exposed-modules:  AFRP
                     , HomeAssistant.Controller
                     , HomeAssistant.Controller.Bedroom
+                    , HomeAssistant.Controller.Kitchen
                     , HomeAssistant.Controller.Children
                     , HomeAssistant.Controller.Ruuvi
                     , HomeAssistant.Runtime
@@ -96,6 +97,11 @@ library
                     , unordered-containers
                     , process
                     , directory
+                    , cereal
+                    , containers
+                    , filepath
+                    , conduit
+                    , cereal-conduit
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -136,7 +142,8 @@ test-suite home-assistant-controller-test
     default-language: GHC2024
 
     -- Modules included in this executable, other than Main.
-    other-modules:    AFRPSpec
+    other-modules:    AFRPLawsSpec
+                    , AFRPSpec
                     , BackoffProp
                     , BedroomSpec
                     , BusSpec
@@ -165,6 +172,7 @@ test-suite home-assistant-controller-test
         hspec,
         stm,
         aeson,
+        cereal,
         text,
         async,
         hedgehog,

src/AFRP.hs

@@ -3,12 +3,14 @@
 
 module AFRP
   ( Mealy(..)
+  , Auto(..)
+  , DecodedAuto(..)
   , eff
   , withEntities
   , Event(..)
   , hold
   , events
-  , switch
+  -- , switch
   , preMapAccum
   , preMapAccumRequest
   , mapAccum
@@ -22,8 +24,10 @@ module AFRP
   , lMerge
   , Pair(..)
   , Request(..)
+  , SerializeUTCTime(..)
+  , SerializeLocalTime(..)
   , edge
-  , dropFirst
+  , waitFor
   , duration
   , tag
   , isEvent
@@ -31,23 +35,70 @@ 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(..), ArrowLoop(..))
-import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime)
-import Control.Monad.Fix (MonadFix (mfix))
+import Control.Arrow (Arrow(..), ArrowChoice(..))
+import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime (LocalTime), utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime, TimeOfDay (TimeOfDay), diffLocalTime)
 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
 
@@ -57,32 +108,174 @@ data Request = Request
   , 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. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
+  , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Auto m a b
   }
 
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
-  Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do
-    Pair x af' <- af nt r a
-    Pair x' bf' <- bf nt r a
-    pure (Pair (x <> x') (af' <> bf'))
+  Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt -> af nt <> bf nt
 
 
 instance Monoid b => Monoid (Mealy eff a b) where
-  mempty = m
-    where
-      m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
+  mempty = Mealy mempty $ \_nt -> mempty
+    -- where
+    --   m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = m
-  where
-    m = Mealy mempty $ \nt req x ->
-      nt (f req x) >>= \b -> pure (Pair b m)
+eff f = Mealy mempty $ \nt -> do
+  Stateful (Codec get put) (State () False) $ \s req a -> do
+    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
@@ -91,53 +284,32 @@ withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
 withEntities es (Mealy _ f) = Mealy es f
 
 instance Category (Mealy eff) where
-  id = Mealy mempty (\_ _ x -> pure (Pair x id))
-  (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
-    Pair b g' <- g nt t a
-    Pair c f' <- f nt t b
-    pure (Pair c (f' . g'))
+  id = Mealy mempty (\_ -> id)
+  (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do
+    f nt . g nt
 
 instance Arrow (Mealy eff) where
-  arr f = mealy
-    where
-      mealy = Mealy mempty $ \_ _ b -> pure (Pair (f b) mealy)
-  first (Mealy st f) = Mealy st $ \nt t (b,d) -> do
-    Pair c f' <- f nt t b
-    pure (Pair (c, d) (first f'))
+  arr f = Mealy mempty $ \_nt -> arr f
+  first (Mealy st f) = Mealy st $ \nt -> first (f nt)
 
 instance ArrowChoice (Mealy eff) where
-  left (Mealy st f) = lm
-    where
-      lm = Mealy st $ \nt t -> \case
-        Left b -> do
-          Pair c f' <- f nt t b
-          pure (Pair (Left c) (left f'))
-        Right d -> pure (Pair (Right d) lm)
+  left (Mealy st f) = Mealy st $ \nt -> left (f nt)
 
--- ArrowLoop is incompatible with strict Pair (strict fields prevent
--- the lazy knot-tying that mfix requires with loop).
--- instance ArrowLoop (Mealy eff) where
---   loop (Mealy st f) = Mealy st $ \nt t b -> do
---     Pair (c,_) f' <- mfix $ \(Pair (_,d) _) -> f nt t (b,d)
---     pure (Pair c (loop f'))
 
 instance Functor (Mealy eff a) where
-  fmap f (Mealy st g) = Mealy st $ \nt t a -> do
-    Pair b g' <- g nt t a
-    pure (Pair (f b) (fmap f g'))
+  fmap f (Mealy st g) = Mealy st $ \nt -> fmap f (g nt)
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy mempty $ \_ _ _ -> pure (Pair b (pure b))
-  Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do
-    b' <- x nt t a
-    let Pair x' xNext = b'
-    Pair f' fNext <- f nt t a
-    pure (Pair (f' x') (fNext <*> xNext))
+  pure b = Mealy mempty $ \_ -> pure b
+  Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt ->
+    f nt <*> x nt
 
 data Event a
   = Tick
   | Event a
-  deriving (Show, Eq, Functor, Foldable, Traversable)
+  deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
+
+instance Serialize a => Serialize (Event a)
 
 instance Semigroup (Event a) where
   (<>) = lMerge
@@ -145,10 +317,13 @@ instance Semigroup (Event a) where
 instance Monoid (Event a) where
   mempty = Tick
 
-hold :: a -> Mealy eff (Event a) a
-hold a = Mealy mempty $ \_ _ -> \case
-  Tick -> pure (Pair a (hold a))
-  Event a' -> pure (Pair a' (hold a'))
+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
+
 
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case
@@ -162,51 +337,89 @@ 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 st f) s = Mealy st $ \nt t a -> do
-  Pair (b, ev) f' <- f nt t a
-  case ev of
-          Tick -> pure (Pair b (switch f' s))
-          Event x -> runMealy (s x) nt t a
+-- 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
+--   Pair (b, ev) f' <- f nt t a
+--   case ev of
+--           Tick -> pure (Pair b (switch f' s))
+--           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 f x extract = go x
-  where
-    go b = Mealy mempty $ \_ _ a ->
-      let next = f b a
-      in pure (Pair (extract b) (go next))
 
-preMapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-preMapAccumRequest f x extract = go x
+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 = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
   where
-    go b = Mealy mempty $ \_ t a ->
-      let next = f t b a
-      in pure (Pair (extract b) (go next))
+    step :: State x -> a -> (b, State x)
+    step s a = let s' = f (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
 
-mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccum f x extract = go x
-  where
-    go b = Mealy mempty $ \_ _ a ->
-      let next = f b a
-      in pure (Pair (extract next) (go next))
 
-mapAccumRequest :: (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
-mapAccumRequest f x extract = go x
+mapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+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
-    go b = Mealy mempty $ \_ t a ->
-      let next = f t b a
-      in pure (Pair (extract next) (go next))
+    step :: State x -> a -> (b, State x)
+    step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
+
+preMapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+preMapAccumRequest step x extract = Mealy mempty $ \_ -> preMapAccumRequest' step x extract
+
+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)
+    step s req a = let s' = f req (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
+
+mapAccumRequest :: (Serialize x, Eq x) => (Request -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
+mapAccumRequest step x extract = Mealy mempty $ \_ -> mapAccumRequest' step x extract
+
+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)
+    step s req a = let s' = f req (state s) a in (extract s', State s' (dirty s || state s /= s'))
 
 data DelayState x a = DelayState
   { pending :: x
   , output  :: !(Event a)
   }
+  deriving (Generic, Eq)
 
+instance (Serialize x, Serialize a) => Serialize (DelayState x a)
 
-delayEvent :: NominalDiffTime -> Mealy eff (Event a) (Event a)
+newtype SerializeUTCTime = SerializeUTCTime UTCTime
+  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
@@ -218,17 +431,17 @@ delayEvent delay =
           queued =
             case input of
               Tick    -> pending st
-              Event x -> pending st ++ [(delay `addUTCTime` now, x)]
+              Event x -> pending st ++ [(SerializeUTCTime $ delay `addUTCTime` now, x)]
 
       in case queued of
-           (due, x) : rest
+           (SerializeUTCTime due, x) : rest
              | due <= now ->
                  DelayState rest (Event x)
 
            _ ->
                  DelayState queued Tick
 
-debounce :: NominalDiffTime -> Mealy eff (Event a) (Event a)
+debounce :: (Serialize a, Eq a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
 debounce delay =
   mapAccumRequest step initial output
   where
@@ -237,13 +450,13 @@ debounce delay =
       let now = requestTime req
           held = case input of
                       Tick -> pending st
-                      Event x -> Just (delay `addUTCTime` now, x)
+                      Event x -> Just (SerializeUTCTime $ delay `addUTCTime` now, x)
       in case held of
-              Just (due, x)
+              Just (SerializeUTCTime due, x)
                 | due <= now -> DelayState Nothing (Event x)
               _ -> DelayState held Tick
 
-changes :: Eq a => Mealy eff a (Event a)
+changes :: (Serialize a, 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)
@@ -276,86 +489,126 @@ lMerge (Event a) _ = Event a
 lMerge Tick (Event a) = Event a
 
 edge :: Mealy eff Bool (Event ())
-edge = go False
+edge =
+  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
-    go True = Mealy mempty $ \_ _ -> \case
-      True -> pure (Pair Tick (go True))
-      False -> pure (Pair Tick (go False))
-    go False = Mealy mempty $ \_ _ -> \case
-      True -> pure (Pair (Event ()) (go True))
-      False -> pure (Pair Tick (go False))
-
-
--- | Drop the first 'Event' and pass through everything after. Useful for
--- ignoring a self-triggered event (e.g. a service call that changes the
--- very entity the arrow listens to).
-dropFirst :: Mealy eff (Event a) (Event a)
-dropFirst = go False
-  where
-    go seen = Mealy mempty $ \_ _ input ->
-      case input of
-        Event _ | not seen -> pure (Pair Tick (go True))
-        _ -> pure (Pair input (go seen))
-
+    extract :: WaitingFor -> Bool
+    extract Waiting = False
+    extract Pending{waitingForStart=SerializeLocalTime s, waitingForCurrent=SerializeLocalTime e} =
+      e `diffLocalTime` s >= delta
+    step :: Request -> WaitingFor -> Bool -> WaitingFor
+    step _req _prev False = Waiting
+    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 @(UTCTime, NominalDiffTime)) (maybe 0 snd)
+duration = mapAccumRequest go (Nothing @(SerializeUTCTime, SerializeUTCTime)) (maybe 0 delta)
   where
-    go :: Request -> Maybe (UTCTime, NominalDiffTime) -> a -> Maybe (UTCTime, NominalDiffTime)
-    go req Nothing _ = Just (requestTime req, requestTime req `diffUTCTime` requestTime req)
-    go req (Just (startTime, _)) _ = Just (startTime, requestTime req `diffUTCTime` startTime)
-
+    delta :: (SerializeUTCTime, SerializeUTCTime) -> NominalDiffTime
+    delta (SerializeUTCTime start, SerializeUTCTime end) = end `diffUTCTime` start
+    go :: Request -> Maybe (SerializeUTCTime, SerializeUTCTime) -> a -> Maybe (SerializeUTCTime, SerializeUTCTime)
+    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
+-- 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.
 rollup
-  :: Int -- ^ How many items to pass through before burst protection
-  -> Int -- ` How many seconds to collect the bursty data
+  :: (Serialize a, Eq a)
+  => Int -- ^ How many items to pass through before burst protection
+  -> Int -- ^ How many seconds to collect the bursty data
   -> Mealy eff (Event a) (Event [a])
-rollup limit seconds = mapAccumRequest go (Left Tick) (either id (\(_, _, _, ev) -> ev))
+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)
+    go
+      :: Request
+      -> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
+      -> Event a
+      -> Either (Event [a]) (SerializeUTCTime, Int, Seq a, Event [a])
+
+    go _ (Left _) Tick =
+      Left Tick
+
+    go req (Left _) (Event a) =
+      Right
+        ( 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 :: Int -> Mealy eff (Event a) [a]
+sliding :: (Serialize a, Eq a) => 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]
-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)
 
+requestLocalTime :: Request -> LocalTime
+requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
 
 currentTime :: Mealy eff a LocalTime
-currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ ->
-  pure (Pair (utcToLocalTime requestTimeZone requestTime) currentTime)
+currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
+  requestLocalTime req
 
 
+stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)
+stepAuto (Fun f) req a = pure (f req a, Fun f)
+stepAuto (Stateful codec s f) req a = do
+  (b, s') <- f s req 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,6 +8,7 @@ module HomeAssistant.Controller
   , HASSEff(..)
   , HASS
   , callService
+  , callServiceDyn
   , entityChangeEvent
   , entityChangeEvent'
   , entityRead
@@ -27,7 +28,7 @@ module HomeAssistant.Controller
   , Light(..)
   ) where
 
-import AFRP (Mealy (..), Pair (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
+import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value, object, (.=))
@@ -37,6 +38,8 @@ import Control.Lens (has, only, (^?), to)
 import Data.Aeson.Lens (key, _String, _Integral)
 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)
@@ -59,17 +62,20 @@ 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 = m
-  where
-    m = Mealy mempty $ \nt req -> \case
-      Event a -> nt (Trace req a) >>= \() -> pure (Pair (Event a) m)
-      Tick -> pure (Pair Tick m)
+traceEvent = proc ev -> do
+  case ev of
+       Event a -> eff Trace -< a
+       Tick -> returnA -< ()
+  returnA -< ev
 
 traceValue :: Show a => HASS a a
 traceValue = proc x -> do
@@ -77,10 +83,14 @@ traceValue = proc x -> do
   returnA -< x
 
 data DoorState = Open | Closed
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic)
+
+instance Serialize DoorState
 
 data Presence = Occupied | Unoccupied
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic)
+
+instance Serialize Presence
 
 presence :: T.Text -> HASS (Event Value) (Event Presence)
 presence entityId =entityBool entityId

src/HomeAssistant/Controller/Bedroom.hs

@@ -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/Kitchen.hs

@@ -0,0 +1,59 @@
+{-# 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,6 +13,8 @@ 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
@@ -21,7 +23,9 @@ ruuviPressures :: Mealy eff (Event Value) Double
 ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
 
 data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
-            deriving (Show, Eq)
+            deriving (Show, Eq, Generic)
+
+instance Serialize Ruuvi
 
 ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
 ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Pair (..), Request (..))
+import AFRP (Event (..), Mealy (..), Request (..), Auto, stepAutoSerializing, load, DecodedAuto (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -31,18 +31,20 @@ 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 :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (Pair b (Mealy eff a b))
-step nt trace (Mealy _ f) a = do
+step :: (MonadIO m) => FilePath -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
+step path trace st a = do
   now <- liftIO getCurrentTime
   tz <- liftIO getCurrentTimeZone
-  f nt (Request now tz 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
 
@@ -51,25 +53,31 @@ 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 False
+  , Controller "bedroom-humidifier" humidifierController True
   , 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 :: Bus -> Controller -> IO Void
-runController bus (Controller name machine _enabled) = do
+runController :: FilePath -> Bus -> Controller -> IO Void
+runController rootDir bus (Controller name machine _enabled) = do
   inbound <- atomically (dupTChan (busInbound bus))
-  go inbound machine
+  let ns = Namespace [name]
+  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 inbound f = do
+    go path inbound f = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
-      let ns = Namespace [name]
-      Pair _ f' <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
-      go inbound f'
+      (_, next) <- step path uuid f msg
+      go path inbound next
 
 defaultMain :: IO ()
 defaultMain = withSocketsDo $ do
@@ -77,6 +85,7 @@ defaultMain = withSocketsDo $ do
   withBus severity $ \bus -> do
     token <- getEnv "HA_TOKEN"
     host <- getEnv "HA_HOST"
+    rootPath <- fromMaybe "/tmp/" <$> lookupEnv "HA_LIB_DIR"
     store <- System.Metrics.newStore
     System.Metrics.registerGcMetrics store
     rrdPath <- fromMaybe "hass-controller.rrd" <$> lookupEnv "HA_RRD_PATH"
@@ -86,7 +95,7 @@ defaultMain = withSocketsDo $ do
         workers =
           [ ("reader", readerAction host 8123 token ents bus)
           , ("writer", writerAction bus)
-          ] ++ [ (name, runController bus c) | c@(Controller name _ True) <- controllers ]
+          ] ++ [ (name, runController rootPath 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

test/AFRPLawsSpec.hs

@@ -0,0 +1,256 @@
+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

@@ -9,9 +9,10 @@ import Data.Foldable (for_)
 import AFRP
 import Data.Functor.Identity (Identity (..))
 import Data.List (sort)
+import Data.Serialize (get, put, runGet, runPut)
 import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Time (NominalDiffTime, UTCTime (..), utc)
+import Data.Time (Day (..), NominalDiffTime, LocalTime(..), TimeOfDay(..), UTCTime (..), picosecondsToDiffTime, utc)
 import Data.UUID (nil)
 import Hedgehog
 import qualified Hedgehog.Gen as Gen
@@ -25,17 +26,24 @@ fakeRequest = Request (sec 0) utc 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 _ [] = []
-runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
-  Pair b m' -> b : runPure m' as
+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
 
 -- | Run a Mealy with a per-step wall clock (seconds since the day-0 epoch).
 runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b]
-runTimed _ [] = []
-runTimed m ((s, a) : as) =
-  case runIdentity (AFRP.runMealy m id (Request (sec s) utc nil) a) of
-    Pair b m' -> b : runTimed m' as
+runTimed m = go (runMealy m id)
+  where
+    go _ [] = []
+    go w ((s, a) : 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) }
@@ -54,12 +62,11 @@ 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 s0 as = go m s0 as
+runStEff m = go (runMealy m id)
   where
     go _ s [] = ([], s)
-    go m' s (a : rest) =
-      case unSt (AFRP.runMealy m' id fakeRequest a) s of
-        (Pair b m'', s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
+    go w s (a : rest) = case unSt (stepAuto w fakeRequest a) s of
+      ((b, w'), s') -> let (bs, s'') = go w' s' rest in (b : bs, s'')
 
 spec :: Spec
 spec = describe "AFRP" $ do
@@ -72,7 +79,6 @@ spec = describe "AFRP" $ do
   lMergeSpec
   changesSpec
   edgeSpec
-  dropFirstSpec
   filterASpec
   slidingSpec
   mapAccumSpec
@@ -81,9 +87,8 @@ spec = describe "AFRP" $ do
   delayEventSpec
   debounceSpec
   rollupSpec
-  fixedSpec
+  serializeSpec
   effSpec
-  switchSpec
   mapAccumRequestSpec
   preMapAccumRequestSpec
   whenASpec
@@ -211,19 +216,6 @@ edgeSpec = describe "edge" $ do
               else o' === Tick
         _ -> failure
 
-dropFirstSpec :: Spec
-dropFirstSpec = describe "dropFirst" $ do
-  it "drops the first Event, passes the rest" $
-    runPure dropFirst [Tick, Event 1, Event 2, Event 3]
-      `shouldBe` [Tick, Tick, Event 2, Event 3 :: Event Int]
-
-  it "passes Tick through untouched before first Event" $
-    runPure dropFirst [Tick, Tick, Tick :: Event Int]
-      `shouldBe` [Tick, Tick, Tick :: Event Int]
-
-  it "drops only the first Event, Ticks before it are inert" $
-    runPure dropFirst [Tick, Tick, Event 'a', Tick, Event 'b']
-      `shouldBe` [Tick, Tick, Tick, Tick, Event 'b' :: Event Char]
 
 filterASpec :: Spec
 filterASpec = describe "filterA" $ do
@@ -407,36 +399,6 @@ 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
@@ -444,6 +406,34 @@ 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" $
@@ -456,41 +446,17 @@ 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 :: Int) 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 :: Int]
-
-  it "prefix outputs come from the first arrow, suffix from the continuation" $
-    hedgehog $ do
-      threshold <- forAll $ Gen.int (Range.linear (-20) 20)
-      xs <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear (-20) 20))
-      let firstArr = arr (\x -> (x, if x >= threshold then Event () else Tick))
-          out = runPure (switch firstArr (const (arr (const 99)))) xs
-          (pre, _post) = break (>= threshold) xs
-      take (length pre) out === pre
-      drop (length pre) out === replicate (length xs - length pre) 99
-
 mapAccumRequestSpec :: Spec
 mapAccumRequestSpec = describe "mapAccumRequest" $ do
   it "accumulates request times, post-state extraction" $
-    runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
+    runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
              [(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 ++ [requestTime req]) [] id)
+      let out = runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take (i + 1) secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -498,14 +464,14 @@ mapAccumRequestSpec = describe "mapAccumRequest" $ do
 preMapAccumRequestSpec :: Spec
 preMapAccumRequestSpec = describe "preMapAccumRequest" $ do
   it "accumulates request times, pre-state extraction" $
-    runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
+    runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
              [(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 ++ [requestTime req]) [] id)
+      let out = runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take i secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -569,11 +535,11 @@ sampleSpec = describe "sample" $ do
 
 -- | A stateless arrow carrying a fixed entity set, for testing propagation.
 subscribed :: S.Set T.Text -> Mealy Identity Int Int
-subscribed ents = Mealy ents $ \_ _ a -> pure (Pair a (subscribed ents))
+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 $ \_ _ a -> pure (Pair (a +) (subscribedF ents))
+subscribedF ents = Mealy ents $ \_ -> Fun $ \_ a -> (a +)
 
 entitiesSpec :: Spec
 entitiesSpec = describe "entities" $ do
@@ -590,7 +556,7 @@ entitiesSpec = describe "entities" $ do
     entities (hold 'a') `shouldBe` S.empty
     entities (changes @Int) `shouldBe` S.empty
     entities edge `shouldBe` S.empty
-    entities (sliding (3 :: Int)) `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"))

test/Main.hs

@@ -1,6 +1,7 @@
 module Main (main) where
 
 import Test.Hspec (hspec)
+import qualified AFRPLawsSpec
 import qualified AFRPSpec
 import qualified BackoffProp
 import qualified BedroomSpec
@@ -12,6 +13,7 @@ import qualified SupervisorSpec
 
 main :: IO ()
 main = hspec $ do
+  AFRPLawsSpec.spec
   AFRPSpec.spec
   BedroomSpec.spec
   BusSpec.spec

test/Support.hs

@@ -16,7 +16,7 @@ import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
 import Data.Time (UTCTime (..), utc)
 import Data.UUID (nil)
-import AFRP (Mealy (..), Pair (..), Request (..))
+import AFRP (Mealy (..), Request (..), stepAuto)
 import HomeAssistant.Controller (HASSEff (..), Service)
 
 fakeRequest :: Request
@@ -49,10 +49,12 @@ interp (Trace _ _) = pure ()
 
 -- | Run a HASS arrow over a list of inputs, collecting per-step emitted services.
 runHASS :: Mealy HASSEff a b -> [a] -> [(b, [Service])]
-runHASS _ [] = []
-runHASS m (a : as) =
-  case runAcc (runMealy m interp fakeRequest a) [] of
-    (Pair b m', svcs) -> (b, svcs) : runHASS m' as
+runHASS m = go (runMealy m interp)
+  where
+    go _ [] = []
+    go w (a : as) =
+      case runAcc (stepAuto w fakeRequest a) [] of
+        ((b, w'), svcs) -> (b, svcs) : go w' as
 
 services :: [(b, [Service])] -> [[Service]]
 services = map snd