{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Ecstasy.Internal where
import Control.Arrow (first, second)
import Control.Monad (mzero, void)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (runMaybeT)
import Control.Monad.Trans.Reader (runReaderT, asks)
import Control.Monad.Trans.State.Strict (modify, get, gets, evalStateT)
import qualified Control.Monad.Trans.State.Strict as S
import Data.Ecstasy.Internal.Deriving
import qualified Data.Ecstasy.Types as T
import Data.Ecstasy.Types hiding (unEnt)
import Data.Foldable (for_)
import Data.Functor.Identity (Identity (..))
import Data.Maybe (catMaybes)
import Data.Traversable (for)
import Data.Tuple (swap)
import GHC.Generics
class HasWorld' world => HasWorld world m where
getEntity
:: Monad m
=> Ent
-> SystemT world m (world 'FieldOf)
default getEntity
:: ( Monad m
, GGetEntity m
(Rep (world ('WorldOf m)))
(Rep (world 'FieldOf))
, Generic (world 'FieldOf)
, Generic (world ('WorldOf m))
)
=> Ent
-> SystemT world m (world 'FieldOf)
getEntity e = do
w <- SystemT $ gets snd
lift . fmap to . gGetEntity @m (from w) $ T.unEnt e
{-# INLINE getEntity #-}
setEntity
:: Ent
-> world 'SetterOf
-> SystemT world m ()
default setEntity
:: ( GSetEntity m
(Rep (world 'SetterOf))
(Rep (world ('WorldOf m)))
, Generic (world ('WorldOf m))
, Generic (world 'SetterOf)
, Monad m
)
=> Ent
-> world 'SetterOf
-> SystemT world m ()
setEntity e s = do
w <- SystemT $ gets snd
x <- lift . fmap to . gSetEntity (from s) (T.unEnt e) $ from w
SystemT . modify . second $ const x
{-# INLINE setEntity #-}
defStorage :: world ('WorldOf m)
default defStorage
:: ( Generic (world ('WorldOf m))
, GDefault 'True (Rep (world ('WorldOf m)))
)
=> world ('WorldOf m)
defStorage = def @'True
class HasWorld' world where
convertSetter
:: world 'FieldOf
-> world 'SetterOf
default convertSetter
:: ( GConvertSetter (Rep (world 'FieldOf))
(Rep (world 'SetterOf))
, Generic (world 'FieldOf)
, Generic (world 'SetterOf)
)
=> world 'FieldOf
-> world 'SetterOf
convertSetter = to . gConvertSetter . from
{-# INLINE convertSetter #-}
newEntity :: world 'FieldOf
default newEntity
:: ( Generic (world 'FieldOf)
, GDefault 'True (Rep (world 'FieldOf))
)
=> world 'FieldOf
newEntity = def @'True
{-# INLINE newEntity #-}
unchanged :: world 'SetterOf
default unchanged
:: ( Generic (world 'SetterOf)
, GDefault 'True (Rep (world 'SetterOf))
)
=> world 'SetterOf
unchanged = def @'True
{-# INLINE unchanged #-}
delEntity :: world 'SetterOf
default delEntity
:: ( Generic (world 'SetterOf)
, GDefault 'False (Rep (world 'SetterOf))
)
=> world 'SetterOf
delEntity = def @'False
{-# INLINE delEntity #-}
instance ( Generic (world 'SetterOf)
, Generic (world 'FieldOf)
, GConvertSetter (Rep (world 'FieldOf))
(Rep (world 'SetterOf))
, GDefault 'True (Rep (world 'FieldOf))
, GDefault 'False (Rep (world 'SetterOf))
, GDefault 'True (Rep (world 'SetterOf))
) => HasWorld' world
instance ( HasWorld' world
, Generic (world 'SetterOf)
, Generic (world ('WorldOf m))
, Generic (world 'FieldOf)
, GConvertSetter (Rep (world 'FieldOf))
(Rep (world 'SetterOf))
, GDefault 'True (Rep (world 'FieldOf))
, GDefault 'False (Rep (world 'SetterOf))
, GDefault 'True (Rep (world 'SetterOf))
, GDefault 'True (Rep (world ('WorldOf m)))
, GSetEntity m
(Rep (world 'SetterOf))
(Rep (world ('WorldOf m)))
, GGetEntity m
(Rep (world ('WorldOf m)))
(Rep (world 'FieldOf))
, Monad m
) => HasWorld world m
nextEntity
:: Monad m
=> SystemT a m Ent
nextEntity = do
(e, _) <- SystemT S.get
SystemT . modify . first . const $ e + 1
pure $ Ent e
createEntity
:: (HasWorld world m, Monad m)
=> world 'FieldOf
-> SystemT world m Ent
createEntity cs = do
e <- nextEntity
setEntity e $ convertSetter cs
pure e
deleteEntity
:: (HasWorld world m, Monad m)
=> Ent
-> SystemT world m ()
deleteEntity = flip setEntity delEntity
unQueryT
:: QueryT world m a
-> Ent
-> world 'FieldOf
-> m (Maybe a)
unQueryT q e f = runMaybeT $ flip runReaderT (e, f) $ runQueryT' q
emap
:: ( HasWorld world m
, Monad m
)
=> EntTarget world m
-> QueryT world m (world 'SetterOf)
-> SystemT world m ()
emap t f = do
es <- t
for_ es $ \e -> do
cs <- getEntity e
sets <- lift $ unQueryT f e cs
for_ sets $ setEntity e
efor
:: ( HasWorld world m
, Monad m
)
=> EntTarget world m
-> QueryT world m a
-> SystemT world m [a]
efor t f = do
es <- t
fmap catMaybes $ for es $ \e -> do
cs <- getEntity e
lift $ unQueryT f e cs
eover
:: ( HasWorld world m
, Monad m
)
=> EntTarget world m
-> QueryT world m (a, world 'SetterOf)
-> SystemT world m [a]
eover t f = do
es <- t
fmap catMaybes $ for es $ \e -> do
cs <- getEntity e
mset <- lift $ unQueryT f e cs
for mset $ \(a, setter) -> do
setEntity e setter
pure a
runQueryT
:: ( HasWorld world m
, Monad m
)
=> Ent
-> QueryT world m a
-> SystemT world m (Maybe a)
runQueryT e qt = do
cs <- getEntity e
lift $ unQueryT qt e cs
yieldSystemT
:: Monad m
=> SystemState world m
-> SystemT world m a
-> m (SystemState world m, a)
yieldSystemT w = fmap swap . flip S.runStateT w . runSystemT'
runSystemT
:: Monad m
=> world ('WorldOf m)
-> SystemT world m a
-> m a
runSystemT w = flip evalStateT (0, w) . runSystemT'
runSystem
:: world ('WorldOf Identity)
-> System world a
-> a
runSystem = (runIdentity .) . runSystemT
with
:: Monad m
=> (world 'FieldOf -> Maybe a)
-> QueryT world m ()
with = void . query
{-# INLINE with #-}
without
:: Monad m
=> (world 'FieldOf -> Maybe a)
-> QueryT world m ()
without f = do
e <- QueryT $ asks snd
maybe (pure ()) (const mzero) $ f e
query
:: Monad m
=> (world 'FieldOf -> Maybe a)
-> QueryT world m a
query f = do
e <- QueryT $ asks snd
maybe mzero pure $ f e
{-# INLINE query #-}
queryMaybe
:: Monad m
=> (world 'FieldOf -> Maybe a)
-> QueryT world m (Maybe a)
queryMaybe f = fmap f $ QueryT $ asks snd
queryEnt
:: Monad m
=> QueryT world m Ent
queryEnt = QueryT $ asks fst
queryFlag
:: Monad m
=> (world 'FieldOf -> Maybe ())
-> QueryT world m Bool
queryFlag = fmap (maybe False (const True)) . queryMaybe
queryDef
:: Monad m
=> z
-> (world 'FieldOf -> Maybe z)
-> QueryT world m z
queryDef z = fmap (maybe z id) . queryMaybe
type EntTarget world m = SystemT world m [Ent]
allEnts :: Monad m => EntTarget world m
allEnts = do
(es, _) <- SystemT get
pure $ Ent <$> [0 .. es - 1]
someEnts :: Monad m => [Ent] -> EntTarget world m
someEnts = pure
anEnt :: Monad m => Ent -> EntTarget world m
anEnt = pure . pure
maybeToUpdate :: Maybe a -> Update a
maybeToUpdate Nothing = Unset
maybeToUpdate (Just a) = Set a