{-|
Stability: experimental

This module is experimental, and its API might change between point releases.
Use at your own risk.

The default relation between an entity and a component value is one to zero
or one. The entity may or may not have a value for the component, but if the
component value exists, it belongs to an entity. This module enables setting
multiple "child" component values rooted under the same "parent" entity,
providing a one to many relation: the parent entity has zero or more child
values of the component type. Concretely, these component values are of type
'Child' @c@, belong to their own separate entities, and are explicitly linked
to the parent entity.

Ad-hoc child relationships may be established without using this module by
including a parent 'Entity' in your component's type, but this is limiting in
regards to traversing the relationship. Systems concerned with the relationship
may only start from the child entities' component(s) and then fetch the parent
entity's component(s). By expressing the relationship using this module, you get
support for iteration over the parent-child relationship in whichever way is
more convenient for your systems, i.e. you can map over child entities using the
'Child' component then fetch the child entity's parent component(s) as needed,
or you can map over the parent entities' 'ChildList' component then fetch the
child entities' component(s) as needed.

Some example use cases for this module:

- Parent entity has a position defined in world space and child entities have
data relative to the parent's position e.g. hitboxes, sprite animations, etc.
- Parent entity is a leader and child entities are squad members e.g. a
necromancer can summon skeletons

For an introduction to using this module, see the [associated
example](https://github.com/jonascarpay/apecs/tree/master/examples/Children.hs).
-}

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Apecs.Experimental.Children
  ( -- * Component
    Child(..)
    -- * Pseudocomponents
  , 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

-- | The 'Child' component wraps the parent entity and the child entity's
-- underlying component value.
--
-- If you want a @Foo@ component in your game to be treated as a child
-- component, specify the component type as @Child Foo@ when declaring your
-- world:
--
-- > newtype Hitbox = Hitbox AABB deriving Show
-- > instance Component Hitbox where type Storage Hitbox = Map Hitbox
-- >
-- > -- A type alias solely for TH quoting's sake.
-- > type ChildHitbox = Child Hitbox
-- >
-- > makeWorld "World" [''ChildHitbox]
--
-- If your system is iterating over the 'Child' component but does not need the
-- parent entity, use the 'ChildValue' pseudocomponent instead for better
-- performance.
--
-- Note that if you delete a parent entity (i.e. 'Apecs.System.destroy'
-- all of the parent entity's components), consider a
-- 'Apecs.System.destroy' on the parent entity's children too. See
-- 'ChildList' for assistance on this. This is more from a memory
-- management point of view than one of safety: nothing via standard
-- usage of this library will break if a child "outlives" its
-- parent. However, both trying to directly 'Apecs.System.get' some
-- component value of a child's non-existent parent or trying to
-- directly 'Apecs.System.get' a parent's non-existent 'ChildList' will
-- result in runtime errors. Raw use of 'Apecs.System.get' is inherently
-- dangerous and its risk is not specific to the behavior provided by
-- this module.
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)

-- | 'Children' augments another store with support for one-to-many parent-child
-- relationships.
--
-- This wrapper is not exported. If the user wants a @Foo@ component to be
-- treated as a child component, they declare their component when building
-- their world as type @Child Foo@. This will cause the @Children@ store wrapper
-- to be used via the @Storage@/@Elem@ type relation.
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
      -- @insertLookupWithKey@ uses a @StrictPair@ internally for its result
      -- before converting to standard pair, so there's no need to evaluate
      -- @childToParentMap'@ here before writing it to the @IORef@.
      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
            -- If the child was previously mapped to a different parent, be sure
            -- to clean up the old mapping from parent to child.
            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
          -- If the parent entity can't be found, assume the child was
          -- previously destroyed.
          () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Just Int
parent, IntMap Int
childToParentMap') -> do
          -- @updateLookupWithKey@ uses a @StrictPair@ internally for its result
          -- before converting to standard pair, so there's no need to evaluate
          -- @childToParentMap'@ here before writing it to the @IORef@.
          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

-- | Accessor pseudocomponent that produces just the underlying component value
-- as opposed to 'Child' which also produces the parent entity.
--
-- For best performance, you should prefer 'ChildValue' over 'Child' if your
-- system is iterating over children and does not need the parent entities.
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

-- | Pseudocomponent that produces all child entities for a parent.
--
-- A useful property of this pseudocomponent is that it may be destroyed, which
-- does a cascading 'Apecs.System.destroy' on all of the parent's children:
--
-- > -- Remove all of player 1 entity's hitboxes:
-- > destroy player1 $ Proxy @(ChildList Hitbox)
--
-- The cascading 'Apecs.System.destroy' behavior is provided for convenience,
-- but note that if you assigned additional components to the child entities,
-- those components will not be destroyed. In this case, you should destroy
-- all components on the children explicitly, e.g.:
--
-- > ChildList children :: ChildList Hitbox <- get player1
-- > for_ children $ \child -> do
-- >   destroy child $ Proxy @ComponentsToDestroy
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
    ]