Skip to content

Commit

Permalink
Merge pull request #275 from HeinrichApfelmus/buildw-type
Browse files Browse the repository at this point in the history
small refactor: make BuildW a proper data type
  • Loading branch information
HeinrichApfelmus authored Nov 26, 2023
2 parents 652ab3b + e7cb0fc commit 173cc76
Show file tree
Hide file tree
Showing 2 changed files with 26 additions and 20 deletions.
22 changes: 11 additions & 11 deletions reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs
Original file line number Diff line number Diff line change
Expand Up @@ -128,29 +128,29 @@ addOutput p = do
{ _evalO = fromMaybe (pure $ pure ()) <$> readPulseP p
}
_nodeP p `addChild` o
RW.tell $ BuildW (mempty, [o], mempty, mempty)
RW.tell emptyBuildW{ bwOutputs = [o] }

{-----------------------------------------------------------------------------
Build monad
------------------------------------------------------------------------------}
runBuildIO :: BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO i m = do
(a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m
liftIOLaters -- execute late IOs
return (a,topologyUpdates,os)
(a, buildW) <- unfold mempty m -- BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m
bwLateIO buildW -- execute late IOs
return (a, bwDependencyChanges buildW, bwOutputs buildW)
where
-- Recursively execute the buildLater calls.
unfold :: BuildW -> BuildIO a -> IO (a, BuildW)
unfold w m = do
(a, BuildW (w1, w2, w3, later)) <- RW.runReaderWriterIOT m i
let w' = w <> BuildW (w1,w2,w3,mempty)
w'' <- case later of
(a, buildW) <- RW.runReaderWriterIOT m i
let w' = w <> buildW{ bwLateBuild = Nothing }
w'' <- case bwLateBuild buildW of
Just m -> snd <$> unfold w' m
Nothing -> return w'
return (a,w'')

buildLater :: Build () -> Build ()
buildLater x = RW.tell $ BuildW (mempty, mempty, mempty, Just x)
buildLater x = RW.tell emptyBuildW{ bwLateBuild = Just x }

-- | Pretend to return a value right now,
-- but do not actually calculate it until later.
Expand Down Expand Up @@ -186,17 +186,17 @@ keepAlive child parent = liftIO $ void $

addChild :: SomeNode -> SomeNode -> Build ()
addChild parent child =
RW.tell $ BuildW ([InsertEdge parent child], mempty, mempty, mempty)
RW.tell emptyBuildW{ bwDependencyChanges = [InsertEdge parent child] }

changeParent :: Pulse child -> Pulse parent -> Build ()
changeParent pulse0 parent0 =
RW.tell $ BuildW ([ChangeParentTo pulse parent], mempty, mempty, mempty)
RW.tell emptyBuildW{ bwDependencyChanges = [ChangeParentTo pulse parent] }
where
pulse = _nodeP pulse0
parent = _nodeP parent0

liftIOLater :: IO () -> Build ()
liftIOLater x = RW.tell $ BuildW (mempty, mempty, x, mempty)
liftIOLater x = RW.tell emptyBuildW{ bwLateIO = x }

{-----------------------------------------------------------------------------
EvalL monad
Expand Down
24 changes: 15 additions & 9 deletions reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -47,21 +47,27 @@ type Build = ReaderWriterIOT BuildR BuildW IO
type BuildR = (Time, Pulse ())
-- ( current time
-- , pulse that always fires)
newtype BuildW = BuildW (DependencyChanges, [Output], IO (), Maybe (Build ()))
-- reader : current timestamp
-- writer : ( actions that change the network topology
-- , outputs to be added to the network
-- , late IO actions
-- , late build actions
-- )
data BuildW = BuildW
{ -- | actions that change the network topology
bwDependencyChanges :: DependencyChanges
, -- | outputs to be added to the network
bwOutputs :: [Output]
, -- | late IO actions
bwLateIO :: IO ()
, -- | late build actions
bwLateBuild :: Maybe (Build ())
}

instance Semigroup BuildW where
BuildW x <> BuildW y = BuildW (x <> y)
BuildW x1 x2 x3 x4 <> BuildW y1 y2 y3 y4 = BuildW (x1 <> y1) (x2 <> y2) (x3 <> y3) (x4 <> y4)

instance Monoid BuildW where
mempty = BuildW mempty
mempty = emptyBuildW
mappend = (<>)

emptyBuildW :: BuildW
emptyBuildW = BuildW mempty mempty mempty mempty

type BuildIO = Build

data DependencyChange parent child
Expand Down

0 comments on commit 173cc76

Please sign in to comment.