{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
module Games.ECS.Component.TH.Internal
( makeHasComponentClass,
makeComponentAccessor,
makeConstructorPatternAndValuePair,
)
where
import Control.Lens
import Data.Char
import Data.List
import Data.Maybe (fromMaybe)
import Games.ECS.Component
import Games.ECS.Entity
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
accessorBuilder :: (Quote m) => m Type -> m Type -> m Type -> m Type -> m Exp
accessorBuilder :: forall (m :: * -> *).
Quote m =>
m Type -> m Type -> m Type -> m Type -> m Exp
accessorBuilder m Type
hkd m Type
name m Type
s m Type
a = [|runIndexedTraversal $ accessor @($m Type
name) @($m Type
hkd) @($m Type
s) @(Prop $m Type
a) @($m Type
a)|]
normalName :: Name
normalName :: Name
normalName = 'Normal
uniqueName :: Name
uniqueName :: Name
uniqueName = 'Unique
requiredName :: Name
requiredName :: Name
requiredName = 'Required
makeHasComponentClassName :: String -> Name
makeHasComponentClassName :: [Char] -> Name
makeHasComponentClassName [Char]
name = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"Has" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
name)] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
name
makeUsingComponentClassName :: String -> Name
makeUsingComponentClassName :: [Char] -> Name
makeUsingComponentClassName [Char]
name = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"Using" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
name)] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
name
makeHasComponentClass :: (MonadFail m, Quote m, Quasi m) => Name -> m [Dec]
makeHasComponentClass :: forall (m :: * -> *).
(MonadFail m, Quote m, Quasi m) =>
Name -> m [Dec]
makeHasComponentClass Name
componentName = do
Type
componentType <- Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
componentName
[Dec]
componentInstance <- Q [Dec] -> m [Dec]
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q [Dec] -> m [Dec]) -> Q [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q [Dec]
reifyInstances ''Games.ECS.Component.CanonicalName [Type
componentType]
case [Dec]
componentInstance of
[] -> [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"No Component.CanonicalName instance found for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Name -> [Char]
forall a. Show a => a -> [Char]
show Name
componentName) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
[_canonicalNameDec :: Dec
_canonicalNameDec@(TySynInstD (TySynEqn Maybe [TyVarBndr ()]
_ Type
_ canonicalNameType :: Type
canonicalNameType@(LitT (StrTyLit [Char]
canonicalName))))] -> do
let hasComponentClassName :: Name
hasComponentClassName = [Char] -> Name
makeHasComponentClassName [Char]
canonicalName
let worldTypeName :: Name
worldTypeName = [Char] -> Name
mkName [Char]
"worldType"
let s :: m Type
s = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> m Type) -> Name -> m Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"s"
Type
worldType <- Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
worldTypeName
let worldType' :: m Type
worldType' = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
worldType
componentType' :: m Type
componentType' = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
componentType
canonicalNameType' :: m Type
canonicalNameType' = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
canonicalNameType
[Dec]
classSignatures <- m Type -> Type -> m Type -> m [Dec]
forall (m :: * -> *).
(MonadFail m, Quote m) =>
m Type -> Type -> m Type -> m [Dec]
makeRawComponentAccessorSignatures (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
worldType) Type
canonicalNameType (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
componentType)
Type
classContext <-
[t|
( World $m Type
worldType',
Component $m Type
componentType',
EntityProperty $m Type
canonicalNameType' $m Type
worldType' Individual (Prop $m Type
componentType') $m Type
componentType',
OpticsFor $m Type
canonicalNameType' $m Type
worldType' Storing (Prop $m Type
componentType') $m Type
componentType'
~ ReifiedIndexedTraversal' Entity ($m Type
worldType' Storing) $m Type
componentType'
)
|]
Dec
classDec <- m [Type]
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec
classD ([Type] -> m [Type]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type
classContext]) Name
hasComponentClassName [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
worldTypeName BndrVis
BndrReq] [] ((Dec -> m Dec) -> [Dec] -> [m Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> m Dec
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
classSignatures)
Type
useComponentDecType <-
[t|
( $(Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
hasComponentClassName) $m Type
worldType',
EntityProperty $m Type
canonicalNameType' $m Type
worldType' $m Type
s (Prop $m Type
componentType') $m Type
componentType',
OpticsFor $m Type
canonicalNameType' $m Type
worldType' $m Type
s (Prop $m Type
componentType') $m Type
componentType'
~ ReifiedIndexedTraversal' Entity ($m Type
worldType' $m Type
s) $m Type
componentType'
)
|]
Dec
useComponentDec <- Name -> [TyVarBndr BndrVis] -> m Type -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr BndrVis] -> m Type -> m Dec
tySynD ([Char] -> Name
makeUsingComponentClassName [Char]
canonicalName) [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
worldTypeName BndrVis
BndrReq, Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV ([Char] -> Name
mkName [Char]
"s") BndrVis
BndrReq] (Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
useComponentDecType)
pure [Dec
classDec, Dec
useComponentDec]
[Dec]
_ -> [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Error while processing Component.CanonicalName instance for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
componentName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
makeRawComponentAccessorSignatures :: (MonadFail m, Quote m) => m Type -> Type -> m Type -> m [Dec]
makeRawComponentAccessorSignatures :: forall (m :: * -> *).
(MonadFail m, Quote m) =>
m Type -> Type -> m Type -> m [Dec]
makeRawComponentAccessorSignatures m Type
worldType canonicalNameType' :: Type
canonicalNameType'@(LitT (StrTyLit [Char]
name')) m Type
componentType = do
let nameType :: m Type
nameType = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
canonicalNameType'
s' :: Name
s' = [Char] -> Name
mkName [Char]
"s"
s :: m Type
s = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s'
namedOptic :: Name
namedOptic = [Char] -> Name
mkName [Char]
name'
Dec
entitiesWithSig <-
Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
([Char] -> Name
makeWithName [Char]
name')
[t|
Control.Lens.Fold ($m Type
worldType Storing) IntersectionOfEntities
|]
Dec
adderSig <-
Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
([Char] -> Name
makeAdderName [Char]
name')
[t|
Control.Lens.IndexedSetter' Entity ($m Type
worldType Individual) $m Type
componentType
|]
Dec
removerSig <-
Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
([Char] -> Name
makeRemoverName [Char]
name')
[t|
$m Type
worldType Individual -> $m Type
worldType Individual
|]
Type
context <-
[t|
( EntityProperty $m Type
nameType $m Type
worldType $m Type
s (Prop $m Type
componentType) $m Type
componentType,
OpticsFor $m Type
nameType $m Type
worldType $m Type
s (Prop $m Type
componentType) $m Type
componentType
~ ReifiedIndexedTraversal' Entity ($m Type
worldType $m Type
s) $m Type
componentType
)
|]
Dec
theSignature <-
Name -> m Type -> m Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD
Name
namedOptic
( [TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT
[Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
s' Specificity
inferredSpec]
([Type] -> m [Type]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type
context])
[t|
IndexedTraversal' Entity ($m Type
worldType $m Type
s) $m Type
componentType
|]
)
pure [Dec
theSignature, Dec
adderSig, Dec
removerSig, Dec
entitiesWithSig]
makeRawComponentAccessorSignatures m Type
_ Type
_ m Type
_ = [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Mischief afoot with makeRawComponentAccessorSignatures"
makeRemoverName' :: String -> String -> Name
makeRemoverName' :: [Char] -> [Char] -> Name
makeRemoverName' [Char]
postfix [Char]
name =
[Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"remove" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
name)] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
postfix
makeRemoverName :: String -> Name
makeRemoverName :: [Char] -> Name
makeRemoverName = [Char] -> [Char] -> Name
makeRemoverName' [Char]
""
makeAdderName' :: String -> String -> Name
makeAdderName' :: [Char] -> [Char] -> Name
makeAdderName' [Char]
postfix [Char]
name = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"add" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
name)] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
postfix
makeAdderName :: String -> Name
makeAdderName :: [Char] -> Name
makeAdderName = [Char] -> [Char] -> Name
makeAdderName' [Char]
""
makeWithName' :: String -> String -> Name
makeWithName' :: [Char] -> [Char] -> Name
makeWithName' [Char]
postfix [Char]
name = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"with" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char -> Char
toUpper ([Char] -> Char
forall a. HasCallStack => [a] -> a
head [Char]
name)] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
postfix
makeWithName :: String -> Name
makeWithName :: [Char] -> Name
makeWithName = [Char] -> [Char] -> Name
makeWithName' [Char]
""
makeComponentAccessor :: (Quasi m, Quote m) => D.ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeComponentAccessor :: forall (m :: * -> *).
(Quasi m, Quote m) =>
ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeComponentAccessor ConstructorInfo
constructorInfo m Type
worldType tys :: (Type, Type, Type)
tys@(nameType' :: Type
nameType'@(LitT (StrTyLit [Char]
name')), Type
a', Type
_) = do
let nameType :: m Type
nameType = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
nameType'
a :: m Type
a = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a'
s' :: Name
s' = [Char] -> Name
mkName [Char]
"s"
s :: m Type
s = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
s'
namedOptic :: Name
namedOptic = [Char] -> Name
mkName [Char]
name'
built :: m Exp
built = m Type -> m Type -> m Type -> m Type -> m Exp
forall (m :: * -> *).
Quote m =>
m Type -> m Type -> m Type -> m Type -> m Exp
accessorBuilder m Type
worldType m Type
nameType m Type
s m Type
a
[Dec]
sigs <- m Type -> Type -> m Type -> m [Dec]
forall (m :: * -> *).
(MonadFail m, Quote m) =>
m Type -> Type -> m Type -> m [Dec]
makeRawComponentAccessorSignatures m Type
worldType Type
nameType' m Type
a
Dec
theBody <- Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
namedOptic [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
built) []]
let adderPat :: m Pat
adderPat = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
makeAdderName [Char]
name')
removerPat :: m Pat
removerPat = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
makeRemoverName [Char]
name')
withPat :: m Pat
withPat = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Char] -> Name
makeWithName [Char]
name')
let setterPat :: m Exp
setterPat =
[|
setTyped @(Field $m Type
nameType Individual (Prop $m Type
a) $m Type
a) @($m Type
worldType Individual) . injectToField @($m Type
nameType) @($m Type
worldType) @Individual @(Prop $m Type
a)
|]
let removerLambda :: m Exp
removerLambda =
[|
setTyped @(Field $m Type
nameType Individual (Prop $m Type
a) $m Type
a) @($m Type
worldType Individual) (defaultField @($m Type
nameType) @($m Type
worldType) @Individual @(Prop $m Type
a))
|]
Dec
adderInlinePragma <- Name -> Inline -> RuleMatch -> Phases -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD ([Char] -> Name
makeAdderName [Char]
name') Inline
Inline RuleMatch
FunLike Phases
AllPhases
Dec
removerInlinePragma <- Name -> Inline -> RuleMatch -> Phases -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD ([Char] -> Name
makeRemoverName [Char]
name') Inline
Inline RuleMatch
FunLike Phases
AllPhases
Dec
withComonentInlinePragma <- Name -> Inline -> RuleMatch -> Phases -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD ([Char] -> Name
makeWithName [Char]
name') Inline
Inline RuleMatch
FunLike Phases
AllPhases
Dec
opticInlinePragma <- Name -> Inline -> RuleMatch -> Phases -> m Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
namedOptic Inline
Inline RuleMatch
ConLike Phases
AllPhases
[Dec]
withComponent <-
[d|$m Pat
withPat = storage @($m Type
nameType) @($m Type
worldType) @Storing @(Prop $m Type
a) @($m Type
a) . entityKeys . from asIntersection|]
[Dec]
componentAdder <-
[d|
$m Pat
adderPat = conjoined (sets (\f ent -> $m Exp
setterPat (error ("Entity " ++ show ent ++ " never had its " ++ name' ++ " set!")) ent & $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
namedOptic) %~ f)) (isets (\f ent -> $m Exp
setterPat (error ("Entity " ++ show ent ++ " never had its " ++ name' ++ " set!")) ent & $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
namedOptic) %@~ f))
|]
[Dec]
componentRemover <-
[d|
$m Pat
removerPat = $m Exp
removerLambda
|]
let className :: Name
className = [Char] -> Name
makeHasComponentClassName [Char]
name'
classInstanceContext :: m [a]
classInstanceContext = [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
classInstanceType :: m Type
classInstanceType = (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
className) m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
worldType
Dec
classInstance <- m [Type] -> m Type -> [m Dec] -> m Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD m [Type]
classInstanceContext m Type
classInstanceType ((Dec -> m Dec) -> [Dec] -> [m Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> m Dec
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
componentAdder [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
componentRemover [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
sigs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
withComponent [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec
theBody, Dec
withComonentInlinePragma, Dec
adderInlinePragma, Dec
removerInlinePragma, Dec
opticInlinePragma]))
[Dec]
hasTypeInstance <- ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
forall (m :: * -> *).
(Quasi m, Quote m) =>
ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeHasTypeInstance ConstructorInfo
constructorInfo m Type
worldType (Type, Type, Type)
tys
pure ([Dec
classInstance ] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
hasTypeInstance)
makeComponentAccessor ConstructorInfo
_ m Type
_ (Type, Type, Type)
_ = [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Mischief afoot with makeComponentAccessor"
makeHasTypeInstance :: (Quasi m, Quote m) => D.ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeHasTypeInstance :: forall (m :: * -> *).
(Quasi m, Quote m) =>
ConstructorInfo -> m Type -> (Type, Type, Type) -> m [Dec]
makeHasTypeInstance ConstructorInfo
constructorInfo m Type
worldType (nameType' :: Type
nameType'@(LitT (StrTyLit [Char]
name')), Type
a', Type
s') = do
let nameType :: m Type
nameType = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
nameType'
a :: m Type
a = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a'
Type
fieldType <- [t|Games.ECS.Component.AComponent $m Type
nameType $(Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
s') $m Type
a|]
let fieldPosition' :: Maybe Int
fieldPosition' = [Char] -> [[Char]] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex ((Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> [Char]) -> (Type -> Doc) -> Type -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall a. Ppr a => a -> Doc
ppr) Type
fieldType) ((Type -> [Char]) -> [Type] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> [Char]) -> (Type -> Doc) -> Type -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall a. Ppr a => a -> Doc
ppr) ([Type] -> [[Char]]) -> [Type] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
constructorInfo)
fieldPosition :: Int
fieldPosition = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error ((Type -> [Char]
forall a. Show a => a -> [Char]
show Type
fieldType) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (ConstructorInfo -> [Char]
forall a. Show a => a -> [Char]
show ConstructorInfo
constructorInfo))) Maybe Int
fieldPosition'
(m Exp
getterBindingVar, m Pat
consPat, m Pat
valP, m Exp
_, m Exp
setterPattern) = 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
constructorInfo Int
fieldPosition
[Dec]
componentInstances <- Q [Dec] -> m [Dec]
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q [Dec] -> m [Dec]) -> Q [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q [Dec]
reifyInstances ''Prop [Type
a']
case [Dec]
componentInstances of
[] -> [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"No Component instance found for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Don't forget to also call makeHasComponentClass!")
[TySynInstD (TySynEqn Maybe [TyVarBndr ()]
_bndrs Type
_lhs (PromotedT Name
prop))] -> do
[Dec]
theInstance <- Name
-> m Type -> m Pat -> m Exp -> m Pat -> m Exp -> m Type -> m [Dec]
theInstanceFunc Name
prop m Type
nameType m Pat
consPat m Exp
getterBindingVar m Pat
valP m Exp
setterPattern m Type
a
pure [Dec]
theInstance
[Dec]
_ -> [Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Weird Component instance found for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
". Don't forget to also call makeHasComponentClass!")
where
theInstanceFunc :: Name
-> m Type -> m Pat -> m Exp -> m Pat -> m Exp -> m Type -> m [Dec]
theInstanceFunc Name
p m Type
nameType m Pat
consPat m Exp
getterBindingVar m Pat
valP m Exp
setterPattern m Type
a
| Name
p Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
requiredName =
[d|
instance {-# OVERLAPS #-} (Prop $m Type
a ~ Required) => Games.ECS.Slot.HasType (TaggedComponent $m Type
nameType $m Type
a) ($m Type
worldType Individual) where
{-# INLINE CONLIKE typed #-}
typed = Control.Lens.lens getTyped (flip setTyped)
{-# INLINE CONLIKE getTyped #-}
getTyped $m Pat
consPat = $m Exp
getterBindingVar
{-# INLINE CONLIKE setTyped #-}
setTyped $m Pat
valP $m Pat
consPat = $m Exp
setterPattern
|]
theInstanceFunc Name
p m Type
nameType m Pat
consPat m Exp
getterBindingVar m Pat
valP m Exp
setterPattern m Type
a
| Name
p Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
normalName =
[d|
instance {-# OVERLAPS #-} (Prop $m Type
a ~ Normal) => Games.ECS.Slot.HasType (TaggedComponent $m Type
nameType (Maybe $m Type
a)) ($m Type
worldType Individual) where
{-# INLINE CONLIKE typed #-}
typed = Control.Lens.lens getTyped (flip setTyped)
{-# INLINE CONLIKE getTyped #-}
getTyped $m Pat
consPat = $m Exp
getterBindingVar
{-# INLINE CONLIKE setTyped #-}
setTyped $m Pat
valP $m Pat
consPat = $m Exp
setterPattern
instance {-# OVERLAPS #-} (Prop $m Type
a ~ Normal, Storage $m Type
a ~ saa) => Games.ECS.Slot.HasType (TaggedComponent $m Type
nameType (saa $m Type
a)) ($m Type
worldType Storing) where
{-# INLINE CONLIKE typed #-}
typed = Control.Lens.lens getTyped (flip setTyped)
{-# INLINE CONLIKE getTyped #-}
getTyped $m Pat
consPat = $m Exp
getterBindingVar
{-# INLINE CONLIKE setTyped #-}
setTyped $m Pat
valP $m Pat
consPat = $m Exp
setterPattern
|]
theInstanceFunc Name
p m Type
nameType m Pat
consPat m Exp
getterBindingVar m Pat
valP m Exp
setterPattern m Type
a
| Name
p Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
uniqueName =
[d|
instance {-# OVERLAPS #-} (Prop $m Type
a ~ Games.ECS.World.Unique) => Games.ECS.Slot.HasType (TaggedComponent $m Type
nameType (Maybe $m Type
a)) ($m Type
worldType Individual) where
{-# INLINE CONLIKE typed #-}
typed = Control.Lens.lens getTyped (flip setTyped)
{-# INLINE CONLIKE getTyped #-}
getTyped $m Pat
consPat = $m Exp
getterBindingVar
{-# INLINE CONLIKE setTyped #-}
setTyped $m Pat
valP $m Pat
consPat = $m Exp
setterPattern
instance {-# OVERLAPS #-} (Prop $m Type
a ~ Games.ECS.World.Unique) => Games.ECS.Slot.HasType (TaggedComponent $m Type
nameType (UniqueStore $m Type
a)) ($m Type
worldType Storing) where
{-# INLINE CONLIKE typed #-}
typed = Control.Lens.lens getTyped (flip setTyped)
{-# INLINE CONLIKE getTyped #-}
getTyped $m Pat
consPat = $m Exp
getterBindingVar
{-# INLINE CONLIKE setTyped #-}
setTyped $m Pat
valP $m Pat
consPat = $m Exp
setterPattern
|]
theInstanceFunc Name
_ m Type
nameType m Pat
_ m Exp
_ m Pat
_ m Exp
_ m Type
_ = do
Type
theName <- m Type
nameType
[Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Weird stuff is going on when creating HasType instance for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Type -> [Char]
forall a. Show a => a -> [Char]
show Type
theName) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
makeHasTypeInstance ConstructorInfo
_ m Type
worldType (Type, Type, Type)
_ = do
Type
worldTy <- m Type
worldType
[Char] -> m [Dec]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Error while creating HasType instance for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
worldTy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
makeConstructorPatternAndValuePair :: (Quote m) => D.ConstructorInfo -> Int -> (m Exp, m Pat, m Pat, m Exp, m Exp)
makeConstructorPatternAndValuePair :: forall (m :: * -> *).
Quote m =>
ConstructorInfo -> Int -> (m Exp, m Pat, m Pat, m Exp, m Exp)
makeConstructorPatternAndValuePair ConstructorInfo
constructorInfo Int
fieldPosition = (m Exp
getterBindingVar, m Pat
consPat, m Pat
valP, m Exp
valE, m Exp
setterPattern)
where
valName :: Name
valName = [Char] -> Name
mkName [Char]
"val"
valE :: m Exp
valE = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valName
valP :: m Pat
valP = (m Pat -> m Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP (m Pat -> m Pat) -> (Name -> m Pat) -> Name -> m Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP) Name
valName
numFields :: Int
numFields = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
constructorInfo)
fieldNames :: [Name]
fieldNames = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> [Char] -> Name
mkName ([Char]
"_theField" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)) [Int
0 .. (Int
numFields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
fieldPatterns :: [m Pat]
fieldPatterns = (Name -> m Pat) -> [Name] -> [m Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m Pat -> m Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
tildeP (m Pat -> m Pat) -> (Name -> m Pat) -> Name -> m Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP) [Name]
fieldNames
consPat :: m Pat
consPat = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructorInfo) [m Pat]
fieldPatterns
getterBindingVar :: m Exp
getterBindingVar = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name]
fieldNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
fieldPosition)
prefix :: [m Exp]
prefix = (Name -> m Exp) -> [Name] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
fieldPosition [Name]
fieldNames)
mid :: [m Exp]
mid = [m Exp]
prefix [m Exp] -> [m Exp] -> [m Exp]
forall a. [a] -> [a] -> [a]
++ [m Exp
valE]
postfix :: [m Exp]
postfix = [m Exp]
mid [m Exp] -> [m Exp] -> [m Exp]
forall a. [a] -> [a] -> [a]
++ (Name -> m Exp) -> [Name] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop (Int
fieldPosition Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Name]
fieldNames)
setterPattern :: m Exp
setterPattern = (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 (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (ConstructorInfo -> Name
D.constructorName ConstructorInfo
constructorInfo)) [m Exp]
postfix