Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

slightly defunctionalize Latch by giving it a PureL constructor #290

Merged
merged 1 commit into from
Nov 26, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
55 changes: 35 additions & 20 deletions reactive-banana/src/Reactive/Banana/Prim/Mid/Combinators.hs
Original file line number Diff line number Diff line change
@@ -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 )
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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.
Expand All @@ -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
32 changes: 22 additions & 10 deletions reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -204,12 +203,22 @@ liftIOLater x = RW.tell $ BuildW (mempty, mempty, x, mempty)
-- | 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

Expand Down Expand Up @@ -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

Expand Down
9 changes: 7 additions & 2 deletions reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -93,7 +93,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.
Expand All @@ -103,7 +108,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
Expand Down
Loading