refactor: remove f wrapper from HSet (#44)

Author: matthunz

examples/Scheduler.hs

@@ -9,7 +9,6 @@ module Main where
 import Aztecs
 import qualified Aztecs.World as W
 import Control.Monad.IO.Class
-import Control.Monad.Identity
 
 newtype Position = Position Int
   deriving (Show, Eq)
@@ -99,24 +98,23 @@ app ::
        Run '[] RenderSystem
      ]
 app =
-  hcons (Run MoveSystem)
-    . hcons (Run PhysicsSystem)
-    . hcons (Run CombatSystem)
-    . hcons (Run RenderSystem)
-    $ hempty
+  HCons (Run MoveSystem) $
+  HCons (Run PhysicsSystem) $
+  HCons (Run CombatSystem) $
+  HCons (Run RenderSystem) $
+  HEmpty
 
 appSmall ::
-  HSetT
-    Identity
+  HSet
     '[ Run '[After PhysicsSystem] MoveSystem,
        Run '[] PhysicsSystem,
        Run '[] RenderSystem
      ]
 appSmall =
-  hcons (Run MoveSystem)
-    . hcons (Run PhysicsSystem)
-    . hcons (Run RenderSystem)
-    $ hempty
+  HCons (Run MoveSystem) $
+  HCons (Run PhysicsSystem) $
+  HCons (Run RenderSystem) $
+  HEmpty
 
 runSchedulerExample :: IO ()
 runSchedulerExample = do

src/Aztecs/ECS/Executor.hs

@@ -11,7 +11,7 @@
 module Aztecs.ECS.Executor where
 
 import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.HSet (HSet, HSetT (..), Subset)
+import Aztecs.ECS.HSet (HSet (..), Subset)
 import Aztecs.ECS.Queryable.Internal
 import Aztecs.ECS.System
 import Aztecs.World
@@ -56,7 +56,7 @@ instance
   ) =>
   Execute' m (HSet (sys ': systems))
   where
-  execute' (HCons (Identity system) rest) =
+  execute' (HCons system rest) =
     ( do
         inputs <- access
         runSystem system inputs
@@ -70,8 +70,9 @@ instance (Applicative m) => Execute m (HSet '[]) where
   execute _ = pure ()
 
 instance
+  {-# OVERLAPPABLE #-}
   ( Monad m,
-    Execute' m (Identity systems),
+    Execute' m systems,
     Execute m (HSet schedule)
   ) =>
   Execute m (HSet (systems ': schedule))

src/Aztecs/ECS/HSet.hs

@@ -12,8 +12,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Aztecs.ECS.HSet
-  ( HSet,
-    HSetT (..),
+  ( HSet (..),
     Run (..),
     UnwrapSystem,
     GetConstraints,
@@ -22,8 +21,6 @@ module Aztecs.ECS.HSet
     Lookup (..),
     AdjustM (..),
     Subset (..),
-    hcons,
-    hempty,
   )
 where
 
@@ -34,11 +31,9 @@ import qualified Data.SparseSet.Strict.Mutable as MS
 import Data.Word
 import Prelude hiding (lookup)
 
-type HSet = HSetT Identity
-
-data HSetT f ts where
-  HEmpty :: HSetT f '[]
-  HCons :: f t -> HSetT f ts -> HSetT f (t ': ts)
+data HSet ts where
+  HEmpty :: HSet '[]
+  HCons :: t -> HSet ts -> HSet (t ': ts)
 
 data Before (sys :: Type)
 
@@ -58,27 +53,25 @@ type family GetConstraints (runSys :: Type) :: [Type] where
 instance (Show sys) => Show (Run constraints sys) where
   show (Run sys) = "Run " ++ show sys
 
-instance (ShowHSet f ts) => Show (HSetT f ts) where
+instance (ShowHSet  ts) => Show (HSet ts) where
   show = showHSet
 
-class ShowHSet f ts where
-  showHSet :: HSetT f ts -> String
+class ShowHSet  ts where
+  showHSet :: HSet ts -> String
 
-instance ShowHSet f '[] where
+instance ShowHSet '[] where
   showHSet _ = "HEmpty"
 
-instance (Show (f t), ShowHSet f ts) => ShowHSet f (t ': ts) where
+instance (Show t, ShowHSet ts) => ShowHSet (t ': ts) where
   showHSet (HCons x xs) = "HCons " ++ show x ++ " (" ++ showHSet xs ++ ")"
 
-
-
 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 :: HSetT f ts -> f t
+  lookup :: HSet ts -> t
 
 instance {-# OVERLAPPING #-} Lookup t (t ': ts) where
   lookup (HCons x _) = x
@@ -88,35 +81,25 @@ instance {-# OVERLAPPABLE #-} (Lookup t ts) => Lookup t (u ': ts) where
   lookup (HCons _ xs) = lookup xs
   {-# INLINE lookup #-}
 
-class AdjustM m f t ts where
-  adjustM :: (f t -> m (f t)) -> HSetT f ts -> m (HSetT f ts)
+class AdjustM m  t ts where
+  adjustM :: (t-> m t) -> HSet ts -> m (HSet ts)
 
-instance {-# OVERLAPPING #-} (Applicative m) => AdjustM m f t (t ': ts) where
+instance {-# OVERLAPPING #-} (Applicative m) => AdjustM m  t (t ': ts) where
   adjustM f (HCons x xs) = HCons <$> f x <*> pure xs
   {-# INLINE adjustM #-}
 
-instance {-# OVERLAPPABLE #-} (Functor m, AdjustM m f t ts) => AdjustM m f t (u ': ts) where
+instance {-# OVERLAPPABLE #-} (Functor m, AdjustM m t ts) => AdjustM m t (u ': ts) where
   adjustM f (HCons y xs) = HCons y <$> adjustM f xs
   {-# INLINE adjustM #-}
 
 class Subset (subset :: [Type]) (superset :: [Type]) where
-  subset :: HSetT f superset -> HSetT f subset
+  subset :: HSet superset -> HSet subset
 
 instance Subset '[] superset where
   subset _ = HEmpty
   {-# INLINE subset #-}
 
-instance
-  ( Lookup t superset,
-    Subset ts superset
-  ) =>
-  Subset (t ': ts) superset
-  where
+instance (Lookup t superset, Subset ts superset) => Subset (t ': ts) superset where
   subset hset = HCons (lookup hset) (subset @ts hset)
   {-# INLINE subset #-}
 
-hcons :: (Applicative f) => t -> HSetT f ts -> HSetT f (t ': ts)
-hcons x = HCons (pure x)
-
-hempty :: HSetT f '[]
-hempty = HEmpty

src/Aztecs/ECS/Schedule/Internal.hs

@@ -15,10 +15,9 @@
 module Aztecs.ECS.Schedule.Internal where
 
 import Aztecs.ECS.Access.Internal
-import Aztecs.ECS.HSet (HSetT (..), Run)
+import Aztecs.ECS.HSet (HSet (..), Run)
 import Aztecs.ECS.Queryable.Internal
 import Aztecs.ECS.System
-import Control.Monad.Identity
 import Data.Kind
 
 class Schedule m s where
@@ -78,24 +77,27 @@ type family If (condition :: Bool) (then_ :: k) (else_ :: k) :: k where
   If 'True then_ else_ = then_
   If 'False then_ else_ = else_
 
-instance Schedule m (HSetT (IdentityT m) '[]) where
-  type Scheduled m (HSetT (IdentityT m) '[]) = HSetT (HSetT (IdentityT m)) '[]
+type family GroupsToNestedHSet m (groups :: [[Type]]) :: [Type] where
+  GroupsToNestedHSet m '[] = '[]
+  GroupsToNestedHSet m (group ': rest) = HSet (MapToIdentityT m group) ': GroupsToNestedHSet m rest
+
+instance Schedule m (HSet '[]) where
+  type Scheduled m (HSet '[]) = HSet '[]
   schedule HEmpty = HEmpty
 
-instance (System m sys) => Schedule m (HSetT (IdentityT m) '[sys]) where
-  type Scheduled m (HSetT (IdentityT m) '[sys]) = HSetT (HSetT (IdentityT m)) (GroupSystems m '[sys])
-  schedule (HCons (IdentityT sys) HEmpty) =
-    HCons (HCons (IdentityT sys) HEmpty) HEmpty
+instance (System m sys) => Schedule m (HSet '[sys]) where
+  type Scheduled m (HSet '[sys]) = HSet (GroupsToNestedHSet m (GroupSystems m '[sys]))
+  schedule (HCons sys HEmpty) = HCons (HCons sys HEmpty) HEmpty
 
 instance
   ( System m sys,
     AllSystems m rest,
     rest ~ (sys2 ': rest'),
     CompileGroups m (GroupSystems m (sys ': rest)) (sys ': rest)
   ) =>
-  Schedule m (HSetT (IdentityT m) (sys ': rest))
+  Schedule m (HSet (sys ': rest))
   where
-  type Scheduled m (HSetT (IdentityT m) (sys ': rest)) = HSetT (HSetT (IdentityT m)) (GroupSystems m (sys ': rest))
+  type Scheduled m (HSet (sys ': rest)) = HSet (GroupsToNestedHSet m (GroupSystems m (sys ': rest)))
   schedule = compileGroups @m @(GroupSystems m (sys ': rest)) @(sys ': rest)
 
 class AllSystems m systems
@@ -107,7 +109,7 @@ instance (System m (Run constraints sys), AllSystems m rest) => AllSystems m (Ru
 instance {-# OVERLAPPABLE #-} (System m sys, AllSystems m rest) => AllSystems m (sys ': rest)
 
 class CompileGroups m (groups :: [[Type]]) (systems :: [Type]) where
-  compileGroups :: HSetT (IdentityT m) systems -> HSetT (HSetT (IdentityT m)) groups
+  compileGroups :: HSet systems -> HSet (GroupsToNestedHSet m groups)
 
 instance CompileGroups m '[] systems where
   compileGroups _ = HEmpty
@@ -123,23 +125,27 @@ instance
     HCons (compileGroup @m @group @systems systems) (compileGroups @m @rest @systems systems)
 
 class CompileGroup m (group :: [Type]) (systems :: [Type]) where
-  compileGroup :: HSetT (IdentityT m) systems -> HSetT (IdentityT m) group
+  compileGroup :: HSet systems -> HSet (MapToIdentityT m group)
+
+type family MapToIdentityT m (systems :: [Type]) :: [Type] where
+  MapToIdentityT m '[] = '[]
+  MapToIdentityT m (sys ': rest) = sys ': MapToIdentityT m rest
 
 instance CompileGroup m '[] systems where
   compileGroup _ = HEmpty
 
 instance (ExtractSystem m sys systems) => CompileGroup m '[sys] systems where
-  compileGroup systems = HCons (extractSystem @m @sys @systems systems) HEmpty
+  compileGroup systems = HCons ((extractSystem @m @sys @systems systems)) HEmpty
 
 instance
   (ExtractSystem m sys systems, CompileGroup m rest systems) =>
   CompileGroup m (sys ': rest) systems
   where
   compileGroup systems =
-    HCons (extractSystem @m @sys @systems systems) (compileGroup @m @rest @systems systems)
+    HCons ((extractSystem @m @sys @systems systems)) (compileGroup @m @rest @systems systems)
 
 class ExtractSystem m (sys :: Type) (systems :: [Type]) where
-  extractSystem :: HSetT (IdentityT m) systems -> IdentityT m sys
+  extractSystem :: HSet systems -> sys
 
 instance ExtractSystem m sys (sys ': rest) where
   extractSystem (HCons sys _) = sys

src/Aztecs/ECS/Scheduler/Internal.hs

@@ -44,7 +44,7 @@ instance
   type SchedulerInput m (HSet systems) = systems
   type
     SchedulerOutput m (HSet systems) =
-      HSetT HSet (ScheduleLevels m (TopologicalSort (BuildSystemGraph systems)))
+      HSet (LevelsToNestedHSet (ScheduleLevels m (TopologicalSort (BuildSystemGraph systems))))
 
   buildSchedule = scheduleSystemLevels @m @(TopologicalSort (BuildSystemGraph systems))
 
@@ -166,13 +166,17 @@ scheduleSystemLevels ::
     ScheduleLevelsBuilder m levels systems
   ) =>
   HSet systems ->
-  HSetT HSet (ScheduleLevels m levels)
+  HSet (LevelsToNestedHSet (ScheduleLevels m levels))
 scheduleSystemLevels = buildScheduleLevels @m @levels @systems
 
+type family LevelsToNestedHSet (levels :: [[Type]]) :: [Type] where
+  LevelsToNestedHSet '[] = '[]
+  LevelsToNestedHSet (level ': rest) = HSet level ': LevelsToNestedHSet rest
+
 class ScheduleLevelsBuilder (m :: Type -> Type) (levels :: [[Type]]) (systems :: [Type]) where
   buildScheduleLevels ::
     HSet systems ->
-    HSetT HSet (ScheduleLevels m levels)
+    HSet (LevelsToNestedHSet (ScheduleLevels m levels))
 
 instance ScheduleLevelsBuilder m '[] systems where
   buildScheduleLevels _ = HEmpty
@@ -222,7 +226,7 @@ instance
   SystemReorderer originalSystems (targetSys ': restTargets)
   where
   reorderSystems originalSystems =
-    let (targetSys, remaining) = extractFromHSet @targetSys @originalSystems originalSystems
+    let (Identity targetSys, remaining) = extractFromHSet @targetSys @originalSystems originalSystems
         rest = reorderSystems @(RemainingAfterExtract targetSys originalSystems) @restTargets remaining
      in HCons targetSys rest
 
@@ -237,14 +241,14 @@ class ExtractFromHSet (targetSys :: Type) (systems :: [Type]) where
     (Identity targetSys, HSet (RemainingAfterExtract targetSys systems))
 
 instance {-# OVERLAPPING #-} ExtractFromHSet sys (sys ': rest) where
-  extractFromHSet (HCons sys rest) = (sys, rest)
+  extractFromHSet (HCons sys rest) = (Identity sys, rest)
 
 instance
   {-# OVERLAPPING #-}
   (RemainingAfterExtract sys (Run constraints sys ': rest) ~ rest) =>
   ExtractFromHSet sys (Run constraints sys ': rest)
   where
-  extractFromHSet (HCons (Identity (Run sys)) rest) = (Identity sys, rest)
+  extractFromHSet (HCons (Run sys) rest) = (Identity sys, rest)
 
 instance
   ( ExtractFromHSet targetSys rest,
@@ -257,15 +261,13 @@ instance
     let (target, remaining) = extractFromHSet @targetSys @rest rest
      in (target, HCons other remaining)
 
-instance (Applicative m) => Execute m (HSetT HSet '[]) where
-  execute HEmpty = pure ()
-
 instance
+  {-# OVERLAPPING #-}
   ( Monad m,
     Execute' m (HSet level),
-    Execute m (HSetT HSet restLevels)
+    Execute m (HSet restLevels)
   ) =>
-  Execute m (HSetT HSet (level ': restLevels))
+  Execute m (HSet (HSet level ': restLevels))
   where
   execute (HCons level restLevels) = do
     ExecutorT $ \run -> run $ execute' level