Flags.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-| A store for flag-like components backed by an off-heap 'Index'.

A flag component has exactly one value, so the store keeps only membership.
Derive 'Generic' for the component to let the store produce that value:

@
data Dead = Dead deriving (Generic)
instance Component Dead where type Storage Dead = Flags Dead
@
-}
module Apecs.Stores.Flags
  ( Flags (..)
  , Unit (..)
  , clear
  ) where

import Apecs.Core (Component (..), Elem, ExplDestroy (..), ExplGet (..), ExplInit (..), ExplMembers (..), ExplSet (..), Has (..), SystemT)
import Apecs.Stores.Index (HasIndex (..), Index)
import Apecs.Stores.Index qualified as Index
import Control.Monad.IO.Class (MonadIO (..))
import GHC.Generics (Generic (..), M1 (..), U1 (..))

newtype Flags c = Flags Index

type instance Elem (Flags c) = c

class Unit f where
  unit :: f p

instance Unit U1 where
  unit = U1

instance (Unit f) => Unit (M1 i meta f) where
  unit = M1 unit

instance (MonadIO m) => ExplInit m (Flags c) where
  explInit = liftIO $ Flags <$> Index.new

instance (MonadIO m, Generic c, Unit (Rep c)) => ExplGet m (Flags c) where
  explGet _ _ = pure $ to unit
  {-# INLINE explGet #-}
  explExists (Flags index) = liftIO . Index.member index
  {-# INLINE explExists #-}

instance (MonadIO m) => ExplSet m (Flags c) where
  explSet (Flags index) ety _ = liftIO $ Index.insert index ety
  {-# INLINE explSet #-}

instance (MonadIO m) => ExplDestroy m (Flags c) where
  explDestroy (Flags index) = liftIO . Index.delete index
  {-# INLINE explDestroy #-}

instance (MonadIO m) => ExplMembers m (Flags c) where
  explMembers (Flags index) = liftIO $ Index.toVector index
  {-# INLINE explMembers #-}

instance HasIndex (Flags c) where
  getIndex (Flags index) = index

clear :: forall c w m. (Has w m c, Storage c ~ Flags c, MonadIO m) => SystemT w m ()
clear = do
  Flags index <- getStore @w @m @c
  liftIO $ Index.clear index