From ba2e4bc0a594bfa1f30d1453c300ba6fcdd012b3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 24 Feb 2023 10:16:32 -0500 Subject: [PATCH 1/2] refactor: make BuildW a proper data type --- .../src/Reactive/Banana/Prim/Mid/Plumbing.hs | 22 +++++++++---------- .../src/Reactive/Banana/Prim/Mid/Types.hs | 21 ++++++++++-------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs index 8ee3c5c7..cb056cda 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs +++ b/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs @@ -129,29 +129,29 @@ addOutput p = do { _evalO = fromMaybe (pure $ pure ()) <$> readPulseP p } _nodeP p `addChild` o - RW.tell $ BuildW (mempty, [o], mempty, mempty) + RW.tell mempty { bwOutputs = [o] } {----------------------------------------------------------------------------- Build monad ------------------------------------------------------------------------------} runBuildIO :: BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output]) runBuildIO i m = do - (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m - doit liftIOLaters -- execute late IOs - return (a,topologyUpdates,os) + (a, buildW) <- unfold mempty m -- BuildW (topologyUpdates, os, liftIOLaters, _)) <- unfold mempty m + doit (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 mempty { bwLateBuild = Just x } -- | Pretend to return a value right now, -- but do not actually calculate it until later. @@ -187,17 +187,17 @@ keepAlive child parent = liftIO $ void $ addChild :: SomeNode -> SomeNode -> Build () addChild parent child = - RW.tell $ BuildW ([InsertEdge parent child], mempty, mempty, mempty) + RW.tell mempty { bwDependencyChanges = [InsertEdge parent child] } changeParent :: Pulse child -> Pulse parent -> Build () changeParent pulse0 parent0 = - RW.tell $ BuildW ([ChangeParentTo pulse parent], mempty, mempty, mempty) + RW.tell mempty { bwDependencyChanges = [ChangeParentTo pulse parent] } where pulse = _nodeP pulse0 parent = _nodeP parent0 liftIOLater :: IO () -> Build () -liftIOLater x = RW.tell $ BuildW (mempty, mempty, Action x, mempty) +liftIOLater x = RW.tell mempty { bwLateIO = Action x } {----------------------------------------------------------------------------- EvalL monad diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs index 7a3d633a..0cafeb60 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs +++ b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs @@ -47,19 +47,22 @@ type Build = ReaderWriterIOT BuildR BuildW IO type BuildR = (Time, Pulse ()) -- ( current time -- , pulse that always fires) -newtype BuildW = BuildW (DependencyChanges, [Output], Action, 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 :: Action + , -- | 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 = BuildW mempty mempty mempty mempty mappend = (<>) type BuildIO = Build From f5f8fc72efe2f070ab27195a1c6e5dfa7f22fbfb Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 25 Feb 2023 07:29:52 -0500 Subject: [PATCH 2/2] add emptyBuildW alias for mempty::BuildW and adjust record update syntax spacing --- .../src/Reactive/Banana/Prim/Mid/Plumbing.hs | 12 ++++++------ .../src/Reactive/Banana/Prim/Mid/Types.hs | 5 ++++- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs index cb056cda..f3776187 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs +++ b/reactive-banana/src/Reactive/Banana/Prim/Mid/Plumbing.hs @@ -129,7 +129,7 @@ addOutput p = do { _evalO = fromMaybe (pure $ pure ()) <$> readPulseP p } _nodeP p `addChild` o - RW.tell mempty { bwOutputs = [o] } + RW.tell emptyBuildW{ bwOutputs = [o] } {----------------------------------------------------------------------------- Build monad @@ -144,14 +144,14 @@ runBuildIO i m = do unfold :: BuildW -> BuildIO a -> IO (a, BuildW) unfold w m = do (a, buildW) <- RW.runReaderWriterIOT m i - let w' = w <> buildW { bwLateBuild = Nothing } + 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 mempty { bwLateBuild = 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. @@ -187,17 +187,17 @@ keepAlive child parent = liftIO $ void $ addChild :: SomeNode -> SomeNode -> Build () addChild parent child = - RW.tell mempty { bwDependencyChanges = [InsertEdge parent child] } + RW.tell emptyBuildW{ bwDependencyChanges = [InsertEdge parent child] } changeParent :: Pulse child -> Pulse parent -> Build () changeParent pulse0 parent0 = - RW.tell mempty { bwDependencyChanges = [ChangeParentTo pulse parent] } + RW.tell emptyBuildW{ bwDependencyChanges = [ChangeParentTo pulse parent] } where pulse = _nodeP pulse0 parent = _nodeP parent0 liftIOLater :: IO () -> Build () -liftIOLater x = RW.tell mempty { bwLateIO = Action x } +liftIOLater x = RW.tell emptyBuildW{ bwLateIO = Action x } {----------------------------------------------------------------------------- EvalL monad diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs index 0cafeb60..3bf600b8 100644 --- a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs +++ b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs @@ -62,9 +62,12 @@ instance Semigroup BuildW where 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 mempty mempty + mempty = emptyBuildW mappend = (<>) +emptyBuildW :: BuildW +emptyBuildW = BuildW mempty mempty mempty mempty + type BuildIO = Build data DependencyChange parent child