Fix memory memory leak

- Tuple to strict pair
- Self-recursive loops with more knot tying <- this was the thing

src/HomeAssistant/Controller.hs

@@ -27,7 +27,7 @@ module HomeAssistant.Controller
   , Light(..)
   ) where
 
-import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
+import AFRP (Mealy (..), Pair (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
 import Control.Arrow (Arrow(..), returnA)
 import Control.Category ((>>>))
 import Data.Aeson (Value, object, (.=))
@@ -65,9 +65,11 @@ debug = proc x -> do
   returnA -< x
 
 traceEvent :: Show a => HASS (Event a) (Event a)
-traceEvent = Mealy mempty $ \nt req -> \case
-  Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
-  Tick -> pure (Tick, traceEvent)
+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)
 
 traceValue :: Show a => HASS a a
 traceValue = proc x -> do

src/HomeAssistant/Runtime.hs

@@ -13,7 +13,7 @@ module HomeAssistant.Runtime
   , runController
   ) where
 
-import AFRP (Event (..), Mealy (..), Request (..))
+import AFRP (Event (..), Mealy (..), Pair (..), Request (..))
 import Control.Concurrent.Async (async, waitAny)
 import Control.Concurrent.STM (atomically, dupTChan, readTChan)
 import Data.Aeson (Value)
@@ -35,7 +35,7 @@ import Control.Monad.Fix (MonadFix)
 import HomeAssistant.Controller.Ruuvi (ruuviController)
 import HomeAssistant.Controller.Children (schoolLightController)
 
-step :: (MonadFix m, MonadIO m) => (forall x. eff x -> m x) -> UUID -> Mealy eff a b -> a -> m (b, Mealy eff a b)
+step :: (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
   now <- liftIO getCurrentTime
   tz <- liftIO getCurrentTimeZone
@@ -65,7 +65,7 @@ runController bus (Controller name machine _enabled) = do
       msg <- atomically (readTChan inbound)
       uuid <- UUID.V4.nextRandom
       let ns = Namespace [name]
-      (_, f') <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
+      Pair _ f' <- step (runKatipContextT (busLogEnv bus) () ns . channelHassEval bus) uuid f msg
       go inbound f'
 
 defaultMain :: IO ()

src/HomeAssistant/Runtime/Connection.hs

@@ -91,7 +91,7 @@ subscribe bus conn ents =
 -- even when no state changes arrive.
 receiveLoop :: Bus -> WS.Connection -> IO Void
 receiveLoop bus conn = forever $ do
-  winner <- race (threadDelay 1000000) (WS.receiveData conn)
+  winner <- race (threadDelay 1_000_000) (WS.receiveData conn)
   case winner of
     Left () -> atomically $ writeTChan (busInbound bus) Tick
     Right msg -> case eitherDecode msg of