Add explMemberSet method to ExplMembers typeclass

apecs-physics/src/Apecs/Physics/Body.hs

@@ -22,6 +22,7 @@ import           Control.Monad.IO.Class (MonadIO)
 import qualified Data.IntMap         as M
 import qualified Data.IntSet         as S
 import           Data.IORef
+import qualified Data.IntSet         as IS
 import qualified Data.Vector.Unboxed as U
 import           Foreign.ForeignPtr  (withForeignPtr)
 import           Foreign.Ptr
@@ -87,6 +88,7 @@ instance MonadIO m => ExplDestroy m (Space Body) where
 
 instance MonadIO m => ExplMembers m (Space Body) where
   explMembers (Space bMap _ _ _ _) = liftIO $ U.fromList . M.keys <$> readIORef bMap
+  explMemberSet (Space bMap _ _ _ _) = liftIO $ M.keysSet <$> readIORef bMap
 
 instance MonadIO m => ExplGet m (Space Body) where
   explExists (Space bMap _ _ _ _) ety = liftIO $ M.member ety <$> readIORef bMap

apecs-physics/src/Apecs/Physics/Constraint.hs

@@ -24,6 +24,7 @@ import           Control.Monad.IO.Class (MonadIO)
 import qualified Data.IntMap         as M
 import qualified Data.IntSet         as S
 import           Data.IORef
+import qualified Data.IntSet         as IS
 import qualified Data.Vector.Unboxed as U
 import           Foreign.ForeignPtr  (withForeignPtr)
 import           Foreign.Ptr
@@ -178,6 +179,7 @@ instance MonadIO m => ExplDestroy m (Space Constraint) where
 
 instance MonadIO m => ExplMembers m (Space Constraint) where
   explMembers (Space _ _ cMap _ _) = liftIO $ U.fromList . M.keys <$> readIORef cMap
+  explMemberSet (Space _ _ cMap _ _) = liftIO $ M.keysSet <$> readIORef cMap
 
 instance MonadIO m => ExplGet m (Space Constraint) where
   explExists (Space _ _ cMap _ _) ety = liftIO $ M.member ety <$> readIORef cMap

apecs-physics/src/Apecs/Physics/Shape.hs

@@ -19,6 +19,7 @@ import           Data.Bits
 import qualified Data.IntMap          as M
 import qualified Data.IntSet          as S
 import           Data.IORef
+import qualified Data.IntSet          as IS
 import           Data.Monoid          ((<>))
 import qualified Data.Vector.Storable as V
 import qualified Data.Vector.Unboxed  as U
@@ -62,6 +63,7 @@ instance (MonadIO m, Has w m Physics) => Has w m Shape where
 
 instance MonadIO m => ExplMembers m (Space Shape) where
   explMembers (Space _ sMap _ _ _) = liftIO $ U.fromList . M.keys <$> readIORef sMap
+  explMemberSet (Space _ sMap _ _ _) = liftIO $ M.keysSet <$> readIORef sMap
 
 instance MonadIO m => ExplDestroy m (Space Shape) where
   explDestroy (Space bMap sMap _ _ spc) sEty = liftIO $ do

apecs-stm/src/Apecs/STM.hs

@@ -32,6 +32,7 @@ import           Data.Maybe
 import           Data.Monoid                 (Sum (..))
 import           Data.Semigroup
 import           Data.Typeable (Typeable, typeRep)
+import qualified Data.IntSet                 as IS
 import qualified Data.Vector.Unboxed         as U
 import           Language.Haskell.TH
 import qualified ListT                       as L
@@ -69,6 +70,8 @@ instance ExplDestroy STM (Map c) where
 instance ExplMembers STM (Map c) where
   {-# INLINE explMembers #-}
   explMembers (Map m) = U.unfoldrM L.uncons $ fst <$> M.listT m
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Map m) = IS.fromList . U.toList <$> explMembers (Map m)
 
 instance ExplInit IO (Map c) where
   {-# INLINE explInit #-}
@@ -87,6 +90,8 @@ instance ExplDestroy IO (Map c) where
 instance ExplMembers IO (Map c) where
   {-# INLINE explMembers #-}
   explMembers m = S.atomically $ explMembers m
+  {-# INLINE explMemberSet #-}
+  explMemberSet m = S.atomically $ explMemberSet m
 
 newtype Unique c = Unique (TVar (Maybe (Int, c)))
 type instance Elem (Unique c) = c
@@ -118,6 +123,10 @@ instance ExplMembers STM (Unique c) where
   explMembers (Unique ref) = flip fmap (readTVar ref) $ \case
     Nothing -> mempty
     Just (ety, _) -> U.singleton ety
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Unique ref) = flip fmap (readTVar ref) $ \case
+    Nothing -> mempty
+    Just (ety, _) -> IS.singleton ety
 
 instance ExplInit IO (Unique c) where
   {-# INLINE explInit #-}
@@ -136,6 +145,8 @@ instance ExplDestroy IO (Unique c) where
 instance ExplMembers IO (Unique c) where
   {-# INLINE explMembers #-}
   explMembers m = S.atomically $ explMembers m
+  {-# INLINE explMemberSet #-}
+  explMemberSet m = S.atomically $ explMemberSet m
 
 newtype Global c = Global (TVar c)
 type instance Elem (Global c) = c

apecs/src/Apecs/Components.hs

@@ -14,6 +14,8 @@
 module Apecs.Components where
 
 import Data.Functor.Identity
+import qualified Data.IntSet          as IS
+import qualified Data.Vector.Unboxed  as U
 
 import           Apecs.Core
 import qualified Apecs.THTuples as T
@@ -40,6 +42,8 @@ instance ExplSet m s => ExplSet m (Identity s) where
 instance ExplMembers m s => ExplMembers m (Identity s) where
   {-# INLINE explMembers #-}
   explMembers (Identity s) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Identity s) = explMemberSet s
 instance ExplDestroy m s => ExplDestroy m (Identity s) where
   {-# INLINE explDestroy #-}
   explDestroy (Identity s) = explDestroy s
@@ -136,6 +140,12 @@ instance (ExplDestroy m sa, ExplDestroy m sb)
   explDestroy (EitherStore sa sb) ety =
     explDestroy sa ety >> explDestroy sb ety
 
+instance (ExplMembers m sa, ExplMembers m sb) => ExplMembers m (EitherStore sa sb) where
+  {-# INLINE explMemberSet #-}
+  explMemberSet (EitherStore sa sb) = IS.union <$> explMemberSet sa <*> explMemberSet sb
+  {-# INLINE explMembers #-}
+  explMembers s = U.fromList . IS.toList <$> explMemberSet s
+
 -- Unit instances ()
 instance Monad m => Has w m () where
   {-# INLINE getStore #-}
@@ -183,6 +193,8 @@ instance ExplGet m s => ExplGet m (FilterStore s) where
 instance ExplMembers m s => ExplMembers m (FilterStore s) where
   {-# INLINE explMembers #-}
   explMembers (FilterStore s) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet (FilterStore s) = explMemberSet s
 
 -- | Pseudostore used to produce components of type 'Entity'.
 -- Always returns @True@ for @explExists@, and echoes back the entity argument for @explGet@.

apecs/src/Apecs/Core.hs

@@ -13,6 +13,7 @@
 module Apecs.Core where
 
 import           Control.Monad.Trans.Reader
+import qualified Data.IntSet          as IS
 import qualified Data.Vector.Unboxed  as U
 
 -- | An Entity is just an integer, used to index into a component store.
@@ -72,6 +73,10 @@ class Monad m => ExplMembers m s where
   -- | Returns an unboxed vector of member indices
   explMembers :: s -> m (U.Vector Int)
 
+  -- | Returns an IntSet of member indices
+  explMemberSet :: s -> m IS.IntSet
+  explMemberSet s = IS.fromList . U.toList <$> explMembers s
+
 type Get     w m c = (Has w m c, ExplGet     m (Storage c))
 type Set     w m c = (Has w m c, ExplSet     m (Storage c))
 type Members w m c = (Has w m c, ExplMembers m (Storage c))

apecs/src/Apecs/Experimental/Children.hs

@@ -136,6 +136,9 @@ instance (MonadIO m, ExplMembers m s) => ExplMembers m (Children s) where
   {-# INLINE explMembers #-}
   explMembers :: Children s -> m (U.Vector Int)
   explMembers (Children _ _ s) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet :: Children s -> m IntSet
+  explMemberSet (Children _ _ s) = explMemberSet s
 
 instance (MonadIO m, ExplGet m s, Typeable (Elem s)) => ExplGet m (Children s) where
   {-# INLINE explGet #-}
@@ -220,6 +223,9 @@ instance ExplMembers m s => ExplMembers m (ChildValueStore s) where
   {-# INLINE explMembers #-}
   explMembers :: ChildValueStore s -> m (U.Vector Int)
   explMembers (ChildValueStore (Children _ _ s)) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet :: ChildValueStore s -> m IntSet
+  explMemberSet (ChildValueStore (Children _ _ s)) = explMemberSet s
 
 instance ExplGet m s => ExplGet m (ChildValueStore s) where
   {-# INLINE explExists #-}
@@ -264,6 +270,10 @@ instance MonadIO m => ExplMembers m (ChildListStore s) where
   explMembers :: ChildListStore s -> m (U.Vector Int)
   explMembers (ChildListStore (Children parentToChildren _ _)) = do
     liftIO $ U.fromList . M.keys <$> IORef.readIORef parentToChildren
+  {-# INLINE explMemberSet #-}
+  explMemberSet :: ChildListStore s -> m IntSet
+  explMemberSet (ChildListStore (Children parentToChildren _ _)) =
+    liftIO $ M.keysSet <$> IORef.readIORef parentToChildren
 
 instance (MonadIO m, Typeable (Elem s)) => ExplGet m (ChildListStore s) where
   {-# INLINE explExists #-}

apecs/src/Apecs/Experimental/Components.hs

@@ -13,6 +13,7 @@ module Apecs.Experimental.Components
   , Head (..)
   ) where
 
+import qualified Data.IntSet as IS
 import qualified Data.Vector.Unboxed as U
 
 import Apecs.Core
@@ -52,3 +53,6 @@ instance (ExplGet m s) => ExplGet m (HeadStore s) where
 
 instance (ExplMembers m s) => ExplMembers m (HeadStore s) where
   explMembers (HeadStore s) = U.take 1 <$> explMembers s
+  explMemberSet (HeadStore s) = do
+    members <- explMembers s
+    pure $ if U.null members then mempty else IS.singleton (U.head members)

apecs/src/Apecs/Experimental/Reactive.hs

@@ -96,6 +96,8 @@ instance ExplGet m s => ExplGet m (Reactive r s) where
 instance ExplMembers m s => ExplMembers m (Reactive r s) where
   {-# INLINE explMembers #-}
   explMembers (Reactive _ s) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Reactive _ s) = explMemberSet s
 
 -- | Prints a message to stdout every time a component is updated.
 data Printer c = Printer

apecs/src/Apecs/Experimental/Stores.hs

@@ -84,6 +84,7 @@ instance
   , Elem (s (Stack c)) ~ Stack c
   ) => ExplMembers m (Pushdown s c) where
     explMembers (Pushdown s) = explMembers s
+    explMemberSet (Pushdown s) = explMemberSet s
 
 instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where
   type Storage (Stack c) = StackStore (Storage c)
@@ -120,3 +121,4 @@ instance
   , ExplMembers m (s (Stack c))
   ) => ExplMembers m (StackStore (Pushdown s c)) where
   explMembers (StackStore (Pushdown s)) = explMembers s
+  explMemberSet (StackStore (Pushdown s)) = explMemberSet s

apecs/src/Apecs/Stores.hs

@@ -23,6 +23,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class   (lift)
 import           Data.Bits                   (shiftL, (.&.))
 import qualified Data.IntMap.Strict          as M
+import qualified Data.IntSet                 as IS
 import           Data.IORef
 import           Data.Proxy
 import           Data.Typeable               (Typeable, typeRep)
@@ -66,6 +67,8 @@ instance MonadIO m => ExplDestroy m (Map c) where
 instance MonadIO m => ExplMembers m (Map c) where
   {-# INLINE explMembers #-}
   explMembers (Map ref) = liftIO$ U.fromList . M.keys <$> readIORef ref
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Map ref) = liftIO$ M.keysSet <$> readIORef ref
 
 -- | A Unique contains zero or one component.
 --   Writing to it overwrites both the previous component and its owner.
@@ -101,6 +104,10 @@ instance MonadIO m => ExplMembers m (Unique c) where
   explMembers (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case
     Nothing -> mempty
     Just (ety, _) -> U.singleton ety
+  {-# INLINE explMemberSet #-}
+  explMemberSet (Unique ref) = liftIO$ flip fmap (readIORef ref) $ \case
+    Nothing -> mempty
+    Just (ety, _) -> IS.singleton ety
 
 -- | A 'Global' contains exactly one component.
 --   The initial value is 'mempty' from the component's 'Monoid' instance.
@@ -226,6 +233,8 @@ instance ExplGet m s => ExplGet m (ReadOnly s) where
 instance ExplMembers m s => ExplMembers m (ReadOnly s) where
   {-# INLINE explMembers #-}
   explMembers (ReadOnly s) = explMembers s
+  {-# INLINE explMemberSet #-}
+  explMemberSet (ReadOnly s) = explMemberSet s
 
 setReadOnly :: forall w m s c.
   ( Has w m c

apecs/src/Apecs/TH.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies    #-}
@@ -8,7 +9,11 @@ module Apecs.TH
   , makeWorldAndComponents
   , makeMapComponents
   , makeMapComponentsFor
-  , makeInstanceTuples
+  , hasStoreInstance
+  , makeInstanceFold
+  , mkFoldT
+  , mkTupleT
+  , mkEitherT
   ) where
 
 import           Control.Monad        (filterM)
@@ -54,31 +59,73 @@ makeWorldNoEC worldName cTypes = do
           getStore = let field $pat = $(varE x) in asks field
       |]
 
-  -- Destructible type synonym
-  destructible_decl <- makeInstanceTuples (worldName ++ "Destructible") ''ExplDestroy cTypes
+  -- World-wide collections for particular types
+  let skip = ["Global", "ReadOnly"]
+  let m = ConT ''IO
+  destructible <- filterM (hasStoreInstance skip ''ExplDestroy m) cTypes
+  destructible_decl <- makeInstanceFold mkTupleT (worldName ++ "Destructible") destructible
 
-  pure $ data_decl : destructible_decl ++ concat (init_world : instances)
+  enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes
+  enumerable_decl <- makeInstanceFold mkEitherT (worldName ++ "Enumerable") enumerable
+
+  pure $ data_decl : destructible_decl : enumerable_decl : concat (init_world : instances)
   where
     enumerate :: [a] -> [(Int,a)]
     enumerate = zip [0..]
 
-makeInstanceTuples :: String -> Name -> [Name] -> Q [Dec]
-makeInstanceTuples synName cls cTypes = do
-  let destructible ty
-        | nameBase ty == "EntityCounter" = pure False
-        | otherwise = isInstance cls [ConT ''IO, AppT (ConT ''Storage) (ConT ty)]
-  destroyableTypes <- filterM destructible cTypes
-  let getType ty = ConT ty
-  decl <- tySynD (mkName synName) [] (pure $ mkTupleT $ getType <$> destroyableTypes)
-  return [decl]
-
 mkTupleT :: [Type] -> Type
 mkTupleT [] = ConT ''()
 mkTupleT [t] = t
 mkTupleT ts
   | len <= 8 = foldl AppT (TupleT len) ts
   | otherwise = foldl AppT (TupleT 8) (take 7 ts ++ [mkTupleT (drop 7 ts)])
-  where len = length ts
+  where
+    len = length ts
+
+mkEitherT :: [Type] -> Type
+mkEitherT = mkFoldT ''Either ''()
+
+mkFoldT :: Name -> Name -> [Type] -> Type
+mkFoldT _con nil [] = ConT nil
+mkFoldT _con _nil [t] = t
+mkFoldT con nil (t : ts) = AppT (AppT (ConT con) t) (mkFoldT con nil ts)
+
+makeInstanceFold :: ([Type] -> Type) -> String -> [Name] -> Q Dec
+makeInstanceFold foldT synName cTypes =
+  tySynD (mkName synName) [] . pure $
+    foldT $ map ConT cTypes
+
+-- | Resolve storage type and check for an instance like @ExplThis m (Map Position)@
+--
+-- Can be used to pre-filter component lists for 'makeInstanceFold'.
+hasStoreInstance
+  :: [String] -- ^ Skip those stores
+  -> Name -- ^ Class name (ExplThis)
+  -> Type -- ^ @m@ var like @ConT ''IO@
+  -> Name -- ^ component type name
+  -> Q Bool
+hasStoreInstance skip cls mType cType = do
+  storageT <- resolveStorageType cType
+  case storageT of
+    Just (AppT (ConT store) _stored)
+      | nameBase store `elem` skip -> pure False
+    Just resolved -> isInstance cls [mType, resolved]
+    Nothing -> pure False
+
+-- | Resolve the @Storage@ type family for a component type.
+--
+-- On GHC < 9.2, @isInstance@ does not reduce type family applications,
+-- so we need to resolve @Storage ty@ before passing it to @isInstance@.
+resolveStorageType :: Name -> Q (Maybe Type)
+resolveStorageType ty = do
+  insts <- reifyInstances ''Storage [ConT ty]
+  pure $ case insts of
+#if MIN_VERSION_template_haskell(2,15,0)
+    [TySynInstD (TySynEqn _ _ rhs)] -> Just rhs
+#else
+    [TySynInstD _ (TySynEqn _ rhs)] -> Just rhs
+#endif
+    _ -> Nothing
 
 -- | Creates 'Component' instances with 'Map' stores
 makeMapComponents :: [Name] -> Q [Dec]