Add PulseCalculation

This ADT describes all possible functions of a pulse node.

reactive-banana/src/Reactive/Banana/Prim/Combinators.hs

@@ -15,7 +15,7 @@ import Reactive.Banana.Prim.Plumbing
     , readPulseP, readLatchP, readLatchFutureP, liftBuildP,
     )
 import qualified Reactive.Banana.Prim.Plumbing (pureL)
-import           Reactive.Banana.Prim.Types    (Latch, Future, Pulse, Build)
+import           Reactive.Banana.Prim.Types    (Latch, Future, Pulse, Build, PulseCalculation(..))
 
 import Debug.Trace
 -- debug s = trace s
@@ -26,7 +26,7 @@ debug s = id
 ------------------------------------------------------------------------------}
 mapP :: (a -> b) -> Pulse a -> Build (Pulse b)
 mapP f p1 = do
-    p2 <- newPulse "mapP" $ {-# SCC mapP #-} fmap f <$> readPulseP p1
+    p2 <- newPulse "mapP" (PulseMap f p1)
     p2 `dependOn` p1
     return p2
 
@@ -36,45 +36,33 @@ mapP f p1 = do
 -- of a 'Latch' to a pulse.
 tagFuture :: Latch a -> Pulse b -> Build (Pulse (Future a))
 tagFuture x p1 = do
-    p2 <- newPulse "tagFuture" $
-        fmap . const <$> readLatchFutureP x <*> readPulseP p1
+    p2 <- newPulse "tagFuture" $ PulseFuture x p1
     p2 `dependOn` p1
     return p2
 
 filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
 filterJustP p1 = do
-    p2 <- newPulse "filterJustP" $ {-# SCC filterJustP #-} join <$> readPulseP p1
+    p2 <- newPulse "filterJustP" $ PulseJoin p1
     p2 `dependOn` p1
     return p2
 
 unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b)
 unsafeMapIOP f p1 = do
-        p2 <- newPulse "unsafeMapIOP" $
-            {-# SCC unsafeMapIOP #-} eval =<< readPulseP p1
+        p2 <- newPulse "unsafeMapIOP" $ PulseMapIO f p1
         p2 `dependOn` p1
         return p2
-    where
-    eval (Just x) = Just <$> liftIO (f x)
-    eval Nothing  = return Nothing
 
 unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)
 unionWithP f px py = do
-        p <- newPulse "unionWithP" $
-            {-# SCC unionWithP #-} eval <$> readPulseP px <*> readPulseP py
+        p <- newPulse "unionWithP" $ PulseUnionWith f px py
         p `dependOn` px
         p `dependOn` py
         return p
-    where
-    eval (Just x) (Just y) = Just (f x y)
-    eval (Just x) Nothing  = Just x
-    eval Nothing  (Just y) = Just y
-    eval Nothing  Nothing  = Nothing
 
 -- See note [LatchRecursion]
 applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)
 applyP f x = do
-    p <- newPulse "applyP" $
-        {-# SCC applyP #-} fmap <$> readLatchP f <*> readPulseP x
+    p <- newPulse "applyP" $ PulseApply f x
     p `dependOn` x
     return p
 
@@ -113,30 +101,16 @@ switchL l pl = mdo
 
 executeP :: Pulse (b -> Build a) -> b -> Build (Pulse a)
 executeP p1 b = do
-        p2 <- newPulse "executeP" $ {-# SCC executeP #-} eval =<< readPulseP p1
+        p2 <- newPulse "executeP" $ PulseExecute p1 b
         p2 `dependOn` p1
         return p2
-    where
-    eval (Just x) = Just <$> liftBuildP (x b)
-    eval Nothing  = return Nothing
 
 switchP :: Pulse (Pulse a) -> Build (Pulse a)
 switchP pp = mdo
     never <- neverP
     lp    <- stepperL never pp
-    let
-        -- switch to a new parent
-        switch = do
-            mnew <- readPulseP pp
-            case mnew of
-                Nothing  -> return ()
-                Just new -> liftBuildP $ p2 `changeParent` new
-            return Nothing
-        -- fetch value from old parent
-        eval = readPulseP =<< readLatchP lp
-
-    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())
+    p1 <- newPulse "switchP_in" (PulseSwitch pp p2)
     p1 `dependOn` pp
-    p2 <- newPulse "switchP_out" eval
+    p2 <- newPulse "switchP_out" (PulseReadLatch lp)
     p2 `keepAlive` p1
     return p2

reactive-banana/src/Reactive/Banana/Prim/Compile.hs

@@ -28,7 +28,7 @@ compile m state1 = do
     theAlwaysP <- case nAlwaysP state1 of
         Just x   -> return x
         Nothing  -> do
-            (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (return $ Just ())
+            (x,_,_) <- runBuildIO undefined $ newPulse "alwaysP" (PulseAlways ())
             return x
 
     (a, topology, os) <- runBuildIO (nTime state1, theAlwaysP) m

reactive-banana/src/Reactive/Banana/Prim/Evaluation.hs

@@ -1,7 +1,7 @@
 {-----------------------------------------------------------------------------
     reactive-banana
 ------------------------------------------------------------------------------}
-{-# LANGUAGE RecordWildCards, BangPatterns #-}
+{-# LANGUAGE RecordWildCards, BangPatterns, GADTs #-}
 module Reactive.Banana.Prim.Evaluation (
     step
     ) where
@@ -78,7 +78,7 @@ evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty
 evaluateNode :: SomeNode -> EvalP [SomeNode]
 evaluateNode (P p) = {-# SCC evaluateNodeP #-} do
     Pulse{..} <- readRef p
-    ma        <- _evalP
+    ma        <- runPulseCalculation _evalP
     writePulseP _keyP ma
     case ma of
         Nothing -> return []
@@ -118,3 +118,32 @@ insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go
     go (node:xs)      q = go xs (Q.insert ground node q)
             -- O and L nodes have only one parent, so
             -- we can insert them at an arbitrary level
+
+runPulseCalculation :: PulseCalculation a -> EvalP (Maybe a)
+runPulseCalculation (PulseMap f p1) = fmap f <$> readPulseP p1
+runPulseCalculation PulseNever = return Nothing
+runPulseCalculation (PulseJoin p1) = join <$> readPulseP p1
+runPulseCalculation (PulseMapIO f p1) = eval =<< readPulseP p1
+  where eval (Just x) = Just <$> liftIO (f x)
+        eval Nothing = return Nothing
+runPulseCalculation (PulseUnionWith f px py) =
+  eval <$> readPulseP px <*> readPulseP py
+  where eval (Just x) (Just y) = Just (f x y)
+        eval (Just x) Nothing = Just x
+        eval Nothing (Just y) = Just y
+        eval Nothing Nothing = Nothing
+runPulseCalculation (PulseApply f x) = fmap <$> readLatchP f <*> readPulseP x
+runPulseCalculation (PulseExecute p1 b) = eval =<< readPulseP p1
+  where eval (Just x) = Just <$> liftBuildP (x b)
+        eval Nothing = return Nothing
+runPulseCalculation (PulseSwitch pp p2) =
+  do mnew <- readPulseP pp
+     case mnew of
+       Nothing -> return ()
+       Just new -> liftBuildP $ p2 `changeParent` new
+     return Nothing
+runPulseCalculation (PulseReadLatch lp) = readPulseP =<< readLatchP lp
+runPulseCalculation (PulseReadPulse p) = readPulseP p
+runPulseCalculation (PulseAlways x) = return $ Just x
+runPulseCalculation (PulseFuture x p1) =
+  fmap . const <$> readLatchFutureP x <*> readPulseP p1

reactive-banana/src/Reactive/Banana/Prim/IO.hs

@@ -31,7 +31,7 @@ newInput = mdo
     pulse  <- liftIO $ newRef $ Pulse
         { _keyP      = key
         , _seenP     = agesAgo
-        , _evalP     = readPulseP pulse    -- get its own value
+        , _evalP     = PulseReadPulse pulse    -- get its own value
         , _childrenP = []
         , _parentsP  = []
         , _levelP    = ground

reactive-banana/src/Reactive/Banana/Prim/Plumbing.hs

@@ -25,8 +25,10 @@ import           Reactive.Banana.Prim.Util
 {-----------------------------------------------------------------------------
     Build primitive pulses and latches
 ------------------------------------------------------------------------------}
+
+
 -- | Make 'Pulse' from evaluation function
-newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)
+newPulse :: String -> PulseCalculation a -> Build (Pulse a)
 newPulse name eval = liftIO $ do
     key <- Lazy.newKey
     newRef $ Pulse
@@ -56,7 +58,7 @@ neverP = liftIO $ do
     newRef $ Pulse
         { _keyP      = key
         , _seenP     = agesAgo
-        , _evalP     = return Nothing
+        , _evalP     = PulseNever
         , _childrenP = []
         , _parentsP  = []
         , _levelP    = ground

reactive-banana/src/Reactive/Banana/Prim/Types.hs

@@ -3,6 +3,7 @@
 ------------------------------------------------------------------------------}
 {-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 module Reactive.Banana.Prim.Types where
 
 import           Control.Monad.Trans.RWSIO
@@ -86,13 +87,27 @@ type Pulse  a = Ref (Pulse' a)
 data Pulse' a = Pulse
     { _keyP      :: Lazy.Key (Maybe a) -- Key to retrieve pulse from cache.
     , _seenP     :: !Time              -- See note [Timestamp].
-    , _evalP     :: EvalP (Maybe a)    -- Calculate current value.
+    , _evalP     :: PulseCalculation a -- Calculate current value.
     , _childrenP :: [Weak SomeNode]    -- Weak references to child nodes.
     , _parentsP  :: [Weak SomeNode]    -- Weak reference to parent nodes.
     , _levelP    :: !Level             -- Priority in evaluation order.
     , _nameP     :: String             -- Name for debugging.
     }
 
+data PulseCalculation x where
+  PulseMap :: (a -> x) -> Pulse a -> PulseCalculation x
+  PulseFuture :: Latch x -> Pulse a -> PulseCalculation (Future x)
+  PulseNever :: PulseCalculation x
+  PulseJoin :: Pulse (Maybe x) -> PulseCalculation x
+  PulseMapIO :: (a -> IO x) -> Pulse a -> PulseCalculation x
+  PulseUnionWith :: (x -> x -> x) -> Pulse x -> Pulse x -> PulseCalculation x
+  PulseApply :: Latch (a -> x) -> Pulse a -> PulseCalculation x
+  PulseExecute :: Pulse (a -> Build x) -> a -> PulseCalculation x
+  PulseSwitch :: Pulse (Pulse x) -> Pulse x -> PulseCalculation x
+  PulseReadLatch :: Latch (Pulse x) -> PulseCalculation x
+  PulseReadPulse :: Pulse x -> PulseCalculation x
+  PulseAlways :: x -> PulseCalculation x
+
 instance Show (Pulse a) where
     show p = _nameP (unsafePerformIO $ readRef p) ++ " " ++ show (hashWithSalt 0 p)