{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
module Reactive.Banana.Prim.Low.Dependencies (
    -- | Utilities for operating on node 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

{-----------------------------------------------------------------------------
    Accumulate dependency information for nodes
------------------------------------------------------------------------------}
-- | Add a new child node to a parent node.
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)

-- | Assign a new parent to a child node.
-- INVARIANT: The child may have only one parent node.
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)])

-- | Execute the information in the dependency builder
-- to change network topology.
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

{-----------------------------------------------------------------------------
    Set dependencies of individual notes
------------------------------------------------------------------------------}
-- | Add a child node to the children of a parent 'Pulse'.
connectChild
    :: Pulse a  -- ^ Parent node whose '_childP' field is to be updated.
    -> SomeNode -- ^ Child node to add.
    -> IO (Weak SomeNode)
                -- ^ Weak reference with the child as key and the parent as value.
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)        -- child keeps parent alive

-- | Add a child node to a parent node and update evaluation order.
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"

-- | Remove a node from its parents and all parents from this node.
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
    -- delete this child (and dead children) from all parent nodes
    [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  -- get parent node
        Weak SomeNode -> IO ()
forall v. Weak v -> IO ()
finalize Weak SomeNode
w                      -- severe connection in garbage collector
        let isGoodChild :: Weak SomeNode -> IO Bool
isGoodChild Weak SomeNode
w = Weak SomeNode -> IO (Maybe SomeNode)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak SomeNode
w IO (Maybe SomeNode) -> (Maybe SomeNode -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe SomeNode
x ->
              case Maybe SomeNode
x of
                Just SomeNode
y | SomeNode
y SomeNode -> SomeNode -> Bool
forall a. Eq a => a -> a -> Bool
/= Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
child -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                Maybe SomeNode
_                     -> do
                  -- The old parent refers to this child. In this case we'll remove
                  -- this child from the parent, but we also need to finalize the
                  -- weak pointer that points to the child. We need to do this because
                  -- otherwise the weak pointer will stay alive (even though it's
                  -- unreachable) for as long as the child is alive
                  -- https://github.com/HeinrichApfelmus/reactive-banana/pull/256
                  Weak SomeNode -> IO ()
forall v. Weak v -> IO ()
finalize Weak SomeNode
w
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        [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
    -- replace parents by empty list
    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 = []}

-- | Set the parent of a pulse to a different pulse.
doChangeParent :: Pulse a -> Pulse b -> IO ()
doChangeParent :: Pulse a -> Pulse b -> IO ()
doChangeParent Pulse a
child Pulse b
parent = do
    -- remove all previous parents and connect to new parent
    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]
:)

    -- calculate level difference between parent and node
    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
    -- level parent - d = level child - 1

    -- lower all parents of the node if the parent was higher than the node
    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"

{-----------------------------------------------------------------------------
    Helper functions
------------------------------------------------------------------------------}
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 []