module Apecs.Logs
(
Log(..), PureLog(..), FromPure(..), Logger, getLog, readIORef,
LVec1, LVec2, LVec3,
EnumTable, byIndex, byEnum,
) where
import Control.Monad.Reader
import qualified Data.IntSet as S
import Data.IORef
import qualified Data.Vector.Mutable as VM
import qualified Apecs.Slice as Sl
import Apecs.Stores
import Apecs.Types
class PureLog l c where
pureEmpty :: l c
pureOnSet :: Entity a -> Maybe c -> c -> l c -> l c
pureOnDestroy :: Entity a -> c -> l c -> l c
class Log l c where
logEmpty :: IO (l c)
logOnSet :: l c -> Entity a -> Maybe c -> c -> IO ()
logOnDestroy :: l c -> Entity a -> c -> IO ()
logReset :: l c -> IO ()
class HasLog s l where
explGetLog :: s -> l (Stores s)
instance HasLog (Logger l s) l where
explGetLog (Logger l _) = l
getLog :: forall w c l. (Store (Storage c), Has w c, HasLog (Storage c) l, Log l c) => System w (l c)
getLog = do s :: Storage c <- getStore
return (explGetLog s)
newtype FromPure l c = FromPure (IORef (l c))
instance PureLog l c => Log (FromPure l) c where
logEmpty = FromPure <$> newIORef pureEmpty
logOnSet (FromPure lref) e old new = modifyIORef' lref (pureOnSet e old new)
logOnDestroy (FromPure lref) e c = modifyIORef' lref (pureOnDestroy e c)
logReset (FromPure lref) = writeIORef lref pureEmpty
data Logger l s = Logger (l (Stores s)) s
instance (Log l (Stores s), Cachable s) => Store (Logger l s) where
type Stores (Logger l s) = Stores s
initStore = Logger <$> logEmpty <*> initStore
explDestroy (Logger l s) ety = do
mc <- explGet s ety
case mc of
Just c -> logOnDestroy l (Entity ety) c >> explDestroy s ety
_ -> return ()
explExists (Logger _ s) ety = explExists s ety
explMembers (Logger _ s) = explMembers s
explReset (Logger l s) = logReset l >> explReset s
explImapM_ (Logger _ s) = explImapM_ s
explImapM (Logger _ s) = explImapM s
type SafeRW (Logger l s) = SafeRW s
explGetUnsafe (Logger _ s) ety = explGetUnsafe s ety
explGet (Logger _ s) ety = explGet s ety
explSet (Logger l s) ety x = do
mc <- explGet s ety
logOnSet l (Entity ety) mc x
explSet s ety x
explSetMaybe s ety (Nothing) = explDestroy s ety
explSetMaybe s ety (Just x) = explSet s ety x
explModify (Logger l s) ety f = do
mc <- explGet s ety
case mc of
Just c -> explSet (Logger l s) ety (f c)
Nothing -> return ()
explCmapM_ (Logger _ s) = explCmapM_ s
explCmapM (Logger _ s) = explCmapM s
explCimapM_ (Logger _ s) = explCimapM_ s
explCimapM (Logger _ s) = explCimapM s
newtype LVec1 l c = LVec1 (l c)
instance Log l c => Log (LVec1 l) c where
logEmpty = LVec1 <$> logEmpty
logOnSet (LVec1 l) e old new = logOnSet l e old new
logOnDestroy (LVec1 l) e c = logOnDestroy l e c
logReset (LVec1 l) = logReset l
data LVec2 l1 l2 c = LVec2 (l1 c) (l2 c)
instance (Log l1 c, Log l2 c) => Log (LVec2 l1 l2) c where
logEmpty = LVec2 <$> logEmpty <*> logEmpty
logOnSet (LVec2 l1 l2) e old new = logOnSet l1 e old new >> logOnSet l2 e old new
logOnDestroy (LVec2 l1 l2) e c = logOnDestroy l1 e c >> logOnDestroy l2 e c
logReset (LVec2 l1 l2) = logReset l1 >> logReset l2
data LVec3 l1 l2 l3 c = LVec3 (l1 c) (l2 c) (l3 c)
instance (Log l1 c, Log l2 c, Log l3 c) => Log (LVec3 l1 l2 l3) c where
logEmpty = LVec3 <$> logEmpty <*> logEmpty <*> logEmpty
logOnSet (LVec3 l1 l2 l3) e old new = do
logOnSet l1 e old new
logOnSet l2 e old new
logOnSet l3 e old new
logOnDestroy (LVec3 l1 l2 l3) e c = do
logOnDestroy l1 e c
logOnDestroy l2 e c
logOnDestroy l3 e c
logReset (LVec3 l1 l2 l3) = do
logReset l1
logReset l2
logReset l3
newtype EnumTable c = EnumTable (VM.IOVector S.IntSet)
instance (Bounded c, Enum c) => Log EnumTable c where
logEmpty = do
let lo = fromEnum (minBound :: c)
hi = fromEnum (maxBound :: c)
if lo == 0
then EnumTable <$> VM.replicate (hi+1) mempty
else error "Attempted to initialize EnumTable for a component with a non-zero minBound"
logOnSet (EnumTable vec) (Entity e) old new = do
case old of
Nothing -> return ()
Just c -> VM.modify vec (S.delete e) (fromEnum c)
VM.modify vec (S.insert e) (fromEnum new)
logOnDestroy (EnumTable vec) (Entity e) c = VM.modify vec (S.delete e) (fromEnum c)
logReset (EnumTable vec) = forM_ [0..VM.length vec 1] (\e -> VM.write vec e mempty)
byIndex :: EnumTable c -> Int -> System w (Slice c)
byIndex (EnumTable vec) c
| c < 0 = return mempty
| c >= VM.length vec 1 = return mempty
| otherwise = liftIO$ Sl.fromList . S.toList <$> VM.read vec c
byEnum :: Enum c => EnumTable c -> c -> System w (Slice c)
byEnum (EnumTable vec) c = liftIO$ Sl.fromList . S.toList <$> VM.read vec (fromEnum c)