{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Data.Ecstasy.Types where
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.State.Strict (StateT (..))
import Control.Monad.Writer.Class (MonadWriter)
import Data.Functor.Identity (Identity)
import Data.IntMap.Strict (IntMap)
import Data.Kind
newtype Ent = Ent { unEnt :: Int }
deriving (Eq, Ord)
instance Show Ent where
show (Ent e) = "Ent " ++ show e
type SystemState w m = (Int, w ('WorldOf m))
newtype SystemT w m a = SystemT
{ runSystemT' :: StateT (SystemState w m) m a
}
deriving ( Functor
, Applicative
, Monad
, MonadReader r
, MonadWriter ww
, MonadIO
)
instance MonadTrans (SystemT w) where
lift = SystemT . lift
instance MonadState s m => MonadState s (SystemT w m) where
get = SystemT . lift $ get
put = SystemT . lift . put
type System w = SystemT w Identity
newtype QueryT w m a = QueryT
{ runQueryT' :: ReaderT (Ent, w 'FieldOf) (MaybeT m) a
}
deriving ( Functor
, Applicative
, Monad
, MonadState s
, MonadWriter ww
, MonadIO
, Alternative
, MonadPlus
)
instance MonadTrans (QueryT w) where
lift = QueryT . lift . lift
instance MonadReader r m => MonadReader r (QueryT w m) where
ask = QueryT $ lift ask
local f = QueryT . runQueryT' . local f
data VTable m a = VTable
{
vget :: !(Ent -> m (Maybe a))
, vset :: !(Ent -> Update a -> m ())
}
data StorageType
= FieldOf
| WorldOf (Type -> Type)
| SetterOf
data ComponentType
= Field
| Unique
| Virtual
data Update a
= Keep
| Unset
| Set !a
deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)
type family Component (s :: StorageType)
(c :: ComponentType)
(a :: Type) :: Type where
Component 'FieldOf c a = Maybe a
Component 'SetterOf c a = Update a
Component ('WorldOf m) 'Field a = IntMap a
Component ('WorldOf m) 'Unique a = Maybe (Int, a)
Component ('WorldOf m) 'Virtual a = VTable m a