{-# 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 :: forall p. m [Maybe (U1 p)]
genericQueryableRep = [Maybe (U1 p)] -> m [Maybe (U1 p)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [U1 p -> Maybe (U1 p)
forall a. a -> Maybe a
Just U1 p
forall k (p :: k). U1 p
U1]
  {-# INLINE genericQueryableRep #-}

instance
  ( Monad m,
    GenericQueryable m f,
    GenericQueryable m g
  ) =>
  GenericQueryable m (f :*: g)
  where
  genericQueryableRep :: forall p. m [Maybe ((:*:) f g p)]
genericQueryableRep = do
    [Maybe (f p)]
fs <- m [Maybe (f p)]
forall p. m [Maybe (f p)]
forall (m :: * -> *) (f :: * -> *) p.
GenericQueryable m f =>
m [Maybe (f p)]
genericQueryableRep
    (Maybe (f p) -> Maybe (g p) -> Maybe ((:*:) f g p))
-> [Maybe (f p)] -> [Maybe (g p)] -> [Maybe ((:*:) f g p)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe (f p)
f Maybe (g p)
g -> f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f p -> g p -> (:*:) f g p)
-> Maybe (f p) -> Maybe (g p -> (:*:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (f p)
f Maybe (g p -> (:*:) f g p) -> Maybe (g p) -> Maybe ((:*:) f g p)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (g p)
g) [Maybe (f p)]
fs ([Maybe (g p)] -> [Maybe ((:*:) f g p)])
-> m [Maybe (g p)] -> m [Maybe ((:*:) f g p)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Maybe (g p)]
forall p. m [Maybe (g p)]
forall (m :: * -> *) (f :: * -> *) p.
GenericQueryable m f =>
m [Maybe (f p)]
genericQueryableRep
  {-# INLINE genericQueryableRep #-}

instance (Functor m, GenericQueryable m f) => GenericQueryable m (M1 i c f) where
  genericQueryableRep :: forall p. m [Maybe (M1 i c f p)]
genericQueryableRep = (Maybe (f p) -> Maybe (M1 i c f p))
-> [Maybe (f p)] -> [Maybe (M1 i c f p)]
forall a b. (a -> b) -> [a] -> [b]
map ((f p -> M1 i c f p) -> Maybe (f p) -> Maybe (M1 i c f p)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ([Maybe (f p)] -> [Maybe (M1 i c f p)])
-> m [Maybe (f p)] -> m [Maybe (M1 i c f p)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Maybe (f p)]
forall p. m [Maybe (f p)]
forall (m :: * -> *) (f :: * -> *) p.
GenericQueryable m f =>
m [Maybe (f p)]
genericQueryableRep
  {-# INLINE genericQueryableRep #-}

instance (Functor m, Queryable m a) => GenericQueryable m (K1 i a) where
  genericQueryableRep :: forall p. m [Maybe (K1 i a p)]
genericQueryableRep = (Query a -> [Maybe (K1 i a p)])
-> m (Query a) -> m [Maybe (K1 i a p)]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe a -> Maybe (K1 i a p)) -> [Maybe a] -> [Maybe (K1 i a p)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> K1 i a p) -> Maybe a -> Maybe (K1 i a p)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1) ([Maybe a] -> [Maybe (K1 i a p)])
-> (Query a -> [Maybe a]) -> Query a -> [Maybe (K1 i a p)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query a -> [Maybe a]
forall a. Query a -> [Maybe a]
unQuery) m (Query a)
forall (m :: * -> *) a. Queryable m a => m (Query a)
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 = ([Maybe (Rep a Any)] -> Query a)
-> m [Maybe (Rep a Any)] -> m (Query a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Maybe a] -> Query a
forall a. [Maybe a] -> Query a
Query ([Maybe a] -> Query a)
-> ([Maybe (Rep a Any)] -> [Maybe a])
-> [Maybe (Rep a Any)]
-> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Rep a Any) -> Maybe a) -> [Maybe (Rep a Any)] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map ((Rep a Any -> a) -> Maybe (Rep a Any) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to)) m [Maybe (Rep a Any)]
forall p. m [Maybe (Rep a p)]
forall (m :: * -> *) (f :: * -> *) p.
GenericQueryable m f =>
m [Maybe (f p)]
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))