diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Combinators.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Combinators.hs index a890778..c7eb5bb 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Combinators.hs +++ b/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 diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs index 36e56c4..bd9c9a9 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs +++ b/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 diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs index 621fe48..dda0386 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs +++ b/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