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

-- |
-- Module      : Aztecs.ECS.World.Observers
-- 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.World.Observers
  ( ObserverID (..),
    Observers (..),
    EntityObservers (..),
    DynamicObserver (..),
    empty,
    insertEntityObserver,
    insertEventObserver,
    addEntityObserver,
    addGlobalObserver,
    lookupEntityObservers,
    lookupGlobalObservers,
    lookupCallback,
    removeObserver,
  )
where

import Aztecs.ECS.Entity
import Aztecs.ECS.World.Observers.Internal
import Data.Dynamic
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Typeable

-- | Empty `Observers`.
empty :: Observers m
empty :: forall (m :: * -> *). Observers m
empty =
  Observers
    { entityObservers' :: Map EntityID EntityObservers
entityObservers' = Map EntityID EntityObservers
forall a. Monoid a => a
mempty,
      globalObservers :: Map TypeRep (Set ObserverID)
globalObservers = Map TypeRep (Set ObserverID)
forall a. Monoid a => a
mempty,
      observerCallbacks :: Map ObserverID (DynamicObserver m)
observerCallbacks = Map ObserverID (DynamicObserver m)
forall a. Monoid a => a
mempty,
      nextObserverId :: ObserverID
nextObserverId = Int -> ObserverID
ObserverID Int
0
    }

-- | Insert an entity observer callback.
insertEntityObserver ::
  forall e m.
  (Typeable e, Monad m) =>
  (EntityID -> e -> m ()) ->
  Observers m ->
  (ObserverID, Observers m)
insertEntityObserver :: forall e (m :: * -> *).
(Typeable e, Monad m) =>
(EntityID -> e -> m ()) -> Observers m -> (ObserverID, Observers m)
insertEntityObserver EntityID -> e -> m ()
callback Observers m
os =
  let !oId :: ObserverID
oId = Observers m -> ObserverID
forall (m :: * -> *). Observers m -> ObserverID
nextObserverId Observers m
os
      dynCallback :: EntityID -> Dynamic -> m ()
dynCallback EntityID
eId Dynamic
dyn = case Dynamic -> Maybe e
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
        Just e
evt -> EntityID -> e -> m ()
callback EntityID
eId e
evt
        Maybe e
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   in ( ObserverID
oId,
        Observers m
os
          { observerCallbacks = Map.insert oId (DynEntityObserver dynCallback) (observerCallbacks os),
            nextObserverId = ObserverID (unObserverId oId + 1)
          }
      )

-- | Insert an event observer callback.
insertEventObserver ::
  forall e m.
  (Typeable e, Monad m) =>
  (e -> m ()) ->
  Observers m ->
  (ObserverID, Observers m)
insertEventObserver :: forall e (m :: * -> *).
(Typeable e, Monad m) =>
(e -> m ()) -> Observers m -> (ObserverID, Observers m)
insertEventObserver e -> m ()
callback Observers m
os =
  let !oId :: ObserverID
oId = Observers m -> ObserverID
forall (m :: * -> *). Observers m -> ObserverID
nextObserverId Observers m
os
      dynCallback :: Dynamic -> m ()
dynCallback Dynamic
dyn = case Dynamic -> Maybe e
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
        Just e
evt -> e -> m ()
callback e
evt
        Maybe e
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   in ( ObserverID
oId,
        Observers m
os
          { observerCallbacks = Map.insert oId (DynEventObserver dynCallback) (observerCallbacks os),
            nextObserverId = ObserverID (unObserverId oId + 1)
          }
      )

-- | Add an observer to a specific entity for a given event type.
addEntityObserver :: forall m e. (Typeable e) => EntityID -> ObserverID -> Observers m -> Observers m
addEntityObserver :: forall (m :: * -> *) e.
Typeable e =>
EntityID -> ObserverID -> Observers m -> Observers m
addEntityObserver EntityID
e ObserverID
oId Observers m
os =
  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)
      updateEntityObs :: Maybe EntityObservers -> Maybe EntityObservers
updateEntityObs Maybe EntityObservers
Nothing =
        EntityObservers -> Maybe EntityObservers
forall a. a -> Maybe a
Just (EntityObservers -> Maybe EntityObservers)
-> EntityObservers -> Maybe EntityObservers
forall a b. (a -> b) -> a -> b
$ EntityObservers {eventObservers :: Map TypeRep (Set ObserverID)
eventObservers = TypeRep -> Set ObserverID -> Map TypeRep (Set ObserverID)
forall k a. k -> a -> Map k a
Map.singleton TypeRep
eventTypeRep (ObserverID -> Set ObserverID
forall a. a -> Set a
Set.singleton ObserverID
oId)}
      updateEntityObs (Just EntityObservers
eo) =
        EntityObservers -> Maybe EntityObservers
forall a. a -> Maybe a
Just (EntityObservers -> Maybe EntityObservers)
-> EntityObservers -> Maybe EntityObservers
forall a b. (a -> b) -> a -> b
$ EntityObservers
eo {eventObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (eventObservers eo)}
   in Observers m
os {entityObservers' = Map.alter updateEntityObs e (entityObservers' os)}

-- | Add a global observer for a given event type.
addGlobalObserver :: forall m e. (Typeable e) => ObserverID -> Observers m -> Observers m
addGlobalObserver :: forall (m :: * -> *) e.
Typeable e =>
ObserverID -> Observers m -> Observers m
addGlobalObserver ObserverID
oId Observers m
os =
  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)
   in Observers m
os {globalObservers = Map.insertWith Set.union eventTypeRep (Set.singleton oId) (globalObservers os)}

-- | Lookup all observer IDs for an entity and event type.
lookupEntityObservers :: TypeRep -> EntityID -> Observers m -> Set.Set ObserverID
lookupEntityObservers :: forall (m :: * -> *).
TypeRep -> EntityID -> Observers m -> Set ObserverID
lookupEntityObservers TypeRep
eventTypeRep EntityID
e Observers m
os =
  case EntityID -> Map EntityID EntityObservers -> Maybe EntityObservers
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EntityID
e (Observers m -> Map EntityID EntityObservers
forall (m :: * -> *). Observers m -> Map EntityID EntityObservers
entityObservers' Observers m
os) of
    Just EntityObservers
eo -> Set ObserverID
-> TypeRep -> Map TypeRep (Set ObserverID) -> Set ObserverID
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set ObserverID
forall a. Set a
Set.empty TypeRep
eventTypeRep (EntityObservers -> Map TypeRep (Set ObserverID)
eventObservers EntityObservers
eo)
    Maybe EntityObservers
Nothing -> Set ObserverID
forall a. Set a
Set.empty

-- | Lookup all global observer IDs for an event type.
lookupGlobalObservers :: TypeRep -> Observers m -> Set.Set ObserverID
lookupGlobalObservers :: forall (m :: * -> *). TypeRep -> Observers m -> Set ObserverID
lookupGlobalObservers TypeRep
eventTypeRep Observers m
os = Set ObserverID
-> TypeRep -> Map TypeRep (Set ObserverID) -> Set ObserverID
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set ObserverID
forall a. Set a
Set.empty TypeRep
eventTypeRep (Observers m -> Map TypeRep (Set ObserverID)
forall (m :: * -> *). Observers m -> Map TypeRep (Set ObserverID)
globalObservers Observers m
os)

-- | Lookup an observer callback by ID.
lookupCallback :: ObserverID -> Observers m -> Maybe (DynamicObserver m)
lookupCallback :: forall (m :: * -> *).
ObserverID -> Observers m -> Maybe (DynamicObserver m)
lookupCallback ObserverID
oId Observers m
os = ObserverID
-> Map ObserverID (DynamicObserver m) -> Maybe (DynamicObserver m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ObserverID
oId (Observers m -> Map ObserverID (DynamicObserver m)
forall (m :: * -> *).
Observers m -> Map ObserverID (DynamicObserver m)
observerCallbacks Observers m
os)

-- | Remove an observer by ID.
removeObserver :: ObserverID -> Observers m -> Observers m
removeObserver :: forall (m :: * -> *). ObserverID -> Observers m -> Observers m
removeObserver ObserverID
oId Observers m
os =
  Observers m
os
    { observerCallbacks = Map.delete oId (observerCallbacks os),
      entityObservers' = Map.map removeFromEntity (entityObservers' os),
      globalObservers = Map.map (Set.delete oId) (globalObservers os)
    }
  where
    removeFromEntity :: EntityObservers -> EntityObservers
removeFromEntity EntityObservers
eo = EntityObservers
eo {eventObservers = Map.map (Set.delete oId) (eventObservers eo)}