Merge pull request #290 from HeinrichApfelmus/pure-latch-constructor

slightly defunctionalize Latch by giving it a PureL constructor

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

@@ -1,9 +1,29 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-----------------------------------------------------------------------------
     reactive-banana
 ------------------------------------------------------------------------------}
-module Reactive.Banana.Prim.Mid.Combinators where
+module Reactive.Banana.Prim.Mid.Combinators (
+    -- * Pulse
+    mapP,
+    tagFuture,
+    filterJustP,
+    unsafeMapIOP,
+    mergeWithP,
+    applyP,
+
+    -- * Latch
+    Reactive.Banana.Prim.Mid.Plumbing.pureL,
+    mapL,
+    applyL,
+    accumL,
+
+    -- * Dynamic event switching
+    switchL,
+    executeP,
+    switchP,
+  ) where
 
 import Control.Monad
     ( join )
@@ -13,17 +33,13 @@ import Control.Monad.IO.Class
 import Reactive.Banana.Prim.Mid.Plumbing
     ( newPulse, newLatch, cachedLatch
     , dependOn, keepAlive, changeParent
-    , getValueL
-    , readPulseP, readLatchP, readLatchFutureP, liftBuildP,
+    , getValueL, getValueL'
+    , readPulseP, readLatchP, readLatchP', readLatchFutureP, liftBuildP,
     )
 import qualified Reactive.Banana.Prim.Mid.Plumbing
     ( pureL )
 import Reactive.Banana.Prim.Mid.Types
-    ( Latch, Future, Pulse, Build, EvalP )
-
-debug :: String -> a -> a
--- debug s = trace s
-debug _ = id
+    ( Latch(..), Latch', Future, Pulse, Build, EvalP )
 
 {-----------------------------------------------------------------------------
     Combinators - basic
@@ -89,30 +105,29 @@ applyP f x = do
     p `dependOn` x
     return p
 
-pureL :: a -> Latch a
-pureL = Reactive.Banana.Prim.Mid.Plumbing.pureL
-
 -- specialization of   mapL f = applyL (pureL f)
 mapL :: (a -> b) -> Latch a -> Latch b
-mapL f lx = cachedLatch ({-# SCC mapL #-} f <$> getValueL lx)
+mapL f = \case
+  PureL x -> PureL (f x)
+  ImpureL lx -> ImpureL (cachedLatch ({-# SCC mapL #-} f <$> getValueL' lx))
 
 applyL :: Latch (a -> b) -> Latch a -> Latch b
-applyL lf lx = cachedLatch
-    ({-# SCC applyL #-} getValueL lf <*> getValueL lx)
+applyL (PureL f) (PureL x) = PureL (f x)
+applyL lf lx = ImpureL (cachedLatch ({-# SCC applyL #-} getValueL lf <*> getValueL lx))
 
 accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
 accumL a p1 = do
     (updateOn, x) <- newLatch a
     p2 <- newPulse "accumL" $ do
-      a <- readLatchP x
+      a <- readLatchP' x
       f <- readPulseP p1
       return $ fmap (\g -> g a) f
     p2 `dependOn` p1
     updateOn p2
-    return (x,p2)
+    return (ImpureL x,p2)
 
 -- specialization of accumL
-stepperL :: a -> Pulse a -> Build (Latch a)
+stepperL :: a -> Pulse a -> Build (Latch' a)
 stepperL a p = do
     (updateOn, x) <- newLatch a
     updateOn p
@@ -124,7 +139,7 @@ stepperL a p = do
 switchL :: Latch a -> Pulse (Latch a) -> Build (Latch a)
 switchL l pl = mdo
     x <- stepperL l pl
-    return $ cachedLatch $ getValueL x >>= getValueL
+    return $ ImpureL $ cachedLatch $ getValueL' x >>= getValueL
 
 executeP :: forall a b. Pulse (b -> Build a) -> b -> Build (Pulse a)
 executeP p1 b = do
@@ -142,7 +157,7 @@ switchP p pp = do
     lp <- stepperL p pp
 
     -- fetch the latest Pulse value
-    pout <- newPulse "switchP_out" (readPulseP =<< readLatchP lp)
+    pout <- newPulse "switchP_out" (readPulseP =<< readLatchP' lp)
 
     let -- switch the Pulse `pout` to a new parent,
         -- keeping track of the new dependencies.
@@ -155,7 +170,7 @@ switchP p pp = do
 
     pin <- newPulse "switchP_in" switch :: Build (Pulse ())
     pin  `dependOn` pp
-    
+
     pout `dependOn` p       -- initial dependency
     pout `keepAlive` pin    -- keep switches happening
     pure pout

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE RecursiveDo #-}
@@ -61,16 +62,11 @@ neverP = liftIO $ do
     pure $ Pulse{_key,_nodeP}
 
 -- | Return a 'Latch' that has a constant value
-{-# NOINLINE pureL #-}
 pureL :: a -> Latch a
-pureL a = unsafePerformIO $ Ref.new $ Latch
-    { _seenL  = beginning
-    , _valueL = a
-    , _evalL  = return a
-    }
+pureL = PureL
 
 -- | Make new 'Latch' that can be updated by a 'Pulse'
-newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch a)
+newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch' a)
 newLatch a = do
     latch <- liftIO $ mdo
         latch <- Ref.new $ Latch
@@ -100,7 +96,7 @@ newLatch a = do
     return (updateOn, latch)
 
 -- | Make a new 'Latch' that caches a previous computation.
-cachedLatch :: EvalL a -> Latch a
+cachedLatch :: EvalL a -> Latch' a
 cachedLatch eval = unsafePerformIO $ mdo
     latch <- Ref.new $ Latch
         { _seenL  = agesAgo
@@ -177,6 +173,9 @@ alwaysP = snd <$> RW.ask
 readLatchB :: Latch a -> Build a
 readLatchB = liftIO . readLatchIO
 
+readLatchB' :: Latch' a -> Build a
+readLatchB' = liftIO . readLatchIO'
+
 dependOn :: Pulse child -> Pulse parent -> Build ()
 dependOn child parent = _nodeP parent `addChild` _nodeP child
 
@@ -204,12 +203,22 @@ liftIOLater x = RW.tell emptyBuildW{ bwLateIO = x }
 -- | Evaluate a latch (-computation) at the latest time,
 -- but discard timestamp information.
 readLatchIO :: Latch a -> IO a
-readLatchIO latch = do
+readLatchIO = \case
+    PureL x -> pure x
+    ImpureL latch -> readLatchIO' latch
+
+readLatchIO' :: Latch' a -> IO a
+readLatchIO' latch = do
     Latch{..} <- Ref.read latch
     liftIO $ fst <$> RW.runReaderWriterIOT _evalL ()
 
 getValueL :: Latch a -> EvalL a
-getValueL latch = do
+getValueL = \case
+    PureL x -> pure x
+    ImpureL latch -> getValueL' latch
+
+getValueL' :: Latch' a -> EvalL a
+getValueL' latch = do
     Latch{..} <- Ref.read latch
     _evalL
 
@@ -241,6 +250,9 @@ writePulseP key a = do
 readLatchP :: Latch a -> EvalP a
 readLatchP = liftBuildP . readLatchB
 
+readLatchP' :: Latch' a -> EvalP a
+readLatchP' = liftBuildP . readLatchB'
+
 readLatchFutureP :: Latch a -> EvalP (Future a)
 readLatchFutureP = return . readLatchIO
 

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

@@ -99,7 +99,12 @@ instance Show (Pulse a) where
 showUnique :: Unique -> String
 showUnique = show . hashWithSalt 0
 
-type Latch  a = Ref.Ref (LatchD a)
+data Latch a
+  = PureL a
+  | ImpureL !(Latch' a)
+
+type Latch' a = Ref.Ref (LatchD a)
+
 data LatchD a = Latch
     { _seenL  :: !Time               -- Timestamp for the current value. See Note [Timestamp]
     , _valueL :: a                   -- Current value.
@@ -109,7 +114,7 @@ data LatchD a = Latch
 type LatchWrite = SomeNode
 data LatchWriteD = forall a. LatchWriteD
     { _evalLW  :: EvalP a            -- Calculate value to write.
-    , _latchLW :: Weak (Latch a)     -- Destination 'Latch' to write to.
+    , _latchLW :: Weak (Latch' a)    -- Destination 'Latch' to write to.
     }
 
 type Output  = SomeNode