{-# 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
) where
import Control.Monad.Reader
import qualified Data.IntMap.Strict as M
import Data.IORef
import Data.Proxy
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
newtype Map c = Map (IORef (M.IntMap c))
type instance Elem (Map c) = c
instance MonadIO m => ExplInit m (Map c) where
explInit = liftIO$ Map <$> newIORef mempty
instance MonadIO m => ExplGet m (Map c) where
explExists (Map ref) ety = liftIO$ M.member ety <$> readIORef ref
explGet (Map ref) ety = liftIO$ flip fmap (M.lookup ety <$> readIORef ref) $ \case
Just c -> c
Nothing -> error $ "Reading non-existant Map component for entity " <> show ety
{-# INLINE explExists #-}
{-# INLINE explGet #-}
instance MonadIO m => ExplSet m (Map c) where
{-# INLINE explSet #-}
explSet (Map ref) ety x = liftIO$
modifyIORef' ref (M.insert ety x)
instance MonadIO m => ExplDestroy m (Map c) where
{-# INLINE explDestroy #-}
explDestroy (Map ref) ety = liftIO$
readIORef ref >>= writeIORef ref . M.delete ety
instance MonadIO m => ExplMembers m (Map c) where
{-# INLINE explMembers #-}
explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref
newtype Unique c = Unique (IORef (Maybe (Int, c)))
type instance Elem (Unique c) = c
instance MonadIO m => ExplInit m (Unique c) where
explInit = liftIO$ Unique <$> newIORef Nothing
instance MonadIO m => ExplGet m (Unique c) where
{-# INLINE explGet #-}
explGet (Unique ref) _ = liftIO$ flip fmap (readIORef ref) $ \case
Just (_, c) -> c
Nothing -> error $ "Reading non-existant Unique component"
{-# INLINE explExists #-}
explExists (Unique ref) ety = liftIO$ maybe False ((==ety) . fst) <$> readIORef ref
instance MonadIO m => ExplSet m (Unique c) where
{-# INLINE explSet #-}
explSet (Unique ref) ety c = liftIO$ writeIORef ref (Just (ety, c))
instance MonadIO m => ExplDestroy m (Unique c) where
{-# INLINE explDestroy #-}
explDestroy (Unique ref) ety = liftIO$ readIORef ref >>=
mapM_ (flip when (writeIORef ref Nothing) . (==ety) . fst)
instance MonadIO m => ExplMembers m (Unique c) where
{-# INLINE explMembers #-}
explMembers (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case
Nothing -> mempty
Just (ety, _) -> U.singleton ety
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 = liftIO$ Global <$> newIORef mempty
instance MonadIO m => ExplGet m (Global c) where
{-# INLINE explGet #-}
explGet (Global ref) _ = liftIO$ readIORef ref
{-# INLINE explExists #-}
explExists _ _ = return True
instance MonadIO m => ExplSet m (Global c) where
{-# INLINE explSet #-}
explSet (Global ref) _ c = liftIO$ writeIORef ref c
class Cachable s
instance Cachable (Map s)
instance (KnownNat n, Cachable s) => Cachable (Cache n s)
data Cache (n :: Nat) s =
Cache Int (UM.IOVector Int) (VM.IOVector (Elem s)) s
cacheMiss :: t
cacheMiss = error "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 = do
let n = fromIntegral$ natVal (Proxy @n)
tags <- liftIO$ UM.replicate n (-2)
cache <- liftIO$ VM.replicate n cacheMiss
child <- explInit
return (Cache n tags cache child)
instance (MonadIO m, ExplGet m s) => ExplGet m (Cache n s) where
{-# INLINE explGet #-}
explGet (Cache n tags cache s) ety = do
let index = ety `rem` n
tag <- liftIO$ UM.unsafeRead tags index
if tag == ety
then liftIO$ VM.unsafeRead cache index
else explGet s ety
{-# INLINE explExists #-}
explExists (Cache n tags _ s) ety = do
tag <- liftIO$ UM.unsafeRead tags (ety `rem` n)
if tag == ety then return True else explExists s ety
instance (MonadIO m, ExplSet m s) => ExplSet m (Cache n s) where
{-# INLINE explSet #-}
explSet (Cache n tags cache s) ety x = do
let index = ety `rem` n
tag <- liftIO$ UM.unsafeRead tags index
when (tag /= (-2) && tag /= ety) $ do
cached <- liftIO$ VM.unsafeRead cache index
explSet s tag cached
liftIO$ UM.unsafeWrite tags index ety
liftIO$ VM.unsafeWrite cache index x
instance (MonadIO m, ExplDestroy m s) => ExplDestroy m (Cache n s) where
{-# INLINE explDestroy #-}
explDestroy (Cache n tags cache s) ety = do
let index = ety `rem` n
tag <- liftIO$ UM.unsafeRead tags (ety `rem` n)
if tag == ety
then do
liftIO$ UM.unsafeWrite tags index (-2)
liftIO$ VM.unsafeWrite cache index cacheMiss
else explDestroy s ety
instance (MonadIO m, ExplMembers m s) => ExplMembers m (Cache n s) where
{-# INLINE explMembers #-}
explMembers (Cache _ tags _ s) = do
cached <- liftIO$ U.filter (/= (-2)) <$> U.freeze tags
stored <- explMembers s
return $! cached U.++ stored
newtype ReadOnly s = ReadOnly s
type instance Elem (ReadOnly s) = Elem s
instance (Functor m, ExplInit m s) => ExplInit m (ReadOnly s) where
explInit = ReadOnly <$> explInit
instance ExplGet m s => ExplGet m (ReadOnly s) where
explExists (ReadOnly s) = explExists s
explGet (ReadOnly s) = explGet s
{-# INLINE explExists #-}
{-# INLINE explGet #-}
instance ExplMembers m s => ExplMembers m (ReadOnly s) where
{-# INLINE explMembers #-}
explMembers (ReadOnly s) = explMembers 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 ety) c = do
ReadOnly s <- getStore
lift $ explSet s ety 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 ety) _ = do
ReadOnly s :: Storage c <- getStore
lift $ explDestroy s ety