A simple, functional event manager.

EventManager.hs

{-# LANGUAGE RankNTypes, PolyKinds, GeneralisedNewtypeDeriving #-}

module EventManager (
  EventManager,
  EventTag, eventTag,
  attach, trigger,
) where

-- base
import Prelude hiding (lookup)
import Type.Reflection (Typeable, TypeRep, typeRep)
import Data.Foldable (fold)

-- some
import Data.GADT.Compare (GEq, GCompare)

-- dependent-map
import Data.Dependent.Map (DMap, unionWithKey, empty, insertWith, lookup)


newtype EventManager = EventManager (DMap EventTag Handler)

instance Semigroup EventManager where
  EventManager dm1 <> EventManager dm2
    = EventManager (unionWithKey (\_ -> (<>)) dm1 dm2)

instance Monoid EventManager where
  mempty = EventManager empty


newtype EventTag e = EventTag (TypeRep e)
  deriving (GEq, GCompare)

eventTag :: Typeable e => EventTag e
eventTag = EventTag typeRep


newtype Handler e = Handler{ ($$) :: forall a. Monoid a => e a -> a }

instance Semigroup (Handler e) where
  h1 <> h2 = Handler \ev -> h1 $$ ev <> h2 $$ ev

instance Monoid (Handler e) where
  mempty = Handler \_ -> mempty


attach
  :: EventTag e -> (forall a. Monoid a => e a -> a)
  -> EventManager -> EventManager
attach tag h (EventManager dm)
  = EventManager (insertWith (flip (<>)) tag (Handler h) dm)

trigger :: Monoid a => EventManager -> EventTag e -> e a -> a
trigger (EventManager dm) tag ev = fold (lookup tag dm) $$ ev