Fix memory memory leak

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

src/AFRP.hs

@@ -20,6 +20,7 @@ module AFRP
   , (>>|)
   , toEvent
   , lMerge
+  , Pair(..)
   , Request(..)
   , edge
   , dropFirst
@@ -48,6 +49,8 @@ import Data.UUID (UUID)
 import qualified Data.Set as S
 import qualified Data.Text as T
 
+data Pair a b = Pair !a !b
+
 data Request = Request
   { requestTime :: !UTCTime
   , requestTimeZone :: !TimeZone
@@ -59,23 +62,27 @@ data Request = Request
 -- 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 (b, Mealy eff a b)
+  , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
   }
 
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
   Mealy ast af <> Mealy bst bf = Mealy (ast <> bst) $ \nt r a -> do
-    (x, af') <- af nt r a
-    (x', bf') <- bf nt r a
-    pure (x <> x', af' <> bf')
+    Pair x af' <- af nt r a
+    Pair x' bf' <- bf nt r a
+    pure (Pair (x <> x') (af' <> bf'))
 
 
 instance Monoid b => Monoid (Mealy eff a b) where
-  mempty = Mealy mempty $ \_ _ _ -> pure (mempty, mempty)
+  mempty = m
+    where
+      m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m)
 
 eff :: (Request -> a -> eff b) -> Mealy eff a b
-eff f = Mealy mempty $ \nt req x ->
-  nt (f req x) >>= \b -> pure (b, eff f)
+eff f = m
+  where
+    m = Mealy mempty $ \nt req x ->
+      nt (f req x) >>= \b -> pure (Pair b m)
 
 -- | Override the static entity set of an arrow. Use when a combinator
 -- (e.g. 'switch') hides continuation entities from the runtime's
@@ -84,41 +91,48 @@ withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b
 withEntities es (Mealy _ f) = Mealy es f
 
 instance Category (Mealy eff) where
-  id = Mealy mempty (\_ _ x -> pure (x, id))
+  id = Mealy mempty (\_ _ x -> pure (Pair x id))
   (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt t a -> do
-    (b, g') <- g nt t a
-    (c, f') <- f nt t b
-    pure (c, f' . g')
+    Pair b g' <- g nt t a
+    Pair c f' <- f nt t b
+    pure (Pair c (f' . g'))
 
 instance Arrow (Mealy eff) where
-  arr f = Mealy mempty $ \_ _ b -> pure (f b, arr f)
+  arr f = mealy
+    where
+      mealy = Mealy mempty $ \_ _ b -> pure (Pair (f b) mealy)
   first (Mealy st f) = Mealy st $ \nt t (b,d) -> do
-    (c, f') <- f nt t b
-    pure ((c, d), first f')
+    Pair c f' <- f nt t b
+    pure (Pair (c, d) (first f'))
 
 instance ArrowChoice (Mealy eff) where
-  left m@(Mealy st f) = Mealy st $ \nt t -> \case
-    Left b -> do
-      (c, f') <- f nt t b
-      pure (Left c, left f')
-    Right d -> pure (Right d, left m)
+  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)
 
-instance ArrowLoop (Mealy eff) where
-  loop (Mealy st f) = Mealy st $ \nt t b -> do
-    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
-    pure (c, loop f')
+-- 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
-    (b, g') <- g nt t a
-    pure (f b, fmap f g')
+    Pair b g' <- g nt t a
+    pure (Pair (f b) (fmap f g'))
 
 instance Applicative (Mealy eff a) where
-  pure b = Mealy mempty $ \_ _ _ -> pure (b, pure b)
+  pure b = Mealy mempty $ \_ _ _ -> pure (Pair b (pure b))
   Mealy ast f <*> Mealy bst x = Mealy (ast <> bst) $ \nt t a -> do
-    (f', fNext) <- f nt t a
-    (x', xNext) <- x nt t a
-    pure (f' x', fNext <*> xNext)
+    b' <- x nt t a
+    let Pair x' xNext = b'
+    Pair f' fNext <- f nt t a
+    pure (Pair (f' x') (fNext <*> xNext))
 
 data Event a
   = Tick
@@ -133,8 +147,8 @@ instance Monoid (Event a) where
 
 hold :: a -> Mealy eff (Event a) a
 hold a = Mealy mempty $ \_ _ -> \case
-  Tick -> pure (a, hold a)
-  Event a' -> pure (a', hold a')
+  Tick -> pure (Pair a (hold a))
+  Event a' -> pure (Pair a' (hold a'))
 
 events :: Mealy eff (Event a) (Either () a)
 events = arr $ \case
@@ -150,9 +164,9 @@ 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
-  ((b, ev), f') <- f nt t a
+  Pair (b, ev) f' <- f nt t a
   case ev of
-          Tick -> pure (b, switch f' s)
+          Tick -> pure (Pair b (switch f' s))
           Event x -> runMealy (s x) nt t a
 
 sample :: Mealy eff (a, Event b) (Event a)
@@ -163,28 +177,28 @@ preMapAccum f x extract = go x
   where
     go b = Mealy mempty $ \_ _ a ->
       let next = f b a
-      in pure (extract b, go next)
+      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
   where
     go b = Mealy mempty $ \_ t a ->
       let next = f t b a
-      in pure (extract b, go next)
+      in pure (Pair (extract b) (go next))
 
 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 (extract next, go next)
+      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
   where
     go b = Mealy mempty $ \_ t a ->
       let next = f t b a
-      in pure (extract next, go next)
+      in pure (Pair (extract next) (go next))
 
 data DelayState x a = DelayState
   { pending :: x
@@ -265,11 +279,11 @@ edge :: Mealy eff Bool (Event ())
 edge = go False
   where
     go True = Mealy mempty $ \_ _ -> \case
-      True -> pure (Tick, go True)
-      False -> pure (Tick, go False)
+      True -> pure (Pair Tick (go True))
+      False -> pure (Pair Tick (go False))
     go False = Mealy mempty $ \_ _ -> \case
-      True -> pure (Event (), go True)
-      False -> pure (Tick, go False)
+      True -> pure (Pair (Event ()) (go True))
+      False -> pure (Pair Tick (go False))
 
 
 -- | Drop the first 'Event' and pass through everything after. Useful for
@@ -280,8 +294,8 @@ dropFirst = go False
   where
     go seen = Mealy mempty $ \_ _ input ->
       case input of
-        Event _ | not seen -> pure (Tick, go True)
-        _ -> pure (input, go seen)
+        Event _ | not seen -> pure (Pair Tick (go True))
+        _ -> pure (Pair input (go seen))
 
 
 duration :: forall eff a. Mealy eff a NominalDiffTime
@@ -340,7 +354,7 @@ fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
 
 currentTime :: Mealy eff a LocalTime
 currentTime = Mealy mempty $ \_ Request{requestTime, requestTimeZone} _ ->
-  pure (utcToLocalTime requestTimeZone requestTime, currentTime)
+  pure (Pair (utcToLocalTime requestTimeZone requestTime) currentTime)
 
 
 onEvent :: Mealy eff a () -> Mealy eff (Event a) ()

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