{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.Core where
import Control.Monad.Reader
import Data.Functor.Identity
import qualified Data.Vector.Unboxed as U
import qualified Apecs.THTuples as T
newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show, Enum)
newtype SystemT w m a = SystemT {unSystem :: ReaderT w m a} deriving (Functor, Monad, Applicative, MonadTrans, MonadIO)
type System w a = SystemT w IO a
deriving instance Monad m => MonadReader w (SystemT w m)
class (Elem (Storage c) ~ c) => Component c where
type Storage c
class (Monad m, Component c) => Has w m c where
getStore :: SystemT w m (Storage c)
type family Elem s
class ExplInit m s where
explInit :: m s
class Monad m => ExplGet m s where
explGet :: s -> Int -> m (Elem s)
explExists :: s -> Int -> m Bool
class Monad m => ExplSet m s where
explSet :: s -> Int -> Elem s -> m ()
class Monad m => ExplDestroy m s where
explDestroy :: s -> Int -> m ()
class Monad m => ExplMembers m s where
explMembers :: s -> m (U.Vector Int)
type Get w m c = (Has w m c, ExplGet m (Storage c))
type Set w m c = (Has w m c, ExplSet m (Storage c))
type Members w m c = (Has w m c, ExplMembers m (Storage c))
type Destroy w m c = (Has w m c, ExplDestroy m (Storage c))
instance Component c => Component (Identity c) where
type Storage (Identity c) = Identity (Storage c)
instance Has w m c => Has w m (Identity c) where
{-# INLINE getStore #-}
getStore = Identity <$> getStore
type instance Elem (Identity s) = Identity (Elem s)
instance ExplGet m s => ExplGet m (Identity s) where
{-# INLINE explGet #-}
explGet (Identity s) e = Identity <$> explGet s e
{-# INLINE explExists #-}
explExists (Identity s) = explExists s
instance ExplSet m s => ExplSet m (Identity s) where
{-# INLINE explSet #-}
explSet (Identity s) e (Identity x) = explSet s e x
instance ExplMembers m s => ExplMembers m (Identity s) where
{-# INLINE explMembers #-}
explMembers (Identity s) = explMembers s
instance ExplDestroy m s => ExplDestroy m (Identity s) where
{-# INLINE explDestroy #-}
explDestroy (Identity s) = explDestroy s
T.makeInstances [2..8]
data Not a = Not
newtype NotStore s = NotStore s
instance Component c => Component (Not c) where
type Storage (Not c) = NotStore (Storage c)
instance (Has w m c) => Has w m (Not c) where
{-# INLINE getStore #-}
getStore = NotStore <$> getStore
type instance Elem (NotStore s) = Not (Elem s)
instance ExplGet m s => ExplGet m (NotStore s) where
{-# INLINE explGet #-}
explGet _ _ = return Not
{-# INLINE explExists #-}
explExists (NotStore sa) ety = not <$> explExists sa ety
instance ExplDestroy m s => ExplSet m (NotStore s) where
{-# INLINE explSet #-}
explSet (NotStore sa) ety _ = explDestroy sa ety
newtype MaybeStore s = MaybeStore s
instance Component c => Component (Maybe c) where
type Storage (Maybe c) = MaybeStore (Storage c)
instance (Has w m c) => Has w m (Maybe c) where
{-# INLINE getStore #-}
getStore = MaybeStore <$> getStore
type instance Elem (MaybeStore s) = Maybe (Elem s)
instance ExplGet m s => ExplGet m (MaybeStore s) where
{-# INLINE explGet #-}
explGet (MaybeStore sa) ety = do
e <- explExists sa ety
if e then Just <$> explGet sa ety
else return Nothing
explExists _ _ = return True
instance (ExplDestroy m s, ExplSet m s) => ExplSet m (MaybeStore s) where
{-# INLINE explSet #-}
explSet (MaybeStore sa) ety Nothing = explDestroy sa ety
explSet (MaybeStore sa) ety (Just x) = explSet sa ety x
data EitherStore sa sb = EitherStore sa sb
instance (Component ca, Component cb) => Component (Either ca cb) where
type Storage (Either ca cb) = EitherStore (Storage ca) (Storage cb)
instance (Has w m ca, Has w m cb) => Has w m (Either ca cb) where
{-# INLINE getStore #-}
getStore = EitherStore <$> getStore <*> getStore
type instance Elem (EitherStore sa sb) = Either (Elem sa) (Elem sb)
instance (ExplGet m sa, ExplGet m sb) => ExplGet m (EitherStore sa sb) where
{-# INLINE explGet #-}
explGet (EitherStore sa sb) ety = do
e <- explExists sb ety
if e then Right <$> explGet sb ety
else Left <$> explGet sa ety
{-# INLINE explExists #-}
explExists (EitherStore sa sb) ety = do
e <- explExists sb ety
if e then return True
else explExists sa ety
instance (ExplSet m sa, ExplSet m sb) => ExplSet m (EitherStore sa sb) where
{-# INLINE explSet #-}
explSet (EitherStore _ sb) ety (Right b) = explSet sb ety b
explSet (EitherStore sa _) ety (Left a) = explSet sa ety a
instance (ExplDestroy m sa, ExplDestroy m sb)
=> ExplDestroy m (EitherStore sa sb) where
{-# INLINE explDestroy #-}
explDestroy (EitherStore sa sb) ety =
explDestroy sa ety >> explDestroy sb ety
instance Monad m => Has w m () where
{-# INLINE getStore #-}
getStore = return ()
instance Component () where
type Storage () = ()
type instance Elem () = ()
instance Monad m => ExplGet m () where
{-# INLINE explExists #-}
explExists _ _ = return True
{-# INLINE explGet #-}
explGet _ _ = return ()
instance Monad m => ExplSet m () where
{-# INLINE explSet #-}
explSet _ _ _ = return ()
instance Monad m => ExplDestroy m () where
{-# INLINE explDestroy #-}
explDestroy _ _ = return ()
data Filter c = Filter deriving (Eq, Show)
newtype FilterStore s = FilterStore s
instance Component c => Component (Filter c) where
type Storage (Filter c) = FilterStore (Storage c)
instance Has w m c => Has w m (Filter c) where
{-# INLINE getStore #-}
getStore = FilterStore <$> getStore
type instance Elem (FilterStore s) = Filter (Elem s)
instance ExplGet m s => ExplGet m (FilterStore s) where
{-# INLINE explGet #-}
explGet _ _ = return Filter
{-# INLINE explExists #-}
explExists (FilterStore s) ety = explExists s ety
instance ExplMembers m s => ExplMembers m (FilterStore s) where
{-# INLINE explMembers #-}
explMembers (FilterStore s) = explMembers s
data EntityStore = EntityStore
instance Component Entity where
type Storage Entity = EntityStore
instance Monad m => Has w m Entity where
{-# INLINE getStore #-}
getStore = return EntityStore
type instance Elem EntityStore = Entity
instance Monad m => ExplGet m EntityStore where
{-# INLINE explGet #-}
explGet _ ety = return $ Entity ety
{-# INLINE explExists #-}
explExists _ _ = return True