{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Data.Aztecs.System
  ( Access (..),
    runAccess,
    runAccess',
    all,
    get,
    command,
    System (..),
    runSystem,
    runSystem',
    Cache (..),
  )
where

import Control.Monad.IO.Class
import Data.Aztecs.Command
import Data.Aztecs.Query (Query (..))
import qualified Data.Aztecs.Query as Q
import Data.Aztecs.World (Entity, World (..))
import Data.Aztecs.World.Archetypes (Archetype, ArchetypeId)
import qualified Data.Aztecs.World.Archetypes as A
import Data.Foldable (foldrM)
import Data.Kind
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Typeable
import Prelude hiding (all, read)

newtype Cache = Cache (Map Archetype ArchetypeId)
  deriving (NonEmpty Cache -> Cache
Cache -> Cache -> Cache
(Cache -> Cache -> Cache)
-> (NonEmpty Cache -> Cache)
-> (forall b. Integral b => b -> Cache -> Cache)
-> Semigroup Cache
forall b. Integral b => b -> Cache -> Cache
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Cache -> Cache -> Cache
<> :: Cache -> Cache -> Cache
$csconcat :: NonEmpty Cache -> Cache
sconcat :: NonEmpty Cache -> Cache
$cstimes :: forall b. Integral b => b -> Cache -> Cache
stimes :: forall b. Integral b => b -> Cache -> Cache
Semigroup, Semigroup Cache
Cache
Semigroup Cache =>
Cache
-> (Cache -> Cache -> Cache) -> ([Cache] -> Cache) -> Monoid Cache
[Cache] -> Cache
Cache -> Cache -> Cache
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Cache
mempty :: Cache
$cmappend :: Cache -> Cache -> Cache
mappend :: Cache -> Cache -> Cache
$cmconcat :: [Cache] -> Cache
mconcat :: [Cache] -> Cache
Monoid)

data Access (m :: Type -> Type) a where
  PureA :: a -> Access m a
  MapA :: (a -> b) -> Access m a -> Access m b
  AppA :: Access m (a -> b) -> Access m a -> Access m b
  BindA :: Access m a -> (a -> Access m b) -> Access m b
  AllA :: Archetype -> Query m a -> Access m [a]
  GetA :: Archetype -> Query m a -> Entity -> Access m (Maybe a)
  CommandA :: Command m () -> Access m ()
  LiftA :: m a -> Access m a

instance Functor (Access m) where
  fmap :: forall a b. (a -> b) -> Access m a -> Access m b
fmap = (a -> b) -> Access m a -> Access m b
forall a b (m :: * -> *). (a -> b) -> Access m a -> Access m b
MapA

instance (Monad m) => Applicative (Access m) where
  pure :: forall a. a -> Access m a
pure = a -> Access m a
forall a (m :: * -> *). a -> Access m a
PureA
  <*> :: forall a b. Access m (a -> b) -> Access m a -> Access m b
(<*>) = Access m (a -> b) -> Access m a -> Access m b
forall (m :: * -> *) a b.
Access m (a -> b) -> Access m a -> Access m b
AppA

instance (Monad m) => Monad (Access m) where
  >>= :: forall a b. Access m a -> (a -> Access m b) -> Access m b
(>>=) = Access m a -> (a -> Access m b) -> Access m b
forall (m :: * -> *) a b.
Access m a -> (a -> Access m b) -> Access m b
BindA

instance (MonadIO m) => MonadIO (Access m) where
  liftIO :: forall a. IO a -> Access m a
liftIO IO a
io = m a -> Access m a
forall (m :: * -> *) a. m a -> Access m a
LiftA (IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)

runAccess :: Access IO a -> World -> Cache -> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess :: forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess (PureA a
a) World
w Cache
c = (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Access IO a) a
forall a b. b -> Either a b
Right a
a, World
w, Cache
c, [])
runAccess (MapA a -> a
f Access IO a
a) World
w Cache
cache = do
  (Either (Access IO a) a
a', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess Access IO a
a World
w Cache
cache
  (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( case Either (Access IO a) a
a' of
        Left Access IO a
a'' -> Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left ((a -> a) -> Access IO a -> Access IO a
forall a b (m :: * -> *). (a -> b) -> Access m a -> Access m b
MapA a -> a
f Access IO a
a'')
        Right a
a'' -> a -> Either (Access IO a) a
forall a b. b -> Either a b
Right (a -> a
f a
a''),
      World
w',
      Cache
cache',
      [Command IO ()]
cmds
    )
runAccess (AppA Access IO (a -> a)
f Access IO a
a) World
w Cache
cache = do
  (Either (Access IO (a -> a)) (a -> a)
f', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO (a -> a)
-> World
-> Cache
-> IO
     (Either (Access IO (a -> a)) (a -> a), World, Cache,
      [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess Access IO (a -> a)
f World
w Cache
cache
  (Either (Access IO a) a
a', World
w'', Cache
cache'', [Command IO ()]
cmds') <- Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess Access IO a
a World
w' Cache
cache'
  (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( case (Either (Access IO (a -> a)) (a -> a)
f', Either (Access IO a) a
a') of
        (Right a -> a
f'', Right a
a'') -> a -> Either (Access IO a) a
forall a b. b -> Either a b
Right (a -> a
f'' a
a'')
        (Left Access IO (a -> a)
f'', Either (Access IO a) a
_) -> Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left (Access IO (a -> a) -> Access IO a -> Access IO a
forall (m :: * -> *) a b.
Access m (a -> b) -> Access m a -> Access m b
AppA Access IO (a -> a)
f'' Access IO a
a)
        (Either (Access IO (a -> a)) (a -> a)
_, Left Access IO a
a'') -> Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left (Access IO (a -> a) -> Access IO a -> Access IO a
forall (m :: * -> *) a b.
Access m (a -> b) -> Access m a -> Access m b
AppA Access IO (a -> a)
f Access IO a
a''),
      World
w'',
      Cache
cache'',
      [Command IO ()]
cmds [Command IO ()] -> [Command IO ()] -> [Command IO ()]
forall a. [a] -> [a] -> [a]
++ [Command IO ()]
cmds'
    )
runAccess (BindA Access IO a
a a -> Access IO a
f) World
w Cache
cache = do
  (Either (Access IO a) a
a', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess Access IO a
a World
w Cache
cache
  case Either (Access IO a) a
a' of
    Left Access IO a
a'' -> (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left (Access IO a -> (a -> Access IO a) -> Access IO a
forall (m :: * -> *) a b.
Access m a -> (a -> Access m b) -> Access m b
BindA Access IO a
a'' a -> Access IO a
f), World
w', Cache
cache', [Command IO ()]
cmds)
    Right a
a'' -> Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess (a -> Access IO a
f a
a'') World
w' Cache
cache'
runAccess (AllA Archetype
a Query IO a
qb) World
w (Cache Map Archetype ArchetypeId
cache) = case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Query IO a -> Archetype
forall (m :: * -> *) a. Query m a -> Archetype
Q.buildQuery Query IO a
qb) Map Archetype ArchetypeId
cache of
  Just ArchetypeId
aId -> do
    [a]
es <- ArchetypeId -> Query IO a -> World -> IO [a]
forall (m :: * -> *) a.
MonadIO m =>
ArchetypeId -> Query m a -> World -> m [a]
Q.all ArchetypeId
aId Query IO a
qb World
w
    (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Access IO a) a
forall a b. b -> Either a b
Right a
[a]
es, World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
  Maybe ArchetypeId
Nothing -> (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left (Archetype -> Query IO a -> Access IO [a]
forall (m :: * -> *) a. Archetype -> Query m a -> Access m [a]
AllA Archetype
a Query IO a
qb), World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
runAccess (GetA Archetype
arch Query IO a
q Entity
e) World
w (Cache Map Archetype ArchetypeId
cache) = do
  case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Archetype
arch Map Archetype ArchetypeId
cache of
    Just ArchetypeId
aId -> do
      Maybe a
a <- ArchetypeId -> Query IO a -> Entity -> World -> IO (Maybe a)
forall (m :: * -> *) a.
MonadIO m =>
ArchetypeId -> Query m a -> Entity -> World -> m (Maybe a)
Q.get ArchetypeId
aId Query IO a
q Entity
e World
w
      (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Access IO a) a
forall a b. b -> Either a b
Right a
Maybe a
a, World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
    Maybe ArchetypeId
Nothing -> (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access IO a -> Either (Access IO a) a
forall a b. a -> Either a b
Left (Archetype -> Query IO a -> Entity -> Access IO (Maybe a)
forall (m :: * -> *) a.
Archetype -> Query m a -> Entity -> Access m (Maybe a)
GetA Archetype
arch Query IO a
q Entity
e), World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
runAccess (CommandA Command IO ()
cmd) World
w Cache
cache = (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Access IO a) a
forall a b. b -> Either a b
Right (), World
w, Cache
cache, [Command IO ()
cmd])
runAccess (LiftA IO a
io) World
w Cache
cache = do
  a
a <- IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io
  (Either (Access IO a) a, World, Cache, [Command IO ()])
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either (Access IO a) a
forall a b. b -> Either a b
Right a
a, World
w, Cache
cache, [])

runAccess' :: Access IO a -> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' :: forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' (PureA a
a) World
w Cache
c = (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, World
w, Cache
c, [])
runAccess' (MapA a -> a
f Access IO a
a) World
w Cache
cache = do
  (a
a', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' Access IO a
a World
w Cache
cache
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
f a
a', World
w', Cache
cache', [Command IO ()]
cmds)
runAccess' (AppA Access IO (a -> a)
f Access IO a
a) World
w Cache
cache = do
  (a -> a
f', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO (a -> a)
-> World -> Cache -> IO (a -> a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' Access IO (a -> a)
f World
w Cache
cache
  (a
a', World
w'', Cache
cache'', [Command IO ()]
cmds') <- Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' Access IO a
a World
w' Cache
cache'
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
f' a
a', World
w'', Cache
cache'', [Command IO ()]
cmds [Command IO ()] -> [Command IO ()] -> [Command IO ()]
forall a. [a] -> [a] -> [a]
++ [Command IO ()]
cmds')
runAccess' (BindA Access IO a
a a -> Access IO a
f) World
w Cache
cache = do
  (a
a', World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' Access IO a
a World
w Cache
cache
  (a
b, World
w'', Cache
cache'', [Command IO ()]
cmds') <- Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
forall a.
Access IO a
-> World -> Cache -> IO (a, World, Cache, [Command IO ()])
runAccess' (a -> Access IO a
f a
a') World
w' Cache
cache'
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
b, World
w'', Cache
cache'', [Command IO ()]
cmds [Command IO ()] -> [Command IO ()] -> [Command IO ()]
forall a. [a] -> [a] -> [a]
++ [Command IO ()]
cmds')
runAccess' (AllA Archetype
_ Query IO a
qb) (World Components
cs Archetypes
as) (Cache Map Archetype ArchetypeId
cache) = do
  (ArchetypeId
aId, World
w) <- case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Query IO a -> Archetype
forall (m :: * -> *) a. Query m a -> Archetype
Q.buildQuery Query IO a
qb) Map Archetype ArchetypeId
cache of
    Just ArchetypeId
q' -> (ArchetypeId, World) -> IO (ArchetypeId, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchetypeId
q', Components -> Archetypes -> World
World Components
cs Archetypes
as)
    Maybe ArchetypeId
Nothing -> do
      (ArchetypeId
x, Archetypes
as') <- Archetype
-> Components -> Archetypes -> IO (ArchetypeId, Archetypes)
A.insertArchetype (Query IO a -> Archetype
forall (m :: * -> *) a. Query m a -> Archetype
Q.buildQuery Query IO a
qb) Components
cs Archetypes
as
      (ArchetypeId, World) -> IO (ArchetypeId, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchetypeId
x, Components -> Archetypes -> World
World Components
cs Archetypes
as')
  [a]
es <- ArchetypeId -> Query IO a -> World -> IO [a]
forall (m :: * -> *) a.
MonadIO m =>
ArchetypeId -> Query m a -> World -> m [a]
Q.all ArchetypeId
aId Query IO a
qb World
w
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
[a]
es, World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
runAccess' (GetA Archetype
arch Query IO a
q Entity
e) (World Components
cs Archetypes
as) (Cache Map Archetype ArchetypeId
cache) = do
  (ArchetypeId
aId, World
w) <- case Archetype -> Map Archetype ArchetypeId -> Maybe ArchetypeId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Archetype
arch Map Archetype ArchetypeId
cache of
    Just ArchetypeId
q' -> (ArchetypeId, World) -> IO (ArchetypeId, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchetypeId
q', Components -> Archetypes -> World
World Components
cs Archetypes
as)
    Maybe ArchetypeId
Nothing -> do
      (ArchetypeId
x, Archetypes
as') <- Archetype
-> Components -> Archetypes -> IO (ArchetypeId, Archetypes)
A.insertArchetype Archetype
arch Components
cs Archetypes
as
      (ArchetypeId, World) -> IO (ArchetypeId, World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchetypeId
x, Components -> Archetypes -> World
World Components
cs Archetypes
as')
  Maybe a
a <- ArchetypeId -> Query IO a -> Entity -> World -> IO (Maybe a)
forall (m :: * -> *) a.
MonadIO m =>
ArchetypeId -> Query m a -> Entity -> World -> m (Maybe a)
Q.get ArchetypeId
aId Query IO a
q Entity
e World
w
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
Maybe a
a, World
w, Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
cache, [])
runAccess' (CommandA Command IO ()
cmd) World
w Cache
cache = (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), World
w, Cache
cache, [Command IO ()
cmd])
runAccess' (LiftA IO a
io) World
w Cache
cache = do
  a
a <- IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io
  (a, World, Cache, [Command IO ()])
-> IO (a, World, Cache, [Command IO ()])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, World
w, Cache
cache, [])

-- | Query all matches.
all :: (Monad m) => Query m a -> Access m [a]
all :: forall (m :: * -> *) a. Monad m => Query m a -> Access m [a]
all Query m a
q = ([a], Archetype) -> [a]
forall a b. (a, b) -> a
fst (([a], Archetype) -> [a])
-> Access m ([a], Archetype) -> Access m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archetype -> Query m a -> Access m ([a], Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
forall a. Monoid a => a
mempty Query m a
q

all' :: (Monad m) => Archetype -> Query m a -> Access m ([a], Archetype)
all' :: forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
arch (PureQ a
a) = ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
a], Archetype
arch)
all' Archetype
arch (MapQ a1 -> a
f Query m a1
a) = Archetype -> Query m a -> Access m ([a], Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
arch (a1 -> a
f (a1 -> a) -> Query m a1 -> Query m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query m a1
a)
all' Archetype
arch (AppQ Query m (a1 -> a)
f Query m a1
a) = Archetype -> Query m a -> Access m ([a], Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
arch (Query m (a1 -> a)
f Query m (a1 -> a) -> Query m a1 -> Query m a
forall a b. Query m (a -> b) -> Query m a -> Query m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Query m a1
a)
all' Archetype
arch (BindQ Query m a1
a a1 -> Query m a
f) = do
  ([a1]
a', Archetype
arch') <- Archetype -> Query m a1 -> Access m ([a1], Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
arch Query m a1
a
  (a1 -> ([a], Archetype) -> Access m ([a], Archetype))
-> ([a], Archetype) -> [a1] -> Access m ([a], Archetype)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
    ( \a1
q ([a]
acc, Archetype
archAcc) -> do
        ([a]
as, Archetype
archAcc') <- Archetype -> Query m a -> Access m ([a], Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Query m a -> Access m ([a], Archetype)
all' Archetype
archAcc (a1 -> Query m a
f a1
q)
        ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
acc, Archetype
archAcc')
    )
    ([], Archetype
arch')
    [a1]
a'
all' Archetype
arch (LiftQ m a
m) = do
  a
a <- m a -> Access m a
forall (m :: * -> *) a. m a -> Access m a
LiftA m a
m
  ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a
a], Archetype
arch)
all' Archetype
arch (ReadQ Archetype
arch') = do
  let arch'' :: Archetype
arch'' = (Archetype
arch Archetype -> Archetype -> Archetype
forall a. Semigroup a => a -> a -> a
<> Archetype
arch')
  [a]
as <- Archetype -> Query m a -> Access m [a]
forall (m :: * -> *) a. Archetype -> Query m a -> Access m [a]
AllA Archetype
arch'' (Archetype -> Query m a
forall a (m :: * -> *). Component a => Archetype -> Query m a
ReadQ Archetype
arch')
  ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as, Archetype
arch'')
all' Archetype
arch (WriteQ a -> a
f Archetype
arch') = do
  let arch'' :: Archetype
arch'' = (Archetype
arch Archetype -> Archetype -> Archetype
forall a. Semigroup a => a -> a -> a
<> Archetype
arch')
  [a]
as <- Archetype -> Query m a -> Access m [a]
forall (m :: * -> *) a. Archetype -> Query m a -> Access m [a]
AllA Archetype
arch'' ((a -> a) -> Archetype -> Query m a
forall a (m :: * -> *).
Component a =>
(a -> a) -> Archetype -> Query m a
WriteQ a -> a
f Archetype
arch')
  ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as, Archetype
arch'')
all' Archetype
arch Query m a
EntityQ = do
  [Entity]
es <- Archetype -> Query m Entity -> Access m [Entity]
forall (m :: * -> *) a. Archetype -> Query m a -> Access m [a]
AllA Archetype
arch Query m Entity
forall (m :: * -> *). Query m Entity
EntityQ
  ([a], Archetype) -> Access m ([a], Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
[Entity]
es, Archetype
arch)

get :: (Monad m) => Entity -> Query m a -> Access m (Maybe a)
get :: forall (m :: * -> *) a.
Monad m =>
Entity -> Query m a -> Access m (Maybe a)
get Entity
e Query m a
q = (Maybe a, Archetype) -> Maybe a
forall a b. (a, b) -> a
fst ((Maybe a, Archetype) -> Maybe a)
-> Access m (Maybe a, Archetype) -> Access m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
forall a. Monoid a => a
mempty Entity
e Query m a
q

get' :: (Monad m) => Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' :: forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
arch Entity
_ (PureQ a
a) = (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Archetype
arch)
get' Archetype
arch Entity
e (MapQ a1 -> a
f Query m a1
qb) = Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
arch Entity
e (a1 -> a
f (a1 -> a) -> Query m a1 -> Query m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query m a1
qb)
get' Archetype
arch Entity
e (AppQ Query m (a1 -> a)
f Query m a1
a) = Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
arch Entity
e (Query m (a1 -> a)
f Query m (a1 -> a) -> Query m a1 -> Query m a
forall a b. Query m (a -> b) -> Query m a -> Query m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Query m a1
a)
get' Archetype
arch Entity
e (BindQ Query m a1
a a1 -> Query m a
f) = do
  (Maybe a1
a', Archetype
arch') <- Archetype -> Entity -> Query m a1 -> Access m (Maybe a1, Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
arch Entity
e Query m a1
a
  case (a1 -> Query m a) -> Maybe a1 -> Maybe (Query m a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a1 -> Query m a
f Maybe a1
a' of
    Just Query m a
a'' -> Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
forall (m :: * -> *) a.
Monad m =>
Archetype -> Entity -> Query m a -> Access m (Maybe a, Archetype)
get' Archetype
arch' Entity
e Query m a
a''
    Maybe (Query m a)
Nothing -> (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, Archetype
arch')
get' Archetype
arch Entity
_ (LiftQ m a
m) = do
  a
a <- m a -> Access m a
forall (m :: * -> *) a. m a -> Access m a
LiftA m a
m
  (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Archetype
arch)
get' Archetype
arch Entity
e (ReadQ Archetype
arch') = do
  let arch'' :: Archetype
arch'' = (Archetype
arch Archetype -> Archetype -> Archetype
forall a. Semigroup a => a -> a -> a
<> Archetype
arch')
  Maybe a
a <- Archetype -> Query m a -> Entity -> Access m (Maybe a)
forall (m :: * -> *) a.
Archetype -> Query m a -> Entity -> Access m (Maybe a)
GetA Archetype
arch'' (Archetype -> Query m a
forall a (m :: * -> *). Component a => Archetype -> Query m a
ReadQ Archetype
arch') Entity
e
  (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
a, Archetype
arch'')
get' Archetype
arch Entity
e (WriteQ a -> a
f Archetype
arch') = do
  let arch'' :: Archetype
arch'' = (Archetype
arch Archetype -> Archetype -> Archetype
forall a. Semigroup a => a -> a -> a
<> Archetype
arch')
  Maybe a
a <- Archetype -> Query m a -> Entity -> Access m (Maybe a)
forall (m :: * -> *) a.
Archetype -> Query m a -> Entity -> Access m (Maybe a)
GetA Archetype
arch'' ((a -> a) -> Archetype -> Query m a
forall a (m :: * -> *).
Component a =>
(a -> a) -> Archetype -> Query m a
WriteQ a -> a
f Archetype
arch') Entity
e
  (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
a, Archetype
arch'')
get' Archetype
arch Entity
e Query m a
EntityQ = (Maybe a, Archetype) -> Access m (Maybe a, Archetype)
forall a. a -> Access m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
Entity
e, Archetype
arch)

command :: Command m () -> Access m ()
command :: forall (m :: * -> *). Command m () -> Access m ()
command = Command m () -> Access m ()
forall (m :: * -> *). Command m () -> Access m ()
CommandA

class (Typeable a) => System m a where
  access :: Access m ()

runSystem :: forall a. (System IO a) => World -> IO World
runSystem :: forall a. System IO a => World -> IO World
runSystem World
w = do
  (Maybe (Access IO ())
_, Cache
_, [Command IO ()]
_, World
w') <- forall a.
System IO a =>
Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystem' @a (Map Archetype ArchetypeId -> Cache
Cache Map Archetype ArchetypeId
forall a. Monoid a => a
mempty) World
w
  World -> IO World
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return World
w'

runSystem' :: forall a. (System IO a) => Cache -> World -> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystem' :: forall a.
System IO a =>
Cache
-> World
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
runSystem' Cache
cache World
w = do
  (Either (Access IO ()) ()
result, World
w', Cache
cache', [Command IO ()]
cmds) <- Access IO ()
-> World
-> Cache
-> IO (Either (Access IO ()) (), World, Cache, [Command IO ()])
forall a.
Access IO a
-> World
-> Cache
-> IO (Either (Access IO a) a, World, Cache, [Command IO ()])
runAccess (forall (m :: * -> *) a. System m a => Access m ()
access @IO @a) World
w Cache
cache
  case Either (Access IO ()) ()
result of
    Left Access IO ()
a -> (Maybe (Access IO ()), Cache, [Command IO ()], World)
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Access IO () -> Maybe (Access IO ())
forall a. a -> Maybe a
Just Access IO ()
a, Cache
cache', [Command IO ()]
cmds, World
w')
    Right ()
_ -> (Maybe (Access IO ()), Cache, [Command IO ()], World)
-> IO (Maybe (Access IO ()), Cache, [Command IO ()], World)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Access IO ())
forall a. Maybe a
Nothing, Cache
cache', [Command IO ()]
cmds, World
w')