{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module Reactive.Banana.Prim.Low.Dependencies (
addChild, changeParent, buildDependencies,
) where
import Control.Monad
import Data.Monoid
import System.Mem.Weak
import qualified Reactive.Banana.Prim.Low.Graph as Graph
import Reactive.Banana.Prim.Low.Types
import Reactive.Banana.Prim.Low.Util
addChild :: SomeNode -> SomeNode -> DependencyBuilder
addChild :: SomeNode -> SomeNode -> DependencyBuilder
addChild SomeNode
parent SomeNode
child = ((Graph SomeNode -> Graph SomeNode) -> Endo (Graph SomeNode)
forall a. (a -> a) -> Endo a
Endo ((Graph SomeNode -> Graph SomeNode) -> Endo (Graph SomeNode))
-> (Graph SomeNode -> Graph SomeNode) -> Endo (Graph SomeNode)
forall a b. (a -> b) -> a -> b
$ (SomeNode, SomeNode) -> Graph SomeNode -> Graph SomeNode
forall a. (Eq a, Hashable a) => (a, a) -> Graph a -> Graph a
Graph.insertEdge (SomeNode
parent,SomeNode
child), [(SomeNode, SomeNode)]
forall a. Monoid a => a
mempty)
changeParent :: Pulse a -> Pulse b -> DependencyBuilder
changeParent :: Pulse a -> Pulse b -> DependencyBuilder
changeParent Pulse a
child Pulse b
parent = (Endo (Graph SomeNode)
forall a. Monoid a => a
mempty, [(Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
child, Pulse b -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse b
parent)])
buildDependencies :: DependencyBuilder -> IO ()
buildDependencies :: DependencyBuilder -> IO ()
buildDependencies (Endo Graph SomeNode -> Graph SomeNode
f, [(SomeNode, SomeNode)]
parents) = do
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [SomeNode
x SomeNode -> SomeNode -> IO ()
`doAddChild` SomeNode
y | SomeNode
x <- Graph SomeNode -> [SomeNode]
forall a. (Eq a, Hashable a) => Graph a -> [a]
Graph.listParents Graph SomeNode
gr, SomeNode
y <- Graph SomeNode -> SomeNode -> [SomeNode]
forall a. (Eq a, Hashable a) => Graph a -> a -> [a]
Graph.getChildren Graph SomeNode
gr SomeNode
x]
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Pulse a
x Pulse a -> Pulse a -> IO ()
forall a b. Pulse a -> Pulse b -> IO ()
`doChangeParent` Pulse a
y | (P Pulse a
x, P Pulse a
y) <- [(SomeNode, SomeNode)]
parents]
where
gr :: Graph.Graph SomeNode
gr :: Graph SomeNode
gr = Graph SomeNode -> Graph SomeNode
f Graph SomeNode
forall a. Graph a
Graph.emptyGraph
connectChild
:: Pulse a
-> SomeNode
-> IO (Weak SomeNode)
connectChild :: Pulse a -> SomeNode -> IO (Weak SomeNode)
connectChild Pulse a
parent SomeNode
child = do
Weak SomeNode
w <- SomeNode -> SomeNode -> IO (Weak SomeNode)
forall v. SomeNode -> v -> IO (Weak v)
mkWeakNodeValue SomeNode
child SomeNode
child
Pulse a -> (Pulse' a -> Pulse' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Pulse a
parent ((Pulse' a -> Pulse' a) -> IO ())
-> (Pulse' a -> Pulse' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens (Pulse' a) [Weak SomeNode]
-> ([Weak SomeNode] -> [Weak SomeNode]) -> Pulse' a -> Pulse' a
forall s a. Lens s a -> (a -> a) -> s -> s
update Lens (Pulse' a) [Weak SomeNode]
forall a. Lens (Pulse' a) [Weak SomeNode]
childrenP (Weak SomeNode
wWeak SomeNode -> [Weak SomeNode] -> [Weak SomeNode]
forall a. a -> [a] -> [a]
:)
SomeNode -> SomeNode -> IO (Weak SomeNode)
forall v. SomeNode -> v -> IO (Weak v)
mkWeakNodeValue SomeNode
child (Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
parent)
doAddChild :: SomeNode -> SomeNode -> IO ()
doAddChild :: SomeNode -> SomeNode -> IO ()
doAddChild (P Pulse a
parent) (P Pulse a
child) = do
Level
level1 <- Pulse' a -> Level
forall a. Pulse' a -> Level
_levelP (Pulse' a -> Level) -> IO (Pulse' a) -> IO Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
child
Level
level2 <- Pulse' a -> Level
forall a. Pulse' a -> Level
_levelP (Pulse' a -> Level) -> IO (Pulse' a) -> IO Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
parent
let level :: Level
level = Level
level1 Level -> Level -> Level
forall a. Ord a => a -> a -> a
`max` (Level
level2 Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
1)
Weak SomeNode
w <- Pulse a
parent Pulse a -> SomeNode -> IO (Weak SomeNode)
forall a. Pulse a -> SomeNode -> IO (Weak SomeNode)
`connectChild` Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
child
Pulse a -> (Pulse' a -> Pulse' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Pulse a
child ((Pulse' a -> Pulse' a) -> IO ())
-> (Pulse' a -> Pulse' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens (Pulse' a) Level -> Level -> Pulse' a -> Pulse' a
forall s a. Lens s a -> a -> s -> s
set Lens (Pulse' a) Level
forall a. Lens (Pulse' a) Level
levelP Level
level (Pulse' a -> Pulse' a)
-> (Pulse' a -> Pulse' a) -> Pulse' a -> Pulse' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens (Pulse' a) [Weak SomeNode]
-> ([Weak SomeNode] -> [Weak SomeNode]) -> Pulse' a -> Pulse' a
forall s a. Lens s a -> (a -> a) -> s -> s
update Lens (Pulse' a) [Weak SomeNode]
forall a. Lens (Pulse' a) [Weak SomeNode]
parentsP (Weak SomeNode
wWeak SomeNode -> [Weak SomeNode] -> [Weak SomeNode]
forall a. a -> [a] -> [a]
:)
doAddChild (P Pulse a
parent) SomeNode
node = IO (Weak SomeNode) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak SomeNode) -> IO ()) -> IO (Weak SomeNode) -> IO ()
forall a b. (a -> b) -> a -> b
$ Pulse a
parent Pulse a -> SomeNode -> IO (Weak SomeNode)
forall a. Pulse a -> SomeNode -> IO (Weak SomeNode)
`connectChild` SomeNode
node
doAddChild (L LatchWrite
_) SomeNode
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"doAddChild: Cannot add children to LatchWrite"
doAddChild (O Output
_) SomeNode
_ = [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"doAddChild: Cannot add children to Output"
removeParents :: Pulse a -> IO ()
removeParents :: Pulse a -> IO ()
removeParents Pulse a
child = do
c :: Pulse' a
c@Pulse{[Weak SomeNode]
_parentsP :: forall a. Pulse' a -> [Weak SomeNode]
_parentsP :: [Weak SomeNode]
_parentsP} <- Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
child
[Weak SomeNode] -> (Weak SomeNode -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Weak SomeNode]
_parentsP ((Weak SomeNode -> IO ()) -> IO ())
-> (Weak SomeNode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Weak SomeNode
w -> do
Just (P Pulse a
parent) <- Weak SomeNode -> IO (Maybe SomeNode)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak SomeNode
w
Weak SomeNode -> IO ()
forall v. Weak v -> IO ()
finalize Weak SomeNode
w
let isGoodChild :: Weak SomeNode -> IO Bool
isGoodChild Weak SomeNode
w = Bool -> Bool
not (Bool -> Bool)
-> (Maybe SomeNode -> Bool) -> Maybe SomeNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (SomeNode -> Bool) -> Maybe SomeNode -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (SomeNode -> SomeNode -> Bool
forall a. Eq a => a -> a -> Bool
== Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
child) (Maybe SomeNode -> Bool) -> IO (Maybe SomeNode) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak SomeNode -> IO (Maybe SomeNode)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak SomeNode
w
[Weak SomeNode]
new <- (Weak SomeNode -> IO Bool) -> [Weak SomeNode] -> IO [Weak SomeNode]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Weak SomeNode -> IO Bool
isGoodChild ([Weak SomeNode] -> IO [Weak SomeNode])
-> (Pulse' a -> [Weak SomeNode]) -> Pulse' a -> IO [Weak SomeNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pulse' a -> [Weak SomeNode]
forall a. Pulse' a -> [Weak SomeNode]
_childrenP (Pulse' a -> IO [Weak SomeNode])
-> IO (Pulse' a) -> IO [Weak SomeNode]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
parent
Pulse a -> (Pulse' a -> Pulse' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Pulse a
parent ((Pulse' a -> Pulse' a) -> IO ())
-> (Pulse' a -> Pulse' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens (Pulse' a) [Weak SomeNode]
-> [Weak SomeNode] -> Pulse' a -> Pulse' a
forall s a. Lens s a -> a -> s -> s
set Lens (Pulse' a) [Weak SomeNode]
forall a. Lens (Pulse' a) [Weak SomeNode]
childrenP [Weak SomeNode]
new
Pulse a -> Pulse' a -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> a -> m ()
put Pulse a
child (Pulse' a -> IO ()) -> Pulse' a -> IO ()
forall a b. (a -> b) -> a -> b
$ Pulse' a
c{_parentsP :: [Weak SomeNode]
_parentsP = []}
doChangeParent :: Pulse a -> Pulse b -> IO ()
doChangeParent :: Pulse a -> Pulse b -> IO ()
doChangeParent Pulse a
child Pulse b
parent = do
Pulse a -> IO ()
forall a. Pulse a -> IO ()
removeParents Pulse a
child
Weak SomeNode
w <- Pulse b
parent Pulse b -> SomeNode -> IO (Weak SomeNode)
forall a. Pulse a -> SomeNode -> IO (Weak SomeNode)
`connectChild` Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
child
Pulse a -> (Pulse' a -> Pulse' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Pulse a
child ((Pulse' a -> Pulse' a) -> IO ())
-> (Pulse' a -> Pulse' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens (Pulse' a) [Weak SomeNode]
-> ([Weak SomeNode] -> [Weak SomeNode]) -> Pulse' a -> Pulse' a
forall s a. Lens s a -> (a -> a) -> s -> s
update Lens (Pulse' a) [Weak SomeNode]
forall a. Lens (Pulse' a) [Weak SomeNode]
parentsP (Weak SomeNode
wWeak SomeNode -> [Weak SomeNode] -> [Weak SomeNode]
forall a. a -> [a] -> [a]
:)
Level
levelParent <- Pulse' b -> Level
forall a. Pulse' a -> Level
_levelP (Pulse' b -> Level) -> IO (Pulse' b) -> IO Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse b -> IO (Pulse' b)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse b
parent
Level
levelChild <- Pulse' a -> Level
forall a. Pulse' a -> Level
_levelP (Pulse' a -> Level) -> IO (Pulse' a) -> IO Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
child
let d :: Level
d = Level
levelParent Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
levelChild Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
1
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Level
d Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
> Level
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[SomeNode]
parents <- SomeNode -> GraphM IO SomeNode -> IO [SomeNode]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
a -> GraphM m a -> m [a]
Graph.reversePostOrder (Pulse b -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse b
parent) GraphM IO SomeNode
getParents
[SomeNode] -> (SomeNode -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SomeNode]
parents ((SomeNode -> IO ()) -> IO ()) -> (SomeNode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
P Pulse a
node -> Pulse a -> (Pulse' a -> Pulse' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Pulse a
node ((Pulse' a -> Pulse' a) -> IO ())
-> (Pulse' a -> Pulse' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens (Pulse' a) Level -> (Level -> Level) -> Pulse' a -> Pulse' a
forall s a. Lens s a -> (a -> a) -> s -> s
update Lens (Pulse' a) Level
forall a. Lens (Pulse' a) Level
levelP (Level -> Level -> Level
forall a. Num a => a -> a -> a
subtract Level
d)
L LatchWrite
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"doChangeParent: Cannot change parent of LatchWrite"
O Output
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"doChangeParent: Cannot change parent of Output"
getParents :: SomeNode -> IO [SomeNode]
getParents :: GraphM IO SomeNode
getParents (P Pulse a
p) = [Weak SomeNode] -> IO [SomeNode]
forall v. [Weak v] -> IO [v]
deRefWeaks ([Weak SomeNode] -> IO [SomeNode])
-> (Pulse' a -> [Weak SomeNode]) -> Pulse' a -> IO [SomeNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pulse' a -> [Weak SomeNode]
forall a. Pulse' a -> [Weak SomeNode]
_parentsP (Pulse' a -> IO [SomeNode]) -> IO (Pulse' a) -> IO [SomeNode]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
p
getParents SomeNode
_ = [SomeNode] -> IO [SomeNode]
forall (m :: * -> *) a. Monad m => a -> m a
return []