{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Aztecs.ECS.Observer
-- 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.Observer
  ( Observer (..),
    ObserverID (..),
    ObserverKind (..),
    observer,
    observerFor,
    observerGlobal,
  )
where

import Aztecs.ECS.Access.Internal
import Aztecs.ECS.Component
import Aztecs.ECS.Entity
import Aztecs.ECS.Event
import qualified Aztecs.ECS.World as W
import Aztecs.ECS.World.Bundle
import Aztecs.ECS.World.Internal (World (..))
import qualified Aztecs.ECS.World.Observers as O
import Aztecs.ECS.World.Observers.Internal
import Control.Monad.State
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable
import Data.Vector (Vector)

-- | The kind of observer - either entity-specific or global.
data ObserverKind m e
  = -- | Observe events on specific entities (callback receives EntityID and event).
    EntityObserver !(Set EntityID) !(EntityID -> e -> Access m ())
  | -- | Observe all events of this type globally (callback receives just the event).
    EventObserver !(e -> Access m ())

-- | Observer component
data Observer m e = Observer
  { -- | The kind and callback for this observer.
    forall (m :: * -> *) e. Observer m e -> ObserverKind m e
observerKind :: !(ObserverKind m e),
    -- | The ObserverID assigned after registration (Nothing before registration).
    forall (m :: * -> *) e. Observer m e -> Maybe ObserverID
observerId :: !(Maybe ObserverID)
  }

instance Show (ObserverKind m e) where
  show :: ObserverKind m e -> String
show (EntityObserver Set EntityID
targets EntityID -> e -> Access m ()
_) = String
"EntityObserver " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set EntityID -> String
forall a. Show a => a -> String
show Set EntityID
targets
  show (EventObserver e -> Access m ()
_) = String
"EventObserver"

instance Show (Observer m e) where
  show :: Observer m e -> String
show Observer m e
o = String
"Observer { kind = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ObserverKind m e -> String
forall a. Show a => a -> String
show (Observer m e -> ObserverKind m e
forall (m :: * -> *) e. Observer m e -> ObserverKind m e
observerKind Observer m e
o) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", id = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe ObserverID -> String
forall a. Show a => a -> String
show (Observer m e -> Maybe ObserverID
forall (m :: * -> *) e. Observer m e -> Maybe ObserverID
observerId Observer m e
o) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"

instance (Monad m, Typeable m, Event e) => Component m (Observer m e) where
  type StorageT (Observer m e) = Vector (Observer m e)

  componentOnInsert :: EntityID -> Observer m e -> Access m ()
componentOnInsert EntityID
ownerEntity Observer m e
o = 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
    (ObserverID
oId, Observers (StateT (World m) m)
observers') <- case Observer m e -> ObserverKind m e
forall (m :: * -> *) e. Observer m e -> ObserverKind m e
observerKind Observer m e
o of
      EntityObserver Set EntityID
targets EntityID -> e -> Access m ()
f -> do
        let f' :: EntityID -> e -> StateT (World m) m ()
f' EntityID
eId e
evt = Access m () -> StateT (World m) m ()
forall (m :: * -> *) a. Access m a -> StateT (World m) m a
unAccess (Access m () -> StateT (World m) m ())
-> Access m () -> StateT (World m) m ()
forall a b. (a -> b) -> a -> b
$ EntityID -> e -> Access m ()
f EntityID
eId e
evt
            (ObserverID
oId, Observers (StateT (World m) m)
observers') = forall e (m :: * -> *).
(Typeable e, Monad m) =>
(EntityID -> e -> m ()) -> Observers m -> (ObserverID, Observers m)
O.insertEntityObserver @e EntityID -> e -> StateT (World m) m ()
f' (Observers (StateT (World m) m)
 -> (ObserverID, Observers (StateT (World m) m)))
-> Observers (StateT (World m) m)
-> (ObserverID, Observers (StateT (World m) m))
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
            observers'' :: Observers (StateT (World m) m)
observers'' = (EntityID
 -> Observers (StateT (World m) m)
 -> Observers (StateT (World m) m))
-> Observers (StateT (World m) m)
-> Set EntityID
-> Observers (StateT (World m) m)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\EntityID
e Observers (StateT (World m) m)
os -> forall (m :: * -> *) e.
Typeable e =>
EntityID -> ObserverID -> Observers m -> Observers m
O.addEntityObserver @_ @e EntityID
e ObserverID
oId Observers (StateT (World m) m)
os) Observers (StateT (World m) m)
observers' Set EntityID
targets
        (ObserverID, Observers (StateT (World m) m))
-> StateT (World m) m (ObserverID, Observers (StateT (World m) m))
forall a. a -> StateT (World m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ObserverID
oId, Observers (StateT (World m) m)
observers'')
      EventObserver e -> Access m ()
callback -> do
        let wrappedCallback :: e -> StateT (World m) m ()
wrappedCallback e
evt = Access m () -> StateT (World m) m ()
forall (m :: * -> *) a. Access m a -> StateT (World m) m a
unAccess (Access m () -> StateT (World m) m ())
-> Access m () -> StateT (World m) m ()
forall a b. (a -> b) -> a -> b
$ e -> Access m ()
callback e
evt
            (ObserverID
oId, Observers (StateT (World m) m)
observers') = forall e (m :: * -> *).
(Typeable e, Monad m) =>
(e -> m ()) -> Observers m -> (ObserverID, Observers m)
O.insertEventObserver @e e -> StateT (World m) m ()
wrappedCallback (World m -> Observers (StateT (World m) m)
forall (m :: * -> *). World m -> Observers (StateT (World m) m)
observers World m
w)
            observers'' :: Observers (StateT (World m) m)
observers'' = forall (m :: * -> *) e.
Typeable e =>
ObserverID -> Observers m -> Observers m
O.addGlobalObserver @_ @e ObserverID
oId Observers (StateT (World m) m)
observers'
        (ObserverID, Observers (StateT (World m) m))
-> StateT (World m) m (ObserverID, Observers (StateT (World m) m))
forall a. a -> StateT (World m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ObserverID
oId, Observers (StateT (World m) m)
observers'')
    let o' :: Observer m e
o' = Observer m e
o {observerId = Just oId}
        w' :: World m
w' = EntityID -> BundleT m -> World m -> World m
forall (m :: * -> *).
Monad m =>
EntityID -> BundleT m -> World m -> World m
W.insertUntracked EntityID
ownerEntity (Observer m e -> BundleT m
forall (m :: * -> *) a. Component m a => a -> BundleT m
bundleUntracked Observer m e
o') World m
w {observers = observers'}
    World m -> StateT (World m) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World m
w'

  componentOnRemove :: EntityID -> Observer m e -> Access m ()
componentOnRemove EntityID
_ownerEntity Observer m e
o = 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
$ case Observer m e -> Maybe ObserverID
forall (m :: * -> *) e. Observer m e -> Maybe ObserverID
observerId Observer m e
o of
    Just ObserverID
oId -> do
      !World m
w <- StateT (World m) m (World m)
forall s (m :: * -> *). MonadState s m => m s
get
      World m -> StateT (World m) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put World m
w {observers = O.removeObserver oId (observers w)}
    Maybe ObserverID
Nothing -> () -> StateT (World m) m ()
forall a. a -> StateT (World m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Create an observer for specific entities.
observerFor :: forall m e. (Event e) => Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
observerFor :: forall (m :: * -> *) e.
Event e =>
Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
observerFor Set EntityID
targets EntityID -> e -> Access m ()
callback = Observer {observerKind :: ObserverKind m e
observerKind = Set EntityID -> (EntityID -> e -> Access m ()) -> ObserverKind m e
forall (m :: * -> *) e.
Set EntityID -> (EntityID -> e -> Access m ()) -> ObserverKind m e
EntityObserver Set EntityID
targets EntityID -> e -> Access m ()
callback, observerId :: Maybe ObserverID
observerId = Maybe ObserverID
forall a. Maybe a
Nothing}

-- | Create a global observer (observes all events of this type).
observerGlobal :: forall m e. (Event e) => (e -> Access m ()) -> Observer m e
observerGlobal :: forall (m :: * -> *) e.
Event e =>
(e -> Access m ()) -> Observer m e
observerGlobal e -> Access m ()
callback = Observer {observerKind :: ObserverKind m e
observerKind = (e -> Access m ()) -> ObserverKind m e
forall (m :: * -> *) e. (e -> Access m ()) -> ObserverKind m e
EventObserver e -> Access m ()
callback, observerId :: Maybe ObserverID
observerId = Maybe ObserverID
forall a. Maybe a
Nothing}

-- | Create an observer for a single entity.
observer :: forall m e. (Event e) => EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
observer :: forall (m :: * -> *) e.
Event e =>
EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
observer EntityID
e = Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
forall (m :: * -> *) e.
Event e =>
Set EntityID -> (EntityID -> e -> Access m ()) -> Observer m e
observerFor (EntityID -> Set EntityID
forall a. a -> Set a
Set.singleton EntityID
e)