{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Aztecs.ECS.HSet
  ( HSet (..),
    Lookup (..),
    AdjustM (..),
    Subset (..),
  )
where

import Data.Kind
import Prelude hiding (lookup)

data HSet ts where
  HEmpty :: HSet '[]
  HCons :: t -> HSet ts -> HSet (t ': ts)

instance (ShowHSet ts) => Show (HSet ts) where
  show :: HSet ts -> String
show = HSet ts -> String
forall (ts :: [*]). ShowHSet ts => HSet ts -> String
showHSet
  {-# INLINE show #-}

class ShowHSet ts where
  showHSet :: HSet ts -> String

instance ShowHSet '[] where
  showHSet :: HSet '[] -> String
showHSet HSet '[]
_ = String
"HEmpty"
  {-# INLINE showHSet #-}

instance (Show t, ShowHSet ts) => ShowHSet (t ': ts) where
  showHSet :: HSet (t : ts) -> String
showHSet (HCons t
x HSet ts
xs) = String
"HCons " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HSet ts -> String
forall (ts :: [*]). ShowHSet ts => HSet ts -> String
showHSet HSet ts
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  {-# INLINE showHSet #-}

type family Elem (t :: k) (ts :: [k]) :: Bool where
  Elem t '[] = 'False
  Elem t (t ': xs) = 'True
  Elem t (_ ': xs) = Elem t xs

class Lookup (t :: Type) (ts :: [Type]) where
  lookup :: HSet ts -> t

instance {-# OVERLAPPING #-} Lookup t (t ': ts) where
  lookup :: HSet (t : ts) -> t
lookup (HCons t
x HSet ts
_) = t
t
x
  {-# INLINE lookup #-}

instance {-# OVERLAPPABLE #-} (Lookup t ts) => Lookup t (u ': ts) where
  lookup :: HSet (u : ts) -> t
lookup (HCons t
_ HSet ts
xs) = HSet ts -> t
forall t (ts :: [*]). Lookup t ts => HSet ts -> t
lookup HSet ts
xs
  {-# INLINE lookup #-}

class AdjustM m t ts where
  adjustM :: (t -> m t) -> HSet ts -> m (HSet ts)

instance {-# OVERLAPPING #-} (Applicative m) => AdjustM m t (t ': ts) where
  adjustM :: (t -> m t) -> HSet (t : ts) -> m (HSet (t : ts))
adjustM t -> m t
f (HCons t
x HSet ts
xs) = t -> HSet ts -> HSet (t : ts)
forall t (ts :: [*]). t -> HSet ts -> HSet (t : ts)
HCons (t -> HSet ts -> HSet (t : ts))
-> m t -> m (HSet ts -> HSet (t : ts))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> m t
f t
t
x m (HSet ts -> HSet (t : ts)) -> m (HSet ts) -> m (HSet (t : ts))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HSet ts -> m (HSet ts)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HSet ts
HSet ts
xs
  {-# INLINE adjustM #-}

instance {-# OVERLAPPABLE #-} (Functor m, AdjustM m t ts) => AdjustM m t (u ': ts) where
  adjustM :: (t -> m t) -> HSet (u : ts) -> m (HSet (u : ts))
adjustM t -> m t
f (HCons t
y HSet ts
xs) = u -> HSet ts -> HSet (u : ts)
forall t (ts :: [*]). t -> HSet ts -> HSet (t : ts)
HCons u
t
y (HSet ts -> HSet (u : ts)) -> m (HSet ts) -> m (HSet (u : ts))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (t -> m t) -> HSet ts -> m (HSet ts)
forall (m :: * -> *) t (ts :: [*]).
AdjustM m t ts =>
(t -> m t) -> HSet ts -> m (HSet ts)
adjustM t -> m t
f HSet ts
HSet ts
xs
  {-# INLINE adjustM #-}

class Subset (subset :: [Type]) (superset :: [Type]) where
  subset :: HSet superset -> HSet subset

instance Subset '[] superset where
  subset :: HSet superset -> HSet '[]
subset HSet superset
_ = HSet '[]
HEmpty
  {-# INLINE subset #-}

instance (Lookup t superset, Subset ts superset) => Subset (t ': ts) superset where
  subset :: HSet superset -> HSet (t : ts)
subset HSet superset
hset = t -> HSet ts -> HSet (t : ts)
forall t (ts :: [*]). t -> HSet ts -> HSet (t : ts)
HCons (HSet superset -> t
forall t (ts :: [*]). Lookup t ts => HSet ts -> t
lookup HSet superset
hset) (forall (subset :: [*]) (superset :: [*]).
Subset subset superset =>
HSet superset -> HSet subset
subset @ts HSet superset
hset)
  {-# INLINE subset #-}