module Reactive.Banana.Prim.Dependencies (
Deps, dOrder, empty, allChildren, children, parents,
addChild, changeParent,
Continue(..), maybeContinue, traverseDependencies,
DepsQueue, emptyQ, insert, minView,
) where
import Control.Monad.Trans.Writer
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.Hashable
import qualified Data.IntPSQ as Q
import Reactive.Banana.Prim.Order
import qualified Reactive.Banana.Prim.Order as Order
type Map = Map.HashMap
type Set = Set.HashSet
data Deps a = Deps
{ dChildren :: Map a [a]
, dParents :: Map a [a]
, dOrder :: Order a
} deriving (Show)
allChildren :: Deps a -> [(a, [a])]
allChildren = Map.toList . dChildren
children deps x =
maybe [] id . Map.lookup x $ dChildren deps
parents deps x = maybe [] id . Map.lookup x $ dParents deps
empty :: Hashable a => Deps a
empty = Deps
{ dChildren = Map.empty
, dParents = Map.empty
, dOrder = Order.flat
}
addChild :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a
addChild parent child deps1@(Deps{..}) = deps2
where
deps2 = Deps
{ dChildren = Map.insertWith (++) parent [child] dChildren
, dParents = Map.insertWith (++) child [parent] dParents
, dOrder = ensureAbove child parent dOrder
}
when b f = if b then f else id
changeParent :: (Eq a, Hashable a) => a -> a -> Deps a -> Deps a
changeParent child parent deps1@(Deps{..}) = deps2
where
deps2 = Deps
{ dChildren = Map.insertWith (++) parent [child]
$ removeChild parentsOld dChildren
, dParents = Map.insert child [parent] dParents
, dOrder = recalculateParent child parent (parents deps2) dOrder
}
parentsOld = parents deps1 child
removeChild1 = Map.adjust (filter (/= child))
removeChild = concatenate . map removeChild1
concatenate = foldr (.) id
data Continue = Children | Done
deriving (Eq, Ord, Show, Read)
maybeContinue :: Maybe a -> Continue
maybeContinue Nothing = Done
maybeContinue (Just _) = Children
traverseDependencies :: forall a m. (Eq a, Hashable a, Monad m)
=> (a -> m Continue) -> Deps a -> [a] -> m ()
traverseDependencies f deps roots = go $ insertList roots emptyQ
where
order = dOrder deps
insertList xs q = foldr (\x -> insert (level x order) x) q xs
go q1 = case minView q1 of
Nothing -> return ()
Just (a, q2) -> do
continue <- f a
case continue of
Done -> go q2
Children -> go $ insertList (children deps a) q2
data DepsQueue a = DQ !(Q.IntPSQ Level a) !(Set a) Int
emptyQ :: DepsQueue a
emptyQ = DQ Q.empty Set.empty 0
insert :: (Eq a, Hashable a) => Level -> a -> DepsQueue a -> DepsQueue a
insert k a q@(DQ queue seen n) =
if a `Set.member` seen
then q
else DQ (Q.insert (n+1) k a queue) (Set.insert a seen) (n+1)
minView :: DepsQueue a -> Maybe (a, DepsQueue a)
minView (DQ queue seen n) = case Q.minView queue of
Nothing -> Nothing
Just (_, _, a, queue2) -> Just (a, DQ queue2 seen n)
test1 = id
. changeParent 'C' 'A'
. addChild 'C' 'D'
. addChild 'B' 'C'
. addChild 'B' 'D'
. addChild 'A' 'B'
. addChild 'a' 'B'
$ empty
test2 = id
. addChild 'g' 'h' . addChild 'e' 'g'
. addChild 'B' 'g' . addChild 'A' 'B'
. addChild 'f' 'h'
. addChild 'e' 'f' . addChild 'd' 'e' . addChild 'a' 'd'
. addChild 'c' 'f' . addChild 'b' 'c' . addChild 'a' 'b'
$ empty
test3 = changeParent 'A' 'f' $ test2
listChildren :: (Eq a, Hashable a) => Deps a -> a -> [a]
listChildren deps x = snd $ runWriter $ traverseDependencies f deps [x]
where f x = tell [x] >> return Children