Created
January 21, 2025 16:07
-
-
Save LSLeary/85cd56a0ff5d3f193fda7024ea23e221 to your computer and use it in GitHub Desktop.
A simple, functional event manager.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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