Extract and generalize destructible_decl

apecs/src/Apecs/TH.hs

@@ -8,6 +8,7 @@ module Apecs.TH
   , makeWorldAndComponents
   , makeMapComponents
   , makeMapComponentsFor
+  , makeInstanceTuples
   ) where
 
 import           Control.Monad        (filterM)
@@ -54,27 +55,30 @@ makeWorldNoEC worldName cTypes = do
       |]
 
   -- Destructible type synonym
-  destructible_decl <- do
-    let name = mkName $ worldName ++ "Destructible"
-    let destructible ty
-          | nameBase ty == "EntityCounter" = pure False
-          | otherwise = isInstance ''ExplDestroy [ConT ''IO, AppT (ConT ''Storage) (ConT ty)]
-    destroyableTypes <- filterM destructible cTypes
-    let getType ty = ConT ty
-    tySynD name [] (pure $ mkTupleT $ getType <$> destroyableTypes)
-
-  pure $ data_decl : destructible_decl : concat (init_world : instances)
+  destructible_decl <- makeInstanceTuples (worldName ++ "Destructible") ''ExplDestroy cTypes
+
+  pure $ data_decl : destructible_decl ++ concat (init_world : instances)
   where
     enumerate :: [a] -> [(Int,a)]
     enumerate = zip [0..]
 
-    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
+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
 
 -- | Creates 'Component' instances with 'Map' stores
 makeMapComponents :: [Name] -> Q [Dec]