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

-- |
-- Module      :  Games.ECS.Component.TH.Internal
-- Description : Template Haskell derivation of Component classes
-- Copyright   :  (C) 2020 Sophie Taylor
-- License     :  AGPL-3.0-or-later
-- Maintainer  :  Sophie Taylor <sophie@spacekitteh.moe>
-- Stability   :  experimental
-- Portability: GHC
--
-- Implements helper classes and constraints on components.
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

-- | Forms the accessor optic based on the properties of the component.
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

-- | Computes the name for a \"classy optics\" style class.
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

-- | Computes the name for the  \"Using\" type synonyms.
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

-- | Creates the \"classy optics\" class, and the \"Using\" type synonym, matching a 'Component'.
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
  -- Look up the "CanonicalName" associated type to get the standard name used to reference the component
  [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"
      -- We need this type var for the HKD optics lookup fuckery
      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)
      -- Not sure we really need /all/ of this, but it works.
      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'
          )
          |]
      -- Declare the actual "Has<xyz>" class, with the adder and remover functions, and the accessing optic
      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)

      -- Create the "Using<xyz>" type synonym.
      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'
          )
          |]
      -- The "Using<xyz>" type synonym has two type parameters: The world type, and the storage variable. The
      -- storage variable depends on whether you're accessing individual entity components or the storage of
      -- components.
      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]
"!")

-- | Create the accessing functions/optic signatures for a given component.
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'
      -- The component type
      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"

-- | Computes  the name for a component remover function, with a given postfix.
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

-- | Computes the name for a component remover function.
makeRemoverName :: String -> Name
makeRemoverName :: [Char] -> Name
makeRemoverName = [Char] -> [Char] -> Name
makeRemoverName' [Char]
""

-- | Computes the name for a component addition function, with a given postfix.
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

-- | Computes the name for a component addition function.
makeAdderName :: String -> Name
makeAdderName :: [Char] -> Name
makeAdderName = [Char] -> [Char] -> Name
makeAdderName' [Char]
""

-- | Computes the name for a "withComponent" function, with a given postfix.
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]
""

-- | Make the instance for the \"classy optics\" for a given world and canonically named component. We make
-- the bodies for the optics for accessing components, as well as (law-breaking?) setters that create them if
-- they're missing.
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'
      -- name = pure @Q name'
      a :: m Type
a = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a' -- The component type
      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
  -- fieldType <- [t|Field $nameType $s (Prop $a) $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

  {-  clset <- [|set|]
    clview <- [|view |]
    let   worldRuleBinderType = typedRuleVar (mkName "w") (appT worldType s)
          sRuleType = typedRuleVar s' s
          opticAccessorForRule = varE namedOptic
          wName = mkName "w"
          lhsExpr = AppE (AppE (AppE clset (VarE namedOptic)) (AppE (AppE clview (VarE namedOptic)) (VarE wName))) (VarE wName)
                          --(appE (appE [|set|] ( [|($opticAccessorForRule)|])) [|(view ($opticAccessorForRule) w) w|])
    opticRule <- pragRuleD (name' ++ "/set . get") [worldRuleBinderType] (pure lhsExpr) [|w|] AllPhases -}
  --
  --              [d| {-# RULES "component/set . get" forall w . set $(opticAccessorForRule) (view $(opticAccessorForRule) w) w = w #-} |] -- TODO get proper component name --
  [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 {-,  opticRule-}] [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"

-- | This is so we do not have to use the Generics-based functions which use indexing, and so are hella slow. At this point, we do not need the generic-lens package at all.
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' -- The component type
  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 :: (Prop $a ~ Required) => Lens' ($worldType Individual) (Tagged $nameType $a)
              typed = Control.Lens.lens getTyped (flip setTyped)

              -- getTyped :: (Prop $a ~ Required) => $worldType Individual -> (Tagged $nameType $a)
              {-# 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 :: (Prop $a ~ Normal) => Lens' ($worldType Individual) (Tagged $nameType (Maybe $a))
              typed = Control.Lens.lens getTyped (flip setTyped)

              -- getTyped :: (Prop $a ~ Normal) => $worldType Individual -> (Tagged $nameType (Maybe $a))
              {-# 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 :: (Prop $a ~ Normal) => Lens' ($worldType Storing) (Tagged $nameType (Storage $a $a))
              typed = Control.Lens.lens getTyped (flip setTyped)

              --                         getTyped :: (Prop $a ~ Normal) => $worldType Storing -> (Tagged $nameType (Storage $a $a))
              {-# 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 :: (Prop $a ~ Games.ECS.World.Unique) => Lens' ($worldType Individual) (Tagged $nameType (Maybe $a))
              typed = Control.Lens.lens getTyped (flip setTyped)

              -- getTyped :: (Prop $a ~ Games.ECS.World.Unique) => $worldType Individual -> (Tagged $nameType (Maybe $a))
              {-# 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 :: (Prop $a ~ Games.ECS.World.Unique) => Lens' ($worldType Storing) (Tagged $nameType (UniqueStore $a))
              typed = Control.Lens.lens getTyped (flip setTyped)

              -- getTyped :: (Prop $a ~ Games.ECS.World.Unique) => $worldType Storing -> (Tagged $nameType (UniqueStore $a))
              {-# 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