{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Apecs.Experimental.Children
(
Child(..)
, ChildValue(..)
, ChildList(..)
) where
import Apecs.Core
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Foldable (for_)
import Data.IORef (IORef)
import Data.IntMap.Strict (IntMap)
import Data.IntSet (IntSet)
import Data.List.NonEmpty (NonEmpty)
import Type.Reflection (TypeRep, Typeable, typeRep)
import qualified Data.IORef as IORef
import qualified Data.IntMap.Strict as M
import qualified Data.IntSet as S
import qualified Data.List.NonEmpty as NE
import qualified Data.Vector.Unboxed as U
data Child c = Child !Entity !c deriving (Child c -> Child c -> Bool
(Child c -> Child c -> Bool)
-> (Child c -> Child c -> Bool) -> Eq (Child c)
forall c. Eq c => Child c -> Child c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => Child c -> Child c -> Bool
== :: Child c -> Child c -> Bool
$c/= :: forall c. Eq c => Child c -> Child c -> Bool
/= :: Child c -> Child c -> Bool
Eq, Int -> Child c -> ShowS
[Child c] -> ShowS
Child c -> String
(Int -> Child c -> ShowS)
-> (Child c -> String) -> ([Child c] -> ShowS) -> Show (Child c)
forall c. Show c => Int -> Child c -> ShowS
forall c. Show c => [Child c] -> ShowS
forall c. Show c => Child c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> Child c -> ShowS
showsPrec :: Int -> Child c -> ShowS
$cshow :: forall c. Show c => Child c -> String
show :: Child c -> String
$cshowList :: forall c. Show c => [Child c] -> ShowS
showList :: [Child c] -> ShowS
Show)
instance Component c => Component (Child c) where
type Storage (Child c) = Children (Storage c)
data Children s = Children
{ forall s. Children s -> IORef (IntMap IntSet)
childrenParentToChildren :: !(IORef (IntMap IntSet))
, forall s. Children s -> IORef (IntMap Int)
childrenChildToParent :: !(IORef (IntMap Int))
, forall s. Children s -> s
childrenDelegate :: !s
}
type instance Elem (Children s) = Child (Elem s)
instance (MonadIO m, ExplInit m s) => ExplInit m (Children s) where
{-# INLINE explInit #-}
explInit :: m (Children s)
explInit :: m (Children s)
explInit = do
s
childrenDelegate <- m s
forall (m :: * -> *) s. ExplInit m s => m s
explInit
IO (Children s) -> m (Children s)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Children s) -> m (Children s))
-> IO (Children s) -> m (Children s)
forall a b. (a -> b) -> a -> b
$ do
IORef (IntMap IntSet)
childrenParentToChildren <- IntMap IntSet -> IO (IORef (IntMap IntSet))
forall a. a -> IO (IORef a)
IORef.newIORef IntMap IntSet
forall a. IntMap a
M.empty
IORef (IntMap Int)
childrenChildToParent <- IntMap Int -> IO (IORef (IntMap Int))
forall a. a -> IO (IORef a)
IORef.newIORef IntMap Int
forall a. IntMap a
M.empty
Children s -> IO (Children s)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Children
{ IORef (IntMap IntSet)
childrenParentToChildren :: IORef (IntMap IntSet)
childrenParentToChildren :: IORef (IntMap IntSet)
childrenParentToChildren
, IORef (IntMap Int)
childrenChildToParent :: IORef (IntMap Int)
childrenChildToParent :: IORef (IntMap Int)
childrenChildToParent
, s
childrenDelegate :: s
childrenDelegate :: s
childrenDelegate
}
instance (MonadIO m, ExplMembers m s) => ExplMembers m (Children s) where
{-# INLINE explMembers #-}
explMembers :: Children s -> m (U.Vector Int)
explMembers :: Children s -> m (Vector Int)
explMembers (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
_ s
s) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s
instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where
{-# INLINE explGet #-}
explGet :: Children s -> Int -> m (Child (Elem s))
explGet :: Children s -> Int -> m (Child (Elem s))
explGet (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
childToParent s
s) Int
child = do
IO (Maybe Int) -> m (Maybe Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
child (IntMap Int -> Maybe Int) -> IO (IntMap Int) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap Int) -> IO (IntMap Int)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap Int)
childToParent) m (Maybe Int)
-> (Maybe Int -> m (Child (Elem s))) -> m (Child (Elem s))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Int
Nothing -> String -> m (Child (Elem s))
forall a. HasCallStack => String -> a
error (String -> m (Child (Elem s))) -> String -> m (Child (Elem s))
forall a b. (a -> b) -> a -> b
$ TypeRep (Elem s) -> Int -> String
forall a. TypeRep a -> Int -> String
parentNotFound (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @(Elem s)) Int
child
Just Int
parent -> do
Elem s
component <- s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s Int
child
Child (Elem s) -> m (Child (Elem s))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Child (Elem s) -> m (Child (Elem s)))
-> Child (Elem s) -> m (Child (Elem s))
forall a b. (a -> b) -> a -> b
$ Entity -> Elem s -> Child (Elem s)
forall c. Entity -> c -> Child c
Child (Int -> Entity
Entity Int
parent) Elem s
component
{-# INLINE explExists #-}
explExists :: Children s -> Int -> m Bool
explExists :: Children s -> Int -> m Bool
explExists (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
_ s
s) = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s
instance (MonadIO m, ExplSet m s) => ExplSet m (Children s) where
{-# INLINE explSet #-}
explSet :: Children s -> Int -> Child (Elem s) -> m ()
explSet :: Children s -> Int -> Child (Elem s) -> m ()
explSet (Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
childToParent s
s) Int
child (Child (Entity Int
parent) Elem s
x) = do
s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
child Elem s
x
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
(Maybe Int
mPrevParent, IntMap Int
childToParentMap') <-
(Int -> Int -> Int -> Int)
-> Int -> Int -> IntMap Int -> (Maybe Int, IntMap Int)
forall a.
(Int -> a -> a -> a) -> Int -> a -> IntMap a -> (Maybe a, IntMap a)
M.insertLookupWithKey Int -> Int -> Int -> Int
insertChildToParent Int
child Int
parent
(IntMap Int -> (Maybe Int, IntMap Int))
-> IO (IntMap Int) -> IO (Maybe Int, IntMap Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap Int) -> IO (IntMap Int)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap Int)
childToParent
IORef (IntMap Int) -> IntMap Int -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (IntMap Int)
childToParent IntMap Int
childToParentMap'
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (IntMap IntSet)
parentToChildren
((IntMap IntSet -> IntMap IntSet) -> IO ())
-> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
M.insertWith IntSet -> IntSet -> IntSet
S.union Int
parent (Int -> IntSet
S.singleton Int
child)
(IntMap IntSet -> IntMap IntSet)
-> (IntMap IntSet -> IntMap IntSet)
-> IntMap IntSet
-> IntMap IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case Maybe Int
mPrevParent of
Just Int
prevParent | Int
prevParent Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
parent ->
(IntSet -> Maybe IntSet) -> Int -> IntMap IntSet -> IntMap IntSet
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
M.update (Int -> IntSet -> Maybe IntSet
deleteParentToChild Int
child) Int
prevParent
Maybe Int
_ -> IntMap IntSet -> IntMap IntSet
forall a. a -> a
id
where
insertChildToParent :: M.Key -> Int -> Int -> Int
insertChildToParent :: Int -> Int -> Int -> Int
insertChildToParent Int
_k Int
newParent Int
_prevParent = Int
newParent
instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Children s) where
{-# INLINE explDestroy #-}
explDestroy :: Children s -> Int -> m ()
explDestroy :: Children s -> Int -> m ()
explDestroy (Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
childToParent s
s) Int
child = do
s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
child
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
IntMap Int
childToParentMap <- IORef (IntMap Int) -> IO (IntMap Int)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap Int)
childToParent
case (Int -> Int -> Maybe Int)
-> Int -> IntMap Int -> (Maybe Int, IntMap Int)
forall a.
(Int -> a -> Maybe a) -> Int -> IntMap a -> (Maybe a, IntMap a)
M.updateLookupWithKey Int -> Int -> Maybe Int
deleteChildToParent Int
child IntMap Int
childToParentMap of
(Maybe Int
Nothing, IntMap Int
_) -> do
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just Int
parent, IntMap Int
childToParentMap') -> do
IORef (IntMap Int) -> IntMap Int -> IO ()
forall a. IORef a -> a -> IO ()
IORef.writeIORef IORef (IntMap Int)
childToParent IntMap Int
childToParentMap'
IORef (IntMap IntSet) -> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef' IORef (IntMap IntSet)
parentToChildren
((IntMap IntSet -> IntMap IntSet) -> IO ())
-> (IntMap IntSet -> IntMap IntSet) -> IO ()
forall a b. (a -> b) -> a -> b
$ (IntSet -> Maybe IntSet) -> Int -> IntMap IntSet -> IntMap IntSet
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
M.update (Int -> IntSet -> Maybe IntSet
deleteParentToChild Int
child) Int
parent
where
deleteChildToParent :: M.Key -> Int -> Maybe Int
deleteChildToParent :: Int -> Int -> Maybe Int
deleteChildToParent Int
_k Int
_v = Maybe Int
forall a. Maybe a
Nothing
newtype ChildValue c = ChildValue c deriving (ChildValue c -> ChildValue c -> Bool
(ChildValue c -> ChildValue c -> Bool)
-> (ChildValue c -> ChildValue c -> Bool) -> Eq (ChildValue c)
forall c. Eq c => ChildValue c -> ChildValue c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => ChildValue c -> ChildValue c -> Bool
== :: ChildValue c -> ChildValue c -> Bool
$c/= :: forall c. Eq c => ChildValue c -> ChildValue c -> Bool
/= :: ChildValue c -> ChildValue c -> Bool
Eq, Int -> ChildValue c -> ShowS
[ChildValue c] -> ShowS
ChildValue c -> String
(Int -> ChildValue c -> ShowS)
-> (ChildValue c -> String)
-> ([ChildValue c] -> ShowS)
-> Show (ChildValue c)
forall c. Show c => Int -> ChildValue c -> ShowS
forall c. Show c => [ChildValue c] -> ShowS
forall c. Show c => ChildValue c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> ChildValue c -> ShowS
showsPrec :: Int -> ChildValue c -> ShowS
$cshow :: forall c. Show c => ChildValue c -> String
show :: ChildValue c -> String
$cshowList :: forall c. Show c => [ChildValue c] -> ShowS
showList :: [ChildValue c] -> ShowS
Show)
instance Component c => Component (ChildValue c) where
type Storage (ChildValue c) = ChildValueStore (Storage c)
newtype ChildValueStore s = ChildValueStore (Children s)
type instance Elem (ChildValueStore s) = ChildValue (Elem s)
instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildValue c) where
{-# INLINE getStore #-}
getStore :: SystemT w m (Storage (ChildValue c))
getStore :: SystemT w m (Storage (ChildValue c))
getStore = Children (Storage c) -> ChildValueStore (Storage c)
forall s. Children s -> ChildValueStore s
ChildValueStore (Children (Storage c) -> ChildValueStore (Storage c))
-> SystemT w m (Children (Storage c))
-> SystemT w m (ChildValueStore (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage (Child c))
SystemT w m (Children (Storage c))
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
instance ExplMembers m s => ExplMembers m (ChildValueStore s) where
{-# INLINE explMembers #-}
explMembers :: ChildValueStore s -> m (U.Vector Int)
explMembers :: ChildValueStore s -> m (Vector Int)
explMembers (ChildValueStore (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
_ s
s)) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s
instance ExplGet m s => ExplGet m (ChildValueStore s) where
{-# INLINE explExists #-}
explExists :: ChildValueStore s -> Int -> m Bool
explExists :: ChildValueStore s -> Int -> m Bool
explExists (ChildValueStore (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
_ s
s)) = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s
{-# INLINE explGet #-}
explGet :: ChildValueStore s -> Int -> m (ChildValue (Elem s))
explGet :: ChildValueStore s -> Int -> m (ChildValue (Elem s))
explGet (ChildValueStore (Children IORef (IntMap IntSet)
_ IORef (IntMap Int)
_ s
s)) Int
child =
Elem s -> ChildValue (Elem s)
forall c. c -> ChildValue c
ChildValue (Elem s -> ChildValue (Elem s))
-> m (Elem s) -> m (ChildValue (Elem s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s Int
child
newtype ChildList c = ChildList (NonEmpty Entity) deriving (ChildList c -> ChildList c -> Bool
(ChildList c -> ChildList c -> Bool)
-> (ChildList c -> ChildList c -> Bool) -> Eq (ChildList c)
forall c. ChildList c -> ChildList c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. ChildList c -> ChildList c -> Bool
== :: ChildList c -> ChildList c -> Bool
$c/= :: forall c. ChildList c -> ChildList c -> Bool
/= :: ChildList c -> ChildList c -> Bool
Eq, Int -> ChildList c -> ShowS
[ChildList c] -> ShowS
ChildList c -> String
(Int -> ChildList c -> ShowS)
-> (ChildList c -> String)
-> ([ChildList c] -> ShowS)
-> Show (ChildList c)
forall c. Int -> ChildList c -> ShowS
forall c. [ChildList c] -> ShowS
forall c. ChildList c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Int -> ChildList c -> ShowS
showsPrec :: Int -> ChildList c -> ShowS
$cshow :: forall c. ChildList c -> String
show :: ChildList c -> String
$cshowList :: forall c. [ChildList c] -> ShowS
showList :: [ChildList c] -> ShowS
Show)
instance Component c => Component (ChildList c) where
type Storage (ChildList c) = ChildListStore (Storage c)
newtype ChildListStore s = ChildListStore (Children s)
type instance Elem (ChildListStore s) = ChildList (Elem s)
instance (MonadIO m, Component c, Has w m (Child c)) => Has w m (ChildList c) where
{-# INLINE getStore #-}
getStore :: SystemT w m (Storage (ChildList c))
getStore :: SystemT w m (Storage (ChildList c))
getStore = Children (Storage c) -> ChildListStore (Storage c)
forall s. Children s -> ChildListStore s
ChildListStore (Children (Storage c) -> ChildListStore (Storage c))
-> SystemT w m (Children (Storage c))
-> SystemT w m (ChildListStore (Storage c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage (Child c))
SystemT w m (Children (Storage c))
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
instance MonadIO m => ExplMembers m (ChildListStore s) where
{-# INLINE explMembers #-}
explMembers :: ChildListStore s -> m (U.Vector Int)
explMembers :: ChildListStore s -> m (Vector Int)
explMembers (ChildListStore (Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
_ s
_)) = do
IO (Vector Int) -> m (Vector Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector Int) -> m (Vector Int))
-> IO (Vector Int) -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
U.fromList ([Int] -> Vector Int)
-> (IntMap IntSet -> [Int]) -> IntMap IntSet -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap IntSet -> [Int]
forall a. IntMap a -> [Int]
M.keys (IntMap IntSet -> Vector Int)
-> IO (IntMap IntSet) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap IntSet) -> IO (IntMap IntSet)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap IntSet)
parentToChildren
instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where
{-# INLINE explExists #-}
explExists :: ChildListStore s -> Int -> m Bool
explExists :: ChildListStore s -> Int -> m Bool
explExists (ChildListStore (Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
_ s
_)) Int
parent = do
IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap IntSet -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
parent (IntMap IntSet -> Bool) -> IO (IntMap IntSet) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap IntSet) -> IO (IntMap IntSet)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap IntSet)
parentToChildren
{-# INLINE explGet #-}
explGet :: ChildListStore s -> Int -> m (ChildList (Elem s))
explGet :: ChildListStore s -> Int -> m (ChildList (Elem s))
explGet (ChildListStore (Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
_ s
_)) Int
parent = do
IO (Maybe (NonEmpty Entity)) -> m (Maybe (NonEmpty Entity))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe IntSet -> Maybe (NonEmpty Entity)
toNE (Maybe IntSet -> Maybe (NonEmpty Entity))
-> (IntMap IntSet -> Maybe IntSet)
-> IntMap IntSet
-> Maybe (NonEmpty Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
parent (IntMap IntSet -> Maybe (NonEmpty Entity))
-> IO (IntMap IntSet) -> IO (Maybe (NonEmpty Entity))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap IntSet) -> IO (IntMap IntSet)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap IntSet)
parentToChildren) m (Maybe (NonEmpty Entity))
-> (Maybe (NonEmpty Entity) -> m (ChildList (Elem s)))
-> m (ChildList (Elem s))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (NonEmpty Entity)
Nothing -> String -> m (ChildList (Elem s))
forall a. HasCallStack => String -> a
error (String -> m (ChildList (Elem s)))
-> String -> m (ChildList (Elem s))
forall a b. (a -> b) -> a -> b
$ TypeRep (Elem s) -> Int -> String
forall a. TypeRep a -> Int -> String
parentNotFound (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @(Elem s)) Int
parent
Just NonEmpty Entity
children -> ChildList (Elem s) -> m (ChildList (Elem s))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChildList (Elem s) -> m (ChildList (Elem s)))
-> ChildList (Elem s) -> m (ChildList (Elem s))
forall a b. (a -> b) -> a -> b
$ NonEmpty Entity -> ChildList (Elem s)
forall c. NonEmpty Entity -> ChildList c
ChildList NonEmpty Entity
children
where
toNE :: Maybe IntSet -> Maybe (NonEmpty Entity)
toNE :: Maybe IntSet -> Maybe (NonEmpty Entity)
toNE Maybe IntSet
mChildEnts
| Just IntSet
childEnts <- Maybe IntSet
mChildEnts = [Entity] -> Maybe (NonEmpty Entity)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (Int -> Entity
Entity (Int -> Entity) -> [Int] -> [Entity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntSet -> [Int]
S.elems IntSet
childEnts)
| Bool
otherwise = Maybe (NonEmpty Entity)
forall a. Maybe a
Nothing
instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (ChildListStore s) where
{-# INLINE explDestroy #-}
explDestroy :: ChildListStore s -> Int -> m ()
explDestroy :: ChildListStore s -> Int -> m ()
explDestroy (ChildListStore children :: Children s
children@(Children IORef (IntMap IntSet)
parentToChildren IORef (IntMap Int)
_ s
_)) Int
parent = do
IO (Maybe IntSet) -> m (Maybe IntSet)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
parent (IntMap IntSet -> Maybe IntSet)
-> IO (IntMap IntSet) -> IO (Maybe IntSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap IntSet) -> IO (IntMap IntSet)
forall a. IORef a -> IO a
IORef.readIORef IORef (IntMap IntSet)
parentToChildren) m (Maybe IntSet) -> (Maybe IntSet -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe IntSet
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just IntSet
childSet -> do
[Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (IntSet -> [Int]
S.elems IntSet
childSet) ((Int -> m ()) -> m ()) -> (Int -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
child -> do
Children s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy Children s
children Int
child
deleteParentToChild :: Int -> IntSet -> Maybe IntSet
deleteParentToChild :: Int -> IntSet -> Maybe IntSet
deleteParentToChild Int
child IntSet
v
| IntSet
v' <- Int -> IntSet -> IntSet
S.delete Int
child IntSet
v, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntSet -> Bool
S.null IntSet
v' = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
v'
| Bool
otherwise = Maybe IntSet
forall a. Maybe a
Nothing
parentNotFound :: TypeRep a -> Int -> String
parentNotFound :: forall a. TypeRep a -> Int -> String
parentNotFound TypeRep a
tyRep Int
ety =
[String] -> String
unwords
[ String
"Reading non-existent parent entity for child component of type"
, TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
tyRep
, String
"for child entity"
, Int -> String
forall a. Show a => a -> String
show Int
ety
]