{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Aztecs.ECS.Access.Internal
-- Copyright   : (c) Matt Hunzinger, 2025
-- License     : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  : matt@hunzinger.me
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Aztecs.ECS.Access.Internal
  ( Access (..),
    runAccessWith,
    evalAccess,
    triggerEvent,
    triggerEntityEvent,
  )
where

import Aztecs.ECS.Entity
import Aztecs.ECS.Event
import Aztecs.ECS.World.Internal
import qualified Aztecs.ECS.World.Observers as O
import Aztecs.ECS.World.Observers.Internal
import Control.Monad
import Control.Monad.Fix
import Control.Monad.State
import Data.Dynamic
import Data.Maybe
import qualified Data.Set as Set
import Data.Typeable

-- | Access into a `World`.
newtype Access m a = Access {forall (m :: * -> *) a. Access m a -> StateT (World m) m a
unAccess :: StateT (World m) m a}
  deriving ((forall a b. (a -> b) -> Access m a -> Access m b)
-> (forall a b. a -> Access m b -> Access m a)
-> Functor (Access m)
forall a b. a -> Access m b -> Access m a
forall a b. (a -> b) -> Access m a -> Access m b
forall (m :: * -> *) a b.
Functor m =>
a -> Access m b -> Access m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Access m a -> Access m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Access m a -> Access m b
fmap :: forall a b. (a -> b) -> Access m a -> Access m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Access m b -> Access m a
<$ :: forall a b. a -> Access m b -> Access m a
Functor, Functor (Access m)
Functor (Access m) =>
(forall a. a -> Access m a)
-> (forall a b. Access m (a -> b) -> Access m a -> Access m b)
-> (forall a b c.
    (a -> b -> c) -> Access m a -> Access m b -> Access m c)
-> (forall a b. Access m a -> Access m b -> Access m b)
-> (forall a b. Access m a -> Access m b -> Access m a)
-> Applicative (Access m)
forall a. a -> Access m a
forall a b. Access m a -> Access m b -> Access m a
forall a b. Access m a -> Access m b -> Access m b
forall a b. Access m (a -> b) -> Access m a -> Access m b
forall a b c.
(a -> b -> c) -> Access m a -> Access m b -> Access m c
forall (m :: * -> *). Monad m => Functor (Access m)
forall (m :: * -> *) a. Monad m => a -> Access m a
forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m a
forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m b
forall (m :: * -> *) a b.
Monad m =>
Access m (a -> b) -> Access m a -> Access m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Access m a -> Access m b -> Access m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> Access m a
pure :: forall a. a -> Access m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Access m (a -> b) -> Access m a -> Access m b
<*> :: forall a b. Access m (a -> b) -> Access m a -> Access m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Access m a -> Access m b -> Access m c
liftA2 :: forall a b c.
(a -> b -> c) -> Access m a -> Access m b -> Access m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m b
*> :: forall a b. Access m a -> Access m b -> Access m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m a
<* :: forall a b. Access m a -> Access m b -> Access m a
Applicative, Applicative (Access m)
Applicative (Access m) =>
(forall a b. Access m a -> (a -> Access m b) -> Access m b)
-> (forall a b. Access m a -> Access m b -> Access m b)
-> (forall a. a -> Access m a)
-> Monad (Access m)
forall a. a -> Access m a
forall a b. Access m a -> Access m b -> Access m b
forall a b. Access m a -> (a -> Access m b) -> Access m b
forall (m :: * -> *). Monad m => Applicative (Access m)
forall (m :: * -> *) a. Monad m => a -> Access m a
forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m b
forall (m :: * -> *) a b.
Monad m =>
Access m a -> (a -> Access m b) -> Access m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Access m a -> (a -> Access m b) -> Access m b
>>= :: forall a b. Access m a -> (a -> Access m b) -> Access m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Access m a -> Access m b -> Access m b
>> :: forall a b. Access m a -> Access m b -> Access m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Access m a
return :: forall a. a -> Access m a
Monad, Monad (Access m)
Monad (Access m) =>
(forall a. (a -> Access m a) -> Access m a) -> MonadFix (Access m)
forall a. (a -> Access m a) -> Access m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (Access m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> Access m a) -> Access m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> Access m a) -> Access m a
mfix :: forall a. (a -> Access m a) -> Access m a
MonadFix, Monad (Access m)
Monad (Access m) =>
(forall a. IO a -> Access m a) -> MonadIO (Access m)
forall a. IO a -> Access m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (Access m)
forall (m :: * -> *) a. MonadIO m => IO a -> Access m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Access m a
liftIO :: forall a. IO a -> Access m a
MonadIO)

-- | Run an `Access` with a given `World`, returning the result and updated world.
runAccessWith :: Access m a -> World m -> m (a, World m)
runAccessWith :: forall (m :: * -> *) a. Access m a -> World m -> m (a, World m)
runAccessWith Access m a
a = StateT (World m) m a -> World m -> m (a, World m)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Access m a -> StateT (World m) m a
forall (m :: * -> *) a. Access m a -> StateT (World m) m a
unAccess Access m a
a)

-- | Run an `Access` with a given `World`, returning only the result.
evalAccess :: (Monad m) => Access m a -> World m -> m a
evalAccess :: forall (m :: * -> *) a. Monad m => Access m a -> World m -> m a
evalAccess Access m a
a = StateT (World m) m a -> World m -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Access m a -> StateT (World m) m a
forall (m :: * -> *) a. Access m a -> StateT (World m) m a
unAccess Access m a
a)

-- | Trigger an event.
triggerEvent :: forall m e. (Monad m, Event e) => e -> Access m ()
triggerEvent :: forall (m :: * -> *) e. (Monad m, Event e) => e -> Access m ()
triggerEvent e
evt = StateT (World m) m () -> Access m ()
forall (m :: * -> *) a. StateT (World m) m a -> Access m a
Access (StateT (World m) m () -> Access m ())
-> StateT (World m) m () -> Access m ()
forall a b. (a -> b) -> a -> b
$ do
  !World m
w <- StateT (World m) m (World m)
forall s (m :: * -> *). MonadState s m => m s
get
  let eventTypeRep :: TypeRep
eventTypeRep = Proxy e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)
      globalOs :: Set ObserverID
globalOs = TypeRep -> Observers (StateT (World m) m) -> Set ObserverID
forall (m :: * -> *). TypeRep -> Observers m -> Set ObserverID
O.lookupGlobalObservers TypeRep
eventTypeRep (Observers (StateT (World m) m) -> Set ObserverID)
-> Observers (StateT (World m) m) -> Set ObserverID
forall a b. (a -> b) -> a -> b
$ World m -> Observers (StateT (World m) m)
forall (m :: * -> *). World m -> Observers (StateT (World m) m)
observers World m
w
      callbacks :: [DynamicObserver (StateT (World m) m)]
callbacks = (ObserverID -> Maybe (DynamicObserver (StateT (World m) m)))
-> [ObserverID] -> [DynamicObserver (StateT (World m) m)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ObserverID
oId -> ObserverID
-> Observers (StateT (World m) m)
-> Maybe (DynamicObserver (StateT (World m) m))
forall (m :: * -> *).
ObserverID -> Observers m -> Maybe (DynamicObserver m)
O.lookupCallback ObserverID
oId (World m -> Observers (StateT (World m) m)
forall (m :: * -> *). World m -> Observers (StateT (World m) m)
observers World m
w)) ([ObserverID] -> [DynamicObserver (StateT (World m) m)])
-> [ObserverID] -> [DynamicObserver (StateT (World m) m)]
forall a b. (a -> b) -> a -> b
$ Set ObserverID -> [ObserverID]
forall a. Set a -> [a]
Set.toList Set ObserverID
globalOs
      dynEvt :: Dynamic
dynEvt = e -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn e
evt
  [DynamicObserver (StateT (World m) m)]
-> (DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
-> StateT (World m) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DynamicObserver (StateT (World m) m)]
callbacks ((DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
 -> StateT (World m) m ())
-> (DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
-> StateT (World m) m ()
forall a b. (a -> b) -> a -> b
$ \DynamicObserver (StateT (World m) m)
cb -> case DynamicObserver (StateT (World m) m)
cb of
    DynEventObserver Dynamic -> StateT (World m) m ()
f -> Dynamic -> StateT (World m) m ()
f Dynamic
dynEvt
    DynEntityObserver EntityID -> Dynamic -> StateT (World m) m ()
_ -> () -> StateT (World m) m ()
forall a. a -> StateT (World m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Trigger an event for a specific entity.
triggerEntityEvent ::
  forall m e.
  (Monad m, Event e) =>
  EntityID ->
  e ->
  Access m ()
triggerEntityEvent :: forall (m :: * -> *) e.
(Monad m, Event e) =>
EntityID -> e -> Access m ()
triggerEntityEvent EntityID
targetEntity e
evt = StateT (World m) m () -> Access m ()
forall (m :: * -> *) a. StateT (World m) m a -> Access m a
Access (StateT (World m) m () -> Access m ())
-> StateT (World m) m () -> Access m ()
forall a b. (a -> b) -> a -> b
$ do
  !World m
w <- StateT (World m) m (World m)
forall s (m :: * -> *). MonadState s m => m s
get
  let eventTypeRep :: TypeRep
eventTypeRep = Proxy e -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Proxy e -> TypeRep) -> Proxy e -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e
      entityOs :: Set ObserverID
entityOs = TypeRep
-> EntityID -> Observers (StateT (World m) m) -> Set ObserverID
forall (m :: * -> *).
TypeRep -> EntityID -> Observers m -> Set ObserverID
O.lookupEntityObservers TypeRep
eventTypeRep EntityID
targetEntity (Observers (StateT (World m) m) -> Set ObserverID)
-> Observers (StateT (World m) m) -> Set ObserverID
forall a b. (a -> b) -> a -> b
$ World m -> Observers (StateT (World m) m)
forall (m :: * -> *). World m -> Observers (StateT (World m) m)
observers World m
w
      callbacks :: [DynamicObserver (StateT (World m) m)]
callbacks = (ObserverID -> Maybe (DynamicObserver (StateT (World m) m)))
-> [ObserverID] -> [DynamicObserver (StateT (World m) m)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ObserverID
oId -> ObserverID
-> Observers (StateT (World m) m)
-> Maybe (DynamicObserver (StateT (World m) m))
forall (m :: * -> *).
ObserverID -> Observers m -> Maybe (DynamicObserver m)
O.lookupCallback ObserverID
oId (World m -> Observers (StateT (World m) m)
forall (m :: * -> *). World m -> Observers (StateT (World m) m)
observers World m
w)) ([ObserverID] -> [DynamicObserver (StateT (World m) m)])
-> [ObserverID] -> [DynamicObserver (StateT (World m) m)]
forall a b. (a -> b) -> a -> b
$ Set ObserverID -> [ObserverID]
forall a. Set a -> [a]
Set.toList Set ObserverID
entityOs
      dynEvt :: Dynamic
dynEvt = e -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn e
evt
  [DynamicObserver (StateT (World m) m)]
-> (DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
-> StateT (World m) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DynamicObserver (StateT (World m) m)]
callbacks ((DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
 -> StateT (World m) m ())
-> (DynamicObserver (StateT (World m) m) -> StateT (World m) m ())
-> StateT (World m) m ()
forall a b. (a -> b) -> a -> b
$ \DynamicObserver (StateT (World m) m)
cb -> case DynamicObserver (StateT (World m) m)
cb of
    DynEntityObserver EntityID -> Dynamic -> StateT (World m) m ()
f -> EntityID -> Dynamic -> StateT (World m) m ()
f EntityID
targetEntity Dynamic
dynEvt
    DynEventObserver Dynamic -> StateT (World m) m ()
_ -> () -> StateT (World m) m ()
forall a. a -> StateT (World m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()