{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Low.GraphGC
    ( GraphGC
    , listReachableVertices
    , getSize
    , new
    , insertEdge
    , clearPredecessors

    , Step (..)
    , walkSuccessors
    , walkSuccessors_

    , removeGarbage
    
    -- * Debugging
    , printDot
    ) where

import Control.Applicative
    ( (<|>) )
import Control.Monad
    ( unless )
import Data.IORef
    ( IORef, atomicModifyIORef', newIORef, readIORef )
import Data.Maybe
    ( fromJust )
import Data.Unique.Really
    ( Unique )
import Reactive.Banana.Prim.Low.Graph 
    ( Graph, Step )
import Reactive.Banana.Prim.Low.Ref
    ( Ref, WeakRef )

import qualified Control.Concurrent.STM as STM
import qualified Data.HashMap.Strict as Map
import qualified Reactive.Banana.Prim.Low.Graph as Graph
import qualified Reactive.Banana.Prim.Low.Ref as Ref

type Map = Map.HashMap

{-----------------------------------------------------------------------------
    GraphGC
------------------------------------------------------------------------------}
type WeakEdge v = WeakRef v

-- Graph data
data GraphD v = GraphD
    { forall v. GraphD v -> Graph Unique (WeakEdge v)
graph :: !(Graph Unique (WeakEdge v))
    , forall v. GraphD v -> Map Unique (WeakEdge v)
references :: !(Map Unique (WeakRef v))
    }

{- | A directed graph whose edges are mutable
    and whose vertices are subject to garbage collection.

    The vertices of the graph are mutable references of type 'Ref v'.
    

    Generally, the vertices of the graph are not necessarily kept reachable
    by the 'GraphGC' data structure
    — they need to be kept reachable by other parts of your program.

    That said, the edges in the graph do introduce additional reachability
    between vertices:
    Specifically, when an edge (x,y) is present in the graph,
    then the head @y@ will keep the tail @x@ reachable.
    (But the liveness of @y@ needs to come from elsewhere, e.g. another edge.)
    Use 'insertEdge' to insert an edge.

    Moreover, when a vertex is removed because it is no longer reachable,
    then all edges to and from that vertex will also be removed.
    In turn, this may cause further vertices and edges to be removed.

    Concerning garbage collection:
    Note that vertices and edges will not be removed automatically
    when the Haskell garbage collector runs —
    they will be marked as garbage by the Haskell runtime,
    but the actual removal of garbage needs
    to be done explicitly by calling 'removeGarbage'.
    This procedure makes it easier to reason about the state of the 'GraphGC'
    during a call to e.g. 'walkSuccessors'.
-}
data GraphGC v = GraphGC
    { forall v. GraphGC v -> IORef (GraphD v)
graphRef :: IORef (GraphD v)
    , forall v. GraphGC v -> TQueue Unique
deletions :: STM.TQueue Unique
    }

-- | Create a new 'GraphGC'.
new :: IO (GraphGC v)
new :: forall v. IO (GraphGC v)
new = forall v. IORef (GraphD v) -> TQueue Unique -> GraphGC v
GraphGC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall {v}. GraphD v
newGraphD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (TQueue a)
STM.newTQueueIO
  where
    newGraphD :: GraphD v
newGraphD = GraphD
        { graph :: Graph Unique (WeakEdge v)
graph = forall v e. Graph v e
Graph.empty
        , references :: Map Unique (WeakEdge v)
references = forall k v. HashMap k v
Map.empty
        }

getSize :: GraphGC v -> IO Int
getSize :: forall v. GraphGC v -> IO Int
getSize GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} = forall v e. (Eq v, Hashable v) => Graph v e -> Int
Graph.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. GraphD v -> Graph Unique (WeakEdge v)
graph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (GraphD v)
graphRef

-- | List all vertices that are reachable and have at least
-- one edge incident on them.
-- TODO: Is that really what the function does?
listReachableVertices :: GraphGC v -> IO [Ref v]
listReachableVertices :: forall v. GraphGC v -> IO [Ref v]
listReachableVertices GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} = do
    GraphD{Map Unique (WeakRef v)
references :: Map Unique (WeakRef v)
references :: forall v. GraphD v -> Map Unique (WeakEdge v)
references} <- forall a. IORef a -> IO a
readIORef IORef (GraphD v)
graphRef
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [v]
Map.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. Weak a -> IO [a]
inspect Map Unique (WeakRef v)
references
  where
    inspect :: Weak a -> IO [a]
inspect Weak a
ref = do
        Maybe a
mv <- forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak Weak a
ref
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe a
mv of
            Maybe a
Nothing -> []
            Just a
r -> [a
r]

-- | Insert an edge from the first vertex to the second vertex.
insertEdge :: (Ref v, Ref v) -> GraphGC v -> IO ()
insertEdge :: forall v. (Ref v, Ref v) -> GraphGC v -> IO ()
insertEdge (Ref v
x,Ref v
y) g :: GraphGC v
g@GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} = do
    (Bool
xKnown, Bool
yKnown) <-
        WeakEdge v -> IO (Bool, Bool)
insertTheEdge forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (WeakEdge v)
makeWeakPointerThatRepresentsEdge
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
xKnown forall a b. (a -> b) -> a -> b
$ forall v. Ref v -> IO () -> IO ()
Ref.addFinalizer Ref v
x (forall v. GraphGC v -> Unique -> IO ()
finalizeVertex GraphGC v
g Unique
ux)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
yKnown forall a b. (a -> b) -> a -> b
$ forall v. Ref v -> IO () -> IO ()
Ref.addFinalizer Ref v
y (forall v. GraphGC v -> Unique -> IO ()
finalizeVertex GraphGC v
g Unique
uy)
  where
    ux :: Unique
ux = forall a. Ref a -> Unique
Ref.getUnique Ref v
x
    uy :: Unique
uy = forall a. Ref a -> Unique
Ref.getUnique Ref v
y

    makeWeakPointerThatRepresentsEdge :: IO (WeakEdge v)
makeWeakPointerThatRepresentsEdge =
        forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
Ref.mkWeak Ref v
y Ref v
x forall a. Maybe a
Nothing

    insertTheEdge :: WeakEdge v -> IO (Bool, Bool)
insertTheEdge WeakEdge v
we = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (GraphD v)
graphRef forall a b. (a -> b) -> a -> b
$
        \GraphD{Graph Unique (WeakEdge v)
graph :: Graph Unique (WeakEdge v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph,Map Unique (WeakEdge v)
references :: Map Unique (WeakEdge v)
references :: forall v. GraphD v -> Map Unique (WeakEdge v)
references} ->
            ( GraphD
                { graph :: Graph Unique (WeakEdge v)
graph
                    = forall v e.
(Eq v, Hashable v) =>
(v, v) -> e -> Graph v e -> Graph v e
Graph.insertEdge (Unique
ux,Unique
uy) WeakEdge v
we
                    forall a b. (a -> b) -> a -> b
$ Graph Unique (WeakEdge v)
graph
                , references :: Map Unique (WeakEdge v)
references
                    = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Unique
ux (forall a. Ref a -> WeakRef a
Ref.getWeakRef Ref v
x)
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Unique
uy (forall a. Ref a -> WeakRef a
Ref.getWeakRef Ref v
y)
                    forall a b. (a -> b) -> a -> b
$ Map Unique (WeakEdge v)
references
                }
            ,   ( Unique
ux forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`Map.member` Map Unique (WeakEdge v)
references
                , Unique
uy forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`Map.member` Map Unique (WeakEdge v)
references
                ) 
            )

-- | Remove all the edges that connect the vertex to its predecessors.
clearPredecessors :: Ref v -> GraphGC v -> IO ()
clearPredecessors :: forall v. Ref v -> GraphGC v -> IO ()
clearPredecessors Ref v
x GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} = do
    GraphD v
g <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (GraphD v)
graphRef forall a b. (a -> b) -> a -> b
$ \GraphD v
g -> (forall {v}. GraphD v -> GraphD v
removeIncomingEdges GraphD v
g, GraphD v
g)
    forall {v}. GraphD v -> IO ()
finalizeIncomingEdges GraphD v
g
  where
    removeIncomingEdges :: GraphD v -> GraphD v
removeIncomingEdges g :: GraphD v
g@GraphD{Graph Unique (WeakEdge v)
graph :: Graph Unique (WeakEdge v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph} =
        GraphD v
g{ graph :: Graph Unique (WeakEdge v)
graph = forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
Graph.clearPredecessors (forall a. Ref a -> Unique
Ref.getUnique Ref v
x) Graph Unique (WeakEdge v)
graph }
    finalizeIncomingEdges :: GraphD v -> IO ()
finalizeIncomingEdges GraphD{Graph Unique (WeakEdge v)
graph :: Graph Unique (WeakEdge v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph} =
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall v. WeakRef v -> IO ()
Ref.finalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
Graph.getIncoming Graph Unique (WeakEdge v)
graph forall a b. (a -> b) -> a -> b
$ forall a. Ref a -> Unique
Ref.getUnique Ref v
x

-- | Walk through all successors. See 'Graph.walkSuccessors'.
walkSuccessors
    :: Monad m
    => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m [WeakRef v])
walkSuccessors :: forall (m :: * -> *) v.
Monad m =>
[Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m [WeakRef v])
walkSuccessors [Ref v]
roots WeakRef v -> m Step
step GraphGC{IORef (GraphD v)
TQueue Unique
deletions :: TQueue Unique
graphRef :: IORef (GraphD v)
deletions :: forall v. GraphGC v -> TQueue Unique
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
..} = do
    GraphD{Graph Unique (WeakRef v)
graph :: Graph Unique (WeakRef v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph,Map Unique (WeakRef v)
references :: Map Unique (WeakRef v)
references :: forall v. GraphD v -> Map Unique (WeakEdge v)
references} <- forall a. IORef a -> IO a
readIORef IORef (GraphD v)
graphRef
    let rootsMap :: Map Unique (WeakRef v)
rootsMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
            [ (forall a. Ref a -> Unique
Ref.getUnique Ref v
r, forall a. Ref a -> WeakRef a
Ref.getWeakRef Ref v
r) | Ref v
r <- [Ref v]
roots ]
        fromUnique :: Unique -> WeakRef v
fromUnique Unique
u = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$
            forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Unique
u Map Unique (WeakRef v)
references forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Unique
u Map Unique (WeakRef v)
rootsMap
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map Unique -> WeakRef v
fromUnique)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e (m :: * -> *).
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m [v]
Graph.walkSuccessors (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ref a -> Unique
Ref.getUnique [Ref v]
roots) (WeakRef v -> m Step
step forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> WeakRef v
fromUnique)
        forall a b. (a -> b) -> a -> b
$ Graph Unique (WeakRef v)
graph

-- | Walk through all successors. See 'Graph.walkSuccessors_'.
walkSuccessors_ ::
    Monad m => [Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ())
walkSuccessors_ :: forall (m :: * -> *) v.
Monad m =>
[Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ())
walkSuccessors_ [Ref v]
roots WeakRef v -> m Step
step GraphGC v
g = do
    m [WeakRef v]
action <- forall (m :: * -> *) v.
Monad m =>
[Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m [WeakRef v])
walkSuccessors [Ref v]
roots WeakRef v -> m Step
step GraphGC v
g
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ m [WeakRef v]
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-----------------------------------------------------------------------------
    Garbage Collection
------------------------------------------------------------------------------}
-- | Explicitly remove all vertices and edges that have been marked
-- as garbage by the Haskell garbage collector.
removeGarbage :: GraphGC v -> IO ()
removeGarbage :: forall v. GraphGC v -> IO ()
removeGarbage g :: GraphGC v
g@GraphGC{TQueue Unique
deletions :: TQueue Unique
deletions :: forall v. GraphGC v -> TQueue Unique
deletions} = do
    [Unique]
xs <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM [a]
STM.flushTQueue TQueue Unique
deletions
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall v. GraphGC v -> Unique -> IO ()
deleteVertex GraphGC v
g) [Unique]
xs

-- Delete all edges associated with a vertex from the 'GraphGC'.
--
-- TODO: Check whether using an IORef is thread-safe.
-- I think it's fine because we have a single thread that performs deletions.
deleteVertex :: GraphGC v -> Unique -> IO ()
deleteVertex :: forall v. GraphGC v -> Unique -> IO ()
deleteVertex GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} Unique
x =
    forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef (GraphD v)
graphRef forall a b. (a -> b) -> a -> b
$ \GraphD{Graph Unique (WeakEdge v)
graph :: Graph Unique (WeakEdge v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph,Map Unique (WeakEdge v)
references :: Map Unique (WeakEdge v)
references :: forall v. GraphD v -> Map Unique (WeakEdge v)
references} -> GraphD
        { graph :: Graph Unique (WeakEdge v)
graph = forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
Graph.deleteVertex Unique
x Graph Unique (WeakEdge v)
graph
        , references :: Map Unique (WeakEdge v)
references = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Unique
x Map Unique (WeakEdge v)
references
        }

-- Finalize a vertex
finalizeVertex :: GraphGC v -> Unique -> IO ()
finalizeVertex :: forall v. GraphGC v -> Unique -> IO ()
finalizeVertex GraphGC{TQueue Unique
deletions :: TQueue Unique
deletions :: forall v. GraphGC v -> TQueue Unique
deletions} =
    forall a. STM a -> IO a
STM.atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TQueue a -> a -> STM ()
STM.writeTQueue TQueue Unique
deletions

{-----------------------------------------------------------------------------
    Debugging
------------------------------------------------------------------------------}
-- | Show the underlying graph in @graphviz@ dot file format.
printDot :: (Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String
printDot :: forall v.
(Unique -> WeakRef v -> IO String) -> GraphGC v -> IO String
printDot Unique -> WeakRef v -> IO String
format GraphGC{IORef (GraphD v)
graphRef :: IORef (GraphD v)
graphRef :: forall v. GraphGC v -> IORef (GraphD v)
graphRef} = do
    GraphD{Graph Unique (WeakRef v)
graph :: Graph Unique (WeakRef v)
graph :: forall v. GraphD v -> Graph Unique (WeakEdge v)
graph,Map Unique (WeakRef v)
references :: Map Unique (WeakRef v)
references :: forall v. GraphD v -> Map Unique (WeakEdge v)
references} <- forall a. IORef a -> IO a
readIORef IORef (GraphD v)
graphRef
    HashMap Unique String
strings <- forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
Map.traverseWithKey Unique -> WeakRef v -> IO String
format Map Unique (WeakRef v)
references
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v e.
(Eq v, Hashable v) =>
(v -> String) -> Graph v e -> String
Graph.showDot (HashMap Unique String
strings forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
Map.!) Graph Unique (WeakRef v)
graph

{-----------------------------------------------------------------------------
    Helper functions
------------------------------------------------------------------------------}
-- | Atomically modify an 'IORef' without returning a result.
atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ :: forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef a
ref a -> a
f = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef a
ref forall a b. (a -> b) -> a -> b
$ \a
x -> (a -> a
f a
x, ())