Skip to content

Instantly share code, notes, and snippets.

@LSLeary
Created January 21, 2025 16:07
Show Gist options
  • Save LSLeary/85cd56a0ff5d3f193fda7024ea23e221 to your computer and use it in GitHub Desktop.
Save LSLeary/85cd56a0ff5d3f193fda7024ea23e221 to your computer and use it in GitHub Desktop.
A simple, functional event manager.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment