{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      :  Games.ECS.World.TH
-- Description : Template Haskell derivation of 'World' classes
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Automatic derivation of the 'World' class, implementing the bulk of the higher-kinded data pattern.
module Games.ECS.World.TH
  ( makeWorld,
  )
where

import Control.Applicative
import Control.Lens
import Control.Monad
import Data.Coerce
import Data.Foldable
import Data.IntSet qualified as IS
import Data.Kind qualified as DK
import Data.List (findIndex)
import GHC.Generics
import Games.ECS.Component
import Games.ECS.Component.TH.Internal
import Games.ECS.Entity
import Games.ECS.SaveLoad
import Games.ECS.Serialisation
import Games.ECS.Slot
import Games.ECS.World
import Language.Haskell.TH
import Language.Haskell.TH.Datatype qualified as D
import Language.Haskell.TH.Syntax
import Witherable

aComponentName :: Name
aComponentName :: Name
aComponentName = ''Games.ECS.Component.AComponent

-- worldClassName :: Name
-- worldClassName = ''Games.ECS.World.World

-- entRefFieldName :: Name
-- entRefFieldName = ''Games.ECS.World.EntRefField

-- setter'Name :: Name
-- setter'Name = ''Control.Lens.Setter'

extractComponentTypes :: Type -> Maybe (Type, Type, Type)
extractComponentTypes :: Type -> Maybe (Type, Type, Type)
extractComponentTypes = \case
  AppT (AppT (AppT (ConT Name
acName) name :: Type
name@(LitT (StrTyLit String
_))) Type
s) Type
a | Name
acName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
aComponentName -> (Type, Type, Type) -> Maybe (Type, Type, Type)
forall a. a -> Maybe a
Just (Type
name, Type
a, Type
s)
  Type
_ -> Maybe (Type, Type, Type)
forall a. Maybe a
Nothing

-- | Find the position of the entity reference field in a (product) world type. We need this so we can ensure
-- we initialise it with the correct type.
findEntRefFieldPosition :: (MonadFail m) => [Type] -> m Int
findEntRefFieldPosition :: forall (m :: * -> *). MonadFail m => [Type] -> m Int
findEntRefFieldPosition [Type]
fields = do
  let idx :: Maybe Int
idx = ((Type -> Bool) -> [Type] -> Maybe Int)
-> [Type] -> (Type -> Bool) -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Type -> Bool) -> [Type] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex [Type]
fields ((Type -> Bool) -> Maybe Int) -> (Type -> Bool) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ \case
        AppT (ConT Name
_entRefFieldName) Type
_ -> Bool
True
        Type
_ -> Bool
False

  case Maybe Int
idx of
    Just Int
i -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    Maybe Int
Nothing -> String -> m Int
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"World doesn't have an EntRefField!"

-- | Body for constructing a new individual given an entity reference
constructAnEntityWithEntRef :: forall m w. (Quote m) => Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (Entity -> w Individual)
constructAnEntityWithEntRef :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> [(Type, Type)]
-> m Type
-> Code m (Entity -> w 'Individual)
constructAnEntityWithEntRef Int
entRefPosition m Exp
constructor [(Type, Type)]
fieldTypes m Type
worldType =
  Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (Entity -> w 'Individual)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (Entity -> w 'Individual)
constructAnEntityWithEntRefAndValues Int
entRefPosition m Exp
constructor (((Type, Type) -> (Type, Type, Maybe (m Exp)))
-> [(Type, Type)] -> [(Type, Type, Maybe (m Exp))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Type
a, Type
b) -> (Type
a, Type
b, Maybe (m Exp)
forall a. Maybe a
Nothing)) [(Type, Type)]
fieldTypes) m Type
worldType

-- | Creates an expression for constructing a new individual, with the given entity reference value and initial component values.
constructAnEntityWithEntRefAndValues :: forall m w. (Quote m) => Int -> m Exp -> [(Type, Type, Maybe (m Exp))] -> m Type -> Code m (Entity -> w Individual)
constructAnEntityWithEntRefAndValues :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (Entity -> w 'Individual)
constructAnEntityWithEntRefAndValues Int
entRefPosition m Exp
constructor [(Type, Type, Maybe (m Exp))]
fieldTypes m Type
worldType =
  let prefix :: [m Exp]
prefix = ((Type, Type, Maybe (m Exp)) -> m Exp)
-> [(Type, Type, Maybe (m Exp))] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Int
-> [(Type, Type, Maybe (m Exp))] -> [(Type, Type, Maybe (m Exp))]
forall a. Int -> [a] -> [a]
take Int
entRefPosition [(Type, Type, Maybe (m Exp))]
fieldTypes)
      postfix :: [m Exp]
postfix = ((Type, Type, Maybe (m Exp)) -> m Exp)
-> [(Type, Type, Maybe (m Exp))] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Int
-> [(Type, Type, Maybe (m Exp))] -> [(Type, Type, Maybe (m Exp))]
forall a. Int -> [a] -> [a]
drop Int
entRefPosition [(Type, Type, Maybe (m Exp))]
fieldTypes)
      header :: m Exp
header = (m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
constructor [m Exp]
prefix
      mid :: m Exp -> m Exp
mid = m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
header
      ending :: m Exp -> Code m (w 'Individual)
ending m Exp
ent = m Exp -> Code m (w 'Individual)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m (w 'Individual))
-> m Exp -> Code m (w 'Individual)
forall a b. (a -> b) -> a -> b
$ (m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (m Exp -> m Exp
mid m Exp
ent) [m Exp]
postfix
      fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp
      fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Type
_name, Type
_a, Just m Exp
val) = m Exp
val
      fieldFunc (Type
name, Type
a, Maybe (m Exp)
Nothing) = [|defaultField @($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
name)) @($m Type
worldType) @Individual @(Prop $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a)) @($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))|]
   in [||\p
ent -> $$(m Exp -> Code m (w 'Individual)
ending [|ent|])||]

-- | Creates an expression to construct a new, blank world.
constructDefaultWorld :: (Quote m) => Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (w Storing)
constructDefaultWorld :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (w 'Storing)
constructDefaultWorld Int
entRefPos m Exp
constructor [(Type, Type)]
fieldTypes m Type
worldType = m Exp
-> Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (w 'Storing)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
m Exp
-> Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (w 'Storing)
constructWorldWith [|blankEntityStorage|] Int
entRefPos m Exp
constructor (((Type, Type) -> (Type, Type, Maybe (m Exp)))
-> [(Type, Type)] -> [(Type, Type, Maybe (m Exp))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Type
a, Type
b) -> (Type
a, Type
b, Maybe (m Exp)
forall a. Maybe a
Nothing)) [(Type, Type)]
fieldTypes) m Type
worldType

constructWorldWith :: forall m w. (Quote m) => m Exp -> Int -> m Exp -> [(Type, Type, Maybe (m Exp))] -> m Type -> Code m (w Storing)
constructWorldWith :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
m Exp
-> Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (w 'Storing)
constructWorldWith m Exp
entStorage Int
entRefPosition m Exp
constructor [(Type, Type, Maybe (m Exp))]
fieldTypes m Type
worldType = m Exp -> Code m (w 'Storing)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce m Exp
ending
  where
    prefix :: [m Exp]
prefix = ((Type, Type, Maybe (m Exp)) -> m Exp)
-> [(Type, Type, Maybe (m Exp))] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Int
-> [(Type, Type, Maybe (m Exp))] -> [(Type, Type, Maybe (m Exp))]
forall a. Int -> [a] -> [a]
take Int
entRefPosition [(Type, Type, Maybe (m Exp))]
fieldTypes)
    postfix :: [m Exp]
postfix = ((Type, Type, Maybe (m Exp)) -> m Exp)
-> [(Type, Type, Maybe (m Exp))] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Int
-> [(Type, Type, Maybe (m Exp))] -> [(Type, Type, Maybe (m Exp))]
forall a. Int -> [a] -> [a]
drop Int
entRefPosition [(Type, Type, Maybe (m Exp))]
fieldTypes)
    header :: m Exp
header = (m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
constructor [m Exp]
prefix
    mid :: m Exp
mid = m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
header m Exp
entStorage
    ending :: m Exp
ending = (m Exp -> m Exp -> m Exp) -> m Exp -> [m Exp] -> m Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
mid [m Exp]
postfix
    fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp
    fieldFunc :: (Type, Type, Maybe (m Exp)) -> m Exp
fieldFunc (Type
_, Type
_, Just m Exp
val) = m Exp
val
    fieldFunc (Type
name, Type
a, Maybe (m Exp)
Nothing) = [|defaultStorage @($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
name)) @($m Type
worldType) @Storing @(Prop $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a)) @($(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))|]

{-# INLINE traversalIndexedLookups #-}
traversalIndexedLookups :: forall world f p b. (Filterable f, World world, Indexable Entity p) => f Entity -> world Storing -> p (world Individual) b -> f b
traversalIndexedLookups :: forall (world :: Access -> *) (f :: * -> *) (p :: * -> * -> *) b.
(Filterable f, World world, Indexable Entity p) =>
f Entity -> world 'Storing -> p (world 'Individual) b -> f b
traversalIndexedLookups f Entity
ents world 'Storing
world p (world 'Individual) b
f =
  (Entity -> world 'Individual -> b)
-> (Entity, world 'Individual) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed @Entity @p p (world 'Individual) b
f)
    ((Entity, world 'Individual) -> b)
-> f (Entity, world 'Individual) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Entity -> Maybe (Entity, world 'Individual))
-> f Entity -> f (Entity, world 'Individual)
forall a b. (a -> Maybe b) -> f a -> f b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
      ( \Entity
ent -> case world 'Storing -> Entity -> Maybe (world 'Individual)
forall (w :: Access -> *).
World w =>
w 'Storing -> Entity -> Maybe (w 'Individual)
lookupEntity world 'Storing
world (Entity -> Entity
forall a b. Coercible a b => a -> b
coerce Entity
ent) of
          Just world 'Individual
i -> (Entity, world 'Individual) -> Maybe (Entity, world 'Individual)
forall a. a -> Maybe a
Just (Entity -> Entity
forall a b. Coercible a b => a -> b
coerce Entity
ent, world 'Individual
i)
          Maybe (world 'Individual)
Nothing -> Maybe (Entity, world 'Individual)
forall a. Maybe a
Nothing
      )
      f Entity
ents

{-# INLINE traversalNonIndexedLookups #-}
traversalNonIndexedLookups :: (Filterable f, World world) => f Entity -> world Storing -> (world Individual -> b) -> f b
traversalNonIndexedLookups :: forall (f :: * -> *) (world :: Access -> *) b.
(Filterable f, World world) =>
f Entity -> world 'Storing -> (world 'Individual -> b) -> f b
traversalNonIndexedLookups f Entity
ents world 'Storing
world world 'Individual -> b
f =
  world 'Individual -> b
f
    (world 'Individual -> b) -> f (world 'Individual) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Entity -> Maybe (world 'Individual))
-> f Entity -> f (world 'Individual)
forall a b. (a -> Maybe b) -> f a -> f b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe
      (world 'Storing -> Entity -> Maybe (world 'Individual)
forall (w :: Access -> *).
World w =>
w 'Storing -> Entity -> Maybe (w 'Individual)
lookupEntity world 'Storing
world (Entity -> Maybe (world 'Individual))
-> (Entity -> Entity) -> Entity -> Maybe (world 'Individual)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> Entity
forall a b. Coercible a b => a -> b
coerce)
      f Entity
ents

-- | Implements the 'World' typeclass for a type, and creates numerous helper instances.
makeWorld :: forall m. (Quasi m, Quote m) => Name -> m [Dec]
makeWorld :: forall (m :: * -> *). (Quasi m, Quote m) => Name -> m [Dec]
makeWorld Name
worldName = do
  DatatypeInfo
info <- Q DatatypeInfo -> m DatatypeInfo
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q DatatypeInfo -> m DatatypeInfo)
-> Q DatatypeInfo -> m DatatypeInfo
forall a b. (a -> b) -> a -> b
$ Name -> Q DatatypeInfo
D.reifyDatatype Name
worldName

  -- Grab some info we'll need all over the place
  let worldType :: m Type
worldType = Q Type -> m Type
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Type -> m Type) -> Q Type -> m Type
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
worldName
      [ConstructorInfo
constructor] = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
      componentDefinitions' :: [(Type, Type, Type)]
componentDefinitions' = (Type -> Maybe (Type, Type, Type))
-> [Type] -> [(Type, Type, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Type -> Maybe (Type, Type, Type)
extractComponentTypes (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
constructor)
      componentDefinitions :: [(Type, Type)]
componentDefinitions = ((Type, Type, Type) -> (Type, Type))
-> [(Type, Type, Type)] -> [(Type, Type)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Type
a, Type
b, Type
_c) -> (Type
a, Type
b)) [(Type, Type, Type)]
componentDefinitions'
  let componentAccessors :: m [[Dec]]
componentAccessors = [(Type, Type, Type)]
-> ((Type, Type, Type) -> m [Dec]) -> m [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Type, Type, Type)]
componentDefinitions' (ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
forall (m :: * -> *).
(Quasi m, Quote m) =>
ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeComponentAccessor ConstructorInfo
constructor m Type
worldType)
  --  Generate an instance of `World`.
  Int
entRefPosition <- [Type] -> m Int
forall (m :: * -> *). MonadFail m => [Type] -> m Int
findEntRefFieldPosition (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
constructor)

  let totalFieldLength :: Int
totalFieldLength = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
constructor)
      entRefName :: Name
entRefName = String -> Name
mkName String
"entityReferenceField"
      entRefPat :: m Pat
entRefPat = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
entRefName
      entRef :: m Exp
entRef = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
entRefName
      constructorEntityPattern :: [m Pat]
constructorEntityPattern =
        Int -> m Pat -> [m Pat]
forall a. Int -> a -> [a]
replicate Int
entRefPosition m Pat
forall (m :: * -> *). Quote m => m Pat
wildP
          [m Pat] -> [m Pat] -> [m Pat]
forall a. Semigroup a => a -> a -> a
<> [m Pat
entRefPat]
          [m Pat] -> [m Pat] -> [m Pat]
forall a. Semigroup a => a -> a -> a
<> Int -> m Pat -> [m Pat]
forall a. Int -> a -> [a]
replicate ((Int
totalFieldLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
entRefPosition) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) m Pat
forall (m :: * -> *). Quote m => m Pat
wildP
      (m Exp
entityPatternForHasType, m Pat
constructorEntityPatternForHasType, m Pat
valP, m Exp
_valE, m Exp
entRefSetterPat) = ConstructorInfo -> Int -> (m Exp, m Pat, m Pat, m Exp, m Exp)
forall (m :: * -> *).
Quote m =>
ConstructorInfo -> Int -> (m Exp, m Pat, m Pat, m Exp, m Exp)
makeConstructorPatternAndValuePair ConstructorInfo
constructor Int
entRefPosition
      entityPattern :: m Pat
entityPattern = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructor) [m Pat]
constructorEntityPattern
  [Dec]
worldInstance <-
    [d|
      instance {-# OVERLAPS #-} Games.ECS.Slot.HasType (EntRefStoringType) ($m Type
worldType Storing) where
        {-# INLINE CONLIKE typed #-}
        {-# INLINE CONLIKE getTyped #-}
        {-# INLINE CONLIKE setTyped #-}
        typed = Control.Lens.lens getTyped (flip setTyped)
        getTyped ($m Pat
constructorEntityPatternForHasType) = $m Exp
entityPatternForHasType
        setTyped $m Pat
valP ($m Pat
constructorEntityPatternForHasType) = $m Exp
entRefSetterPat

      instance {-# OVERLAPS #-} Games.ECS.Slot.HasType (Entity) ($m Type
worldType Individual) where
        {-# INLINE CONLIKE typed #-}
        {-# INLINE CONLIKE getTyped #-}
        {-# INLINE CONLIKE setTyped #-}
        typed = Control.Lens.lens getTyped (flip setTyped)
        getTyped ($m Pat
constructorEntityPatternForHasType) = $m Exp
entityPatternForHasType
        setTyped $m Pat
valP ($m Pat
constructorEntityPatternForHasType) = $m Exp
entRefSetterPat

      -- TODO: Generate rest of`World` instance
      instance (Generic ($m Type
worldType 'Individual), Generic ($m Type
worldType 'Storing)) => Games.ECS.World.World $m Type
worldType where
        newWorld =
          $( Code m (Any 'Storing) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code m (Any 'Storing) -> m Exp) -> Code m (Any 'Storing) -> m Exp
forall a b. (a -> b) -> a -> b
$
               Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (Any 'Storing)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int -> m Exp -> [(Type, Type)] -> m Type -> Code m (w 'Storing)
constructDefaultWorld
                 Int
entRefPosition
                 (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructor)
                 [(Type, Type)]
componentDefinitions
                 m Type
worldType
           )
        entityReference = conjoined (Control.Lens.to $ \ $m Pat
entityPattern -> $m Exp
entRef) (ito $ \ $m Pat
entityPattern -> ($m Exp
entRef, $m Exp
entRef))
        {-# INLINE unsafeEntityReference #-}
        unsafeEntityReference =
          lens (getTyped :: $m Type
worldType Individual -> Entity) (flip (setTyped :: Entity -> $m Type
worldType Individual -> $m Type
worldType Individual))

        {-# INLINE createNewEntityWithRef #-}
        createNewEntityWithRef ent =
          $( Code m (Entity -> Any 'Individual) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code m (Entity -> Any 'Individual) -> m Exp)
-> Code m (Entity -> Any 'Individual) -> m Exp
forall a b. (a -> b) -> a -> b
$
               Int
-> m Exp
-> [(Type, Type)]
-> m Type
-> Code m (Entity -> Any 'Individual)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> [(Type, Type)]
-> m Type
-> Code m (Entity -> w 'Individual)
constructAnEntityWithEntRef
                 Int
entRefPosition
                 (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructor)
                 [(Type, Type)]
componentDefinitions
                 m Type
worldType
           )
            ent
        {-# INLINE lookupEntity #-}
        lookupEntity world entityToLookup = if existence then Just result else Nothing
          where
            existence = {-HS.member entityToLookup-} IS.member (coerce entityToLookup) $ world ^. (typed @(EntRefField Storing) @($m Type
worldType Storing))
            result = $(Code m (Any 'Individual) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code m (Any 'Individual) -> m Exp)
-> Code m (Any 'Individual) -> m Exp
forall a b. (a -> b) -> a -> b
$ Int
-> m Exp
-> Code m (Any 'Individual)
-> Code m (Any 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (Any 'Individual)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> Code m (w 'Individual)
-> Code m (w 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (w 'Individual)
createIndexedLookups Int
entRefPosition (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructor) (m Exp -> Code m (Any 'Individual)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|created|]) (m Exp -> Code m (Any 'Storing)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|world|]) [(Type, Type)]
componentDefinitions m Type
worldType (m Exp -> Code m Entity
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce (m Exp -> Code m Entity) -> m Exp -> Code m Entity
forall a b. (a -> b) -> a -> b
$ Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"entityToLookup"))

        {-# INLINE CONLIKE entityReferences #-}
        entityReferences :: IndexedFold Entity ($m Type
worldType Storing) Entity
        entityReferences = conjoined ((typed @(EntRefField Storing) @($m Type
worldType Storing)) . knownEntities) ((typed @(EntRefField Storing) @($m Type
worldType Storing)) . knownEntities . selfIndex)

        {-# INLINE lookupEntities #-}
        lookupEntities :: forall f p fol. (Indexable Entity p, Applicative f, Foldable fol) => fol Entity -> p ($m Type
worldType Individual) (f ($m Type
worldType Individual)) -> $m Type
worldType Storing -> f ($m Type
worldType Storing)
        lookupEntities ents' = conjoined normalVer indexedVer
          where
            ents = ents' ^.. folded
            normalVer func world = result
              where
                applied :: [f ($m Type
worldType Individual)]
                applied = traversalNonIndexedLookups ents world func
                result :: f ($m Type
worldType Storing)
                result = liftA3 @f foldl' (pure @f (flip storeEntity)) (pure world) (sequenceA @[] @f applied)
            indexedVer func world = result
              where
                applied :: [f ($m Type
worldType Individual)]
                applied = traversalIndexedLookups ents world func
                result :: f ($m Type
worldType Storing)
                result = liftA3 @f foldl' (pure @f (flip storeEntity)) (pure world) (sequenceA @[] @f applied)
        {-# INLINE storeEntity #-}
        storeEntity ent world = result
          where
            worldWithEntity = world & (typed @(EntRefField Storing) . at (coerce (ent ^. entityReference))) ?~ ()
            worldWithEntity :: $m Type
worldType Storing
            theEntRef = ent ^. entityReference
            result = $(Code m (Any 'Storing) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode (Code m (Any 'Storing) -> m Exp) -> Code m (Any 'Storing) -> m Exp
forall a b. (a -> b) -> a -> b
$ Int
-> m Exp
-> Code m (Any 'Individual)
-> Code m (Any 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (Any 'Storing)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> Code m (w 'Individual)
-> Code m (w 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (w 'Storing)
createStores Int
entRefPosition (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructor) (m Exp -> Code m (Any 'Individual)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|ent|]) (m Exp -> Code m (Any 'Storing)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|worldWithEntity|]) [(Type, Type)]
componentDefinitions m Type
worldType (m Exp -> Code m Entity
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|theEntRef|]))

      instance (XMLSerialise ($m Type
worldType Individual)) => XMLPickler [Node] ($m Type
worldType Storing) where
        {-# INLINE xpickle #-}
        xpickle = worldPickler
      |]

  -- TODO: Generate an `At name FieldType` instance for each Individual's components
  -- TODO: Generate garbage collection function. Note: use Control.Lens.At.sans for this
  -- TODO: Support "global" components - or perhaps just defer to a MonadState
  -- TODO: Generate "Has<X>" classes (elaborated: ReadOnly, WriteOnly, ReadWrite) for each named component, a la classy optics
  -- TODO: Resource Field accessor types
  -- TODO: Enforce intent/queueing system via making optics read-only and using an annotation to say what functions are allowed access, then yeet them with TH
  [Dec]
componentAccessors' <- ([[Dec]] -> [Dec]) -> m [[Dec]] -> m [Dec]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat m [[Dec]]
componentAccessors
  pure ([Dec]
worldInstance [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
componentAccessors')

createIndexedLookups :: forall m w. (Quote m) => Int -> m Exp -> Code m ((w :: Access -> DK.Type) Individual) -> Code m (w Storing) -> [(Type, Type)] -> m Type -> Code m Entity -> Code m (w Individual)
createIndexedLookups :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> Code m (w 'Individual)
-> Code m (w 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (w 'Individual)
createIndexedLookups Int
entRefPos m Exp
constructor Code m (w 'Individual)
_created Code m (w 'Storing)
worldStorage [(Type, Type)]
types m Type
worldType Code m Entity
ent = do
  let applications :: [(Type, Type, Maybe (m Exp))]
      applications :: [(Type, Type, Maybe (m Exp))]
applications =
        [(Type, Type)]
types
          [(Type, Type)]
-> ((Type, Type) -> (Type, Type, Maybe (m Exp)))
-> [(Type, Type, Maybe (m Exp))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ( \(nameType' :: Type
nameType'@(LitT (StrTyLit String
_name')), Type
comp') ->
                  let comp :: m Type
comp = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
comp'
                      nameType :: m Type
nameType = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
nameType'
                   in ( ( Type
nameType',
                          Type
comp',
                          m Exp -> Maybe (m Exp)
forall a. a -> Maybe a
Just
                            [|
                              injectMaybe @($m Type
nameType) @($m Type
worldType) @Individual @(Prop $m Type
comp) @($m Type
comp) ($(Code m (w 'Storing) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode Code m (w 'Storing)
worldStorage) ^. (Games.ECS.Component.storage @($m Type
nameType) @($m Type
worldType) @Storing @(Prop $m Type
comp) @($m Type
comp) . (at $(Code m Entity -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode Code m Entity
ent))))
                              |]
                        )
                      )
              )
  [||$$(Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (Entity -> w 'Individual)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (Entity -> w 'Individual)
constructAnEntityWithEntRefAndValues Int
entRefPos m Exp
constructor [(Type, Type, Maybe (m Exp))]
applications m Type
worldType) $$(Code m Entity
ent)||]

createStores :: forall m w. (Quote m) => Int -> m Exp -> Code m (w Individual) -> Code m (w Storing) -> [(Type, Type)] -> m Type -> Code m Entity -> Code m (w Storing)
createStores :: forall (m :: * -> *) (w :: Access -> *).
Quote m =>
Int
-> m Exp
-> Code m (w 'Individual)
-> Code m (w 'Storing)
-> [(Type, Type)]
-> m Type
-> Code m Entity
-> Code m (w 'Storing)
createStores Int
entRefPos m Exp
constructor Code m (w 'Individual)
individual Code m (w 'Storing)
world [(Type, Type)]
types m Type
worldType Code m Entity
ent = do
  let rawLens :: forall a0. m Type -> m Type -> Code m (Getting a0 (w 'Storing) a0)
rawLens m Type
nameType m Type
componentType = m Exp -> Code m (Getting a0 (w 'Storing) a0)
forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce [|(typed @(Field $m Type
nameType Storing (Prop $m Type
componentType) $m Type
componentType) @($m Type
worldType Storing) . coerced)|]
      rawLens :: m Type -> m Type -> Code m (Getting a0 (w 'Storing) a0)
      applications :: [m Exp]
applications =
        [(Type, Type)]
types
          [(Type, Type)] -> ((Type, Type) -> m Exp) -> [m Exp]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ( \(nameType' :: Type
nameType'@(LitT (StrTyLit String
name')), Type
comp') ->
                  let comp :: m Type
comp = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
comp'
                      viewedField :: Code m Any
viewedField = [||($$Code m (w 'Storing)
world s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. ($$(m Type -> m Type -> Code m (Getting Any (w 'Storing) Any)
forall a0. m Type -> m Type -> Code m (Getting a0 (w 'Storing) a0)
rawLens (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
nameType') m Type
comp)))||]
                   in [|($(m (TExp Any) -> m Exp
forall a (m :: * -> *). Quote m => m (TExp a) -> m Exp
unTypeQ (m (TExp Any) -> m Exp)
-> (Code m Any -> m (TExp Any)) -> Code m Any -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code m Any -> m (TExp Any)
forall (m :: * -> *) a. Code m a -> m (TExp a)
examineCode (Code m Any -> m Exp) -> Code m Any -> m Exp
forall a b. (a -> b) -> a -> b
$ Code m Any
viewedField)) & $(m Exp -> m Type -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE [|Control.Lens.at|] [t|Storage $m Type
comp $m Type
comp|]) $(Code m Entity -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode Code m Entity
ent) .~ ($(Code m (w 'Individual) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode Code m (w 'Individual)
individual) ^? $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
name')))|]
              )

      -- TODO: possibly need some rewrite rules for (set . get)    for the field accessors
      viewed :: m Exp
viewed = [|$(Code m (w 'Storing) -> m Exp
forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode Code m (w 'Storing)
world) ^. (typed @(EntRefField Storing))|]
      viewed :: m Exp
      -- TODO: Replace the "coerced" with "injectToField"
      mappedTypesAndValues :: [(Type, Type, Maybe (m Exp))]
mappedTypesAndValues = ((Type, Type) -> m Exp -> (Type, Type, Maybe (m Exp)))
-> [(Type, Type)] -> [m Exp] -> [(Type, Type, Maybe (m Exp))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
Prelude.zipWith (\(Type
a, Type
b) m Exp
c -> (Type
a, Type
b, m Exp -> Maybe (m Exp)
forall a. a -> Maybe a
Just [|$(m Exp
c) ^. coerced @(Storage $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
b) $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
b))|])) [(Type, Type)]
types [m Exp]
applications

  m Exp
-> Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (w 'Storing)
forall (m :: * -> *) (w :: Access -> *).
Quote m =>
m Exp
-> Int
-> m Exp
-> [(Type, Type, Maybe (m Exp))]
-> m Type
-> Code m (w 'Storing)
constructWorldWith m Exp
viewed Int
entRefPos m Exp
constructor [(Type, Type, Maybe (m Exp))]
mappedTypesAndValues m Type
worldType