aztecs-0.14.0: src/Aztecs/ECS/Query/Internal.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Aztecs.ECS.Query.Internal where

import qualified Aztecs.ECS.HSet as HS
import Aztecs.ECS.Query
import Data.Kind
import Data.Maybe
import GHC.Generics
import Prelude hiding (Read)

type family (++) (xs :: [Type]) (ys :: [Type]) :: [Type] where
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

type family AccessToComponents (accesses :: [Type]) :: [Type] where
  AccessToComponents '[] = '[]
  AccessToComponents (Read a ': rest) = a ': AccessToComponents rest
  AccessToComponents (Write a ': rest) = a ': AccessToComponents rest
  AccessToComponents (With a ': rest) = a ': AccessToComponents rest
  AccessToComponents (Without a ': rest) = AccessToComponents rest

type family ReadComponents (accesses :: [Type]) :: [Type] where
  ReadComponents '[] = '[]
  ReadComponents (Read a ': rest) = a ': ReadComponents rest
  ReadComponents (Write a ': rest) = ReadComponents rest
  ReadComponents (With a ': rest) = ReadComponents rest
  ReadComponents (Without a ': rest) = ReadComponents rest

type family WriteComponents (accesses :: [Type]) :: [Type] where
  WriteComponents '[] = '[]
  WriteComponents (Read a ': rest) = WriteComponents rest
  WriteComponents (Write a ': rest) = a ': WriteComponents rest
  WriteComponents (With a ': rest) = WriteComponents rest
  WriteComponents (Without a ': rest) = WriteComponents rest

type family WithComponents (accesses :: [Type]) :: [Type] where
  WithComponents '[] = '[]
  WithComponents (Read a ': rest) = WithComponents rest
  WithComponents (Write a ': rest) = WithComponents rest
  WithComponents (With a ': rest) = a ': WithComponents rest
  WithComponents (Without a ': rest) = WithComponents rest

type family WithoutComponents (accesses :: [Type]) :: [Type] where
  WithoutComponents '[] = '[]
  WithoutComponents (Read a ': rest) = WithoutComponents rest
  WithoutComponents (Write a ': rest) = WithoutComponents rest
  WithoutComponents (With a ': rest) = WithoutComponents rest
  WithoutComponents (Without a ': rest) = a ': WithoutComponents rest

type family Contains (a :: Type) (list :: [Type]) :: Bool where
  Contains a '[] = 'False
  Contains a (a ': rest) = 'True
  Contains a (b ': rest) = Contains a rest

type family HasOverlap (list1 :: [Type]) (list2 :: [Type]) :: Bool where
  HasOverlap '[] list2 = 'False
  HasOverlap (a ': rest) list2 = Or (Contains a list2) (HasOverlap rest list2)

type family HasDuplicates (list :: [Type]) :: Bool where
  HasDuplicates '[] = 'False
  HasDuplicates (a ': rest) = Or (Contains a rest) (HasDuplicates rest)

type family ValidateAccess (accesses :: [Type]) :: Bool where
  ValidateAccess accesses =
    And
      (Not (HasOverlap (WriteComponents accesses) (ReadComponents accesses)))
      (Not (HasDuplicates (WriteComponents accesses)))

type family And (a :: Bool) (b :: Bool) :: Bool where
  And 'True 'True = 'True
  And 'True 'False = 'False
  And 'False 'True = 'False
  And 'False 'False = 'False

type family Or (a :: Bool) (b :: Bool) :: Bool where
  Or 'True _ = 'True
  Or 'False 'True = 'True
  Or 'False 'False = 'False

type family Not (b :: Bool) :: Bool where
  Not 'True = 'False
  Not 'False = 'True

type ValidAccess accesses = (ValidateAccess accesses ~ 'True)

data Read (a :: Type)

data Write (a :: Type)

data With (a :: Type) = With

data Without (a :: Type) = Without

type family AccessComponent (access :: Type) :: Type where
  AccessComponent (Read a) = a
  AccessComponent (Write a) = a
  AccessComponent (With a) = a
  AccessComponent (Without a) = a

type family GenericQueryableAccess (f :: Type -> Type) :: [Type] where
  GenericQueryableAccess (M1 _ _ f) = GenericQueryableAccess f
  GenericQueryableAccess (f :*: g) = GenericQueryableAccess f ++ GenericQueryableAccess g
  GenericQueryableAccess (K1 _ a) = QueryableAccess a
  GenericQueryableAccess U1 = '[]

class GenericQueryable m (f :: Type -> Type) where
  genericQueryableRep :: m [Maybe (f p)]

instance (Monad m) => GenericQueryable m U1 where
  genericQueryableRep = pure [Just U1]
  {-# INLINE genericQueryableRep #-}

instance
  ( Monad m,
    GenericQueryable m f,
    GenericQueryable m g
  ) =>
  GenericQueryable m (f :*: g)
  where
  genericQueryableRep = do
    fs <- genericQueryableRep
    zipWith (\f g -> (:*:) <$> f <*> g) fs <$> genericQueryableRep
  {-# INLINE genericQueryableRep #-}

instance (Functor m, GenericQueryable m f) => GenericQueryable m (M1 i c f) where
  genericQueryableRep = map (fmap M1) <$> genericQueryableRep
  {-# INLINE genericQueryableRep #-}

instance (Functor m, Queryable m a) => GenericQueryable m (K1 i a) where
  genericQueryableRep = fmap (map (fmap K1) . unQuery) queryable
  {-# INLINE genericQueryableRep #-}

class Queryable m a where
  type QueryableAccess a :: [Type]
  type QueryableAccess a = GenericQueryableAccess (Rep a)

  queryable :: m (Query a)
  default queryable ::
    ( Functor m,
      Generic a,
      GenericQueryable m (Rep a),
      QueryableAccess a ~ GenericQueryableAccess (Rep a),
      ValidAccess (QueryableAccess a)
    ) =>
    m (Query a)
  queryable = fmap (Query . map (fmap to)) genericQueryableRep
  {-# INLINE queryable #-}

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    ValidAccess (QueryableAccess a ++ QueryableAccess b)
  ) =>
  Queryable m (a, b)
  where
  type QueryableAccess (a, b) = QueryableAccess a ++ QueryableAccess b

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    ValidAccess (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
  ) =>
  Queryable m (a, b, c)
  where
  type QueryableAccess (a, b, c) = QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c)

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    Queryable m d,
    ValidAccess
      ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
  ) =>
  Queryable m (a, b, c, d)
  where
  type QueryableAccess (a, b, c, d) = (QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d)

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    Queryable m d,
    Queryable m e,
    ValidAccess
      ( (QueryableAccess a ++ QueryableAccess b)
          ++ (QueryableAccess c ++ (QueryableAccess d ++ QueryableAccess e))
      )
  ) =>
  Queryable m (a, b, c, d, e)
  where
  type
    QueryableAccess (a, b, c, d, e) =
      (QueryableAccess a ++ QueryableAccess b)
        ++ (QueryableAccess c ++ (QueryableAccess d ++ QueryableAccess e))

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    Queryable m d,
    Queryable m e,
    Queryable m f,
    ValidAccess
      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
          ++ (QueryableAccess d ++ (QueryableAccess e ++ QueryableAccess f))
      )
  ) =>
  Queryable m (a, b, c, d, e, f)
  where
  type
    QueryableAccess (a, b, c, d, e, f) =
      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
          ++ (QueryableAccess d ++ (QueryableAccess e ++ QueryableAccess f))
      )

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    Queryable m d,
    Queryable m e,
    Queryable m f,
    Queryable m g,
    ValidAccess
      ( (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
          ++ ((QueryableAccess d ++ QueryableAccess e) ++ (QueryableAccess f ++ QueryableAccess g))
      )
  ) =>
  Queryable m (a, b, c, d, e, f, g)
  where
  type
    QueryableAccess (a, b, c, d, e, f, g) =
      (QueryableAccess a ++ (QueryableAccess b ++ QueryableAccess c))
        ++ ((QueryableAccess d ++ QueryableAccess e) ++ (QueryableAccess f ++ QueryableAccess g))

instance
  ( Monad m,
    Queryable m a,
    Queryable m b,
    Queryable m c,
    Queryable m d,
    Queryable m e,
    Queryable m f,
    Queryable m g,
    Queryable m h,
    ValidAccess
      ( ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
          ++ ((QueryableAccess e ++ QueryableAccess f) ++ (QueryableAccess g ++ QueryableAccess h))
      )
  ) =>
  Queryable m (a, b, c, d, e, f, g, h)
  where
  type
    QueryableAccess (a, b, c, d, e, f, g, h) =
      ((QueryableAccess a ++ QueryableAccess b) ++ (QueryableAccess c ++ QueryableAccess d))
        ++ ((QueryableAccess e ++ QueryableAccess f) ++ (QueryableAccess g ++ QueryableAccess h))