{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE Strict                #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}

module Apecs.Stores
  ( Map, Cache, Unique,
    Global,
    Cachable,
    ReadOnly, setReadOnly, destroyReadOnly
    -- Register, regLookup
  ) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Bits                   (shiftL, (.&.))
import qualified Data.IntMap.Strict          as M
import           Data.IORef
import           Data.Proxy
import           Data.Typeable               (Typeable, typeRep)
import qualified Data.Vector.Mutable         as VM
import qualified Data.Vector.Unboxed         as U
import qualified Data.Vector.Unboxed.Mutable as UM
import           GHC.TypeLits

import           Apecs.Core

-- | A map based on 'Data.IntMap.Strict'. O(log(n)) for most operations.
newtype Map c = Map (IORef (M.IntMap c))

type instance Elem (Map c) = c
instance MonadIO m => ExplInit m (Map c) where
  explInit :: m (Map c)
explInit = IO (Map c) -> m (Map c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Map c) -> m (Map c)) -> IO (Map c) -> m (Map c)
forall a b. (a -> b) -> a -> b
$ IORef (IntMap c) -> Map c
forall c. IORef (IntMap c) -> Map c
Map (IORef (IntMap c) -> Map c) -> IO (IORef (IntMap c)) -> IO (Map c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap c -> IO (IORef (IntMap c))
forall a. a -> IO (IORef a)
newIORef IntMap c
forall a. Monoid a => a
mempty

instance (MonadIO m, Typeable c) => ExplGet m (Map c) where
  explExists :: Map c -> Int -> m Bool
explExists (Map IORef (IntMap c)
ref) Int
ety = IO Bool -> m Bool
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 c -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
ety (IntMap c -> Bool) -> IO (IntMap c) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref
  explGet :: Map c -> Int -> m (Elem (Map c))
explGet    (Map IORef (IntMap c)
ref) Int
ety = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ ((Maybe c -> c) -> IO (Maybe c) -> IO c)
-> IO (Maybe c) -> (Maybe c -> c) -> IO c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe c -> c) -> IO (Maybe c) -> IO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> IntMap c -> Maybe c
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
ety (IntMap c -> Maybe c) -> IO (IntMap c) -> IO (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref) ((Maybe c -> c) -> IO c) -> (Maybe c -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ \case
    Just c
c -> c
c
    Maybe c
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"Reading non-existent Map component"
      , TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe c -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe c
notFound)
      , [Char]
"for entity"
      , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ety
      ]
  {-# INLINE explExists #-}
  {-# INLINE explGet #-}

instance MonadIO m => ExplSet m (Map c) where
  {-# INLINE explSet #-}
  explSet :: Map c -> Int -> Elem (Map c) -> m ()
explSet (Map IORef (IntMap c)
ref) Int
ety Elem (Map c)
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    IORef (IntMap c) -> (IntMap c -> IntMap c) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (IntMap c)
ref (Int -> c -> IntMap c -> IntMap c
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
ety c
Elem (Map c)
x)

instance MonadIO m => ExplDestroy m (Map c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Map c -> Int -> m ()
explDestroy (Map IORef (IntMap c)
ref) Int
ety = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref IO (IntMap c) -> (IntMap c -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef (IntMap c) -> IntMap c -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap c)
ref (IntMap c -> IO ()) -> (IntMap c -> IntMap c) -> IntMap c -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap c -> IntMap c
forall a. Int -> IntMap a -> IntMap a
M.delete Int
ety

instance MonadIO m => ExplMembers m (Map c) where
  {-# INLINE explMembers #-}
  explMembers :: Map c -> m (Vector Int)
explMembers (Map IORef (IntMap c)
ref) = IO (Vector Int) -> m (Vector Int)
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 c -> [Int]) -> IntMap c -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap c -> [Int]
forall a. IntMap a -> [Int]
M.keys (IntMap c -> Vector Int) -> IO (IntMap c) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (IntMap c) -> IO (IntMap c)
forall a. IORef a -> IO a
readIORef IORef (IntMap c)
ref

-- | A Unique contains zero or one component.
--   Writing to it overwrites both the previous component and its owner.
--   Its main purpose is to be a 'Map' optimized for when only ever one component inhabits it.
newtype Unique c = Unique (IORef (Maybe (Int, c)))
type instance Elem (Unique c) = c
instance MonadIO m => ExplInit m (Unique c) where
  explInit :: m (Unique c)
explInit = IO (Unique c) -> m (Unique c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Unique c) -> m (Unique c)) -> IO (Unique c) -> m (Unique c)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> Unique c
forall c. IORef (Maybe (Int, c)) -> Unique c
Unique (IORef (Maybe (Int, c)) -> Unique c)
-> IO (IORef (Maybe (Int, c))) -> IO (Unique c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, c) -> IO (IORef (Maybe (Int, c)))
forall a. a -> IO (IORef a)
newIORef Maybe (Int, c)
forall a. Maybe a
Nothing

instance (MonadIO m, Typeable c) => ExplGet m (Unique c) where
  {-# INLINE explGet #-}
  explGet :: Unique c -> Int -> m (Elem (Unique c))
explGet (Unique IORef (Maybe (Int, c))
ref) Int
_ = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ ((Maybe (Int, c) -> c) -> IO (Maybe (Int, c)) -> IO c)
-> IO (Maybe (Int, c)) -> (Maybe (Int, c) -> c) -> IO c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> c) -> IO (Maybe (Int, c)) -> IO c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref) ((Maybe (Int, c) -> c) -> IO c) -> (Maybe (Int, c) -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ \case
    Just (Int
_, c
c)  -> c
c
    Maybe (Int, c)
notFound -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"Reading non-existent Unique component"
      , TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (Int, c) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Maybe (Int, c)
notFound)
      ]

  {-# INLINE explExists #-}
  explExists :: Unique c -> Int -> m Bool
explExists (Unique IORef (Maybe (Int, c))
ref) Int
ety = IO Bool -> m Bool
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
$ Bool -> ((Int, c) -> Bool) -> Maybe (Int, c) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst) (Maybe (Int, c) -> Bool) -> IO (Maybe (Int, c)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref

instance MonadIO m => ExplSet m (Unique c) where
  {-# INLINE explSet #-}
  explSet :: Unique c -> Int -> Elem (Unique c) -> m ()
explSet (Unique IORef (Maybe (Int, c))
ref) Int
ety Elem (Unique c)
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> Maybe (Int, c) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, c))
ref ((Int, c) -> Maybe (Int, c)
forall a. a -> Maybe a
Just (Int
ety, c
Elem (Unique c)
c))

instance MonadIO m => ExplDestroy m (Unique c) where
  {-# INLINE explDestroy #-}
  explDestroy :: Unique c -> Int -> m ()
explDestroy (Unique IORef (Maybe (Int, c))
ref) Int
ety = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref IO (Maybe (Int, c)) -> (Maybe (Int, c) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    ((Int, c) -> IO ()) -> Maybe (Int, c) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IORef (Maybe (Int, c)) -> Maybe (Int, c) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Int, c))
ref Maybe (Int, c)
forall a. Maybe a
Nothing) (Bool -> IO ()) -> ((Int, c) -> Bool) -> (Int, c) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
ety) (Int -> Bool) -> ((Int, c) -> Int) -> (Int, c) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, c) -> Int
forall a b. (a, b) -> a
fst)

instance MonadIO m => ExplMembers m (Unique c) where
  {-# INLINE explMembers #-}
  explMembers :: Unique c -> m (Vector Int)
explMembers (Unique IORef (Maybe (Int, c))
ref) = IO (Vector Int) -> m (Vector Int)
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
$ ((Maybe (Int, c) -> Vector Int)
 -> IO (Maybe (Int, c)) -> IO (Vector Int))
-> IO (Maybe (Int, c))
-> (Maybe (Int, c) -> Vector Int)
-> IO (Vector Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (Int, c) -> Vector Int)
-> IO (Maybe (Int, c)) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IORef (Maybe (Int, c)) -> IO (Maybe (Int, c))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Int, c))
ref) ((Maybe (Int, c) -> Vector Int) -> IO (Vector Int))
-> (Maybe (Int, c) -> Vector Int) -> IO (Vector Int)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Int, c)
Nothing -> Vector Int
forall a. Monoid a => a
mempty
    Just (Int
ety, c
_) -> Int -> Vector Int
forall a. Unbox a => a -> Vector a
U.singleton Int
ety

-- | A 'Global' contains exactly one component.
--   The initial value is 'mempty' from the component's 'Monoid' instance.
--   Querying a 'Global' at /any/ Entity yields this one component, effectively sharing the component between /all/ entities.
--
--   A Global component can be read with @'get' 0@ or @'get' 1@ or even @'get' undefined@.
--   The convenience entity 'global' is defined as -1, and can be used to make operations on a global more explicit, i.e. 'Time t <- get global'.
--
--   You also can read and write Globals during a 'cmap' over other components.
newtype Global c = Global (IORef c)
type instance Elem (Global c) = c
instance (Monoid c, MonadIO m) => ExplInit m (Global c) where
  {-# INLINE explInit #-}
  explInit :: m (Global c)
explInit = IO (Global c) -> m (Global c)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Global c) -> m (Global c)) -> IO (Global c) -> m (Global c)
forall a b. (a -> b) -> a -> b
$ IORef c -> Global c
forall c. IORef c -> Global c
Global (IORef c -> Global c) -> IO (IORef c) -> IO (Global c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> IO (IORef c)
forall a. a -> IO (IORef a)
newIORef c
forall a. Monoid a => a
mempty

instance MonadIO m => ExplGet m (Global c) where
  {-# INLINE explGet #-}
  explGet :: Global c -> Int -> m (Elem (Global c))
explGet (Global IORef c
ref) Int
_ = IO c -> m c
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO c -> m c) -> IO c -> m c
forall a b. (a -> b) -> a -> b
$ IORef c -> IO c
forall a. IORef a -> IO a
readIORef IORef c
ref
  {-# INLINE explExists #-}
  explExists :: Global c -> Int -> m Bool
explExists Global c
_ Int
_ = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

instance MonadIO m => ExplSet m (Global c) where
  {-# INLINE explSet #-}
  explSet :: Global c -> Int -> Elem (Global c) -> m ()
explSet (Global IORef c
ref) Int
_ Elem (Global c)
c = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef c -> c -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef c
ref c
Elem (Global c)
c

-- | Class of stores that behave like a regular map, and can therefore safely be cached.
--   This prevents stores like `Unique` and 'Global', which do /not/ behave like simple maps, from being cached.
class Cachable s
instance Cachable (Map s)
instance (KnownNat n, Cachable s) => Cachable (Cache n s)

-- | A cache around another store.
--   Caches store their members in a fixed-size vector, so read/write operations become O(1).
--   Caches can provide huge performance boosts, especially when working with large numbers of components.
--
--   The cache size is given as a type-level argument.
--
--   Note that iterating over a cache is linear in cache size, so sparsely populated caches might /decrease/ performance.
--   In general, the exact size of the cache does not matter as long as it reasonably approximates the number of components present.
--
--   The cache uses entity (-2) internally to represent missing entities.
--   If you manually manipulate Entity values, be careful that you do not use (-2)
--
--   The actual cache is not necessarily the given argument, but the next biggest power of two.
--   This is allows most operations to be expressed as bit masks, for a large potential performance boost.
data Cache (n :: Nat) s =
  Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s

cacheMiss :: t
cacheMiss :: t
cacheMiss = [Char] -> t
forall a. HasCallStack => [Char] -> a
error [Char]
"Cache miss! If you are seeing this during normal operation, please open a bug report at https://github.com/jonascarpay/apecs"

type instance Elem (Cache n s) = Elem s

instance (MonadIO m, ExplInit m s, KnownNat n, Cachable s) => ExplInit m (Cache n s) where
  {-# INLINE explInit #-}
  explInit :: m (Cache n s)
explInit = do
    let n :: Int
n = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n) :: Int
        size :: Int
size = [Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> ([Int] -> [Int]) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n) ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Int
1
        mask :: Int
mask = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    IOVector Int
tags <- IO (IOVector Int) -> m (IOVector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (IOVector Int) -> m (IOVector Int))
-> IO (IOVector Int) -> m (IOVector Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> IO (MVector (PrimState IO) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
UM.replicate Int
size (-Int
2)
    MVector RealWorld (Elem s)
cache <- IO (MVector RealWorld (Elem s)) -> m (MVector RealWorld (Elem s))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (MVector RealWorld (Elem s)) -> m (MVector RealWorld (Elem s)))
-> IO (MVector RealWorld (Elem s))
-> m (MVector RealWorld (Elem s))
forall a b. (a -> b) -> a -> b
$ Int -> Elem s -> IO (MVector (PrimState IO) (Elem s))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
VM.replicate Int
size Elem s
forall t. t
cacheMiss
    s
child <- m s
forall (m :: * -> *) s. ExplInit m s => m s
explInit
    Cache n s -> m (Cache n s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IOVector Int -> MVector RealWorld (Elem s) -> s -> Cache n s
forall (n :: Nat) s.
Int -> IOVector Int -> IOVector (Elem s) -> s -> Cache n s
Cache Int
mask IOVector Int
tags MVector RealWorld (Elem s)
cache s
child)

instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where
  {-# INLINE explGet #-}
  explGet :: Cache n s -> Int -> m (Elem (Cache n s))
explGet (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety = do
    let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
    Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags Int
index
    if Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety
       then IO (Elem s) -> m (Elem s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Elem s) -> m (Elem s)) -> IO (Elem s) -> m (Elem s)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> IO (Elem s)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index
       else s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s Int
ety

  {-# INLINE explExists #-}
  explExists :: Cache n s -> Int -> m Bool
explExists (Cache Int
mask IOVector Int
tags IOVector (Elem s)
_ s
s) Int
ety = do
    Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
    if Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s Int
ety

instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where
  {-# INLINE explSet #-}
  explSet :: Cache n s -> Int -> Elem (Cache n s) -> m ()
explSet (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety Elem (Cache n s)
x = do
    let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
    Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags Int
index
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Int
2) Bool -> Bool -> Bool
&& Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ety) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Elem s
cached <- IO (Elem s) -> m (Elem s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (Elem s) -> m (Elem s)) -> IO (Elem s) -> m (Elem s)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> IO (Elem s)
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
VM.unsafeRead IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index
      s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
tag Elem s
cached
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UM.unsafeWrite IOVector Int
MVector (PrimState IO) Int
tags  Int
index Int
ety
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (Elem s) -> Int -> Elem s -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index Elem s
Elem (Cache n s)
x

instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where
  {-# INLINE explDestroy #-}
  explDestroy :: Cache n s -> Int -> m ()
explDestroy (Cache Int
mask IOVector Int
tags IOVector (Elem s)
cache s
s) Int
ety = do
    let index :: Int
index = Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
    Int
tag <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ety) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      MVector (PrimState IO) Int -> Int -> Int -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UM.unsafeWrite IOVector Int
MVector (PrimState IO) Int
tags  Int
index (-Int
2)
      MVector (PrimState IO) (Elem s) -> Int -> Elem s -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite IOVector (Elem s)
MVector (PrimState IO) (Elem s)
cache Int
index Elem s
forall t. t
cacheMiss
    s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
ety

instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where
  {-# INLINE explMembers #-}
  explMembers :: Cache n s -> m (Vector Int)
explMembers (Cache Int
mask IOVector Int
tags IOVector (Elem s)
_ s
s) = do
    Vector Int
cached <- IO (Vector Int) -> m (Vector Int)
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 -> Bool) -> Vector Int -> Vector Int
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
U.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (-Int
2)) (Vector Int -> Vector Int) -> IO (Vector Int) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Int -> IO (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
U.freeze IOVector Int
MVector (PrimState IO) Int
tags
    let etyFilter :: Int -> IO Bool
etyFilter Int
ety = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ety) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVector (PrimState IO) Int -> Int -> IO Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UM.unsafeRead IOVector Int
MVector (PrimState IO) Int
tags (Int
ety Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
    Vector Int
stored <- s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s m (Vector Int) -> (Vector Int -> m (Vector Int)) -> m (Vector Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector Int) -> m (Vector Int))
-> (Vector Int -> IO (Vector Int)) -> Vector Int -> m (Vector Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IO Bool) -> Vector Int -> IO (Vector Int)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
(a -> m Bool) -> Vector a -> m (Vector a)
U.filterM Int -> IO Bool
etyFilter
    Vector Int -> m (Vector Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector Int -> m (Vector Int)) -> Vector Int -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$! Vector Int
cached Vector Int -> Vector Int -> Vector Int
forall a. Unbox a => Vector a -> Vector a -> Vector a
U.++ Vector Int
stored

-- | Wrapper that makes a store read-only by hiding its 'ExplSet' and 'ExplDestroy' instances.
--   This is primarily used to protect the 'EntityCounter' from accidental overwrites.
--   Use 'setReadOnly' and 'destroyReadOnly' to override.
newtype ReadOnly s = ReadOnly s
type instance Elem (ReadOnly s) = Elem s

instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where
  explInit :: m (ReadOnly s)
explInit = s -> ReadOnly s
forall s. s -> ReadOnly s
ReadOnly (s -> ReadOnly s) -> m s -> m (ReadOnly s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall (m :: * -> *) s. ExplInit m s => m s
explInit

instance ExplGet m s => ExplGet m (ReadOnly s) where
  explExists :: ReadOnly s -> Int -> m Bool
explExists (ReadOnly s
s) = s -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists s
s
  explGet :: ReadOnly s -> Int -> m (Elem (ReadOnly s))
explGet    (ReadOnly s
s) = s -> Int -> m (Elem s)
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s
s
  {-# INLINE explExists #-}
  {-# INLINE explGet #-}

instance ExplMembers m s => ExplMembers m (ReadOnly s) where
  {-# INLINE explMembers #-}
  explMembers :: ReadOnly s -> m (Vector Int)
explMembers (ReadOnly s
s) = s -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s
s

setReadOnly :: forall w m s c.
  ( Has w m c
  , Storage c ~ ReadOnly s
  , Elem s ~ c
  , ExplSet m s
  ) => Entity -> c -> SystemT w m ()
setReadOnly :: Entity -> c -> SystemT w m ()
setReadOnly (Entity Int
ety) c
c = do
  ReadOnly s
s <- SystemT w m (ReadOnly s)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ s -> Int -> Elem s -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s
s Int
ety c
Elem s
c

destroyReadOnly :: forall w m s c.
  ( Has w m c
  , Storage c ~ ReadOnly s
  , Elem s ~ c
  , ExplDestroy m s
  ) => Entity -> Proxy c -> SystemT w m ()
destroyReadOnly :: Entity -> Proxy c -> SystemT w m ()
destroyReadOnly (Entity Int
ety) Proxy c
_ = do
  ReadOnly s :: Storage c <- SystemT w m (ReadOnly s)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  m () -> SystemT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> SystemT w m ()) -> m () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ s -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s
s Int
ety