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) ()