From 3ea1609c3a11154bd25d2de63e65566a2d1941e7 Mon Sep 17 00:00:00 2001
From: Alexander Vieth <alexander.vieth@mail.mcgill.ca>
Date: Thu, 31 Mar 2016 17:29:36 -0400
Subject: [PATCH] Pull-based behaviors experiemental implementation

The motivation: when doing DOM programming we sometimes wish to deal
with the dimensions of elements. It seems natural to say that there is a
`Behavior Rect` for an element's bounding client rectangle. But how to
construct such a thing?? We would need an event to give the changes, but
the DOM doesn't supply that, and polling it would probably grow
prohibitively expensive. Why not compute it on-demand?

This patch defines `fromPull :: IO a -> MomentIO (Behavior a)` to
produce pull-based behaviors. Ideally, the IO would be run at most once
per evaluation of the network. In this implementation, it's run at
least 0 times.
---
 .../src/Reactive/Banana/Frameworks.hs         |  5 +++-
 .../Reactive/Banana/Internal/Combinators.hs   | 13 +++++++++
 .../src/Reactive/Banana/Prim/Plumbing.hs      | 28 +++++++++++++++++++
 3 files changed, 45 insertions(+), 1 deletion(-)

diff --git a/reactive-banana/src/Reactive/Banana/Frameworks.hs b/reactive-banana/src/Reactive/Banana/Frameworks.hs
index 32d45a00..cb5eba6b 100644
--- a/reactive-banana/src/Reactive/Banana/Frameworks.hs
+++ b/reactive-banana/src/Reactive/Banana/Frameworks.hs
@@ -18,7 +18,7 @@ module Reactive.Banana.Frameworks (
     -- ** Core functions
     compile, MomentIO,
     module Control.Event.Handler,
-    fromAddHandler, fromChanges, fromPoll,
+    fromAddHandler, fromChanges, fromPoll, fromPull,
     reactimate, Future, reactimate',
     changes,
     -- $changes
@@ -185,6 +185,9 @@ fromAddHandler = MIO . fmap E . Prim.fromAddHandler
 fromPoll :: IO a -> MomentIO (Behavior a)
 fromPoll = MIO . fmap B . Prim.fromPoll
 
+fromPull :: IO a -> MomentIO (Behavior a)
+fromPull = MIO . fmap B . Prim.fromPull
+
 -- | Input,
 -- obtain a 'Behavior' from an 'AddHandler' that notifies changes.
 --
diff --git a/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs b/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
index 423d5385..93eaa6e0 100644
--- a/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
+++ b/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
@@ -2,6 +2,7 @@
     reactive-banana
 ------------------------------------------------------------------------------}
 {-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Reactive.Banana.Internal.Combinators where
 
 import           Control.Concurrent.MVar
@@ -16,6 +17,8 @@ import           Data.Functor.Identity
 import           Data.IORef
 import qualified Reactive.Banana.Prim        as Prim
 import           Reactive.Banana.Prim.Cached
+import           Reactive.Banana.Prim.Types (EvalP, _evalP)
+import           Reactive.Banana.Prim.Plumbing (newLatchIO, alwaysP)
 
 type Build   = Prim.Build
 type Latch a = Prim.Latch a
@@ -100,6 +103,16 @@ fromPoll poll = do
         return $ Prim.fromPure p
     stepperB a e
 
+-- | Like fromPoll, but the IO is run only when the value of the Behavior is
+--   demanded.
+--
+--   FIXME it should only run the action at most once per evaluation cycle.
+fromPull :: forall a . IO a -> Moment (Behavior a)
+fromPull pull = cacheAndSchedule $ liftBuild $ do
+    latch <- newLatchIO pull
+    pulse <- alwaysP
+    pure (latch, pulse)
+
 liftIONow :: IO a -> Moment a
 liftIONow = liftIO
 
diff --git a/reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs b/reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs
index 6dd87556..b19aae9b 100644
--- a/reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs
+++ b/reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs
@@ -96,6 +96,34 @@ newLatch a = mdo
     
     return (updateOn, latch)
 
+-- | Make a new 'Latch' which runs an IO whenever it is checked.
+--   FIXME Please review this. Ideally the IO would run at most once per
+--   cycle.
+newLatchIO :: IO a -> Build (Latch a)
+newLatchIO ioa = mdo
+    a <- liftIO ioa
+    latch <- liftIO $ newRef $ Latch
+        { _seenL  = beginning
+        , _valueL = a
+        , _evalL  = do
+            Latch {..} <- readRef latch
+            RW.tell _seenL
+            a <- liftIO ioa
+            modify' latch (\x -> x { _valueL = a })
+            pure a
+        }
+    w <- liftIO $ mkWeakRefValue latch latch
+    lw <- liftIO $ newRef $ LatchWrite
+        { _evalLW = do
+            Latch {..} <- readRef latch
+            pure _valueL
+        , _latchLW = w
+        }
+    _ <- liftIO $ mkWeakRefValue latch lw
+    always <- alwaysP
+    (P always) `addChild` (L lw)
+    pure latch
+
 -- | Make a new 'Latch' that caches a previous computation.
 cachedLatch :: EvalL a -> Latch a
 cachedLatch eval = unsafePerformIO $ mdo