From 4d4b24f42536d43db31a740f53a4336da27e1b36 Mon Sep 17 00:00:00 2001
From: "google-labs-jules[bot]"
 <161369871+google-labs-jules[bot]@users.noreply.github.com>
Date: Tue, 10 Mar 2026 09:01:42 +0000
Subject: [PATCH 01/10] Add makeComponentTags TH function

Added `makeComponentTags` in `Apecs.TH` to fold component types into an enum of tags as requested.
It takes a string for the enum name and a list of component types, and generates a data declaration where the constructors are the component names prefixed with `T`.
Also added the generation test to the `WorldEnumerable` scenario in `apecs/test/Main.hs`.

Co-authored-by: dpwiz <486682+dpwiz@users.noreply.github.com>
---
 apecs/src/Apecs/TH.hs | 10 ++++++++++
 apecs/test/Main.hs    |  2 ++
 2 files changed, 12 insertions(+)

diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs
index 4d04718..2c51d17 100644
--- a/apecs/src/Apecs/TH.hs
+++ b/apecs/src/Apecs/TH.hs
@@ -9,6 +9,7 @@ module Apecs.TH
   , makeWorldAndComponents
   , makeMapComponents
   , makeMapComponentsFor
+  , makeComponentTags
   , hasStoreInstance
   , makeInstanceFold
   , mkFoldT
@@ -19,6 +20,7 @@ module Apecs.TH
 import           Control.Monad        (filterM)
 import           Control.Monad.Trans.Reader (asks)
 import           Data.Traversable     (for)
+import           GHC.Generics         (Generic)
 import           Language.Haskell.TH
 
 import           Apecs.Core
@@ -171,3 +173,11 @@ turns into
 -}
 makeWorld :: String -> [Name] -> Q [Dec]
 makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])
+
+-- | Creates an Enum of component tags
+makeComponentTags :: String -> [Name] -> Q [Dec]
+makeComponentTags tagName cTypes = do
+  let dataName = mkName tagName
+      cons = map (\c -> NormalC (mkName ("T" ++ nameBase c)) []) cTypes
+      derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded, ''Generic]) ]
+  return [DataD [] dataName [] Nothing cons derivs]
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index 1cbd105..283b237 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
@@ -141,6 +142,7 @@ makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]
 -- Generate a (T1, T2, T3) tuple in a contrived way
 -- (that allows processing component lists when placed in external file)
 pure <$> makeInstanceFold mkTupleT "WorldEnumerableShowable" [''T1, ''T2, ''T3]
+makeComponentTags "WorldTags" [''G1, ''T1, ''T2, ''T3]
 
 worldEntityIds :: System WorldEnumerable S.IntSet
 worldEntityIds = do

From 0bb9d88cf2595157c078c3cb7f7a6f25fa8f71e4 Mon Sep 17 00:00:00 2001
From: "google-labs-jules[bot]"
 <161369871+google-labs-jules[bot]@users.noreply.github.com>
Date: Tue, 10 Mar 2026 13:02:15 +0000
Subject: [PATCH 02/10] feat: add makeComponentSum TH generator

Co-authored-by: dpwiz <486682+dpwiz@users.noreply.github.com>
---
 apecs/src/Apecs/TH.hs | 8 ++++++++
 apecs/test/Main.hs    | 7 +++++++
 2 files changed, 15 insertions(+)

diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs
index 2c51d17..2a200e3 100644
--- a/apecs/src/Apecs/TH.hs
+++ b/apecs/src/Apecs/TH.hs
@@ -10,6 +10,7 @@ module Apecs.TH
   , makeMapComponents
   , makeMapComponentsFor
   , makeComponentTags
+  , makeComponentSum
   , hasStoreInstance
   , makeInstanceFold
   , mkFoldT
@@ -181,3 +182,10 @@ makeComponentTags tagName cTypes = do
       cons = map (\c -> NormalC (mkName ("T" ++ nameBase c)) []) cTypes
       derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded, ''Generic]) ]
   return [DataD [] dataName [] Nothing cons derivs]
+
+-- | Creates a sum type of components
+makeComponentSum :: String -> [Name] -> Q [Dec]
+makeComponentSum tagName cTypes = do
+  let dataName = mkName tagName
+      cons = map (\c -> NormalC (mkName (tagName ++ nameBase c)) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
+  return [DataD [] dataName [] Nothing cons []]
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index 283b237..88b5e1e 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -143,6 +143,7 @@ makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]
 -- (that allows processing component lists when placed in external file)
 pure <$> makeInstanceFold mkTupleT "WorldEnumerableShowable" [''T1, ''T2, ''T3]
 makeComponentTags "WorldTags" [''G1, ''T1, ''T2, ''T3]
+makeComponentSum "WorldSum" [''G1, ''T1, ''T2, ''T3]
 
 worldEntityIds :: System WorldEnumerable S.IntSet
 worldEntityIds = do
@@ -319,5 +320,11 @@ prop_children (NonEmpty writes) = assertSys initChildTest $ do
 
   return True
 
+prop_worldSum :: Property
+prop_worldSum = once $ property $
+  let _g1 = WorldSumG1 (G1 ())
+      _t1 = WorldSumT1 (T1 2)
+  in True
+
 return []
 main = $quickCheckAll

From 2ccd2beb0b215c578aff7d017de9f961ecde7682 Mon Sep 17 00:00:00 2001
From: IC Rainbow <486682+dpwiz@users.noreply.github.com>
Date: Tue, 10 Mar 2026 18:34:45 +0200
Subject: [PATCH 03/10] Add makeWorldTags function and corresponding test (#8)

Also clean up some of the tag/sum mess.

Co-authored-by: google-labs-jules[bot] <161369871+google-labs-jules[bot]@users.noreply.github.com>
---
 apecs/src/Apecs/TH.hs | 32 ++++++++++++++++++++------------
 apecs/test/Main.hs    | 32 ++++++++++++++++++++++++--------
 2 files changed, 44 insertions(+), 20 deletions(-)

diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs
index 2a200e3..4a0445a 100644
--- a/apecs/src/Apecs/TH.hs
+++ b/apecs/src/Apecs/TH.hs
@@ -7,6 +7,7 @@ module Apecs.TH
   ( makeWorld
   , makeWorldNoEC
   , makeWorldAndComponents
+  , makeTaggedComponents
   , makeMapComponents
   , makeMapComponentsFor
   , makeComponentTags
@@ -21,7 +22,6 @@ module Apecs.TH
 import           Control.Monad        (filterM)
 import           Control.Monad.Trans.Reader (asks)
 import           Data.Traversable     (for)
-import           GHC.Generics         (Generic)
 import           Language.Haskell.TH
 
 import           Apecs.Core
@@ -176,16 +176,24 @@ makeWorld :: String -> [Name] -> Q [Dec]
 makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])
 
 -- | Creates an Enum of component tags
-makeComponentTags :: String -> [Name] -> Q [Dec]
-makeComponentTags tagName cTypes = do
-  let dataName = mkName tagName
-      cons = map (\c -> NormalC (mkName ("T" ++ nameBase c)) []) cTypes
-      derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded, ''Generic]) ]
-  return [DataD [] dataName [] Nothing cons derivs]
+makeComponentTags :: String -> String -> [Name] -> Q [Dec]
+makeComponentTags typeName consPrefix cTypes = do
+  let
+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes
+    derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ]
+  pure [DataD [] (mkName typeName) [] Nothing cons derivs]
 
 -- | Creates a sum type of components
-makeComponentSum :: String -> [Name] -> Q [Dec]
-makeComponentSum tagName cTypes = do
-  let dataName = mkName tagName
-      cons = map (\c -> NormalC (mkName (tagName ++ nameBase c)) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
-  return [DataD [] dataName [] Nothing cons []]
+makeComponentSum :: String -> String -> [Name] -> Q [Dec]
+makeComponentSum typeName consPrefix cTypes = do
+  let
+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
+    derivs = [ DerivClause Nothing (map ConT [''Show]) ]
+  pure [DataD [] (mkName typeName) [] Nothing cons derivs]
+
+-- | Calls 'makeComponentTags' and 'makeComponentSum' using the world name.
+makeTaggedComponents :: String -> [Name] -> Q [Dec]
+makeTaggedComponents worldName cTypes = do
+  tags <- makeComponentTags (worldName ++ "Tag") "T" cTypes
+  sums <- makeComponentSum (worldName ++ "Sum") "S" cTypes
+  pure $ tags ++ sums
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index 88b5e1e..35d8fc6 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances       #-}
@@ -19,6 +20,7 @@ import qualified Data.Foldable               as F
 import qualified Data.IntSet                 as S
 import           Data.IORef
 import           Data.List                   ((\\), delete, nub, sort)
+import qualified Data.Map.Strict             as M
 import qualified Data.Vector.Unboxed         as U
 import           Test.QuickCheck
 import           Test.QuickCheck.Monadic
@@ -139,11 +141,10 @@ instance Component G1 where type Storage G1 = Global G1
 
 -- Tests Enumerable class
 makeWorld "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]
+makeTaggedComponents "WorldEnumerable" [''G1, ''T1, ''T2, ''T3]
 -- Generate a (T1, T2, T3) tuple in a contrived way
 -- (that allows processing component lists when placed in external file)
 pure <$> makeInstanceFold mkTupleT "WorldEnumerableShowable" [''T1, ''T2, ''T3]
-makeComponentTags "WorldTags" [''G1, ''T1, ''T2, ''T3]
-makeComponentSum "WorldSum" [''G1, ''T1, ''T2, ''T3]
 
 worldEntityIds :: System WorldEnumerable S.IntSet
 worldEntityIds = do
@@ -168,6 +169,27 @@ prop_enumerable dels t12s t3s = assertSys initWorldEnumerable $ do
   actualAfter <- worldEntityIds
   return (expectedBefore == actualBefore && expectedAfter == actualAfter)
 
+prop_tags :: [Entity] -> [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property
+prop_tags dels t12s t3s = assertSys initWorldEnumerable $ do
+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2
+  forM_ t3s $ \(e, t3) -> set e t3
+
+  entities <- worldEntityIds
+
+  eav <- fmap M.fromList . forM (map Entity $ S.toList entities) $ \e -> do
+    tagged <- forM [minBound .. maxBound] $ \t -> fmap (t,) <$> case t of
+      TG1 -> fmap SG1 <$> get e
+      TT1 -> fmap ST1 <$> get e
+      TT2 -> fmap ST2 <$> get e
+      TT3 -> fmap ST3 <$> get e
+    pure (e, M.fromList [ (t, v) | Just (t, v) <- tagged ])
+
+  let it = show (eav :: M.Map Entity (M.Map WorldEnumerableTag WorldEnumerableSum))
+  guard (length it > 0)
+  liftIO $ putStrLn it
+
+  pure True
+
 prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))
 prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))
 
@@ -320,11 +342,5 @@ prop_children (NonEmpty writes) = assertSys initChildTest $ do
 
   return True
 
-prop_worldSum :: Property
-prop_worldSum = once $ property $
-  let _g1 = WorldSumG1 (G1 ())
-      _t1 = WorldSumT1 (T1 2)
-  in True
-
 return []
 main = $quickCheckAll

From 56fc53811fd9f52bb43b0bc8ab1367d3370e8070 Mon Sep 17 00:00:00 2001
From: IC Rainbow <486682+dpwiz@users.noreply.github.com>
Date: Wed, 11 Mar 2026 00:57:50 +0200
Subject: [PATCH 04/10] Add makeTagLookup and makeTagFromSum

Extra utilities to collect and introspect "everything".

Co-authored-by: google-labs-jules[bot] <161369871+google-labs-jules[bot]@users.noreply.github.com>
---
 apecs/src/Apecs/TH.hs | 67 +++++++++++++++++++++++++++++++++++++------
 apecs/test/Main.hs    |  8 ++----
 2 files changed, 60 insertions(+), 15 deletions(-)

diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs
index 4a0445a..89d6abf 100644
--- a/apecs/src/Apecs/TH.hs
+++ b/apecs/src/Apecs/TH.hs
@@ -12,6 +12,8 @@ module Apecs.TH
   , makeMapComponentsFor
   , makeComponentTags
   , makeComponentSum
+  , makeTagLookup
+  , makeTagFromSum
   , hasStoreInstance
   , makeInstanceFold
   , mkFoldT
@@ -177,23 +179,70 @@ makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter
 
 -- | Creates an Enum of component tags
 makeComponentTags :: String -> String -> [Name] -> Q [Dec]
-makeComponentTags typeName consPrefix cTypes = do
-  let
+makeComponentTags typeName consPrefix cTypes = pure [decl]
+  where
+    decl = DataD [] (mkName typeName) [] Nothing cons derivs
     cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes
     derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ]
-  pure [DataD [] (mkName typeName) [] Nothing cons derivs]
 
 -- | Creates a sum type of components
 makeComponentSum :: String -> String -> [Name] -> Q [Dec]
-makeComponentSum typeName consPrefix cTypes = do
-  let
+makeComponentSum typeName consPrefix cTypes = pure [decl]
+  where
+    decl = DataD [] (mkName typeName) [] Nothing cons derivs
     cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
     derivs = [ DerivClause Nothing (map ConT [''Show]) ]
-  pure [DataD [] (mkName typeName) [] Nothing cons derivs]
+
+makeTagLookup :: String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec]
+makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do
+  e <- newName "e"
+  matches <- mapM (makeMatch e) cTypes
+  t <- newName "t"
+  let body = caseE (varE t) (map pure matches)
+  sig <- sigD fName [t| Entity -> $(conT tagN) -> System $(conT worldN) (Maybe $(conT sumN)) |]
+  decl <- funD fName [clause [varP e, varP t] (normalB body) []]
+  pure [sig, decl]
+  where
+    makeMatch e cType = match (conP tagCon []) (normalB [| fmap $(conE sumCon) <$> get $(varE e) |]) []
+      where
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        sumCon = mkName (sumPrefix ++ nameBase cType)
+    fName = mkName funName
+    tagN  = mkName tagType
+    sumN  = mkName sumType
+    worldN = mkName worldName
+
+makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec]
+makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do
+  s <- newName "s"
+
+  sig <- sigD fName [t| $(conT sumN) -> $(conT tagN) |]
+
+  matches <- mapM makeMatch cTypes
+  let body = caseE (varE s) (map pure matches)
+  decl <- funD fName [clause [varP s] (normalB body) []]
+  pure [sig, decl]
+  where
+    makeMatch cType = match (conP sumCon [wildP]) (normalB (conE tagCon)) []
+      where
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        sumCon = mkName (sumPrefix ++ nameBase cType)
+    fName = mkName funName
+    tagN  = mkName tagType
+    sumN  = mkName sumType
 
 -- | Calls 'makeComponentTags' and 'makeComponentSum' using the world name.
 makeTaggedComponents :: String -> [Name] -> Q [Dec]
 makeTaggedComponents worldName cTypes = do
-  tags <- makeComponentTags (worldName ++ "Tag") "T" cTypes
-  sums <- makeComponentSum (worldName ++ "Sum") "S" cTypes
-  pure $ tags ++ sums
+  tags <- makeComponentTags tagType tagPrefix cTypes
+  sums <- makeComponentSum sumType sumPrefix cTypes
+  getter <- makeTagLookup lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes
+  toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes
+  pure $ tags ++ sums ++ getter ++ toTag
+  where
+    tagType = worldName ++ "Tag"
+    tagPrefix = "T"
+    sumType = worldName ++ "Sum"
+    sumPrefix = "S"
+    lookupFunName = "lookup" ++ worldName ++ "Tag"
+    tagFromSumFunName = "tag" ++ sumType
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index 35d8fc6..868b4de 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -20,6 +20,7 @@ import qualified Data.Foldable               as F
 import qualified Data.IntSet                 as S
 import           Data.IORef
 import           Data.List                   ((\\), delete, nub, sort)
+import qualified Data.IntMap.Strict          as IM
 import qualified Data.Map.Strict             as M
 import qualified Data.Vector.Unboxed         as U
 import           Test.QuickCheck
@@ -177,16 +178,11 @@ prop_tags dels t12s t3s = assertSys initWorldEnumerable $ do
   entities <- worldEntityIds
 
   eav <- fmap M.fromList . forM (map Entity $ S.toList entities) $ \e -> do
-    tagged <- forM [minBound .. maxBound] $ \t -> fmap (t,) <$> case t of
-      TG1 -> fmap SG1 <$> get e
-      TT1 -> fmap ST1 <$> get e
-      TT2 -> fmap ST2 <$> get e
-      TT3 -> fmap ST3 <$> get e
+    tagged <- forM [minBound .. maxBound] $ \t -> fmap (t,) <$> lookupWorldEnumerableTag e t
     pure (e, M.fromList [ (t, v) | Just (t, v) <- tagged ])
 
   let it = show (eav :: M.Map Entity (M.Map WorldEnumerableTag WorldEnumerableSum))
   guard (length it > 0)
-  liftIO $ putStrLn it
 
   pure True
 

From 8e05749edfc268f3bff281c7aa5d2c4d766494f5 Mon Sep 17 00:00:00 2001
From: IC Rainbow <aenor.realm@gmail.com>
Date: Wed, 11 Mar 2026 01:08:06 +0200
Subject: [PATCH 05/10] Extract Apecs.TH.Tags

---
 apecs/apecs.cabal          |  1 +
 apecs/src/Apecs/TH.hs      | 75 -------------------------------
 apecs/src/Apecs/TH/Tags.hs | 90 ++++++++++++++++++++++++++++++++++++++
 apecs/test/Main.hs         |  1 +
 4 files changed, 92 insertions(+), 75 deletions(-)
 create mode 100644 apecs/src/Apecs/TH/Tags.hs

diff --git a/apecs/apecs.cabal b/apecs/apecs.cabal
index a0c5d63..5b94e28 100644
--- a/apecs/apecs.cabal
+++ b/apecs/apecs.cabal
@@ -34,6 +34,7 @@ library
     Apecs.Stores
     Apecs.System
     Apecs.TH
+    Apecs.TH.Tags
     Apecs.Util
 
   other-modules:    Apecs.THTuples
diff --git a/apecs/src/Apecs/TH.hs b/apecs/src/Apecs/TH.hs
index 89d6abf..4d04718 100644
--- a/apecs/src/Apecs/TH.hs
+++ b/apecs/src/Apecs/TH.hs
@@ -7,13 +7,8 @@ module Apecs.TH
   ( makeWorld
   , makeWorldNoEC
   , makeWorldAndComponents
-  , makeTaggedComponents
   , makeMapComponents
   , makeMapComponentsFor
-  , makeComponentTags
-  , makeComponentSum
-  , makeTagLookup
-  , makeTagFromSum
   , hasStoreInstance
   , makeInstanceFold
   , mkFoldT
@@ -176,73 +171,3 @@ turns into
 -}
 makeWorld :: String -> [Name] -> Q [Dec]
 makeWorld worldName cTypes = makeWorldNoEC worldName (cTypes ++ [''EntityCounter])
-
--- | Creates an Enum of component tags
-makeComponentTags :: String -> String -> [Name] -> Q [Dec]
-makeComponentTags typeName consPrefix cTypes = pure [decl]
-  where
-    decl = DataD [] (mkName typeName) [] Nothing cons derivs
-    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes
-    derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ]
-
--- | Creates a sum type of components
-makeComponentSum :: String -> String -> [Name] -> Q [Dec]
-makeComponentSum typeName consPrefix cTypes = pure [decl]
-  where
-    decl = DataD [] (mkName typeName) [] Nothing cons derivs
-    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
-    derivs = [ DerivClause Nothing (map ConT [''Show]) ]
-
-makeTagLookup :: String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec]
-makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do
-  e <- newName "e"
-  matches <- mapM (makeMatch e) cTypes
-  t <- newName "t"
-  let body = caseE (varE t) (map pure matches)
-  sig <- sigD fName [t| Entity -> $(conT tagN) -> System $(conT worldN) (Maybe $(conT sumN)) |]
-  decl <- funD fName [clause [varP e, varP t] (normalB body) []]
-  pure [sig, decl]
-  where
-    makeMatch e cType = match (conP tagCon []) (normalB [| fmap $(conE sumCon) <$> get $(varE e) |]) []
-      where
-        tagCon = mkName (tagPrefix ++ nameBase cType)
-        sumCon = mkName (sumPrefix ++ nameBase cType)
-    fName = mkName funName
-    tagN  = mkName tagType
-    sumN  = mkName sumType
-    worldN = mkName worldName
-
-makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec]
-makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do
-  s <- newName "s"
-
-  sig <- sigD fName [t| $(conT sumN) -> $(conT tagN) |]
-
-  matches <- mapM makeMatch cTypes
-  let body = caseE (varE s) (map pure matches)
-  decl <- funD fName [clause [varP s] (normalB body) []]
-  pure [sig, decl]
-  where
-    makeMatch cType = match (conP sumCon [wildP]) (normalB (conE tagCon)) []
-      where
-        tagCon = mkName (tagPrefix ++ nameBase cType)
-        sumCon = mkName (sumPrefix ++ nameBase cType)
-    fName = mkName funName
-    tagN  = mkName tagType
-    sumN  = mkName sumType
-
--- | Calls 'makeComponentTags' and 'makeComponentSum' using the world name.
-makeTaggedComponents :: String -> [Name] -> Q [Dec]
-makeTaggedComponents worldName cTypes = do
-  tags <- makeComponentTags tagType tagPrefix cTypes
-  sums <- makeComponentSum sumType sumPrefix cTypes
-  getter <- makeTagLookup lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes
-  toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes
-  pure $ tags ++ sums ++ getter ++ toTag
-  where
-    tagType = worldName ++ "Tag"
-    tagPrefix = "T"
-    sumType = worldName ++ "Sum"
-    sumPrefix = "S"
-    lookupFunName = "lookup" ++ worldName ++ "Tag"
-    tagFromSumFunName = "tag" ++ sumType
diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs
new file mode 100644
index 0000000..49b66a8
--- /dev/null
+++ b/apecs/src/Apecs/TH/Tags.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
+
+module Apecs.TH.Tags
+  ( makeTaggedComponents
+  , makeComponentTags
+  , makeComponentSum
+  , makeTagLookup
+  , makeTagFromSum
+  ) where
+
+import           Control.Monad        (filterM)
+import           Control.Monad.Trans.Reader (asks)
+import           Data.Traversable     (for)
+import           Language.Haskell.TH
+
+import           Apecs.Core
+import           Apecs.Stores
+import           Apecs.Util           (EntityCounter)
+
+makeTaggedComponents :: String -> [Name] -> Q [Dec]
+makeTaggedComponents worldName cTypes = do
+  tags <- makeComponentTags tagType tagPrefix cTypes
+  sums <- makeComponentSum sumType sumPrefix cTypes
+  getter <- makeTagLookup lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes
+  toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes
+  pure $ tags ++ sums ++ getter ++ toTag
+  where
+    tagType = worldName ++ "Tag"
+    tagPrefix = "T"
+    sumType = worldName ++ "Sum"
+    sumPrefix = "S"
+    lookupFunName = "lookup" ++ worldName ++ "Tag"
+    tagFromSumFunName = "tag" ++ sumType
+
+-- | Creates an Enum of component tags
+makeComponentTags :: String -> String -> [Name] -> Q [Dec]
+makeComponentTags typeName consPrefix cTypes = pure [decl]
+  where
+    decl = DataD [] (mkName typeName) [] Nothing cons derivs
+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) []) cTypes
+    derivs = [ DerivClause Nothing (map ConT [''Eq, ''Ord, ''Show, ''Enum, ''Bounded]) ]
+
+-- | Creates a sum type of components
+makeComponentSum :: String -> String -> [Name] -> Q [Dec]
+makeComponentSum typeName consPrefix cTypes = pure [decl]
+  where
+    decl = DataD [] (mkName typeName) [] Nothing cons derivs
+    cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
+    derivs = [ DerivClause Nothing (map ConT [''Show]) ]
+
+makeTagLookup :: String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec]
+makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do
+  e <- newName "e"
+  matches <- mapM (makeMatch e) cTypes
+  t <- newName "t"
+  let body = caseE (varE t) (map pure matches)
+  sig <- sigD fName [t| Entity -> $(conT tagN) -> System $(conT worldN) (Maybe $(conT sumN)) |]
+  decl <- funD fName [clause [varP e, varP t] (normalB body) []]
+  pure [sig, decl]
+  where
+    makeMatch e cType = match (conP tagCon []) (normalB [| fmap $(conE sumCon) <$> get $(varE e) |]) []
+      where
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        sumCon = mkName (sumPrefix ++ nameBase cType)
+    fName = mkName funName
+    tagN  = mkName tagType
+    sumN  = mkName sumType
+    worldN = mkName worldName
+
+makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec]
+makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do
+  s <- newName "s"
+
+  sig <- sigD fName [t| $(conT sumN) -> $(conT tagN) |]
+
+  matches <- mapM makeMatch cTypes
+  let body = caseE (varE s) (map pure matches)
+  decl <- funD fName [clause [varP s] (normalB body) []]
+  pure [sig, decl]
+  where
+    makeMatch cType = match (conP sumCon [wildP]) (normalB (conE tagCon)) []
+      where
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        sumCon = mkName (sumPrefix ++ nameBase cType)
+    fName = mkName funName
+    tagN  = mkName tagType
+    sumN  = mkName sumType
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index 868b4de..c65b0f6 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -34,6 +34,7 @@ import           Apecs.Experimental.Reactive
 import           Apecs.Experimental.Stores
 import           Apecs.Stores
 import           Apecs.TH
+import           Apecs.TH.Tags
 import           Apecs.Util
 
 type Vec = (Double, Double)

From cd6b970743b2c119676858aa3b0f95dde329f639 Mon Sep 17 00:00:00 2001
From: IC Rainbow <486682+dpwiz@users.noreply.github.com>
Date: Thu, 12 Mar 2026 15:12:14 +0200
Subject: [PATCH 06/10] Add `makeGetTags` generator and integrate with
 `makeTaggedComponents` (#11)

Co-authored-by: dpwiz <486682+dpwiz@users.noreply.github.com>
Co-authored-by: google-labs-jules[bot] <161369871+google-labs-jules[bot]@users.noreply.github.com>
---
 apecs/src/Apecs/TH/Tags.hs | 47 ++++++++++++++++++++++++++++++++------
 apecs/test/Main.hs         | 29 +++++++++++++++++++++--
 2 files changed, 67 insertions(+), 9 deletions(-)

diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs
index 49b66a8..e03656c 100644
--- a/apecs/src/Apecs/TH/Tags.hs
+++ b/apecs/src/Apecs/TH/Tags.hs
@@ -9,16 +9,15 @@ module Apecs.TH.Tags
   , makeComponentSum
   , makeTagLookup
   , makeTagFromSum
+  , makeGetTags
   ) where
 
 import           Control.Monad        (filterM)
-import           Control.Monad.Trans.Reader (asks)
-import           Data.Traversable     (for)
+import           Control.Monad.Trans.Class (lift)
 import           Language.Haskell.TH
 
-import           Apecs.Core
-import           Apecs.Stores
-import           Apecs.Util           (EntityCounter)
+import Apecs.Core
+import Apecs.TH (hasStoreInstance)
 
 makeTaggedComponents :: String -> [Name] -> Q [Dec]
 makeTaggedComponents worldName cTypes = do
@@ -26,7 +25,13 @@ makeTaggedComponents worldName cTypes = do
   sums <- makeComponentSum sumType sumPrefix cTypes
   getter <- makeTagLookup lookupFunName worldName tagType tagPrefix sumType sumPrefix cTypes
   toTag <- makeTagFromSum tagFromSumFunName tagType tagPrefix sumType sumPrefix cTypes
-  pure $ tags ++ sums ++ getter ++ toTag
+
+  let skip = ["Global", "ReadOnly"]
+  let m = ConT ''IO
+  existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes
+
+  getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing
+  pure $ tags ++ sums ++ getter ++ toTag ++ getTags
   where
     tagType = worldName ++ "Tag"
     tagPrefix = "T"
@@ -34,6 +39,7 @@ makeTaggedComponents worldName cTypes = do
     sumPrefix = "S"
     lookupFunName = "lookup" ++ worldName ++ "Tag"
     tagFromSumFunName = "tag" ++ sumType
+    getTagsFunName = "get" ++ worldName ++ "Tags"
 
 -- | Creates an Enum of component tags
 makeComponentTags :: String -> String -> [Name] -> Q [Dec]
@@ -57,7 +63,7 @@ makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do
   matches <- mapM (makeMatch e) cTypes
   t <- newName "t"
   let body = caseE (varE t) (map pure matches)
-  sig <- sigD fName [t| Entity -> $(conT tagN) -> System $(conT worldN) (Maybe $(conT sumN)) |]
+  sig <- sigD fName [t| Entity -> $(conT tagN) -> SystemT $(conT worldN) IO (Maybe $(conT sumN)) |]
   decl <- funD fName [clause [varP e, varP t] (normalB body) []]
   pure [sig, decl]
   where
@@ -88,3 +94,30 @@ makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do
     fName = mkName funName
     tagN  = mkName tagType
     sumN  = mkName sumType
+
+-- | For each component type, get store and use explExists on the given entity
+makeGetTags :: String -> String -> String -> String -> [Name] -> Q [Dec]
+makeGetTags funName worldName tagType tagPrefix cTypes = do
+  sig <- sigD fName [t| Entity -> SystemT $(conT worldN) IO [$(conT tagN)] |]
+  e <- newName "e"
+  stmts <- mapM (makeStmt e) cTypes
+  decl <- funD fName [clause [varP e] (bodyS stmts) []]
+  pure [sig, decl]
+  where
+    fName = mkName funName
+    tagN = mkName tagType
+    worldN = mkName worldName
+    makeStmt e cType = bindS (varP tagName) body
+      where
+        tagName = mkName ("tag_" ++ nameBase cType)
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        body = [|
+          do
+            s <- getStore :: SystemT $(conT (mkName worldName)) IO (Storage $(conT cType))
+            has <- lift $ explExists s (unEntity $(varE e))
+            pure [$(conE tagCon) | has]
+          |]
+    bodyS stmts = normalB . doE $ map pure stmts ++ [resultE]
+      where
+        tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes
+        resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index c65b0f6..b0e2970 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -171,8 +171,8 @@ prop_enumerable dels t12s t3s = assertSys initWorldEnumerable $ do
   actualAfter <- worldEntityIds
   return (expectedBefore == actualBefore && expectedAfter == actualAfter)
 
-prop_tags :: [Entity] -> [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property
-prop_tags dels t12s t3s = assertSys initWorldEnumerable $ do
+prop_tags_lookup :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property
+prop_tags_lookup t12s t3s = assertSys initWorldEnumerable $ do
   forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2
   forM_ t3s $ \(e, t3) -> set e t3
 
@@ -187,6 +187,31 @@ prop_tags dels t12s t3s = assertSys initWorldEnumerable $ do
 
   pure True
 
+prop_tags_get :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property
+prop_tags_get t12s t3s = assertSys initWorldEnumerable $ do
+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2
+  forM_ t3s $ \(e, t3) -> set e t3
+
+  -- arbitrary will produce overlapping entity sets for t12s and t3s
+  -- the correct set of components for each entity is known at runtime
+  let has_t12s = S.fromList (map (unEntity . fst) t12s)
+  let has_t3s = S.fromList (map (unEntity . fst) t3s)
+
+  forM_ (S.toList $ has_t12s <> has_t3s) $ \ety -> do
+    let t12 = [[TT1, TT2] | ety `S.member` has_t12s]
+    let t3 = [[TT3] | ety `S.member` has_t3s]
+    let
+      expected =
+        -- XXX: matching the order is important.
+        -- getWorldEnumerableTags will iterate in the "constructor order"
+        -- derived from the filtered component type list.
+        concat (t12 ++ t3)
+    tags <- getWorldEnumerableTags $ Entity ety
+    unless (tags == expected) $ do
+      error $ show (tags, expected)
+
+  pure True
+
 prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))
 prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))
 

From 8f6542e90204c8d1cd6384789be5af1034d8edfb Mon Sep 17 00:00:00 2001
From: IC Rainbow <aenor.realm@gmail.com>
Date: Thu, 12 Mar 2026 16:50:31 +0200
Subject: [PATCH 07/10] Add `makeCountComponents` TH generator and integrate
 with `makeTaggedComponents`

Generates a function that counts how many entities have each enumerable
component type, returning `[(tag, Int)]`. Filters by `ExplMembers` so
Global/ReadOnly stores are excluded.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
---
 apecs/src/Apecs/TH/Tags.hs | 35 ++++++++++++++++++++++++++++++++++-
 apecs/test/Main.hs         | 19 +++++++++++++++++++
 2 files changed, 53 insertions(+), 1 deletion(-)

diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs
index e03656c..79dcd3e 100644
--- a/apecs/src/Apecs/TH/Tags.hs
+++ b/apecs/src/Apecs/TH/Tags.hs
@@ -10,10 +10,12 @@ module Apecs.TH.Tags
   , makeTagLookup
   , makeTagFromSum
   , makeGetTags
+  , makeCountComponents
   ) where
 
 import           Control.Monad        (filterM)
 import           Control.Monad.Trans.Class (lift)
+import qualified Data.Vector.Unboxed  as U
 import           Language.Haskell.TH
 
 import Apecs.Core
@@ -31,7 +33,11 @@ makeTaggedComponents worldName cTypes = do
   existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes
 
   getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing
-  pure $ tags ++ sums ++ getter ++ toTag ++ getTags
+
+  enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes
+  countComps <- makeCountComponents countCompsFunName worldName tagType tagPrefix enumerable
+
+  pure $ tags ++ sums ++ getter ++ toTag ++ getTags ++ countComps
   where
     tagType = worldName ++ "Tag"
     tagPrefix = "T"
@@ -40,6 +46,7 @@ makeTaggedComponents worldName cTypes = do
     lookupFunName = "lookup" ++ worldName ++ "Tag"
     tagFromSumFunName = "tag" ++ sumType
     getTagsFunName = "get" ++ worldName ++ "Tags"
+    countCompsFunName = "count" ++ worldName ++ "Components"
 
 -- | Creates an Enum of component tags
 makeComponentTags :: String -> String -> [Name] -> Q [Dec]
@@ -121,3 +128,29 @@ makeGetTags funName worldName tagType tagPrefix cTypes = do
       where
         tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes
         resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames
+
+-- | For each component type with ExplMembers, count the number of entities that have that component.
+makeCountComponents :: String -> String -> String -> String -> [Name] -> Q [Dec]
+makeCountComponents funName worldName tagType tagPrefix cTypes = do
+  sig <- sigD fName [t| SystemT $(conT worldN) IO [($(conT tagN), Int)] |]
+  stmts <- mapM makeStmt cTypes
+  decl <- funD fName [clause [] (bodyS stmts) []]
+  pure [sig, decl]
+  where
+    fName = mkName funName
+    tagN = mkName tagType
+    worldN = mkName worldName
+    makeStmt cType = bindS (varP countName) body
+      where
+        countName = mkName ("count_" ++ nameBase cType)
+        tagCon = mkName (tagPrefix ++ nameBase cType)
+        body = [|
+          do
+            s <- getStore :: SystemT $(conT (mkName worldName)) IO (Storage $(conT cType))
+            members <- lift $ explMembers s
+            pure ($(conE tagCon), U.length members)
+          |]
+    bodyS stmts = normalB . doE $ map pure stmts ++ [resultE]
+      where
+        countNames = map (varE . mkName . ("count_" ++) . nameBase) cTypes
+        resultE = noBindS . appE (varE 'pure) $ listE countNames
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index b0e2970..b009228 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -212,6 +212,25 @@ prop_tags_get t12s t3s = assertSys initWorldEnumerable $ do
 
   pure True
 
+prop_count_components :: [(Entity, T1)] -> [(Entity, T2)] -> [(Entity, T3)] -> Property
+prop_count_components t1s t2s t3s = assertSys initWorldEnumerable $ do
+  forM_ t1s $ uncurry set
+  forM_ t2s $ uncurry set
+  forM_ t3s $ uncurry set
+
+  counts <- countWorldEnumerableComponents
+  let countMap = M.fromList counts
+
+  let expectedT1 = length $ nub $ map fst t1s
+  let expectedT2 = length $ nub $ map fst t2s
+  let expectedT3 = length $ nub $ map fst t3s
+
+  -- G1 is Global and should not appear in counts
+  return $ M.lookup TT1 countMap == Just expectedT1
+        && M.lookup TT2 countMap == Just expectedT2
+        && M.lookup TT3 countMap == Just expectedT3
+        && M.lookup TG1 countMap == Nothing
+
 prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))
 prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))
 

From fa51c0c896f85d00a46cfb2ab4e6a89696929d88 Mon Sep 17 00:00:00 2001
From: IC Rainbow <aenor.realm@gmail.com>
Date: Thu, 12 Mar 2026 17:22:32 +0200
Subject: [PATCH 08/10] Add `countCombinations` utility for census of distinct
 component archetypes

A plain utility function (not TH-generated) that takes a member set and
a tag-getter function, groups entities by their tag combination using
IntSet as a compact intermediate, and returns Map (Set tag) Int.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
---
 apecs/src/Apecs/Util.hs | 25 +++++++++++++++++++++++++
 apecs/test/Main.hs      | 21 +++++++++++++++++++++
 2 files changed, 46 insertions(+)

diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs
index 61d079c..91e3e2e 100644
--- a/apecs/src/Apecs/Util.hs
+++ b/apecs/src/Apecs/Util.hs
@@ -15,13 +15,19 @@ module Apecs.Util (
   -- * EntityCounter
   EntityCounter(..), nextEntity, newEntity, newEntity_,
   Maybify,
+
+  -- * Census
+  countCombinations,
 ) where
 
 import           Control.Applicative  (liftA2)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class (lift)
+import qualified Data.IntSet          as IS
+import qualified Data.Map.Strict      as M
 import           Data.Monoid
 import           Data.Semigroup
+import qualified Data.Set             as S
 import           System.Mem           (performMajorGC)
 
 import           Apecs.Core
@@ -68,6 +74,25 @@ newEntity_ component = do
 runGC :: MonadIO m => SystemT w m ()
 runGC = liftIO performMajorGC
 
+-- | Count entities grouped by their distinct component combination.
+--
+-- Takes the world's entity member set and a tag-getter function (typically
+-- generated by @makeTaggedComponents@), and returns a map from tag sets to
+-- entity counts. Uses 'IntSet' internally for compact tag set representation.
+countCombinations
+  :: (Monad m, Enum tag, Ord tag)
+  => IS.IntSet                        -- ^ Entity IDs to census
+  -> (Entity -> SystemT w m [tag])    -- ^ Tag getter (e.g. @getWorldEnumerableTags@)
+  -> SystemT w m (M.Map (S.Set tag) Int)
+countCombinations entities getTags = do
+  tagSets <- mapM poll (IS.toList entities)
+  let counts = M.fromListWith (+) [(ts, 1 :: Int) | ts <- tagSets]
+  pure $ M.mapKeysMonotonic (S.fromList . map toEnum . IS.toList) counts
+  where
+    poll eid = do
+      tags <- getTags (Entity eid)
+      pure $! IS.fromList (map fromEnum tags)
+
 -- | Wrap tuple elements in Maybe.
 --
 -- This allows to safely `get` component packs generated by @makeInstanceFold mkTupleT@.
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index b009228..d5a8934 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -22,6 +22,7 @@ import           Data.IORef
 import           Data.List                   ((\\), delete, nub, sort)
 import qualified Data.IntMap.Strict          as IM
 import qualified Data.Map.Strict             as M
+import qualified Data.Set                    as Set
 import qualified Data.Vector.Unboxed         as U
 import           Test.QuickCheck
 import           Test.QuickCheck.Monadic
@@ -231,6 +232,26 @@ prop_count_components t1s t2s t3s = assertSys initWorldEnumerable $ do
         && M.lookup TT3 countMap == Just expectedT3
         && M.lookup TG1 countMap == Nothing
 
+prop_count_combinations :: [(Entity, (T1, T2))] -> [(Entity, T3)] -> Property
+prop_count_combinations t12s t3s = assertSys initWorldEnumerable $ do
+  forM_ t12s $ \(e, (t1, t2)) -> set e t1 >> set e t2
+  forM_ t3s $ \(e, t3) -> set e t3
+
+  entities <- worldEntityIds
+  combos <- countCombinations entities getWorldEnumerableTags
+
+  let has_t12s = S.fromList (map (unEntity . fst) t12s)
+  let has_t3s = S.fromList (map (unEntity . fst) t3s)
+  let entityTags ety =
+        (if ety `S.member` has_t12s then [TT1, TT2] else [])
+        ++ (if ety `S.member` has_t3s then [TT3] else [])
+  let expected = M.fromListWith (+)
+        [ (Set.fromList (entityTags ety), 1 :: Int)
+        | ety <- S.toList (has_t12s <> has_t3s)
+        ]
+
+  return $ combos == expected
+
 prop_setGetTuple = genericSetGet initTuples (undefined :: (T1,T2,T3))
 prop_setSetTuple = genericSetSet initTuples (undefined :: (T1,T2,T3))
 

From efdbadfdb4568a16552d02dbb8ddc0705a7e9753 Mon Sep 17 00:00:00 2001
From: IC Rainbow <486682+dpwiz@users.noreply.github.com>
Date: Thu, 12 Mar 2026 21:59:19 +0200
Subject: [PATCH 09/10] Add `HasTags` class (#13)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Follows the same pattern as `Has w m c` — the world type `w` dispatches
to the tag system generated by `makeTaggedComponents`. This enables
generic utilities that work in `SystemT w m` without naming world-specific
types like `getWorldTags`.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
---
 apecs/src/Apecs.hs         |  1 +
 apecs/src/Apecs/Core.hs    |  6 ++++++
 apecs/src/Apecs/TH/Tags.hs | 24 +++++++++++++++++++++++-
 apecs/src/Apecs/Util.hs    | 15 +++++++--------
 apecs/test/Main.hs         |  4 ++--
 5 files changed, 39 insertions(+), 11 deletions(-)

diff --git a/apecs/src/Apecs.hs b/apecs/src/Apecs.hs
index 9ec8995..73ef4e5 100644
--- a/apecs/src/Apecs.hs
+++ b/apecs/src/Apecs.hs
@@ -6,6 +6,7 @@ module Apecs (
   -- * Core types
     SystemT, System, Component(..), Entity(..), Has(..), Not(..),
     Get, Set, Destroy, Members,
+    HasTags(..),
 
   -- * Stores
     Map, Unique, Global, Cache,
diff --git a/apecs/src/Apecs/Core.hs b/apecs/src/Apecs/Core.hs
index 540f644..a0e4fd5 100644
--- a/apecs/src/Apecs/Core.hs
+++ b/apecs/src/Apecs/Core.hs
@@ -81,3 +81,9 @@ 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))
 type Destroy w m c = (Has w m c, ExplDestroy m (Storage c))
+
+-- | @HasTags w@ means that world @w@ has a tag system generated by @makeTaggedComponents@.
+--   Provides a way to query component tags for entities, dispatching on the world type @w@.
+class HasTags w where
+  type WTag w
+  entityTags :: Entity -> SystemT w IO [WTag w]
diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs
index 79dcd3e..573cbea 100644
--- a/apecs/src/Apecs/TH/Tags.hs
+++ b/apecs/src/Apecs/TH/Tags.hs
@@ -11,6 +11,7 @@ module Apecs.TH.Tags
   , makeTagFromSum
   , makeGetTags
   , makeCountComponents
+  , makeHasTagsInstance
   ) where
 
 import           Control.Monad        (filterM)
@@ -33,11 +34,12 @@ makeTaggedComponents worldName cTypes = do
   existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes
 
   getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing
+  hasTagsInst <- makeHasTagsInstance worldName tagType getTagsFunName
 
   enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes
   countComps <- makeCountComponents countCompsFunName worldName tagType tagPrefix enumerable
 
-  pure $ tags ++ sums ++ getter ++ toTag ++ getTags ++ countComps
+  pure $ tags ++ sums ++ getter ++ toTag ++ getTags ++ hasTagsInst ++ countComps
   where
     tagType = worldName ++ "Tag"
     tagPrefix = "T"
@@ -129,6 +131,26 @@ makeGetTags funName worldName tagType tagPrefix cTypes = do
         tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes
         resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames
 
+-- | Generates a @HasTags@ instance for the given world, delegating @entityTags@ to the
+--   generated @getWorldTags@ function.
+makeHasTagsInstance :: String -> String -> String -> Q [Dec]
+makeHasTagsInstance worldName tagType getTagsFunName = pure [decl]
+  where
+    worldN = mkName worldName
+    tagN = mkName tagType
+    getTagsN = mkName getTagsFunName
+    tySynInst =
+#if MIN_VERSION_template_haskell(2,15,0)
+      TySynInstD (TySynEqn Nothing (AppT (ConT ''WTag) (ConT worldN)) (ConT tagN))
+#else
+      TySynInstD ''WTag (TySynEqn [ConT worldN] (ConT tagN))
+#endif
+    decl = InstanceD Nothing []
+      (AppT (ConT ''HasTags) (ConT worldN))
+      [ tySynInst
+      , ValD (VarP 'entityTags) (NormalB (VarE getTagsN)) []
+      ]
+
 -- | For each component type with ExplMembers, count the number of entities that have that component.
 makeCountComponents :: String -> String -> String -> String -> [Name] -> Q [Dec]
 makeCountComponents funName worldName tagType tagPrefix cTypes = do
diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs
index 91e3e2e..4f6c8ec 100644
--- a/apecs/src/Apecs/Util.hs
+++ b/apecs/src/Apecs/Util.hs
@@ -76,21 +76,20 @@ runGC = liftIO performMajorGC
 
 -- | Count entities grouped by their distinct component combination.
 --
--- Takes the world's entity member set and a tag-getter function (typically
--- generated by @makeTaggedComponents@), and returns a map from tag sets to
--- entity counts. Uses 'IntSet' internally for compact tag set representation.
+-- Takes the world's entity member set and uses 'entityTags' from the
+-- 'HasTags' class to query each entity's tags. Returns a map from tag sets
+-- to entity counts.
 countCombinations
-  :: (Monad m, Enum tag, Ord tag)
+  :: (HasTags w, Enum (WTag w), Ord (WTag w))
   => IS.IntSet                        -- ^ Entity IDs to census
-  -> (Entity -> SystemT w m [tag])    -- ^ Tag getter (e.g. @getWorldEnumerableTags@)
-  -> SystemT w m (M.Map (S.Set tag) Int)
-countCombinations entities getTags = do
+  -> SystemT w IO (M.Map (S.Set (WTag w)) Int)
+countCombinations entities = do
   tagSets <- mapM poll (IS.toList entities)
   let counts = M.fromListWith (+) [(ts, 1 :: Int) | ts <- tagSets]
   pure $ M.mapKeysMonotonic (S.fromList . map toEnum . IS.toList) counts
   where
     poll eid = do
-      tags <- getTags (Entity eid)
+      tags <- entityTags (Entity eid)
       pure $! IS.fromList (map fromEnum tags)
 
 -- | Wrap tuple elements in Maybe.
diff --git a/apecs/test/Main.hs b/apecs/test/Main.hs
index d5a8934..c8f8d5d 100644
--- a/apecs/test/Main.hs
+++ b/apecs/test/Main.hs
@@ -207,7 +207,7 @@ prop_tags_get t12s t3s = assertSys initWorldEnumerable $ do
         -- getWorldEnumerableTags will iterate in the "constructor order"
         -- derived from the filtered component type list.
         concat (t12 ++ t3)
-    tags <- getWorldEnumerableTags $ Entity ety
+    tags <- entityTags $ Entity ety
     unless (tags == expected) $ do
       error $ show (tags, expected)
 
@@ -238,7 +238,7 @@ prop_count_combinations t12s t3s = assertSys initWorldEnumerable $ do
   forM_ t3s $ \(e, t3) -> set e t3
 
   entities <- worldEntityIds
-  combos <- countCombinations entities getWorldEnumerableTags
+  combos <- countCombinations entities
 
   let has_t12s = S.fromList (map (unEntity . fst) t12s)
   let has_t3s = S.fromList (map (unEntity . fst) t3s)

From 35966a1f026922a442d6ceac4a4b3476da0707ae Mon Sep 17 00:00:00 2001
From: IC Rainbow <486682+dpwiz@users.noreply.github.com>
Date: Sat, 14 Mar 2026 21:59:53 +0200
Subject: [PATCH 10/10] Split HasTags and detach from IO (#14)

Extract `WTag` as a standalone type family and add `m` parameter to
`HasTags w m`, mirroring the existing `Has w m c` pattern. This allows
`HasTags` to work with apecs-stm (STM) or pure test monads instead of
being hardcoded to IO.

Co-authored-by: Claude Opus 4.6 <noreply@anthropic.com>
---
 apecs/src/Apecs.hs         |  2 +-
 apecs/src/Apecs/Core.hs    | 11 +++--
 apecs/src/Apecs/TH/Tags.hs | 96 ++++++++++++++++++++++++++------------
 apecs/src/Apecs/Util.hs    |  4 +-
 4 files changed, 75 insertions(+), 38 deletions(-)

diff --git a/apecs/src/Apecs.hs b/apecs/src/Apecs.hs
index 73ef4e5..113c3c9 100644
--- a/apecs/src/Apecs.hs
+++ b/apecs/src/Apecs.hs
@@ -6,7 +6,7 @@ module Apecs (
   -- * Core types
     SystemT, System, Component(..), Entity(..), Has(..), Not(..),
     Get, Set, Destroy, Members,
-    HasTags(..),
+    HasTags(..), WTag,
 
   -- * Stores
     Map, Unique, Global, Cache,
diff --git a/apecs/src/Apecs/Core.hs b/apecs/src/Apecs/Core.hs
index a0e4fd5..274941a 100644
--- a/apecs/src/Apecs/Core.hs
+++ b/apecs/src/Apecs/Core.hs
@@ -82,8 +82,11 @@ 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))
 type Destroy w m c = (Has w m c, ExplDestroy m (Storage c))
 
--- | @HasTags w@ means that world @w@ has a tag system generated by @makeTaggedComponents@.
+-- | The type of tags for a world, e.g. @WTag MyWorld = MyWorldTag@.
+--   Standalone so that multiple @HasTags w m@ instances share one equation.
+type family WTag w
+
+-- | @HasTags w m@ means that world @w@ has a tag system generated by @makeTaggedComponents@.
 --   Provides a way to query component tags for entities, dispatching on the world type @w@.
-class HasTags w where
-  type WTag w
-  entityTags :: Entity -> SystemT w IO [WTag w]
+class Monad m => HasTags w m where
+  entityTags :: Entity -> SystemT w m [WTag w]
diff --git a/apecs/src/Apecs/TH/Tags.hs b/apecs/src/Apecs/TH/Tags.hs
index 573cbea..52d59a7 100644
--- a/apecs/src/Apecs/TH/Tags.hs
+++ b/apecs/src/Apecs/TH/Tags.hs
@@ -34,7 +34,7 @@ makeTaggedComponents worldName cTypes = do
   existing <- filterM (hasStoreInstance skip ''ExplGet m) cTypes
 
   getTags <- makeGetTags getTagsFunName worldName tagType tagPrefix existing
-  hasTagsInst <- makeHasTagsInstance worldName tagType getTagsFunName
+  hasTagsInst <- makeHasTagsInstance worldName tagType getTagsFunName existing
 
   enumerable <- filterM (hasStoreInstance skip ''ExplMembers m) cTypes
   countComps <- makeCountComponents countCompsFunName worldName tagType tagPrefix enumerable
@@ -64,25 +64,30 @@ makeComponentSum typeName consPrefix cTypes = pure [decl]
   where
     decl = DataD [] (mkName typeName) [] Nothing cons derivs
     cons = map (\c -> NormalC (mkName $ consPrefix ++ nameBase c) [(Bang NoSourceUnpackedness NoSourceStrictness, ConT c)]) cTypes
-    derivs = [ DerivClause Nothing (map ConT [''Show]) ]
+    derivs = [ DerivClause Nothing [ConT ''Show] ]
 
 makeTagLookup :: String -> String -> String -> String -> String -> String -> [Name] -> Q [Dec]
 makeTagLookup funName worldName tagType tagPrefix sumType sumPrefix cTypes = do
+  m <- newName "m"
+  sig <- forallCompClsSig fName ''Get worldN m cTypes
+    [t|
+      Entity ->
+      $(conT (mkName tagType)) ->
+      SystemT $(conT worldN) $(varT m) (Maybe $(conT (mkName sumType)))
+    |]
   e <- newName "e"
   matches <- mapM (makeMatch e) cTypes
   t <- newName "t"
   let body = caseE (varE t) (map pure matches)
-  sig <- sigD fName [t| Entity -> $(conT tagN) -> SystemT $(conT worldN) IO (Maybe $(conT sumN)) |]
   decl <- funD fName [clause [varP e, varP t] (normalB body) []]
   pure [sig, decl]
   where
-    makeMatch e cType = match (conP tagCon []) (normalB [| fmap $(conE sumCon) <$> get $(varE e) |]) []
+    makeMatch e cType = match (conP tagCon []) (normalB matchBody) []
       where
+        matchBody = [| fmap $(conE sumCon) <$> get $(varE e) |]
         tagCon = mkName (tagPrefix ++ nameBase cType)
         sumCon = mkName (sumPrefix ++ nameBase cType)
     fName = mkName funName
-    tagN  = mkName tagType
-    sumN  = mkName sumType
     worldN = mkName worldName
 
 makeTagFromSum :: String -> String -> String -> String -> String -> [Name] -> Q [Dec]
@@ -107,22 +112,26 @@ makeTagFromSum funName tagType tagPrefix sumType sumPrefix cTypes = do
 -- | For each component type, get store and use explExists on the given entity
 makeGetTags :: String -> String -> String -> String -> [Name] -> Q [Dec]
 makeGetTags funName worldName tagType tagPrefix cTypes = do
-  sig <- sigD fName [t| Entity -> SystemT $(conT worldN) IO [$(conT tagN)] |]
+  m <- newName "m"
+  sig <- forallCompClsSig fName ''Get worldN m cTypes
+    [t|
+      Entity ->
+      SystemT $(conT worldN) $(varT m) [$(conT $ mkName tagType)]
+    |]
   e <- newName "e"
-  stmts <- mapM (makeStmt e) cTypes
+  stmts <- mapM (makeStmt m e) cTypes
   decl <- funD fName [clause [varP e] (bodyS stmts) []]
   pure [sig, decl]
   where
     fName = mkName funName
-    tagN = mkName tagType
     worldN = mkName worldName
-    makeStmt e cType = bindS (varP tagName) body
+    makeStmt m e cType = bindS (varP tagName) body
       where
         tagName = mkName ("tag_" ++ nameBase cType)
         tagCon = mkName (tagPrefix ++ nameBase cType)
         body = [|
           do
-            s <- getStore :: SystemT $(conT (mkName worldName)) IO (Storage $(conT cType))
+            s <- getStore :: SystemT $(conT worldN) $(varT m) (Storage $(conT cType))
             has <- lift $ explExists s (unEntity $(varE e))
             pure [$(conE tagCon) | has]
           |]
@@ -131,44 +140,52 @@ makeGetTags funName worldName tagType tagPrefix cTypes = do
         tagNames = map (varE . mkName . ("tag_" ++) . nameBase) cTypes
         resultE = noBindS . appE (varE 'pure) $ appE (varE 'concat) $ listE tagNames
 
--- | Generates a @HasTags@ instance for the given world, delegating @entityTags@ to the
---   generated @getWorldTags@ function.
-makeHasTagsInstance :: String -> String -> String -> Q [Dec]
-makeHasTagsInstance worldName tagType getTagsFunName = pure [decl]
-  where
-    worldN = mkName worldName
-    tagN = mkName tagType
-    getTagsN = mkName getTagsFunName
-    tySynInst =
+-- | Generates a standalone @type instance WTag World = WorldTag@ and a
+--   @HasTags World m@ instance delegating @entityTags@ to the generated
+--   @getWorldTags@ function.
+makeHasTagsInstance :: String -> String -> String -> [Name] -> Q [Dec]
+makeHasTagsInstance worldName tagType getTagsFunName cTypes = do
+  m <- newName "m"
+  instDec <- instanceD
+    ((:) <$> [t| Monad $(varT m) |] <*> worldConstraints ''Get worldN m cTypes)
+    [t| HasTags $(conT worldN) $(varT m) |]
+    [ valD
+          (varP 'entityTags)
+          (normalB . varE $ mkName getTagsFunName)
+          []
+      ]
+
+  let tySynDec =
 #if MIN_VERSION_template_haskell(2,15,0)
-      TySynInstD (TySynEqn Nothing (AppT (ConT ''WTag) (ConT worldN)) (ConT tagN))
+        TySynInstD $ TySynEqn Nothing (ConT ''WTag `AppT` ConT worldN) (ConT tagN)
 #else
-      TySynInstD ''WTag (TySynEqn [ConT worldN] (ConT tagN))
+        TySynInstD ''WTag $ TySynEqn [ConT worldN] (ConT tagN)
 #endif
-    decl = InstanceD Nothing []
-      (AppT (ConT ''HasTags) (ConT worldN))
-      [ tySynInst
-      , ValD (VarP 'entityTags) (NormalB (VarE getTagsN)) []
-      ]
+  pure [tySynDec, instDec]
+  where
+    worldN = mkName worldName
+    tagN = mkName tagType
 
 -- | For each component type with ExplMembers, count the number of entities that have that component.
 makeCountComponents :: String -> String -> String -> String -> [Name] -> Q [Dec]
 makeCountComponents funName worldName tagType tagPrefix cTypes = do
-  sig <- sigD fName [t| SystemT $(conT worldN) IO [($(conT tagN), Int)] |]
-  stmts <- mapM makeStmt cTypes
+  m <- newName "m"
+  sig <- forallCompClsSig fName ''Members worldN m cTypes
+    [t| SystemT $(conT worldN) $(varT m) [($(conT tagN), Int)] |]
+  stmts <- mapM (makeStmt m) cTypes
   decl <- funD fName [clause [] (bodyS stmts) []]
   pure [sig, decl]
   where
     fName = mkName funName
     tagN = mkName tagType
     worldN = mkName worldName
-    makeStmt cType = bindS (varP countName) body
+    makeStmt m cType = bindS (varP countName) body
       where
         countName = mkName ("count_" ++ nameBase cType)
         tagCon = mkName (tagPrefix ++ nameBase cType)
         body = [|
           do
-            s <- getStore :: SystemT $(conT (mkName worldName)) IO (Storage $(conT cType))
+            s <- getStore :: SystemT $(conT (mkName worldName)) $(varT m) (Storage $(conT cType))
             members <- lift $ explMembers s
             pure ($(conE tagCon), U.length members)
           |]
@@ -176,3 +193,20 @@ makeCountComponents funName worldName tagType tagPrefix cTypes = do
       where
         countNames = map (varE . mkName . ("count_" ++) . nameBase) cTypes
         resultE = noBindS . appE (varE 'pure) $ listE countNames
+
+-- | Build a @f :: forall m. (Cls World m C1, ...) => body@ type signature
+forallCompClsSig :: Name -> Name -> Name -> Name -> [Name] -> Q Type -> Q Dec
+forallCompClsSig fName cls worldN m cTypes mkBody =
+  sigD fName $ forallT [mkPlainTV m] (worldConstraints cls worldN m cTypes) mkBody
+
+worldConstraints :: Name -> Name -> Name -> [Name] -> Q Cxt
+worldConstraints cls worldN m = traverse $ \c ->
+  [t| $(conT cls) $(conT worldN) $(varT m) $(conT c) |]
+
+#if MIN_VERSION_template_haskell(2,17,0)
+mkPlainTV :: Name -> TyVarBndr Specificity
+mkPlainTV n = PlainTV n SpecifiedSpec
+#else
+mkPlainTV :: Name -> TyVarBndr
+mkPlainTV = PlainTV
+#endif
diff --git a/apecs/src/Apecs/Util.hs b/apecs/src/Apecs/Util.hs
index 4f6c8ec..6ee1ffc 100644
--- a/apecs/src/Apecs/Util.hs
+++ b/apecs/src/Apecs/Util.hs
@@ -80,9 +80,9 @@ runGC = liftIO performMajorGC
 -- 'HasTags' class to query each entity's tags. Returns a map from tag sets
 -- to entity counts.
 countCombinations
-  :: (HasTags w, Enum (WTag w), Ord (WTag w))
+  :: (HasTags w m, Enum (WTag w), Ord (WTag w))
   => IS.IntSet                        -- ^ Entity IDs to census
-  -> SystemT w IO (M.Map (S.Set (WTag w)) Int)
+  -> SystemT w m (M.Map (S.Set (WTag w)) Int)
 countCombinations entities = do
   tagSets <- mapM poll (IS.toList entities)
   let counts = M.fromListWith (+) [(ts, 1 :: Int) | ts <- tagSets]